re-work coupons to allow multiple coupon types
[bse.git] / site / cgi-bin / modules / BSE / TB / Coupon.pm
1 package BSE::TB::Coupon;
2 use strict;
3 use Squirrel::Row;
4 our @ISA = qw/Squirrel::Row/;
5 use BSE::TB::CouponTiers;
6
7 our $VERSION = "1.007";
8
9 =head1 NAME
10
11 BSE::TB::Coupon - shop coupon objects
12
13 =head1 SYNOPSIS
14
15   use BSE::TB::Coupons;
16
17   my $coupon = BSE::TB::Coupons->make(...);
18
19 =head1 DESCRIPTION
20
21 Represents shop coupons.
22
23 =head1 METHODS
24
25 =over
26
27 =cut
28
29 sub columns {
30   return qw/id code description release expiry discount_percent campaign last_modified untiered
31             classid config/;
32 }
33
34 sub table {
35   "bse_coupons";
36 }
37
38 sub defaults {
39   require BSE::Util::SQL;
40   return
41     (
42      last_modified => BSE::Util::SQL::now_sqldatetime(),
43      untiered => 1,
44      discount_percent => undef,
45     );
46 }
47
48 =item tiers
49
50 Return the tier ids for a coupon.
51
52 This includes an entry for tier "0" if the coupon is untiered.
53
54 =cut
55
56 sub tiers {
57   my ($self) = @_;
58
59   my @tiers =
60     (
61      ( $self->untiered ? ( 0 ) : () ),
62      BSE::TB::CouponTiers->getColumnBy
63      (
64       tier_id =>
65       [
66        coupon_id => $self->id
67       ]
68      )
69     );
70
71   return wantarray ? @tiers : \@tiers;
72 }
73
74 =item tier_objects
75
76 Return tier objects for each of the tiers this coupon is valid for.
77
78 =cut
79
80 sub tier_objects {
81   my ($self) = @_;
82
83   require BSE::TB::PriceTiers;
84   return BSE::TB::PriceTiers->getSpecial(forCoupon => $self->id);
85 }
86
87 =item set_tiers(\@tiers)
88
89 Set the tiers for a coupon.
90
91 =cut
92
93 sub set_tiers {
94   my ($self, $tiers) = @_;
95
96   my @tiers = grep $_, @$tiers;
97   $self->set_untiered((grep $_ == 0, @$tiers) ? 1 : 0);
98
99   my %current = map { $_->tier_id => $_ }
100     BSE::TB::CouponTiers->getBy2
101         (
102          [
103           coupon_id => $self->id
104          ]
105         );
106
107   my %keep = map { $_->tier_id => $_ } grep $_, delete @current{@tiers};
108
109   $_->remove for values %current;
110
111   for my $tier_id (grep !$keep{$_}, @tiers) {
112     BSE::TB::CouponTiers->make
113         (
114          coupon_id => $self->id,
115          tier_id => $tier_id
116         );
117   }
118
119   1;
120 }
121
122 sub remove {
123   my ($self) = @_;
124
125   $self->is_removable
126     or return;
127
128   my @tiers = BSE::TB::CouponTiers->getBy2
129     (
130      [
131       coupon_id => $self->id
132      ]
133     );
134   $_->remove for @tiers;
135
136   $self->SUPER::remove();
137 }
138
139 sub json_data {
140   my ($self) = @_;
141
142   my $data = $self->data_only;
143   $data->{tiers} = [ $self->tiers ];
144   $data->{config_obj} = $self->config_obj;
145   delete @$data{qw/config discount_percent/};
146
147   return $data;
148 }
149
150 =item is_expired
151
152 Returns true if the coupon has expired.
153
154 =cut
155
156 sub is_expired {
157   my ($self) = @_;
158
159   require BSE::Util::SQL;
160   return BSE::Util::SQL::now_sqldate() gt $self->expiry;
161 }
162
163 =item is_released
164
165 Returns true if the coupon has been released.
166
167 =cut
168
169 sub is_released {
170   my ($self) = @_;
171
172   require BSE::Util::SQL;
173   return $self->release le BSE::Util::SQL::now_sqldate();
174 }
175
176 =item is_valid
177
178 Returns true if the coupon is both released and unexpired.
179
180 =cut
181
182 sub is_valid {
183   my ($self) = @_;
184
185   return $self->is_released && !$self->is_expired;
186 }
187
188 =item is_removable
189
190 Return true if the coupon can be removed.
191
192 =cut
193
194 sub is_removable {
195   my ($self) = @_;
196
197   require BSE::TB::Orders;
198   return !BSE::TB::Orders->getExists([ coupon_id => $self->id ]);
199 }
200
201 =item is_renamable
202
203 Return true if the name can be changed.
204
205 This is currently equivalent to is_removable().
206
207 =cut
208
209 sub is_renamable {
210   my ($self) = @_;
211
212   return $self->is_removable;
213 }
214
215 =item is_active
216
217 Returns a list of (is active, message) for the given cart.
218
219 Wrapper around is_active() for the behaviour.
220
221   my ($active, $msg) = $coupon->is_active($cart);
222
223 =cut
224
225 sub is_active {
226   my ($self, $cart) = @_;
227
228   return $self->behaviour->is_active($self, $cart);
229 }
230
231 =item discount
232
233 Return the discount in cents for the given cart.
234
235 Must only be called if is_active() returned the coupon as active.
236
237 Wrapper around discount() for the behaviour.
238
239   my ($cents) = $coupon->discount($cart);
240
241 =cut
242
243 sub discount {
244   my ($self, $cart) = @_;
245
246   return $self->behaviour->discount($self, $cart);
247 }
248
249 =item product_valid
250
251 Return true if the given cart item is valid for the coupon.
252
253 Only relevant for cart-wide coupons.
254
255 =cut
256
257 sub product_valid {
258   my ($self, $cart, $index) = @_;
259
260   return $self->behaviour->product_valid($self, $cart, $index);
261 }
262
263 =item product_discount
264
265 Return the product specific discount per unit for the given row
266 (counting from zero) in the cart.
267
268 Must only be called if is_active() returned the coupon as active.
269
270 Returns zero if the coupon discount is for the cart as a whole.
271
272 Wrapper around product_discount() for the behaviour.
273
274   my $cents = $coupon->product_discount($cart, $index);
275
276 =cut
277
278 sub product_discount {
279   my ($self, $cart, $index) = @_;
280
281   return $self->behaviour->product_discount($self, $cart, $index);
282 }
283
284 =item product_discount_units
285
286 Return the number of units a product specific discount applies to the given row
287 (counting from zero) in the cart.
288
289 Must only be called if is_active() returned the coupon as active.
290
291 Returns zero if the coupon discount is for the cart as a whole.
292
293 Wrapper around product_discount_units() for the behaviour.
294
295   my $cents = $coupon->product_discount_units($cart, $index);
296
297 =cut
298
299 sub product_discount_units {
300   my ($self, $cart, $index) = @_;
301
302   return $self->behaviour->product_discount_units($self, $cart, $index);
303 }
304
305 =item describe
306
307 Describe the behaviour of the coupon briefly.
308
309 =cut
310
311 sub describe {
312   my ($self) = @_;
313
314   $self->behaviour->describe;
315 }
316
317 =item cart_wide($cart)
318
319 Returns true if the discount provided by the behaviour applies to the
320 cart as a whole.
321
322 =cut
323
324 sub cart_wide {
325   my ($self, $cart) = @_;
326
327   return $self->behaviour->cart_wide($cart);
328 }
329
330 =item set_code($code)
331
332 Set the coupon code.  Requires that is_renamable() be true.
333
334 =cut
335
336 sub set_code {
337   my ($self, $code) = @_;
338
339   $self->is_renamable
340     or return;
341
342   $self->{code} = $code;
343 }
344
345 sub fields {
346   my ($self) = @_;
347
348   my $bclasses = BSE::TB::Coupons->behaviour_classes;
349
350   my %fields =
351     (
352      code =>
353      {
354       description => "Coupon Code",
355       required => 1,
356       width => 20,
357       maxlength => 40,
358       htmltype => "text",
359       rules => "dh_one_line;coupon_code",
360      },
361      description =>
362      {
363       description => "Description",
364       required => 1,
365       width => 80,
366       htmltype => "text",
367       rules => "dh_one_line",
368      },
369      release =>
370      {
371       description => "Release Date",
372       required => 1,
373       width => 10,
374       htmltype => "text",
375       type => "date",
376       rules => "date",
377      },
378      expiry =>
379      {
380       description => "Expiry Date",
381       required => 1,
382       width => 10,
383       htmltype => "text",
384       type => "date",
385       rules => "date",
386      },
387      campaign =>
388      {
389       description => "Campaign",
390       width => 20,
391       maxlength => 20,
392       htmltype => "text",
393       rules => "dh_one_line",
394      },
395      tiers =>
396      {
397       description => "Price Tiers",
398       htmltype => "multicheck",
399       select =>
400       {
401        values => sub {
402          require BSE::TB::PriceTiers;
403          return
404            [
405             { id => 0, description => "Untiered" },
406             BSE::TB::PriceTiers->getColumnsBy
407             (
408              [ qw(id description) ],
409              [ ],
410              { order => "display_order asc" },
411             ),
412            ];
413        },
414        id => "id",
415        label => "description",
416       },
417      },
418      classid =>
419      {
420       description => "Coupon Class",
421       htmltype => "select",
422       select =>
423       {
424        id => "id",
425        label => "label",
426        values =>
427        [
428         sort { lc $a->{label} cmp lc $b->{label} }
429         map
430         +{
431           id => $_,
432           label => $bclasses->{$_}->class_description,
433          },
434         sort { lc $bclasses->{$a}->class_description cmp lc $bclasses->{$b}->class_description}
435         keys %$bclasses
436        ],
437       },
438      },
439     );
440
441   if (ref $self && !$self->is_renamable) {
442     $fields{code}{readonly} = 1;
443   }
444
445   require BSE::Validate;
446   return BSE::Validate::bse_configure_fields(\%fields, BSE::Cfg->single, "bse coupon validation");
447 }
448
449 sub rules {
450   return
451     {
452      coupon_code =>
453      {
454       match => qr/\A[a-zA-Z0-9]+\z/,
455       error => '$n can only contain letters and digits',
456      },
457     };
458 }
459
460 sub config_obj {
461   my ($self) = @_;
462
463   my $config = $self->config;
464   $config = "{}" if $config eq "";
465
466   require JSON;
467   my $obj = JSON->new->decode($config);
468   $obj->{discount_percent} = $self->discount_percent;
469
470   return $obj;
471 }
472
473 sub set_config_obj {
474   my ($self, $obj) = @_;
475
476   $self->set_discount_percent(delete $obj->{discount_percent});
477
478   require JSON;
479   $self->set_config(JSON->new->encode($obj));
480 }
481
482 sub behaviour {
483   my ($self) = @_;
484
485   delete $self->{_behaviour}
486     if $self->{_classid} ne $self->classid
487     || $self->{_config} ne $self->config;
488
489   $self->{_behaviour} ||=
490     BSE::TB::Coupons->behaviour_class($self->classid)->new($self->config_obj);
491   $self->{_classid} = $self->classid;
492   $self->{_config} = $self->config;
493
494   $self->{_behaviour};
495 }
496
497 1;
498
499 =back
500
501 =head1 AUTHOR
502
503 Tony Cook <tony@develop-help.com>
504
505 =cut