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