re-work coupons to allow multiple coupon types
[bse.git] / site / cgi-bin / modules / BSE / TB / Coupon.pm
CommitLineData
023761bd
TC
1package BSE::TB::Coupon;
2use strict;
3use Squirrel::Row;
4our @ISA = qw/Squirrel::Row/;
5use BSE::TB::CouponTiers;
6
b55d4af1 7our $VERSION = "1.007";
023761bd 8
78e38142 9=head1 NAME
023761bd
TC
10
11BSE::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
21Represents shop coupons.
22
23=head1 METHODS
24
25=over
26
27=cut
28
29sub columns {
b55d4af1
TC
30 return qw/id code description release expiry discount_percent campaign last_modified untiered
31 classid config/;
023761bd
TC
32}
33
34sub table {
35 "bse_coupons";
36}
37
38sub defaults {
39 require BSE::Util::SQL;
40 return
41 (
42 last_modified => BSE::Util::SQL::now_sqldatetime(),
43 untiered => 1,
b55d4af1 44 discount_percent => undef,
023761bd
TC
45 );
46}
47
48=item tiers
49
50Return the tier ids for a coupon.
51
78e38142
TC
52This includes an entry for tier "0" if the coupon is untiered.
53
023761bd
TC
54=cut
55
56sub tiers {
57 my ($self) = @_;
58
78e38142 59 my @tiers =
023761bd 60 (
78e38142
TC
61 ( $self->untiered ? ( 0 ) : () ),
62 BSE::TB::CouponTiers->getColumnBy
63 (
64 tier_id =>
65 [
66 coupon_id => $self->id
67 ]
68 )
023761bd 69 );
78e38142
TC
70
71 return wantarray ? @tiers : \@tiers;
023761bd
TC
72}
73
74=item tier_objects
75
76Return tier objects for each of the tiers this coupon is valid for.
77
78=cut
79
80sub 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
89Set the tiers for a coupon.
90
91=cut
92
93sub set_tiers {
94 my ($self, $tiers) = @_;
95
78e38142
TC
96 my @tiers = grep $_, @$tiers;
97 $self->set_untiered((grep $_ == 0, @$tiers) ? 1 : 0);
98
023761bd
TC
99 my %current = map { $_->tier_id => $_ }
100 BSE::TB::CouponTiers->getBy2
101 (
102 [
103 coupon_id => $self->id
104 ]
105 );
106
78e38142 107 my %keep = map { $_->tier_id => $_ } grep $_, delete @current{@tiers};
023761bd 108
de6185f8 109 $_->remove for values %current;
023761bd 110
78e38142 111 for my $tier_id (grep !$keep{$_}, @tiers) {
023761bd
TC
112 BSE::TB::CouponTiers->make
113 (
114 coupon_id => $self->id,
115 tier_id => $tier_id
116 );
117 }
118
119 1;
120}
121
122sub remove {
123 my ($self) = @_;
124
2ced88e0
TC
125 $self->is_removable
126 or return;
127
023761bd
TC
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
139sub json_data {
140 my ($self) = @_;
141
142 my $data = $self->data_only;
143 $data->{tiers} = [ $self->tiers ];
b55d4af1
TC
144 $data->{config_obj} = $self->config_obj;
145 delete @$data{qw/config discount_percent/};
023761bd
TC
146
147 return $data;
148}
149
150=item is_expired
151
152Returns true if the coupon has expired.
153
154=cut
155
156sub 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
165Returns true if the coupon has been released.
166
167=cut
168
169sub 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
178Returns true if the coupon is both released and unexpired.
179
180=cut
181
182sub is_valid {
183 my ($self) = @_;
184
185 return $self->is_released && !$self->is_expired;
186}
187
2ced88e0
TC
188=item is_removable
189
190Return true if the coupon can be removed.
191
192=cut
193
194sub 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
203Return true if the name can be changed.
204
205This is currently equivalent to is_removable().
206
207=cut
208
209sub is_renamable {
210 my ($self) = @_;
211
212 return $self->is_removable;
213}
214
b55d4af1
TC
215=item is_active
216
217Returns a list of (is active, message) for the given cart.
218
219Wrapper around is_active() for the behaviour.
220
221 my ($active, $msg) = $coupon->is_active($cart);
222
223=cut
224
225sub is_active {
226 my ($self, $cart) = @_;
227
228 return $self->behaviour->is_active($self, $cart);
229}
230
231=item discount
232
233Return the discount in cents for the given cart.
234
235Must only be called if is_active() returned the coupon as active.
236
237Wrapper around discount() for the behaviour.
238
239 my ($cents) = $coupon->discount($cart);
240
241=cut
242
243sub discount {
244 my ($self, $cart) = @_;
245
246 return $self->behaviour->discount($self, $cart);
247}
248
249=item product_valid
250
251Return true if the given cart item is valid for the coupon.
252
253Only relevant for cart-wide coupons.
254
255=cut
256
257sub product_valid {
258 my ($self, $cart, $index) = @_;
259
260 return $self->behaviour->product_valid($self, $cart, $index);
261}
262
263=item product_discount
264
265Return the product specific discount per unit for the given row
266(counting from zero) in the cart.
267
268Must only be called if is_active() returned the coupon as active.
269
270Returns zero if the coupon discount is for the cart as a whole.
271
272Wrapper around product_discount() for the behaviour.
273
274 my $cents = $coupon->product_discount($cart, $index);
275
276=cut
277
278sub 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
286Return the number of units a product specific discount applies to the given row
287(counting from zero) in the cart.
288
289Must only be called if is_active() returned the coupon as active.
290
291Returns zero if the coupon discount is for the cart as a whole.
292
293Wrapper around product_discount_units() for the behaviour.
294
295 my $cents = $coupon->product_discount_units($cart, $index);
296
297=cut
298
299sub 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
307Describe the behaviour of the coupon briefly.
308
309=cut
310
311sub describe {
312 my ($self) = @_;
313
314 $self->behaviour->describe;
315}
316
317=item cart_wide($cart)
318
319Returns true if the discount provided by the behaviour applies to the
320cart as a whole.
321
322=cut
323
324sub cart_wide {
325 my ($self, $cart) = @_;
326
327 return $self->behaviour->cart_wide($cart);
328}
329
2ced88e0
TC
330=item set_code($code)
331
332Set the coupon code. Requires that is_renamable() be true.
333
334=cut
335
336sub set_code {
337 my ($self, $code) = @_;
338
339 $self->is_renamable
340 or return;
341
342 $self->{code} = $code;
343}
344
023761bd 345sub fields {
2ced88e0 346 my ($self) = @_;
023761bd 347
b55d4af1
TC
348 my $bclasses = BSE::TB::Coupons->behaviour_classes;
349
023761bd
TC
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 },
023761bd
TC
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;
78e38142
TC
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 ];
023761bd
TC
413 },
414 id => "id",
415 label => "description",
416 },
417 },
b55d4af1
TC
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 },
023761bd
TC
439 );
440
2ced88e0
TC
441 if (ref $self && !$self->is_renamable) {
442 $fields{code}{readonly} = 1;
443 }
444
023761bd
TC
445 require BSE::Validate;
446 return BSE::Validate::bse_configure_fields(\%fields, BSE::Cfg->single, "bse coupon validation");
447}
448
449sub 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 },
023761bd
TC
457 };
458}
459
b55d4af1
TC
460sub 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
473sub 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
482sub 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
023761bd
TC
4971;
498
499=back
500
501=head1 AUTHOR
502
503Tony Cook <tony@develop-help.com>
504
505=cut