added on WebSTLs (webstls.com) at 2026-07-01 22:26:40
| 1 | package MODS::WebSTLs::Promotions; | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs - Promotions (coupons, sales, bundles, flash sales). | |
| 4 | # | |
| 5 | # One module covers both seller-scope and platform-scope promos. Scope | |
| 6 | # is enforced in the helper queries below so /promotions.cgi only ever | |
| 7 | # sees the caller's storefront rows and /admin_promotions.cgi only | |
| 8 | # sees scope='platform' rows. | |
| 9 | # | |
| 10 | # Tables (see section 7 in db_schema.sql): | |
| 11 | # promotions, promotion_models, promotion_redemptions | |
| 12 | # | |
| 13 | # Every table query is guarded with SHOW TABLES LIKE because DBConnect's | |
| 14 | # error() calls exit() on a missing table -- matches feedback_guard_optional_tables. | |
| 15 | #====================================================================== | |
| 16 | use strict; | |
| 17 | use warnings; | |
| 18 | ||
| 19 | sub new { | |
| 20 | my ($class, %args) = @_; | |
| 21 | return bless({}, $class); | |
| 22 | } | |
| 23 | ||
| 24 | # ---- Schema guards --------------------------------------------------- | |
| 25 | sub schema_ready { | |
| 26 | my ($self, $db, $dbh, $DB) = @_; | |
| 27 | foreach my $t (qw(promotions promotion_models promotion_redemptions)) { | |
| 28 | my $r = $db->db_readwrite($dbh, qq~ | |
| 29 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 30 | WHERE table_schema='$DB' AND table_name='$t' | |
| 31 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 32 | return 0 unless ($r && $r->{n}); | |
| 33 | } | |
| 34 | return 1; | |
| 35 | } | |
| 36 | ||
| 37 | # ---- List queries ---------------------------------------------------- | |
| 38 | # Seller-scope: every promo belonging to the user's storefront(s). | |
| 39 | sub list_for_seller { | |
| 40 | my ($self, $db, $dbh, $DB, $uid, $limit) = @_; | |
| 41 | $uid =~ s/[^0-9]//g; | |
| 42 | return () unless $uid; | |
| 43 | return () unless $self->schema_ready($db, $dbh, $DB); | |
| 44 | ||
| 45 | $limit ||= 50; | |
| 46 | $limit =~ s/[^0-9]//g; $limit = 50 unless $limit; $limit = 500 if $limit > 500; | |
| 47 | ||
| 48 | return $db->db_readwrite_multiple($dbh, qq~ | |
| 49 | SELECT p.* | |
| 50 | FROM `${DB}`.promotions p | |
| 51 | JOIN `${DB}`.storefronts s ON s.id = p.storefront_id | |
| 52 | WHERE s.user_id='$uid' AND p.scope='storefront' | |
| 53 | ORDER BY (p.status='active') DESC, p.created_at DESC | |
| 54 | LIMIT $limit | |
| 55 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 56 | } | |
| 57 | ||
| 58 | # Platform-scope: WebSTLs-wide promos. Admin only. | |
| 59 | sub list_for_admin { | |
| 60 | my ($self, $db, $dbh, $DB, $limit) = @_; | |
| 61 | return () unless $self->schema_ready($db, $dbh, $DB); | |
| 62 | ||
| 63 | $limit ||= 100; | |
| 64 | $limit =~ s/[^0-9]//g; $limit = 100 unless $limit; $limit = 500 if $limit > 500; | |
| 65 | ||
| 66 | return $db->db_readwrite_multiple($dbh, qq~ | |
| 67 | SELECT p.* | |
| 68 | FROM `${DB}`.promotions p | |
| 69 | WHERE p.scope='platform' | |
| 70 | ORDER BY (p.status='active') DESC, p.created_at DESC | |
| 71 | LIMIT $limit | |
| 72 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 73 | } | |
| 74 | ||
| 75 | # Single promotion. Caller is responsible for enforcing ownership -- | |
| 76 | # pass scope + uid to the variants below for a checked load. | |
| 77 | sub get { | |
| 78 | my ($self, $db, $dbh, $DB, $id) = @_; | |
| 79 | $id =~ s/[^0-9]//g; | |
| 80 | return {} unless $id; | |
| 81 | return {} unless $self->schema_ready($db, $dbh, $DB); | |
| 82 | my $r = $db->db_readwrite($dbh, qq~ | |
| 83 | SELECT * FROM `${DB}`.promotions WHERE id='$id' LIMIT 1 | |
| 84 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 85 | return ($r && $r->{id}) ? $r : {}; | |
| 86 | } | |
| 87 | ||
| 88 | # Get + enforce seller ownership. | |
| 89 | sub get_for_seller { | |
| 90 | my ($self, $db, $dbh, $DB, $id, $uid) = @_; | |
| 91 | $id =~ s/[^0-9]//g; | |
| 92 | $uid =~ s/[^0-9]//g; | |
| 93 | return {} unless $id && $uid; | |
| 94 | return {} unless $self->schema_ready($db, $dbh, $DB); | |
| 95 | my $r = $db->db_readwrite($dbh, qq~ | |
| 96 | SELECT p.* | |
| 97 | FROM `${DB}`.promotions p | |
| 98 | JOIN `${DB}`.storefronts s ON s.id = p.storefront_id | |
| 99 | WHERE p.id='$id' AND s.user_id='$uid' AND p.scope='storefront' | |
| 100 | LIMIT 1 | |
| 101 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 102 | return ($r && $r->{id}) ? $r : {}; | |
| 103 | } | |
| 104 | ||
| 105 | # Get + enforce platform scope. | |
| 106 | sub get_for_admin { | |
| 107 | my ($self, $db, $dbh, $DB, $id) = @_; | |
| 108 | $id =~ s/[^0-9]//g; | |
| 109 | return {} unless $id; | |
| 110 | return {} unless $self->schema_ready($db, $dbh, $DB); | |
| 111 | my $r = $db->db_readwrite($dbh, qq~ | |
| 112 | SELECT * FROM `${DB}`.promotions WHERE id='$id' AND scope='platform' LIMIT 1 | |
| 113 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 114 | return ($r && $r->{id}) ? $r : {}; | |
| 115 | } | |
| 116 | ||
| 117 | # Linked model rows for a single promo. Returns ordered list of | |
| 118 | # { model_id, role, model_title } tuples for the edit form. | |
| 119 | sub models_for_promo { | |
| 120 | my ($self, $db, $dbh, $DB, $promo_id) = @_; | |
| 121 | $promo_id =~ s/[^0-9]//g; | |
| 122 | return () unless $promo_id; | |
| 123 | return () unless $self->schema_ready($db, $dbh, $DB); | |
| 124 | ||
| 125 | return $db->db_readwrite_multiple($dbh, qq~ | |
| 126 | SELECT pm.model_id, pm.role, m.title | |
| 127 | FROM `${DB}`.promotion_models pm | |
| 128 | LEFT JOIN `${DB}`.models m ON m.id = pm.model_id | |
| 129 | WHERE pm.promotion_id='$promo_id' | |
| 130 | ORDER BY pm.role ASC, m.title ASC | |
| 131 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 132 | } | |
| 133 | ||
| 134 | # ---- Create + update ------------------------------------------------- | |
| 135 | # Centralized write path so the seller and admin handlers share the same | |
| 136 | # validation. Caller supplies %a with the form fields; we sanitize and | |
| 137 | # return either the new promotion id or 0 on failure. | |
| 138 | sub create { | |
| 139 | my ($self, $db, $dbh, $DB, %a) = @_; | |
| 140 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 141 | ||
| 142 | my $fields = $self->_sanitize_fields(\%a); | |
| 143 | return 0 unless $fields; | |
| 144 | ||
| 145 | # Status defaults to 'draft' until the seller hits "Activate". | |
| 146 | my $status = $a{status} || 'draft'; | |
| 147 | my %status_ok = map { $_ => 1 } qw(draft scheduled active paused expired exhausted archived); | |
| 148 | $status = 'draft' unless $status_ok{$status}; | |
| 149 | ||
| 150 | my $sql_status = $self->_qstr($status); | |
| 151 | my $code_sql = defined $fields->{code} ? $self->_qstr($fields->{code}) : 'NULL'; | |
| 152 | my $slug_sql = defined $fields->{public_slug} ? $self->_qstr($fields->{public_slug}) : 'NULL'; | |
| 153 | my $start_sql = defined $fields->{starts_at} ? $self->_qstr($fields->{starts_at}) : 'NULL'; | |
| 154 | my $end_sql = defined $fields->{ends_at} ? $self->_qstr($fields->{ends_at}) : 'NULL'; | |
| 155 | my $maxr_sql = defined $fields->{max_redemptions} ? "'$fields->{max_redemptions}'" : 'NULL'; | |
| 156 | my $maxu_sql = defined $fields->{max_per_user} ? "'$fields->{max_per_user}'" : 'NULL'; | |
| 157 | my $store_sql = defined $fields->{storefront_id} ? "'$fields->{storefront_id}'" : 'NULL'; | |
| 158 | my $creator = defined $a{created_by_user_id} ? $a{created_by_user_id} : ''; | |
| 159 | $creator =~ s/[^0-9]//g; | |
| 160 | my $creator_sql = $creator eq '' ? 'NULL' : "'$creator'"; | |
| 161 | my $name_sql = $self->_qstr($fields->{name}); | |
| 162 | my $desc_sql = $self->_qstr($fields->{description} // ''); | |
| 163 | ||
| 164 | my $r = $db->db_readwrite($dbh, qq~ | |
| 165 | INSERT INTO `${DB}`.promotions | |
| 166 | SET scope='$fields->{scope}', | |
| 167 | storefront_id=$store_sql, | |
| 168 | kind='$fields->{kind}', | |
| 169 | target_kind='$fields->{target_kind}', | |
| 170 | name=$name_sql, | |
| 171 | description=$desc_sql, | |
| 172 | discount_type='$fields->{discount_type}', | |
| 173 | discount_value_bp='$fields->{discount_value_bp}', | |
| 174 | discount_value_cents='$fields->{discount_value_cents}', | |
| 175 | minimum_order_cents='$fields->{minimum_order_cents}', | |
| 176 | code=$code_sql, | |
| 177 | public_slug=$slug_sql, | |
| 178 | starts_at=$start_sql, | |
| 179 | ends_at=$end_sql, | |
| 180 | max_redemptions=$maxr_sql, | |
| 181 | max_per_user=$maxu_sql, | |
| 182 | new_customers_only='$fields->{new_customers_only}', | |
| 183 | status=$sql_status, | |
| 184 | created_by_user_id=$creator_sql | |
| 185 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 186 | return ($r && $r->{mysql_insertid}) ? $r->{mysql_insertid} : 0; | |
| 187 | } | |
| 188 | ||
| 189 | sub update { | |
| 190 | my ($self, $db, $dbh, $DB, $id, %a) = @_; | |
| 191 | $id =~ s/[^0-9]//g; | |
| 192 | return 0 unless $id; | |
| 193 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 194 | ||
| 195 | my $fields = $self->_sanitize_fields(\%a); | |
| 196 | return 0 unless $fields; | |
| 197 | ||
| 198 | my $code_sql = defined $fields->{code} ? $self->_qstr($fields->{code}) : 'NULL'; | |
| 199 | my $slug_sql = defined $fields->{public_slug} ? $self->_qstr($fields->{public_slug}) : 'NULL'; | |
| 200 | my $start_sql = defined $fields->{starts_at} ? $self->_qstr($fields->{starts_at}) : 'NULL'; | |
| 201 | my $end_sql = defined $fields->{ends_at} ? $self->_qstr($fields->{ends_at}) : 'NULL'; | |
| 202 | my $maxr_sql = defined $fields->{max_redemptions} ? "'$fields->{max_redemptions}'" : 'NULL'; | |
| 203 | my $maxu_sql = defined $fields->{max_per_user} ? "'$fields->{max_per_user}'" : 'NULL'; | |
| 204 | my $name_sql = $self->_qstr($fields->{name}); | |
| 205 | my $desc_sql = $self->_qstr($fields->{description} // ''); | |
| 206 | ||
| 207 | $db->db_readwrite($dbh, qq~ | |
| 208 | UPDATE `${DB}`.promotions | |
| 209 | SET kind='$fields->{kind}', | |
| 210 | target_kind='$fields->{target_kind}', | |
| 211 | name=$name_sql, | |
| 212 | description=$desc_sql, | |
| 213 | discount_type='$fields->{discount_type}', | |
| 214 | discount_value_bp='$fields->{discount_value_bp}', | |
| 215 | discount_value_cents='$fields->{discount_value_cents}', | |
| 216 | minimum_order_cents='$fields->{minimum_order_cents}', | |
| 217 | code=$code_sql, | |
| 218 | public_slug=$slug_sql, | |
| 219 | starts_at=$start_sql, | |
| 220 | ends_at=$end_sql, | |
| 221 | max_redemptions=$maxr_sql, | |
| 222 | max_per_user=$maxu_sql, | |
| 223 | new_customers_only='$fields->{new_customers_only}' | |
| 224 | WHERE id='$id' | |
| 225 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 226 | return 1; | |
| 227 | } | |
| 228 | ||
| 229 | sub set_status { | |
| 230 | my ($self, $db, $dbh, $DB, $id, $new_status) = @_; | |
| 231 | $id =~ s/[^0-9]//g; | |
| 232 | return 0 unless $id && $new_status; | |
| 233 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 234 | ||
| 235 | my %status_ok = map { $_ => 1 } qw(draft scheduled active paused expired exhausted archived); | |
| 236 | return 0 unless $status_ok{$new_status}; | |
| 237 | ||
| 238 | $db->db_readwrite($dbh, qq~ | |
| 239 | UPDATE `${DB}`.promotions SET status='$new_status' WHERE id='$id' | |
| 240 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 241 | return 1; | |
| 242 | } | |
| 243 | ||
| 244 | sub delete_promo { | |
| 245 | my ($self, $db, $dbh, $DB, $id) = @_; | |
| 246 | $id =~ s/[^0-9]//g; | |
| 247 | return 0 unless $id; | |
| 248 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 249 | ||
| 250 | # CASCADE removes promotion_models + promotion_redemptions. | |
| 251 | $db->db_readwrite($dbh, qq~ | |
| 252 | DELETE FROM `${DB}`.promotions WHERE id='$id' | |
| 253 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 254 | return 1; | |
| 255 | } | |
| 256 | ||
| 257 | # ---- Linked-model management ---------------------------------------- | |
| 258 | sub clear_models { | |
| 259 | my ($self, $db, $dbh, $DB, $promo_id) = @_; | |
| 260 | $promo_id =~ s/[^0-9]//g; | |
| 261 | return 0 unless $promo_id; | |
| 262 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 263 | $db->db_readwrite($dbh, qq~ | |
| 264 | DELETE FROM `${DB}`.promotion_models WHERE promotion_id='$promo_id' | |
| 265 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 266 | return 1; | |
| 267 | } | |
| 268 | ||
| 269 | sub add_model { | |
| 270 | my ($self, $db, $dbh, $DB, $promo_id, $model_id, $role) = @_; | |
| 271 | $promo_id =~ s/[^0-9]//g; | |
| 272 | $model_id =~ s/[^0-9]//g; | |
| 273 | $role ||= 'target'; | |
| 274 | return 0 unless $promo_id && $model_id; | |
| 275 | my %ok = map { $_ => 1 } qw(required target bonus); | |
| 276 | return 0 unless $ok{$role}; | |
| 277 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 278 | ||
| 279 | # Use INSERT IGNORE since (promotion_id, model_id) is the PK. | |
| 280 | $db->db_readwrite($dbh, qq~ | |
| 281 | INSERT IGNORE INTO `${DB}`.promotion_models | |
| 282 | SET promotion_id='$promo_id', model_id='$model_id', role='$role' | |
| 283 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 284 | return 1; | |
| 285 | } | |
| 286 | ||
| 287 | # ---- Aggregates for the listing page -------------------------------- | |
| 288 | sub redemption_count { | |
| 289 | my ($self, $db, $dbh, $DB, $promo_id) = @_; | |
| 290 | $promo_id =~ s/[^0-9]//g; | |
| 291 | return 0 unless $promo_id; | |
| 292 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 293 | my $r = $db->db_readwrite($dbh, qq~ | |
| 294 | SELECT COUNT(*) AS n FROM `${DB}`.promotion_redemptions WHERE promotion_id='$promo_id' | |
| 295 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 296 | return ($r && defined $r->{n}) ? $r->{n} : 0; | |
| 297 | } | |
| 298 | ||
| 299 | # Per-promo total discount given (cents). Drives the seller list page. | |
| 300 | sub total_discount_given_cents { | |
| 301 | my ($self, $db, $dbh, $DB, $promo_id) = @_; | |
| 302 | $promo_id =~ s/[^0-9]//g; | |
| 303 | return 0 unless $promo_id; | |
| 304 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 305 | my $r = $db->db_readwrite($dbh, qq~ | |
| 306 | SELECT COALESCE(SUM(discount_applied_cents),0) AS n | |
| 307 | FROM `${DB}`.promotion_redemptions | |
| 308 | WHERE promotion_id='$promo_id' | |
| 309 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 310 | return ($r && defined $r->{n}) ? $r->{n} : 0; | |
| 311 | } | |
| 312 | ||
| 313 | # ---- Public-link resolution ----------------------------------------- | |
| 314 | # Used by a future /promo/<slug> handler to redirect into the cart with | |
| 315 | # the code pre-applied. Returns either a matching active promo or {}. | |
| 316 | sub by_slug { | |
| 317 | my ($self, $db, $dbh, $DB, $slug) = @_; | |
| 318 | $slug =~ s/[^A-Za-z0-9_-]//g; | |
| 319 | return {} unless $slug ne ''; | |
| 320 | return {} unless $self->schema_ready($db, $dbh, $DB); | |
| 321 | my $r = $db->db_readwrite($dbh, qq~ | |
| 322 | SELECT * FROM `${DB}`.promotions | |
| 323 | WHERE public_slug='$slug' AND status='active' | |
| 324 | LIMIT 1 | |
| 325 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 326 | return ($r && $r->{id}) ? $r : {}; | |
| 327 | } | |
| 328 | ||
| 329 | # ---- Helpers -------------------------------------------------------- | |
| 330 | # Pretty discount label for the listing/edit pages. | |
| 331 | sub discount_label { | |
| 332 | my ($self, $r) = @_; | |
| 333 | return '-' unless $r && $r->{discount_type}; | |
| 334 | my $t = $r->{discount_type}; | |
| 335 | if ($t eq 'percent') { | |
| 336 | my $pct = ($r->{discount_value_bp} || 0) / 100; | |
| 337 | return sprintf('%.0f%% off', $pct); | |
| 338 | } elsif ($t eq 'fixed_amount') { | |
| 339 | return '$' . sprintf('%.2f', ($r->{discount_value_cents} || 0) / 100) . ' off'; | |
| 340 | } elsif ($t eq 'bundle_price') { | |
| 341 | return 'Bundle for $' . sprintf('%.2f', ($r->{discount_value_cents} || 0) / 100); | |
| 342 | } elsif ($t eq 'free') { | |
| 343 | return 'Free'; | |
| 344 | } | |
| 345 | return $t; | |
| 346 | } | |
| 347 | ||
| 348 | # Friendly status label. | |
| 349 | sub status_label { | |
| 350 | my ($self, $s) = @_; | |
| 351 | return 'Draft' if $s eq 'draft'; | |
| 352 | return 'Scheduled' if $s eq 'scheduled'; | |
| 353 | return 'Active' if $s eq 'active'; | |
| 354 | return 'Paused' if $s eq 'paused'; | |
| 355 | return 'Expired' if $s eq 'expired'; | |
| 356 | return 'Exhausted' if $s eq 'exhausted'; | |
| 357 | return 'Archived' if $s eq 'archived'; | |
| 358 | return ucfirst($s || ''); | |
| 359 | } | |
| 360 | ||
| 361 | # Compute the current effective status given the row's stored status | |
| 362 | # plus the time window + redemption count. Used by the listing page to | |
| 363 | # show "Expired" even if the row's status column still says 'active'. | |
| 364 | sub effective_status { | |
| 365 | my ($self, $r) = @_; | |
| 366 | return 'draft' unless $r && $r->{status}; | |
| 367 | return $r->{status} if $r->{status} =~ /^(draft|paused|archived)$/; | |
| 368 | return 'exhausted' if defined $r->{max_redemptions} | |
| 369 | && $r->{max_redemptions} > 0 | |
| 370 | && ($r->{current_redemptions} || 0) >= $r->{max_redemptions}; | |
| 371 | # Time window flagged via status='scheduled' / 'expired' set by the | |
| 372 | # worker. The status column is authoritative; we only re-derive when | |
| 373 | # the row says active but the window has actually closed. | |
| 374 | return $r->{status}; | |
| 375 | } | |
| 376 | ||
| 377 | # ---- Internal ------------------------------------------------------- | |
| 378 | sub _qstr { | |
| 379 | my ($self, $s) = @_; | |
| 380 | return 'NULL' unless defined $s; | |
| 381 | $s =~ s/'/''/g; | |
| 382 | return "'$s'"; | |
| 383 | } | |
| 384 | ||
| 385 | sub _sanitize_fields { | |
| 386 | my ($self, $a) = @_; | |
| 387 | ||
| 388 | # Scope + kind + discount_type + target_kind are enums. | |
| 389 | my %scope_ok = map { $_ => 1 } qw(storefront platform); | |
| 390 | my %kind_ok = map { $_ => 1 } qw(coupon sale bundle flash_sale); | |
| 391 | my %disc_ok = map { $_ => 1 } qw(percent fixed_amount bundle_price free); | |
| 392 | my %target_ok = map { $_ => 1 } qw(model plan any); | |
| 393 | ||
| 394 | my $scope = $a->{scope} || 'storefront'; | |
| 395 | return undef unless $scope_ok{$scope}; | |
| 396 | my $kind = $a->{kind} || 'coupon'; | |
| 397 | return undef unless $kind_ok{$kind}; | |
| 398 | my $dtype = $a->{discount_type} || 'percent'; | |
| 399 | return undef unless $disc_ok{$dtype}; | |
| 400 | # target_kind defaults to 'model' for backwards compat -- legacy | |
| 401 | # callers (and seller storefront promos) never set it. | |
| 402 | my $target = $a->{target_kind} || 'model'; | |
| 403 | return undef unless $target_ok{$target}; | |
| 404 | ||
| 405 | my $name = defined $a->{name} ? $a->{name} : ''; | |
| 406 | $name =~ s/^\s+|\s+$//g; | |
| 407 | $name = substr($name, 0, 160); | |
| 408 | return undef unless length $name; | |
| 409 | ||
| 410 | my $desc = defined $a->{description} ? $a->{description} : ''; | |
| 411 | $desc =~ s/[\r\n]+/ /g; | |
| 412 | $desc = substr($desc, 0, 500); | |
| 413 | ||
| 414 | # Numeric fields | |
| 415 | my $bp = defined $a->{discount_value_bp} ? $a->{discount_value_bp} : 0; | |
| 416 | $bp =~ s/[^0-9]//g; $bp = 0 unless $bp; $bp = 10000 if $bp > 10000; | |
| 417 | ||
| 418 | my $cents = defined $a->{discount_value_cents} ? $a->{discount_value_cents} : 0; | |
| 419 | $cents =~ s/[^0-9]//g; $cents = 0 unless $cents; | |
| 420 | ||
| 421 | my $min = defined $a->{minimum_order_cents} ? $a->{minimum_order_cents} : 0; | |
| 422 | $min =~ s/[^0-9]//g; $min = 0 unless $min; | |
| 423 | ||
| 424 | # Storefront fk | |
| 425 | my $store = $a->{storefront_id}; | |
| 426 | if (defined $store) { $store =~ s/[^0-9]//g; $store = undef unless $store; } | |
| 427 | ||
| 428 | # Caps: nullable -> "unlimited" | |
| 429 | my $maxr = $a->{max_redemptions}; | |
| 430 | if (defined $maxr && $maxr ne '') { | |
| 431 | $maxr =~ s/[^0-9]//g; | |
| 432 | $maxr = undef unless length $maxr; | |
| 433 | } else { $maxr = undef; } | |
| 434 | ||
| 435 | my $maxu = $a->{max_per_user}; | |
| 436 | if (defined $maxu && $maxu ne '') { | |
| 437 | $maxu =~ s/[^0-9]//g; | |
| 438 | $maxu = undef unless length $maxu; | |
| 439 | } else { $maxu = undef; } | |
| 440 | ||
| 441 | # Code: alphanumeric + dash/underscore, uppercased, max 64. | |
| 442 | my $code = $a->{code}; | |
| 443 | if (defined $code) { | |
| 444 | $code =~ s/^\s+|\s+$//g; | |
| 445 | $code = undef if $code eq ''; | |
| 446 | if (defined $code) { | |
| 447 | $code = uc $code; | |
| 448 | $code =~ s/[^A-Z0-9_-]//g; | |
| 449 | $code = substr($code, 0, 64); | |
| 450 | $code = undef unless length $code; | |
| 451 | } | |
| 452 | } | |
| 453 | ||
| 454 | # Slug: lowercase, alphanumeric + dash/underscore, max 64. | |
| 455 | my $slug = $a->{public_slug}; | |
| 456 | if (defined $slug) { | |
| 457 | $slug =~ s/^\s+|\s+$//g; | |
| 458 | $slug = undef if $slug eq ''; | |
| 459 | if (defined $slug) { | |
| 460 | $slug = lc $slug; | |
| 461 | $slug =~ s/[^a-z0-9_-]//g; | |
| 462 | $slug = substr($slug, 0, 64); | |
| 463 | $slug = undef unless length $slug; | |
| 464 | } | |
| 465 | } | |
| 466 | ||
| 467 | # Time bounds. Accept either '' (= null) or 'YYYY-MM-DD HH:MM:SS' | |
| 468 | # / 'YYYY-MM-DDTHH:MM' (HTML datetime-local). Normalize to MySQL. | |
| 469 | my $starts = _norm_dt($a->{starts_at}); | |
| 470 | my $ends = _norm_dt($a->{ends_at}); | |
| 471 | ||
| 472 | my $new_only = ($a->{new_customers_only} && $a->{new_customers_only} ne '0') ? 1 : 0; | |
| 473 | ||
| 474 | return { | |
| 475 | scope => $scope, | |
| 476 | storefront_id => $store, | |
| 477 | kind => $kind, | |
| 478 | target_kind => $target, | |
| 479 | name => $name, | |
| 480 | description => $desc, | |
| 481 | discount_type => $dtype, | |
| 482 | discount_value_bp => $bp, | |
| 483 | discount_value_cents => $cents, | |
| 484 | minimum_order_cents => $min, | |
| 485 | code => $code, | |
| 486 | public_slug => $slug, | |
| 487 | starts_at => $starts, | |
| 488 | ends_at => $ends, | |
| 489 | max_redemptions => $maxr, | |
| 490 | max_per_user => $maxu, | |
| 491 | new_customers_only => $new_only, | |
| 492 | }; | |
| 493 | } | |
| 494 | ||
| 495 | sub _norm_dt { | |
| 496 | my $s = shift; | |
| 497 | return undef unless defined $s; | |
| 498 | $s =~ s/^\s+|\s+$//g; | |
| 499 | return undef if $s eq ''; | |
| 500 | # Accept 'YYYY-MM-DDTHH:MM' (HTML datetime-local) and append :00. | |
| 501 | if ($s =~ /^(\d{4}-\d{2}-\d{2})T(\d{2}:\d{2})$/) { | |
| 502 | return "$1 $2:00"; | |
| 503 | } | |
| 504 | # Accept 'YYYY-MM-DD HH:MM:SS' verbatim. | |
| 505 | if ($s =~ /^\d{4}-\d{2}-\d{2} \d{2}:\d{2}(:\d{2})?$/) { | |
| 506 | return $s . (defined $1 ? '' : ':00'); | |
| 507 | } | |
| 508 | # Date-only: midnight start. | |
| 509 | if ($s =~ /^\d{4}-\d{2}-\d{2}$/) { | |
| 510 | return "$s 00:00:00"; | |
| 511 | } | |
| 512 | return undef; | |
| 513 | } | |
| 514 | ||
| 515 | #---------------------------------------------------------------------- | |
| 516 | # Public-display helpers. These power the "promo banner" that appears | |
| 517 | # on /pricing.cgi, /billing.cgi, and the landing-page pricing block so | |
| 518 | # any currently-running plan promotion is surfaced to prospects before | |
| 519 | # they have to know the code. Pure reads -- no redemption side effects. | |
| 520 | #---------------------------------------------------------------------- | |
| 521 | ||
| 522 | # Active plan-target promotion, or undef if none are currently | |
| 523 | # advertisable. Filters scope='platform', status='active', target_kind | |
| 524 | # in ('plan','any'), within the time window, and not exhausted. If | |
| 525 | # multiple match (rare on a small platform), the most recently created | |
| 526 | # wins -- new launches naturally bump older codes off the marquee. | |
| 527 | sub active_plan_promo { | |
| 528 | my ($self, $db, $dbh, $DB) = @_; | |
| 529 | return undef unless $self->schema_ready($db, $dbh, $DB); | |
| 530 | my $row = $db->db_readwrite($dbh, qq~ | |
| 531 | SELECT * FROM `${DB}`.promotions | |
| 532 | WHERE scope='platform' | |
| 533 | AND status='active' | |
| 534 | AND target_kind IN ('plan','any') | |
| 535 | AND (starts_at IS NULL OR starts_at <= NOW()) | |
| 536 | AND (ends_at IS NULL OR ends_at > NOW()) | |
| 537 | AND (max_redemptions IS NULL | |
| 538 | OR max_redemptions = 0 | |
| 539 | OR current_redemptions < max_redemptions) | |
| 540 | ORDER BY id DESC | |
| 541 | LIMIT 1 | |
| 542 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 543 | return ($row && $row->{id}) ? $row : undef; | |
| 544 | } | |
| 545 | ||
| 546 | # List the plan_ids this promo is restricted to. EMPTY ARRAY means | |
| 547 | # "applies to every paid plan" -- that's the unrestricted default and | |
| 548 | # how every legacy / freshly-created promo with no admin picks behaves. | |
| 549 | sub eligible_plan_ids { | |
| 550 | my ($self, $db, $dbh, $DB, $promo_id) = @_; | |
| 551 | return () unless $self->schema_ready($db, $dbh, $DB); | |
| 552 | $promo_id =~ s/[^0-9]//g if defined $promo_id; | |
| 553 | return () unless $promo_id; | |
| 554 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 555 | SELECT plan_id FROM `${DB}`.promotion_plans | |
| 556 | WHERE promotion_id='$promo_id' | |
| 557 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 558 | return map { $_->{plan_id} } @rows; | |
| 559 | } | |
| 560 | ||
| 561 | # Does this promo cover this specific plan? An empty promotion_plans | |
| 562 | # row set is treated as "all paid plans", so this returns 0 only for | |
| 563 | # free plans (price_cents == 0) in that case, and otherwise gates by | |
| 564 | # the explicit pick list when one exists. | |
| 565 | sub promo_applies_to_plan { | |
| 566 | my ($self, $db, $dbh, $DB, $promo_id, $plan) = @_; | |
| 567 | return 0 unless $promo_id && $plan && $plan->{id}; | |
| 568 | # Free plans are never discountable -- nothing to discount from $0. | |
| 569 | return 0 if !($plan->{price_cents} || 0); | |
| 570 | my @eligible = $self->eligible_plan_ids($db, $dbh, $DB, $promo_id); | |
| 571 | return 1 unless @eligible; # empty pick list = all paid plans | |
| 572 | return scalar grep { $_ eq $plan->{id} } @eligible; | |
| 573 | } | |
| 574 | ||
| 575 | # Replace the eligibility set for a promo with the given list of plan | |
| 576 | # ids. Pass an empty list to clear restrictions (= "all paid plans"). | |
| 577 | # Used by admin_promotion_action.cgi on create + update. | |
| 578 | sub set_eligible_plans { | |
| 579 | my ($self, $db, $dbh, $DB, $promo_id, $plan_ids_aref) = @_; | |
| 580 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 581 | $promo_id =~ s/[^0-9]//g if defined $promo_id; | |
| 582 | return 0 unless $promo_id; | |
| 583 | ||
| 584 | # Wipe + rewrite. Safe because the join table has no FK pointing | |
| 585 | # at it -- only redemptions reference the parent promo, not these | |
| 586 | # rows. Volume is tiny (<10 picks per promo) so DELETE-then-INSERT | |
| 587 | # is cheaper than a diff. | |
| 588 | $db->db_readwrite($dbh, qq~ | |
| 589 | DELETE FROM `${DB}`.promotion_plans WHERE promotion_id='$promo_id' | |
| 590 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 591 | ||
| 592 | foreach my $pid (@{ $plan_ids_aref || [] }) { | |
| 593 | my $clean = $pid; $clean =~ s/[^0-9]//g; | |
| 594 | next unless $clean; | |
| 595 | $db->db_readwrite($dbh, qq~ | |
| 596 | INSERT IGNORE INTO `${DB}`.promotion_plans | |
| 597 | SET promotion_id='$promo_id', plan_id='$clean' | |
| 598 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 599 | } | |
| 600 | return 1; | |
| 601 | } | |
| 602 | ||
| 603 | # Pretty discount tail for marketing surfaces -- e.g. "20% off", "$10 | |
| 604 | # off", "first month free". Used by pricing.cgi to weave the deal into | |
| 605 | # each plan card's CTA and tagline. | |
| 606 | sub marketing_label { | |
| 607 | my ($self, $promo) = @_; | |
| 608 | return '' unless $promo && $promo->{id}; | |
| 609 | my $t = $promo->{discount_type} || ''; | |
| 610 | if ($t eq 'percent') { | |
| 611 | my $pct = ($promo->{discount_value_bp} || 0) / 100; | |
| 612 | return sprintf('%.0f%% off', $pct); | |
| 613 | } elsif ($t eq 'fixed_amount') { | |
| 614 | return '$' . sprintf('%.2f', ($promo->{discount_value_cents} || 0) / 100) . ' off'; | |
| 615 | } elsif ($t eq 'free') { | |
| 616 | return 'first invoice free'; | |
| 617 | } | |
| 618 | return $self->discount_label($promo); | |
| 619 | } | |
| 620 | ||
| 621 | #---------------------------------------------------------------------- | |
| 622 | # Consumption helpers -- used by /billing.cgi (plan upgrades) and the | |
| 623 | # buyer cart/checkout flow to actually apply a code at purchase time. | |
| 624 | # Everything in this section is target_kind-aware: pass `kind => 'plan'` | |
| 625 | # from billing, `kind => 'model'` from the cart, and the helpers will | |
| 626 | # match only promos whose target_kind allows that context. | |
| 627 | #---------------------------------------------------------------------- | |
| 628 | ||
| 629 | # Look up a promo by its code. Filters by target context so a code | |
| 630 | # created for buyer carts never accidentally redeems on a plan upgrade. | |
| 631 | # | |
| 632 | # Returns the promotion row hashref, or undef when: | |
| 633 | # - no row matches the code | |
| 634 | # - the row's scope doesn't match (storefront vs platform) | |
| 635 | # - the row's target_kind doesn't match the calling context | |
| 636 | # | |
| 637 | # Args: | |
| 638 | # code = the user-entered code, will be uppercased + cleaned | |
| 639 | # kind = 'model' (buyer cart) or 'plan' (billing). Required. | |
| 640 | # storefront_id = required when kind='model'; the promo must either | |
| 641 | # be scope='platform' (cross-storefront) OR | |
| 642 | # scope='storefront' AND storefront_id matches. | |
| 643 | sub load_by_code { | |
| 644 | my ($self, $db, $dbh, $DB, $code, %ctx) = @_; | |
| 645 | return undef unless $self->schema_ready($db, $dbh, $DB); | |
| 646 | ||
| 647 | $code = '' unless defined $code; | |
| 648 | $code =~ s/^\s+|\s+$//g; | |
| 649 | $code = uc $code; | |
| 650 | $code =~ s/[^A-Z0-9_-]//g; | |
| 651 | $code = substr($code, 0, 64); | |
| 652 | return undef unless length $code; | |
| 653 | ||
| 654 | my $kind = $ctx{kind} || ''; | |
| 655 | return undef unless $kind eq 'model' || $kind eq 'plan'; | |
| 656 | ||
| 657 | my $code_sql = $self->_qstr($code); | |
| 658 | my $row = $db->db_readwrite($dbh, qq~ | |
| 659 | SELECT * FROM `${DB}`.promotions | |
| 660 | WHERE code=$code_sql | |
| 661 | LIMIT 1 | |
| 662 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 663 | return undef unless $row && $row->{id}; | |
| 664 | ||
| 665 | # target_kind gate. 'any' promos work in both contexts. | |
| 666 | my $tk = $row->{target_kind} || 'model'; | |
| 667 | return undef unless ($tk eq $kind) || ($tk eq 'any'); | |
| 668 | ||
| 669 | # scope gate. Platform promos apply everywhere; storefront promos | |
| 670 | # only on their own storefront's cart. | |
| 671 | if ($kind eq 'model') { | |
| 672 | my $sid = $ctx{storefront_id}; | |
| 673 | $sid =~ s/[^0-9]//g if defined $sid; | |
| 674 | if (($row->{scope} || '') eq 'storefront') { | |
| 675 | return undef unless $sid && $row->{storefront_id} && $row->{storefront_id} eq $sid; | |
| 676 | } | |
| 677 | } else { | |
| 678 | # Plan upgrades are inherently platform-scope; reject any | |
| 679 | # storefront-scope promo even if target_kind happens to be 'plan'. | |
| 680 | return undef if ($row->{scope} || '') eq 'storefront'; | |
| 681 | } | |
| 682 | return $row; | |
| 683 | } | |
| 684 | ||
| 685 | # Validate a loaded promo against the current redemption attempt. | |
| 686 | # Returns (ok => 1) on success, or (ok => 0, reason => 'human-readable'). | |
| 687 | # | |
| 688 | # Checks: status active, within time window, redemption caps not hit, | |
| 689 | # minimum_order_cents met, per-user cap not exceeded. | |
| 690 | # | |
| 691 | # Args (in %ctx): | |
| 692 | # subtotal_cents = cart total or plan invoice amount | |
| 693 | # buyer_email = required for kind='model' per-user-cap check | |
| 694 | # user_id = required for kind='plan' per-user-cap check | |
| 695 | # kind = 'model' or 'plan' (informational here; load_by_code already gated) | |
| 696 | sub validate { | |
| 697 | my ($self, $db, $dbh, $DB, $promo, %ctx) = @_; | |
| 698 | return (ok => 0, reason => 'No promo loaded.') unless $promo && $promo->{id}; | |
| 699 | ||
| 700 | my $eff = $self->effective_status($promo); | |
| 701 | return (ok => 0, reason => 'This code is not currently active.') unless $eff eq 'active'; | |
| 702 | ||
| 703 | # Time window (status='active' alone doesn't guarantee the window | |
| 704 | # has opened -- the worker may not have moved scheduled -> active yet). | |
| 705 | my $now_row = $db->db_readwrite($dbh, qq~SELECT NOW() AS n~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 706 | my $now = ($now_row && $now_row->{n}) ? $now_row->{n} : ''; | |
| 707 | if (length $now) { | |
| 708 | if ($promo->{starts_at} && $promo->{starts_at} ne '' && $promo->{starts_at} gt $now) { | |
| 709 | return (ok => 0, reason => 'This code has not started yet.'); | |
| 710 | } | |
| 711 | if ($promo->{ends_at} && $promo->{ends_at} ne '' && $promo->{ends_at} lt $now) { | |
| 712 | return (ok => 0, reason => 'This code has expired.'); | |
| 713 | } | |
| 714 | } | |
| 715 | ||
| 716 | # Aggregate cap. | |
| 717 | my $mr = $promo->{max_redemptions}; | |
| 718 | if (defined $mr && $mr ne '' && $mr > 0 | |
| 719 | && ($promo->{current_redemptions} || 0) >= $mr) { | |
| 720 | return (ok => 0, reason => 'This code is fully redeemed.'); | |
| 721 | } | |
| 722 | ||
| 723 | # Minimum order total. | |
| 724 | my $sub = defined $ctx{subtotal_cents} ? $ctx{subtotal_cents} : 0; | |
| 725 | $sub =~ s/[^0-9]//g; $sub = 0 unless $sub; | |
| 726 | if (($promo->{minimum_order_cents} || 0) > $sub) { | |
| 727 | my $need = '$' . sprintf('%.2f', $promo->{minimum_order_cents} / 100); | |
| 728 | return (ok => 0, reason => "This code requires a minimum of $need."); | |
| 729 | } | |
| 730 | ||
| 731 | # Per-user cap. For model orders we key off buyer_email (anonymous | |
| 732 | # buyers don't have an account); for plans we key off user_id. | |
| 733 | my $cap = $promo->{max_per_user}; | |
| 734 | if (defined $cap && $cap ne '' && $cap > 0) { | |
| 735 | my $where; | |
| 736 | if (($ctx{kind} || 'model') eq 'plan') { | |
| 737 | my $uid = $ctx{user_id}; $uid =~ s/[^0-9]//g if defined $uid; | |
| 738 | return (ok => 0, reason => 'Sign in required to redeem this code.') unless $uid; | |
| 739 | $where = "promotion_id='$promo->{id}' AND user_id='$uid'"; | |
| 740 | } else { | |
| 741 | my $email = defined $ctx{buyer_email} ? $ctx{buyer_email} : ''; | |
| 742 | $email =~ s/'/''/g; | |
| 743 | $email = substr($email, 0, 255); | |
| 744 | return (ok => 0, reason => 'Email required to redeem this code.') unless length $email; | |
| 745 | $where = "promotion_id='$promo->{id}' AND buyer_email='$email'"; | |
| 746 | } | |
| 747 | my $r = $db->db_readwrite($dbh, qq~ | |
| 748 | SELECT COUNT(*) AS n FROM `${DB}`.promotion_redemptions WHERE $where | |
| 749 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 750 | my $used = ($r && defined $r->{n}) ? $r->{n} : 0; | |
| 751 | if ($used >= $cap) { | |
| 752 | return (ok => 0, reason => 'You have already used this code the maximum number of times.'); | |
| 753 | } | |
| 754 | } | |
| 755 | ||
| 756 | # new_customers_only is enforced by the model checkout flow against | |
| 757 | # `orders` (the caller passes ctx => new_customer => 0/1 since the | |
| 758 | # check is buyer-scoped and we don't want to do the WHOLE join here). | |
| 759 | if ($promo->{new_customers_only} && $ctx{new_customer} == 0) { | |
| 760 | return (ok => 0, reason => 'This code is only valid for first-time customers.'); | |
| 761 | } | |
| 762 | ||
| 763 | return (ok => 1); | |
| 764 | } | |
| 765 | ||
| 766 | # Compute the discount that this promo applies to a given subtotal. | |
| 767 | # Returns the discount in cents (never more than the subtotal itself -- | |
| 768 | # we cap so the buyer/seller never owes a negative amount). Pure | |
| 769 | # function, no DB writes; caller is responsible for redeem() afterwards | |
| 770 | # to write the audit row and bump the counter. | |
| 771 | sub apply_to_total_cents { | |
| 772 | my ($self, $promo, $subtotal_cents) = @_; | |
| 773 | return 0 unless $promo && $promo->{id}; | |
| 774 | $subtotal_cents = 0 unless $subtotal_cents && $subtotal_cents > 0; | |
| 775 | ||
| 776 | my $t = $promo->{discount_type} || 'percent'; | |
| 777 | my $bp = $promo->{discount_value_bp} || 0; | |
| 778 | my $amt = $promo->{discount_value_cents} || 0; | |
| 779 | ||
| 780 | my $disc = 0; | |
| 781 | if ($t eq 'percent') { | |
| 782 | # bp = basis points (100 bp = 1%). Round to nearest cent. | |
| 783 | $disc = int(($subtotal_cents * $bp / 10000) + 0.5); | |
| 784 | } elsif ($t eq 'fixed_amount') { | |
| 785 | $disc = $amt; | |
| 786 | } elsif ($t eq 'free') { | |
| 787 | $disc = $subtotal_cents; | |
| 788 | } elsif ($t eq 'bundle_price') { | |
| 789 | # Bundle pricing: the bundle COSTS $amt, so the discount is the | |
| 790 | # difference between current subtotal and bundle price. | |
| 791 | $disc = $subtotal_cents - $amt; | |
| 792 | $disc = 0 if $disc < 0; | |
| 793 | } | |
| 794 | # Never discount more than the subtotal -- the floor is $0, not negative. | |
| 795 | $disc = $subtotal_cents if $disc > $subtotal_cents; | |
| 796 | $disc = 0 if $disc < 0; | |
| 797 | return $disc; | |
| 798 | } | |
| 799 | ||
| 800 | # Write a redemption row + bump the promotion's current_redemptions | |
| 801 | # counter. Pick one of the two contexts via `target_kind => 'model'` | |
| 802 | # (with order_id/buyer_*) or `target_kind => 'plan'` (with user_id/ | |
| 803 | # subscription_id/invoice_id). Returns the new redemption row id or 0 | |
| 804 | # on failure. | |
| 805 | sub redeem { | |
| 806 | my ($self, $db, $dbh, $DB, %a) = @_; | |
| 807 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 808 | ||
| 809 | my $pid = $a{promotion_id}; $pid =~ s/[^0-9]//g if defined $pid; | |
| 810 | return 0 unless $pid; | |
| 811 | ||
| 812 | my $tk = $a{target_kind} || 'model'; | |
| 813 | return 0 unless $tk eq 'model' || $tk eq 'plan'; | |
| 814 | ||
| 815 | my $disc = $a{discount_applied_cents} || 0; | |
| 816 | $disc =~ s/[^0-9]//g; $disc = 0 unless $disc; | |
| 817 | ||
| 818 | # Optional context columns. Each path uses a different subset; we | |
| 819 | # set the others to NULL so the audit row is unambiguous. | |
| 820 | my ($order_sql, $buyer_acct_sql, $buyer_email_sql, | |
| 821 | $user_sql, $sub_sql, $inv_sql) = ('NULL') x 6; | |
| 822 | ||
| 823 | if ($tk eq 'model') { | |
| 824 | if (defined $a{order_id}) { | |
| 825 | my $v = $a{order_id}; $v =~ s/[^0-9]//g; | |
| 826 | $order_sql = length $v ? "'$v'" : 'NULL'; | |
| 827 | } | |
| 828 | if (defined $a{buyer_account_id}) { | |
| 829 | my $v = $a{buyer_account_id}; $v =~ s/[^0-9]//g; | |
| 830 | $buyer_acct_sql = length $v ? "'$v'" : 'NULL'; | |
| 831 | } | |
| 832 | if (defined $a{buyer_email} && $a{buyer_email} ne '') { | |
| 833 | $buyer_email_sql = $self->_qstr(substr($a{buyer_email}, 0, 255)); | |
| 834 | } | |
| 835 | } else { | |
| 836 | # target_kind = 'plan' | |
| 837 | if (defined $a{user_id}) { | |
| 838 | my $v = $a{user_id}; $v =~ s/[^0-9]//g; | |
| 839 | $user_sql = length $v ? "'$v'" : 'NULL'; | |
| 840 | } | |
| 841 | if (defined $a{subscription_id}) { | |
| 842 | my $v = $a{subscription_id}; $v =~ s/[^0-9]//g; | |
| 843 | $sub_sql = length $v ? "'$v'" : 'NULL'; | |
| 844 | } | |
| 845 | if (defined $a{invoice_id}) { | |
| 846 | my $v = $a{invoice_id}; $v =~ s/[^0-9]//g; | |
| 847 | $inv_sql = length $v ? "'$v'" : 'NULL'; | |
| 848 | } | |
| 849 | } | |
| 850 | ||
| 851 | my $r = $db->db_readwrite($dbh, qq~ | |
| 852 | INSERT INTO `${DB}`.promotion_redemptions | |
| 853 | SET promotion_id='$pid', | |
| 854 | target_kind='$tk', | |
| 855 | order_id=$order_sql, | |
| 856 | buyer_account_id=$buyer_acct_sql, | |
| 857 | buyer_email=$buyer_email_sql, | |
| 858 | user_id=$user_sql, | |
| 859 | subscription_id=$sub_sql, | |
| 860 | invoice_id=$inv_sql, | |
| 861 | discount_applied_cents='$disc' | |
| 862 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 863 | my $rid = ($r && $r->{mysql_insertid}) ? $r->{mysql_insertid} : 0; | |
| 864 | return 0 unless $rid; | |
| 865 | ||
| 866 | # Bump the denormalized counter so future load_by_code calls can | |
| 867 | # cheaply hit the 'exhausted' cap without scanning redemptions. | |
| 868 | $db->db_readwrite($dbh, qq~ | |
| 869 | UPDATE `${DB}`.promotions | |
| 870 | SET current_redemptions = current_redemptions + 1 | |
| 871 | WHERE id='$pid' | |
| 872 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 873 | ||
| 874 | return $rid; | |
| 875 | } | |
| 876 | ||
| 877 | #---------------------------------------------------------------------- | |
| 878 | # Buyer-cart applied-promo storage. cart_promotions sits between | |
| 879 | # /cart_promo.cgi (write on apply, delete on remove) and | |
| 880 | # /checkout_intent.cgi (read at order creation, then delete). One row | |
| 881 | # per (cart_token, storefront_id) -- the primary key, so applying a | |
| 882 | # new code overwrites the previous one. | |
| 883 | #---------------------------------------------------------------------- | |
| 884 | ||
| 885 | # Has the buyer cart applied a promo on this storefront? Returns the | |
| 886 | # joined promo row, or undef when nothing is applied. | |
| 887 | sub cart_applied { | |
| 888 | my ($self, $db, $dbh, $DB, $cart_token, $sid) = @_; | |
| 889 | return undef unless $self->schema_ready($db, $dbh, $DB); | |
| 890 | $cart_token = '' unless defined $cart_token; | |
| 891 | $cart_token =~ s/[^a-f0-9]//g; | |
| 892 | $sid =~ s/[^0-9]//g if defined $sid; | |
| 893 | return undef unless length $cart_token && $sid; | |
| 894 | my $r = $db->db_readwrite($dbh, qq~ | |
| 895 | SELECT p.* | |
| 896 | FROM `${DB}`.cart_promotions cp | |
| 897 | JOIN `${DB}`.promotions p ON p.id = cp.promotion_id | |
| 898 | WHERE cp.cart_token='$cart_token' AND cp.storefront_id='$sid' | |
| 899 | LIMIT 1 | |
| 900 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 901 | return ($r && $r->{id}) ? $r : undef; | |
| 902 | } | |
| 903 | ||
| 904 | # Set / overwrite the applied promo on a cart. | |
| 905 | sub cart_apply { | |
| 906 | my ($self, $db, $dbh, $DB, $cart_token, $sid, $promo_id) = @_; | |
| 907 | return 0 unless $self->schema_ready($db, $dbh, $DB); | |
| 908 | $cart_token = '' unless defined $cart_token; | |
| 909 | $cart_token =~ s/[^a-f0-9]//g; | |
| 910 | $sid =~ s/[^0-9]//g if defined $sid; | |
| 911 | $promo_id =~ s/[^0-9]//g if defined $promo_id; | |
| 912 | return 0 unless length $cart_token && $sid && $promo_id; | |
| 913 | $db->db_readwrite($dbh, qq~ | |
| 914 | REPLACE INTO `${DB}`.cart_promotions | |
| 915 | SET cart_token='$cart_token', | |
| 916 | storefront_id='$sid', | |
| 917 | promotion_id='$promo_id' | |
| 918 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 919 | return 1; | |
| 920 | } | |
| 921 | ||
| 922 | # Drop the applied promo (after redemption or on buyer remove). | |
| 923 | sub cart_clear { | |
| 924 | my ($self, $db, $dbh, $DB, $cart_token, $sid) = @_; | |
| 925 | return unless $self->schema_ready($db, $dbh, $DB); | |
| 926 | $cart_token = '' unless defined $cart_token; | |
| 927 | $cart_token =~ s/[^a-f0-9]//g; | |
| 928 | $sid =~ s/[^0-9]//g if defined $sid; | |
| 929 | return unless length $cart_token && $sid; | |
| 930 | $db->db_readwrite($dbh, qq~ | |
| 931 | DELETE FROM `${DB}`.cart_promotions | |
| 932 | WHERE cart_token='$cart_token' AND storefront_id='$sid' | |
| 933 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 934 | } | |
| 935 | ||
| 936 | 1; |