add some support for customizing product options
[bse.git] / site / cgi-bin / modules / BSE / Cart.pm
1 package BSE::Cart;
2 use strict;
3 use Scalar::Util;
4 use BSE::PubSub;
5
6 our $VERSION = "1.016";
7
8 =head1 NAME
9
10 BSE::Cart - abstraction for the BSE cart.
11
12 =head1 SYNOPSIS
13
14   use BSE::Cart;
15   my $cart = BSE::Cart->new($req, $stage);
16
17   my $items = $cart->items;
18   my $products = $cart->products;
19
20 =head1 DESCRIPTION
21
22 This class provides a simple abstraction for access to the BSE
23 shopping cart.
24
25 This is intended for use in templates, but may be expanded further.
26
27 =head1 METHODS
28
29 =over
30
31 =item new()
32
33 Create a new cart object based on the session.
34
35 =cut
36
37 sub new {
38   my ($class, $req, $stage) = @_;
39
40   $stage ||= "";
41
42   my $self = bless
43     {
44      products => {},
45      req => $req,
46      stage => $stage,
47      shipping => 0,
48     }, $class;
49   Scalar::Util::weaken($self->{req});
50   my $items = $req->session->{cart} || [];
51   my $myself = $self;
52   Scalar::Util::weaken($myself);
53   my $index = 0;
54   $self->{items} =  [ map BSE::Cart::Item->new($_, $index++, $self), @$items ];
55
56   if ($stage eq 'cart' || $stage eq 'checkout') {
57     $self->_enter_cart;
58   }
59   elsif ($stage eq 'checkupdate') {
60     $self->_checkout_update;
61   }
62
63   $self->{coupon_code} = $self->{req}->session->{cart_coupon_code};
64   defined $self->{coupon_code} or $self->{coupon_code} = "";
65
66   return $self;
67 }
68
69 sub _enter_cart {
70   my ($self) = @_;
71
72   my $req = $self->{req};
73   require BSE::CfgInfo;
74
75   $req->session->{custom} ||= {};
76   my %custom_state = %{$req->session->{custom}};
77
78   $self->{custom_state} = \%custom_state;
79
80   my $cust_class = BSE::CfgInfo::custom_class($self->{req}->cfg);
81   $cust_class->enter_cart(scalar $self->items, scalar $self->products,
82                           \%custom_state, $req->cfg);
83 }
84
85 sub _checkout_update {
86   my ($self) = @_;
87
88   my $req = $self->{req};
89   require BSE::CfgInfo;
90
91   $req->session->{custom} ||= {};
92   my %custom_state = %{$req->session->{custom}};
93
94   $self->{custom_state} = \%custom_state;
95
96   my $cust_class = BSE::CfgInfo::custom_class($self->{req}->cfg);
97   $cust_class->checkout_update
98     ($req->cgi, scalar $self->items, scalar $self->products,
99      \%custom_state, $req->cfg);
100 }
101
102 =item request
103
104 Return the request object.
105
106 =cut
107
108 sub request {
109   $_[0]{req};
110 }
111
112 =item is_empty()
113
114 Return true if the cart has no items in it.
115
116 =cut
117
118 sub is_empty {
119   my ($self) = @_;
120
121   return @{$self->{items}} == 0;
122 }
123
124 =item items()
125
126 Return an array reference of cart items.
127
128 =cut
129
130 sub items {
131   return wantarray ? @{$_[0]{items}} : $_[0]{items};
132 }
133
134 =item products().
135
136 Return an array reference of products in the cart, corresponding to
137 the array reference returned by items().
138
139 =cut
140
141 sub products {
142   my $self = shift;
143
144   my @products = map $self->_product($_->{productId}), @{$self->items};
145
146   return wantarray ? @products : \@products;
147 }
148
149 =item total_cost
150
151 Return the total cost of the items in the cart.
152
153 This does not include shipping costs and is not discounted.
154
155 =cut
156
157 sub total_cost {
158   my ($self) = @_;
159
160   my $total_cost = 0;
161   for my $item (@{$self->items}) {
162     $total_cost += $item->extended_retailPrice;
163   }
164
165   return $total_cost;
166 }
167
168 =item gst
169
170 Return the total GST paid for the items in the cart.
171
172 This currently depends on the gst values of the products.
173
174 This ignores the coupon code discount.
175
176 =cut
177
178 sub gst {
179   my ($self) = @_;
180
181   my $total_gst = 0;
182   for my $item (@{$self->items}) {
183     $total_gst += $item->extended_gst;
184   }
185
186   return $total_gst;
187 }
188
189 =item wholesaleTotal
190
191 Return the wholesale cost for the items in the cart.
192
193 This depends on the wholesale values of the products.
194
195 =cut
196
197 sub wholesaleTotal {
198   my ($self) = @_;
199
200   my $total_wholesale = 0;
201   for my $item (@{$self->items}) {
202     $total_wholesale += $item->extended_wholesale;
203   }
204
205   return $total_wholesale;
206 }
207
208 =item discounted_product_cost
209
210 Cost of products with an product discount taken into account.
211
212 Note: this rounds the total B<down>.
213
214 =cut
215
216 sub discounted_product_cost {
217   my ($self) = @_;
218
219   return $self->total_cost - $self->product_cost_discount;
220 }
221
222 =item product_cost_discount
223
224 Return any amount taken off the product cost.
225
226 =cut
227
228 sub product_cost_discount {
229   my ($self) = @_;
230
231   $self->coupon_active
232     or return 0;
233
234   return $self->{coupon_check}{coupon}->discount($self);
235 }
236
237 =item cfg_shipping
238
239 Return true if the system is configured to prompt for shipper
240 information.
241
242 =cut
243
244 sub cfg_shipping {
245   my $self = shift;
246
247   return $self->{req}->cfg->entry("shop", "shipping", 0);
248 }
249
250 =item set_shipping_cost()
251
252 Set the cost of shipping.
253
254 Called by the shop.
255
256 =cut
257
258 sub set_shipping_cost {
259   my ($self, $cost) = @_;
260
261   $self->{shipping} = $cost;
262 }
263
264 =item shipping_cost()
265
266 Fetch the cost of shipping.
267
268 =cut
269
270 sub shipping_cost {
271   my ($self) = @_;
272
273   return $self->{shipping};
274 }
275
276 =item set_shipping_method
277
278 Set the stored shipping method.  For internal use.
279
280 =cut
281
282 sub set_shipping_method {
283   my ($self, $method) = @_;
284
285   $self->{shipping_method} = $method;
286 }
287
288 =item shipping_method
289
290 The description of the selected shipping method.
291
292 =cut
293
294 sub shipping_method {
295   my ($self) = @_;
296
297   return $self->{shipping_method};
298 }
299
300 =item set_shipping_name
301
302 Set the stored shipping name.  For internal use.
303
304 =cut
305
306 sub set_shipping_name {
307   my ($self, $name) = @_;
308
309   $self->{shipping_name} = $name;
310 }
311
312 =item shipping_name
313
314 The name of the selected shipping method.
315
316 =cut
317
318 sub shipping_name {
319   my ($self) = @_;
320
321   return $self->{shipping_name};
322 }
323
324 =item set_delivery_in
325
326 Set the stored delivery time in days.
327
328 =cut
329
330 sub set_delivery_in {
331   my ($self, $days) = @_;
332
333   $self->{delivery_in} = $days;
334 }
335
336 =item delivery_in
337
338 The expected delivery time in days.  Some shippers may not supply
339 this, in which case this will be an undefined value.
340
341 =cut
342
343 sub delivery_in {
344   my ($self) = @_;
345
346   return $self->{delivery_in};
347 }
348
349 =item total_units
350
351 Return the total number of units in the cart.
352
353 =cut
354
355 sub total_units {
356   my ($self) = @_;
357
358   my $total_units = 0;
359   for my $item (@{$self->items}) {
360     $total_units += $item->units;
361   }
362
363   return $total_units;
364 }
365
366 =item total
367
368 Total of items in the cart, any custom costs and shipping costs.
369
370 =cut
371
372 sub total {
373   my ($self) = @_;
374
375   my $cost = 0;
376
377   $cost += $self->discounted_product_cost;
378
379   $cost += $self->shipping_cost;
380
381   $cost += $self->custom_cost;
382
383   return $cost;
384 }
385
386 =item coupon_code
387
388 The current coupon code.
389
390 =cut
391
392 sub coupon_code {
393   my ($self) = @_;
394
395   return $self->{coupon_code};
396 }
397
398 =item set_coupon_code()
399
400 Used by the shop to set the coupon code.
401
402 =cut
403
404 sub set_coupon_code {
405   my ($self, $code) = @_;
406
407   $code =~ s/\A\s+//;
408   $code =~ s/\s+\z//;
409   $self->{coupon_code} = $code;
410   delete $self->{coupon_valid};
411   $self->{req}->session->{cart_coupon_code} = $code;
412 }
413
414 =item coupon_code_discount_pc
415
416 The percentage discount for the current coupon code, if that code is
417 valid and the contents of the cart are valid for that coupon code.
418
419 This method is historical and no longer useful.
420
421 =cut
422
423 sub coupon_code_discount_pc {
424   my ($self) = @_;
425
426   $self->coupon_valid
427     or return 0;
428
429   return $self->{coupon_check}{coupon}->discount_percent;
430 }
431
432 =item coupon_valid
433
434 Return true if the current coupon code is valid
435
436 =cut
437
438 sub coupon_valid {
439   my ($self) = @_;
440
441   unless ($self->{coupon_check}) {
442     if (length $self->{coupon_code}) {
443       require BSE::TB::Coupons;
444       my ($coupon) = BSE::TB::Coupons->getBy(code => $self->{coupon_code});
445       my %check =
446         (
447          coupon => $coupon,
448          valid => 0,
449          active => 0,
450          msg => "",
451         );
452       #print STDERR " coupon $coupon\n";
453       #print STDERR "released ", 0+ $coupon->is_released, " expired ",
454       # 0+$coupon->is_expired, " valid ", 0+$coupon->is_valid, "\n" if $coupon;
455       if ($coupon && $coupon->is_valid) {
456         $check{valid} = 1;
457         my ($active, $msg) = $coupon->is_active($self);
458         $check{active} = $active;
459         $check{msg} = $msg || "";
460       }
461       $self->{coupon_check} = \%check;
462     }
463     else {
464       $self->{coupon_check} =
465         {
466          valid => 0,
467          active => 0,
468          msg => "",
469         };
470     }
471   }
472
473   return $self->{coupon_check}{valid};
474 }
475
476 =item coupon_active
477
478 Return true if the current coupon is active, ie. both valid and the
479 cart has products of all the right tiers.
480
481 =cut
482
483 sub coupon_active {
484   my ($self) = @_;
485
486   $self->coupon_valid
487     or return 0;
488
489   return $self->{coupon_check}{active};
490 }
491
492 =item coupon_inactive_message
493
494 Returns why the coupon is inactive.
495
496 =cut
497
498 sub coupon_inactive_message {
499   my ($self) = @_;
500
501   $self->coupon_valid
502     or return "";
503
504   return $self->{coupon_check}{msg};
505 }
506
507 =item coupon
508
509 The current coupon object, if and only if the coupon code is valid.
510
511 =cut
512
513 sub coupon {
514   my ($self) = @_;
515
516   $self->coupon_valid
517     or return;
518
519   $self->{coupon_check}{coupon};
520 }
521
522 =item coupon_cart_wide
523
524 Returns true if the coupon discount applies to the cart as a whole.
525
526 Always returns false if the coupon is not active.
527
528 If this is true the item discount methods are useful.
529
530 =cut
531
532 sub coupon_cart_wide {
533   my ($self) = @_;
534
535   $self->coupon_active
536     or return;
537
538   return $self->coupon->cart_wide($self);
539 }
540
541 =item coupon_description
542
543 Describe the coupon.
544
545 Compatible with order objects.
546
547 =cut
548
549 sub coupon_description {
550   my ($self) = @_;
551
552   $self->coupon_valid
553     or return;
554
555   return $self->coupon->describe;
556 }
557
558 =item custom_cost
559
560 Return any custom cost specified by a custom class.
561
562 =cut
563
564 sub custom_cost {
565   my ($self) = @_;
566
567   unless (exists $self->{custom_cost}) {
568     my $obj = BSE::CfgInfo::custom_class($self->{req}->cfg);
569     $self->{custom_cost} =
570       $obj->total_extras(scalar $self->items, scalar $self->products,
571                          $self->{custom_state}, $self->{req}->cfg, $self->{stage});
572   }
573
574   return $self->{custom_cost};
575 }
576
577 =item have_sales_files
578
579 Return true if the cart contains products with files that are for
580 sale.
581
582 =cut
583
584 sub have_sales_files {
585   my ($self) = @_;
586
587   unless (defined $self->{have_sales_files}) {
588     $self->{have_sales_files} = 0;
589   PRODUCTS:
590     for my $prod (@{$self->products}) {
591       if ($prod->has_sales_files) {
592         $self->{have_sales_files} = 1;
593         last PRODUCTS;
594       }
595     }
596   }
597
598   return $self->{have_sales_files};
599 }
600
601 =item need_logon
602
603 Return true if the cart contains items that the user needs to be
604 logged on to purchase, or if the current user isn't qualified to
605 purchase the item.
606
607 Call need_logon_message() to get the reason for this method returning
608 false.
609
610 =cut
611
612 sub need_logon {
613   my ($self) = @_;
614
615   unless (exists $self->{need_logon}) {
616     $self->{need_logon} = $self->_need_logon;
617   }
618
619   $self->{need_logon} or return;
620
621   return 1;
622 }
623
624 =item need_logon_message
625
626 Returns a list with the error message and message id of the reason the
627 user needs to logon for this cart.
628
629 =cut
630
631 sub need_logon_message {
632   my ($self) = @_;
633
634   unless (exists $self->{need_logon}) {
635     $self->{need_logon} = $self->_need_logon;
636   }
637
638   return @{$self->{logon_reason}};
639 }
640
641 =item custom_state
642
643 State managed by a custom class.
644
645 =cut
646
647 sub custom_state {
648   my ($self) = @_;
649
650   $self->{custom_state};
651 }
652
653 =item affiliate_code
654
655 Return the stored affiliate code.
656
657 =cut
658
659 sub affiliate_code {
660   my ($self) = @_;
661
662   my $code = $self->{req}->session->{affiliate_code};
663   defined $code or $code = '';
664
665   return $code;
666 }
667
668 =item any_physical_products
669
670 Returns true if the cart contains any physical products, ie. needs
671 shipping.
672
673 =cut
674
675 sub any_physical_products {
676   my ($self) = @_;
677
678   for my $prod (@{$self->products}) {
679     if ($prod->weight) {
680       return 1;
681       last;
682     }
683   }
684
685   return 0;
686 }
687
688
689 =item _need_logon
690
691 Internal implementation of need_logon.
692
693 =cut
694
695 sub _need_logon {
696   my ($self) = @_;
697
698   my $cfg = $self->{req}->cfg;
699
700   $self->{logon_reason} = [];
701
702   my $reg_if_files = $cfg->entryBool('shop', 'register_if_files', 1);
703
704   my $user = $self->{req}->siteuser;
705
706   if (!$user && $reg_if_files) {
707     require BSE::TB::ArticleFiles;
708     # scan to see if any of the products have files
709     # requires a subscription or subscribes
710     for my $prod (@{$self->products}) {
711       my @files = $prod->files;
712       if (grep $_->forSale, @files) {
713         $self->{logon_reason} =
714           [ "register before checkout", "shop/fileitems" ];
715         return 1;
716       }
717       if ($prod->{subscription_id} != -1) {
718         $self->{logon_reason} =
719           [ "you must be logged in to purchase a subscription", "shop/buysub" ];
720         return 1;
721       }
722       if ($prod->{subscription_required} != -1) {
723         $self->{logon_reason} = 
724           [ "must be logged in to purchase a product requiring a subscription", "shop/subrequired" ];
725         return 1;
726       }
727     }
728   }
729
730   my $require_logon = $cfg->entryBool('shop', 'require_logon', 0);
731   if (!$user && $require_logon) {
732     $self->{logon_reason} =
733       [ "register before checkout", "shop/logonrequired" ];
734     return 1;
735   }
736
737   # check the user has the right required subs
738   # and that they qualify to subscribe for limited subscription products
739   if ($user) {
740     for my $prod (@{$self->products}) {
741       my $sub = $prod->subscription_required;
742       if ($sub && !$user->subscribed_to($sub)) {
743         $self->{logon_reason} =
744           [ "you must be subscribed to $sub->{title} to purchase one of these products", "shop/subrequired" ];
745         return 1;
746       }
747
748       $sub = $prod->subscription;
749       if ($sub && $prod->is_renew_sub_only) {
750         unless ($user->subscribed_to_grace($sub)) {
751           $self->{logon_reason} =
752             [ "you must be subscribed to $sub->{title} to use this renew only product", "sub/renewsubonly" ];
753           return;
754         }
755       }
756       if ($sub && $prod->is_start_sub_only) {
757         if ($user->subscribed_to_grace($sub)) {
758           $self->{logon_reason} =
759             [ "you must not be subscribed to $sub->{title} already to use this new subscription only product", "sub/newsubonly" ];
760           return 1;
761         }
762       }
763     }
764   }
765   
766   return 0;
767 }
768
769 sub _product {
770   my ($self, $id) = @_;
771
772   my $product = $self->{products}{$id};
773   unless ($product) {
774     require BSE::TB::Products;
775     $product = BSE::TB::Products->getByPkey($id)
776       or die "No product $id\n";
777     # FIXME
778     if ($product->generator ne "BSE::Generate::Product") {
779       require BSE::TB::Seminars;
780       $product = BSE::TB::Seminars->getByPkey($id)
781         or die "Not a product, not a seminar $id\n";
782     }
783
784     $self->{products}{$id} = $product;
785   }
786   return $product;
787 }
788
789 sub _session {
790   my ($self, $id) = @_;
791   my $session = $self->{sessions}{$id};
792   unless ($session) {
793     require BSE::TB::SeminarSessions;
794     $session = BSE::TB::SeminarSessions->getByPkey($id);
795     $self->{sessions}{$id} = $session;
796   }
797
798   return $session;
799 }
800
801 =item cleanup()
802
803 Clean up the cart, removing any items that are unreleased, expired or
804 unlisted.
805
806 For BSE use.
807
808 =cut
809
810 sub cleanup {
811   my ($self) = @_;
812
813   my @newitems;
814   for my $item ($self->items) {
815     my $product = $item->product;
816
817     if ($product->is_released && !$product->is_expired && $product->listed) {
818       push @newitems, $item;
819     }
820   }
821
822   $self->{items} = \@newitems;
823 }
824
825 =item empty
826
827 Empty the cart.
828
829 For BSE use.
830
831 =cut
832
833 sub empty {
834   my ($self) = @_;
835
836   my $req = $self->{req};
837
838   # empty the cart ready for the next order
839   delete @{$req->session}{qw/order_info order_info_confirmed order_need_delivery cart order_work cart_coupon_code/};
840 }
841
842 =back
843
844 =cut
845
846 package BSE::Cart::Item;
847
848 sub new {
849   my ($class, $raw_item, $index, $cart) = @_;
850
851   my $item = bless
852     {
853      %$raw_item,
854      index => $index,
855      cart => $cart,
856     }, $class;
857
858   Scalar::Util::weaken($item->{cart});
859
860   return $item;
861 }
862
863 =head2 Item Members
864
865 =over
866
867 =item product
868
869 Returns the product for that line item.
870
871 =cut
872
873 sub product {
874   my $self = shift;
875
876   return $self->{cart}->_product($self->{productId});
877 }
878
879 =item product_id
880
881 Id of the product in this row.
882
883 =cut
884
885 sub product_id {
886   $_[0]{productId};
887 }
888
889 =item price
890
891 =cut
892
893 sub price {
894   my ($self) = @_;
895
896   unless (defined $self->{calc_price}) {
897     $self->{calc_price} = $self->product->price(user => $self->{cart}{req}->siteuser);
898
899     BSE::PubSub->customize(
900       cart_price => {
901         cartitem => $self,
902         cart => $self->{cart},
903         price => \($self->{calc_price}),
904         request => $self->{cart}{req},
905       });
906   }
907
908   return $self->{calc_price};
909 }
910
911 =item extended
912
913 The extended price for the item.
914
915 =cut
916
917 sub extended {
918   my ($self, $base) = @_;
919
920   $base =~ /^(price|retailPrice|gst|wholesalePrice)$/
921     or return 0;
922
923   return $self->$base() * $self->{units};
924 }
925
926 sub extended_retailPrice {
927   $_[0]->extended("price");
928 }
929
930 sub extended_wholesalePrice {
931   $_[0]->extended("wholesalePrice");
932 }
933
934 sub extended_gst {
935   $_[0]->extended("gst");
936 }
937
938 =item units
939
940 The number of units.
941
942 =cut
943
944 sub units {
945   $_[0]{units};
946 }
947
948 =item session_id
949
950 The seminar session id, if any.
951
952 =cut
953
954 sub session_id {
955   $_[0]{session_id};
956 }
957
958 =item tier_id
959
960 The pricing tier id.
961
962 =cut
963
964 sub tier_id {
965   $_[0]{tier};
966 }
967
968 =item link
969
970 A link to the product.
971
972 =cut
973
974 sub link {
975   my ($self, $id) = @_;
976
977   my $product = $self->product;
978   my $link = $product->link;
979   unless ($link =~ /^\w+:/) {
980     $link = BSE::Cfg->single->entryErr("site", "url") . $link;
981   }
982
983   return $link;
984 }
985
986 =item option_list
987
988 Return a list of options for the item, each with:
989
990 =over
991
992 =item *
993
994 id, name - the identifier for the option
995
996 =item *
997
998 value - the value of the option.
999
1000 =item *
1001
1002 desc - the description of the option
1003
1004 =item *
1005
1006 display - display of the option value
1007
1008 =back
1009
1010 =cut
1011
1012 sub option_list {
1013   my ($self) = @_;
1014
1015   my @options = $self->product->option_descs(BSE::Cfg->single, $self->{options});
1016
1017   return wantarray ? @options : \@options;
1018 }
1019
1020 =item option_text
1021
1022 Display text for options for the item.
1023
1024 =cut
1025
1026 sub option_text {
1027   my ($self, $index) = @_;
1028
1029   my $options = $self->option_list;
1030   return join(", ", map "$_->{desc}: $_->{display}", @$options);
1031 }
1032
1033 =item coupon_applies
1034
1035 Returns true for a cart-wide coupon if this item allows the coupon to
1036 apply.
1037
1038 =cut
1039
1040 sub coupon_applies {
1041   my ($self) = @_;
1042
1043   $self->{cart}->coupon_active
1044     or return 0;
1045
1046   return $self->{cart}{coupon_check}{coupon}->product_valid($self->{cart}, $self->{index});
1047 }
1048
1049 =item product_discount
1050
1051 Returns the number of cents of discount this product receives per unit
1052
1053 =cut
1054
1055 sub product_discount {
1056   my ($self) = @_;
1057
1058   $self->{cart}->coupon_active
1059     or return 0;
1060
1061   return $self->{cart}{coupon_check}{coupon}->product_discount($self->{cart}, $self->{index});
1062 }
1063
1064 =item product_discount_units
1065
1066 Returns the number of units in the current row that the product
1067 discount applies to.
1068
1069 =cut
1070
1071 sub product_discount_units {
1072   my ($self) = @_;
1073
1074   $self->{cart}->coupon_active
1075     or return 0;
1076
1077   return $self->{cart}{coupon_check}{coupon}->product_discount_units($self->{cart}, $self->{index});
1078 }
1079
1080
1081 =item session
1082
1083 The session object of the seminar session
1084
1085 =cut
1086
1087 sub session {
1088   my ($self) = @_;
1089
1090   $self->{session_id} or return;
1091   return $self->{cart}->_session($self->{session_id});
1092 }
1093
1094
1095 my %product_keys;
1096
1097 sub AUTOLOAD {
1098   our $AUTOLOAD;
1099   (my $name = $AUTOLOAD) =~ s/^.*:://;
1100   unless (%product_keys) {
1101     require BSE::TB::Products;
1102     %product_keys = map { $_ => 1 } BSE::TB::Product->columns;
1103   }
1104
1105   if ($product_keys{$name}) {
1106     return $_[0]->product->$name();
1107   }
1108   else {
1109     return "* unknown method $name *";
1110   }
1111 }
1112
1113 =item description
1114
1115 =item title
1116
1117 =cut
1118
1119 sub description {
1120   my ($self) = @_;
1121
1122   $self->product->description;
1123 }
1124
1125 sub title {
1126   my ($self) = @_;
1127
1128   $self->product->title;
1129 }
1130
1131 1;
1132
1133 =back
1134
1135 =head1 AUTHOR
1136
1137 Tony Cook <tony@develop-help.com>
1138
1139 =cut