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