added on local at 2026-07-01 21:47:10
| 1 | package MODS::RePricer::Bundles; | |
| 2 | #====================================================================== | |
| 3 | # RePricer -- seller-built bundles. | |
| 4 | # | |
| 5 | # A bundle is its own saleable item that composes 2+ existing models. | |
| 6 | # Sellers price it independently of the sum of component prices to | |
| 7 | # offer a combo discount. The component models stay individually | |
| 8 | # for-sale; the bundle is the "buy all together" path. | |
| 9 | # | |
| 10 | # Public surface: | |
| 11 | # schema_ready, list_for_user, by_id, create, update, delete, | |
| 12 | # set_items($bundle_id, \@model_ids, $uid), | |
| 13 | # items_for_bundle($bundle_id) | |
| 14 | #====================================================================== | |
| 15 | use strict; | |
| 16 | use warnings; | |
| 17 | ||
| 18 | sub new { bless {}, shift } | |
| 19 | ||
| 20 | sub _esc { my $s = shift // ''; $s =~ s/\\/\\\\/g; $s =~ s/'/''/g; return $s; } | |
| 21 | sub _slugify { | |
| 22 | my ($s) = @_; | |
| 23 | return '' unless defined $s; | |
| 24 | $s = lc $s; $s =~ s/[^a-z0-9]+/-/g; $s =~ s/^-+|-+$//g; | |
| 25 | return substr($s, 0, 120); | |
| 26 | } | |
| 27 | ||
| 28 | sub schema_ready { | |
| 29 | my ($self, $db, $dbh, $DB) = @_; | |
| 30 | return $self->{_ready} if exists $self->{_ready}; | |
| 31 | foreach my $t (qw(bundles bundle_items)) { | |
| 32 | my $r = $db->db_readwrite($dbh, qq~ | |
| 33 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 34 | WHERE table_schema='$DB' AND table_name='$t' | |
| 35 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 36 | unless ($r && $r->{n}) { $self->{_ready} = 0; return 0; } | |
| 37 | } | |
| 38 | $self->{_ready} = 1; | |
| 39 | return 1; | |
| 40 | } | |
| 41 | ||
| 42 | sub list_for_user { | |
| 43 | my ($self, $db, $dbh, $DB, $uid) = @_; | |
| 44 | return [] unless $uid && $self->schema_ready($db, $dbh, $DB); | |
| 45 | $uid =~ s/[^0-9]//g; return [] unless length $uid; | |
| 46 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 47 | SELECT b.*, ( | |
| 48 | SELECT COUNT(*) FROM `${DB}`.bundle_items bi | |
| 49 | WHERE bi.bundle_id = b.id | |
| 50 | ) AS item_count | |
| 51 | FROM `${DB}`.bundles b | |
| 52 | WHERE b.user_id='$uid' | |
| 53 | ORDER BY b.updated_at DESC, b.id DESC | |
| 54 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 55 | return \@rows; | |
| 56 | } | |
| 57 | ||
| 58 | sub by_id { | |
| 59 | my ($self, $db, $dbh, $DB, $id, $uid) = @_; | |
| 60 | return undef unless $id && $self->schema_ready($db, $dbh, $DB); | |
| 61 | $id =~ s/[^0-9]//g; return undef unless length $id; | |
| 62 | my $where = ''; | |
| 63 | if ($uid) { | |
| 64 | $uid =~ s/[^0-9]//g; | |
| 65 | $where = " AND user_id='$uid'" if length $uid; | |
| 66 | } | |
| 67 | my $r = $db->db_readwrite($dbh, qq~ | |
| 68 | SELECT * FROM `${DB}`.bundles WHERE id='$id' $where LIMIT 1 | |
| 69 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 70 | return ($r && $r->{id}) ? $r : undef; | |
| 71 | } | |
| 72 | ||
| 73 | # Default storefront for new bundles -- pulls the seller's primary | |
| 74 | # storefront when the caller doesn't pass one. | |
| 75 | sub _default_storefront { | |
| 76 | my ($self, $db, $dbh, $DB, $uid) = @_; | |
| 77 | my $r = $db->db_readwrite($dbh, qq~ | |
| 78 | SELECT id FROM `${DB}`.storefronts | |
| 79 | WHERE user_id='$uid' ORDER BY id ASC LIMIT 1 | |
| 80 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 81 | return ($r && $r->{id}) ? $r->{id} : 0; | |
| 82 | } | |
| 83 | ||
| 84 | sub create { | |
| 85 | my ($self, $db, $dbh, $DB, $uid, %f) = @_; | |
| 86 | return 0 unless $uid && $self->schema_ready($db, $dbh, $DB); | |
| 87 | $uid =~ s/[^0-9]//g; return 0 unless length $uid; | |
| 88 | my $title = substr($f{title} || '', 0, 200); | |
| 89 | return 0 unless length $title; | |
| 90 | my $slug = _slugify($f{slug} || $title) || ('bundle-' . time()); | |
| 91 | my $sid = $f{storefront_id} || $self->_default_storefront($db, $dbh, $DB, $uid); | |
| 92 | return 0 unless $sid; | |
| 93 | my $tag = substr($f{tagline} || '', 0, 180); | |
| 94 | my $desc = substr($f{description} || '', 0, 65535); | |
| 95 | my $kind = lc($f{product_kind} || 'digital'); | |
| 96 | $kind = 'digital' unless $kind =~ /^(digital|physical|both)$/; | |
| 97 | my $bp_cents = int(($f{base_price} || 0) * 100); | |
| 98 | my $pp_cents = int(($f{physical_price} || 0) * 100); | |
| 99 | my $status = lc($f{status} || 'draft'); | |
| 100 | $status = 'draft' unless $status =~ /^(draft|published|archived)$/; | |
| 101 | my $inv = defined $f{inventory_qty} && length $f{inventory_qty} ? int($f{inventory_qty}) : -1; | |
| 102 | my $prod = $f{production_time_days}; | |
| 103 | my $wgt = $f{weight_grams}; | |
| 104 | my $sfc = uc(substr($f{ship_from_country} || '', 0, 2)); $sfc =~ s/[^A-Z]//g; | |
| 105 | my $sopts = $f{shipping_options_json} || ''; | |
| 106 | ||
| 107 | my $prod_sql = (defined $prod && length $prod && $prod =~ /^\d+$/) ? "'$prod'" : 'NULL'; | |
| 108 | my $wgt_sql = (defined $wgt && length $wgt && $wgt =~ /^\d+$/) ? "'$wgt'" : 'NULL'; | |
| 109 | my $sfc_sql = length($sfc) == 2 ? "'$sfc'" : 'NULL'; | |
| 110 | ||
| 111 | $db->db_readwrite($dbh, qq~ | |
| 112 | INSERT INTO `${DB}`.bundles SET | |
| 113 | user_id='$uid', storefront_id='$sid', | |
| 114 | title='~ . _esc($title) . qq~', | |
| 115 | slug='~ . _esc($slug) . qq~', | |
| 116 | tagline='~ . _esc($tag) . qq~', | |
| 117 | description='~ . _esc($desc) . qq~', | |
| 118 | product_kind='$kind', | |
| 119 | base_price_cents='$bp_cents', | |
| 120 | physical_price_cents='$pp_cents', | |
| 121 | status='$status', | |
| 122 | inventory_qty='$inv', | |
| 123 | weight_grams=$wgt_sql, | |
| 124 | production_time_days=$prod_sql, | |
| 125 | ship_from_country=$sfc_sql, | |
| 126 | shipping_options_json='~ . _esc($sopts) . qq~', | |
| 127 | created_at=NOW() | |
| 128 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 129 | my $r = $db->db_readwrite($dbh, qq~SELECT LAST_INSERT_ID() AS id~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 130 | return ($r && $r->{id}) ? $r->{id} : 0; | |
| 131 | } | |
| 132 | ||
| 133 | sub update { | |
| 134 | my ($self, $db, $dbh, $DB, $id, $uid, %f) = @_; | |
| 135 | return 0 unless $self->by_id($db, $dbh, $DB, $id, $uid); | |
| 136 | $id =~ s/[^0-9]//g; | |
| 137 | $uid =~ s/[^0-9]//g; | |
| 138 | my @sets; | |
| 139 | if (defined $f{title}) { push @sets, "title='" . _esc(substr($f{title},0,200)) . "'"; } | |
| 140 | if (defined $f{tagline}) { push @sets, "tagline='" . _esc(substr($f{tagline},0,180)) . "'"; } | |
| 141 | if (defined $f{description}) { push @sets, "description='" . _esc(substr($f{description},0,65535)). "'"; } | |
| 142 | if (defined $f{product_kind}) { | |
| 143 | my $k = lc($f{product_kind}); | |
| 144 | $k = 'digital' unless $k =~ /^(digital|physical|both)$/; | |
| 145 | push @sets, "product_kind='$k'"; | |
| 146 | } | |
| 147 | if (defined $f{base_price}) { push @sets, "base_price_cents='" . int($f{base_price} * 100) . "'"; } | |
| 148 | if (defined $f{physical_price}) { push @sets, "physical_price_cents='" . int($f{physical_price} * 100) . "'"; } | |
| 149 | if (defined $f{status}) { | |
| 150 | my $s = lc($f{status}); | |
| 151 | $s = 'draft' unless $s =~ /^(draft|published|archived)$/; | |
| 152 | push @sets, "status='$s'"; | |
| 153 | } | |
| 154 | if (defined $f{inventory_qty}) { | |
| 155 | my $v = length $f{inventory_qty} ? int($f{inventory_qty}) : -1; | |
| 156 | push @sets, "inventory_qty='$v'"; | |
| 157 | } | |
| 158 | if (defined $f{production_time_days}) { | |
| 159 | my $v = $f{production_time_days}; | |
| 160 | push @sets, length($v) && $v =~ /^\d+$/ ? "production_time_days='$v'" : "production_time_days=NULL"; | |
| 161 | } | |
| 162 | if (defined $f{weight_grams}) { | |
| 163 | my $v = $f{weight_grams}; | |
| 164 | push @sets, length($v) && $v =~ /^\d+$/ ? "weight_grams='$v'" : "weight_grams=NULL"; | |
| 165 | } | |
| 166 | if (defined $f{ship_from_country}) { | |
| 167 | my $v = uc(substr($f{ship_from_country}, 0, 2)); $v =~ s/[^A-Z]//g; | |
| 168 | push @sets, length($v) == 2 ? "ship_from_country='$v'" : "ship_from_country=NULL"; | |
| 169 | } | |
| 170 | if (defined $f{shipping_options_json}) { | |
| 171 | push @sets, "shipping_options_json='" . _esc($f{shipping_options_json}) . "'"; | |
| 172 | } | |
| 173 | return 1 unless @sets; | |
| 174 | $db->db_readwrite($dbh, qq~ | |
| 175 | UPDATE `${DB}`.bundles SET ~ . join(',', @sets) . qq~ | |
| 176 | WHERE id='$id' AND user_id='$uid' LIMIT 1 | |
| 177 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 178 | return 1; | |
| 179 | } | |
| 180 | ||
| 181 | sub delete { | |
| 182 | my ($self, $db, $dbh, $DB, $id, $uid) = @_; | |
| 183 | return 0 unless $self->by_id($db, $dbh, $DB, $id, $uid); | |
| 184 | $id =~ s/[^0-9]//g; | |
| 185 | $uid =~ s/[^0-9]//g; | |
| 186 | $db->db_readwrite($dbh, qq~ | |
| 187 | DELETE FROM `${DB}`.bundles WHERE id='$id' AND user_id='$uid' LIMIT 1 | |
| 188 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 189 | return 1; | |
| 190 | } | |
| 191 | ||
| 192 | # Replace the bundle's items. Items must be owned by the same seller. | |
| 193 | sub set_items { | |
| 194 | my ($self, $db, $dbh, $DB, $bundle_id, $model_ids, $uid) = @_; | |
| 195 | return 0 unless $self->by_id($db, $dbh, $DB, $bundle_id, $uid); | |
| 196 | $bundle_id =~ s/[^0-9]//g; | |
| 197 | $uid =~ s/[^0-9]//g; | |
| 198 | $db->db_readwrite($dbh, qq~ | |
| 199 | DELETE FROM `${DB}`.bundle_items WHERE bundle_id='$bundle_id' | |
| 200 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 201 | my $sort = 0; | |
| 202 | foreach my $mid (@{ $model_ids || [] }) { | |
| 203 | $mid =~ s/[^0-9]//g; next unless length $mid; | |
| 204 | my $own = $db->db_readwrite($dbh, qq~ | |
| 205 | SELECT id FROM `${DB}`.models WHERE id='$mid' AND user_id='$uid' AND purged_at IS NULL LIMIT 1 | |
| 206 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 207 | next unless $own && $own->{id}; | |
| 208 | $db->db_readwrite($dbh, qq~ | |
| 209 | INSERT IGNORE INTO `${DB}`.bundle_items SET | |
| 210 | bundle_id='$bundle_id', model_id='$mid', | |
| 211 | sort_order='$sort', added_at=NOW() | |
| 212 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 213 | $sort++; | |
| 214 | } | |
| 215 | return 1; | |
| 216 | } | |
| 217 | ||
| 218 | sub items_for_bundle { | |
| 219 | my ($self, $db, $dbh, $DB, $bundle_id) = @_; | |
| 220 | return [] unless $self->schema_ready($db, $dbh, $DB); | |
| 221 | $bundle_id =~ s/[^0-9]//g; return [] unless length $bundle_id; | |
| 222 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 223 | SELECT bi.model_id, bi.sort_order, | |
| 224 | m.title, m.slug, m.base_price_cents, m.product_kind, | |
| 225 | m.hero_image_url | |
| 226 | FROM `${DB}`.bundle_items bi | |
| 227 | JOIN `${DB}`.models m ON m.id = bi.model_id | |
| 228 | WHERE bi.bundle_id='$bundle_id' | |
| 229 | AND m.purged_at IS NULL | |
| 230 | ORDER BY bi.sort_order ASC, bi.id ASC | |
| 231 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 232 | return \@rows; | |
| 233 | } | |
| 234 | ||
| 235 | 1; |