added on local at 2026-07-01 22:09:41
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # ShopCart - MVT page-blocks slot editor. | |
| 4 | # | |
| 5 | # /mvt_slots.cgi?id=N -> edit per-variant slot values for ab_test N | |
| 6 | # POST -> save and bounce back to /storefront.cgi#tests | |
| 7 | # | |
| 8 | # The Tests-tab "New MVT block test" form creates a draft ab_test row | |
| 9 | # with surface=page_blocks and N variants whose block_overrides carry | |
| 10 | # the slot names with empty values. This page is where the seller | |
| 11 | # actually fills in the per-variant text for each slot. | |
| 12 | #====================================================================== | |
| 13 | use strict; | |
| 14 | use warnings; | |
| 15 | ||
| 16 | use lib '/var/www/vhosts/3dshawn.com/shop.3dshawn.com'; | |
| 17 | use CGI; | |
| 18 | use MODS::Template; | |
| 19 | use MODS::DBConnect; | |
| 20 | use MODS::Login; | |
| 21 | use MODS::ShopCart::Config; | |
| 22 | use MODS::ShopCart::Wrapper; | |
| 23 | use MODS::ShopCart::Experiments; | |
| 24 | ||
| 25 | my $q = CGI->new; | |
| 26 | my $form = $q->Vars; | |
| 27 | my $tfile = MODS::Template->new; | |
| 28 | my $db = MODS::DBConnect->new; | |
| 29 | my $auth = MODS::Login->new; | |
| 30 | my $cfg = MODS::ShopCart::Config->new; | |
| 31 | my $wrap = MODS::ShopCart::Wrapper->new; | |
| 32 | my $DB = $cfg->settings('database_name'); | |
| 33 | ||
| 34 | $|=1; | |
| 35 | ||
| 36 | my $userinfo = $auth->login_verify(); | |
| 37 | if (!$userinfo) { | |
| 38 | print "Status: 302 Found\nLocation: /login.cgi\n\n"; | |
| 39 | exit; | |
| 40 | } | |
| 41 | my $uid = $userinfo->{user_id}; | |
| 42 | $uid =~ s/[^0-9]//g; | |
| 43 | ||
| 44 | my $tid = $form->{id} || 0; | |
| 45 | $tid =~ s/[^0-9]//g; | |
| 46 | unless ($tid) { | |
| 47 | print "Status: 302 Found\nLocation: /storefront.cgi#tests\n\n"; | |
| 48 | exit; | |
| 49 | } | |
| 50 | ||
| 51 | my $dbh = $db->db_connect(); | |
| 52 | my $exh = MODS::ShopCart::Experiments->new; | |
| 53 | ||
| 54 | # Ownership + surface check. Reject non-page_blocks tests so this page | |
| 55 | # is never used for an unrelated experiment. | |
| 56 | my $row = $db->db_readwrite($dbh, qq~ | |
| 57 | SELECT ab.id, ab.name, ab.surface, ab.status, ab.page_id, ab.variants, | |
| 58 | s.id AS storefront_id, p.title AS page_title, p.slug AS page_slug | |
| 59 | FROM `${DB}`.ab_tests ab | |
| 60 | JOIN `${DB}`.storefronts s ON s.id = ab.storefront_id | |
| 61 | LEFT JOIN `${DB}`.storefront_pages p ON p.id = ab.page_id | |
| 62 | WHERE ab.id='$tid' AND s.user_id='$uid' | |
| 63 | LIMIT 1 | |
| 64 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 65 | unless ($row && $row->{id} && ($row->{surface} || '') eq 'page_blocks') { | |
| 66 | $db->db_disconnect($dbh); | |
| 67 | print "Status: 302 Found\nLocation: /storefront.cgi#tests\n\n"; | |
| 68 | exit; | |
| 69 | } | |
| 70 | ||
| 71 | my @variants = $exh->_parse_variants($row->{variants} || ''); | |
| 72 | ||
| 73 | # Collect every slot name present across the variants so the editor | |
| 74 | # can show one textarea per (variant, slot) pair. | |
| 75 | my @slot_names; | |
| 76 | my %seen; | |
| 77 | foreach my $v (@variants) { | |
| 78 | my $b = $v->{block_overrides} || ''; | |
| 79 | while ($b =~ /"([^"\\]+)"\s*:\s*"((?:[^"\\]|\\.)*)"/g) { | |
| 80 | my $name = $1; | |
| 81 | next if $seen{$name}++; | |
| 82 | push @slot_names, $name; | |
| 83 | } | |
| 84 | } | |
| 85 | @slot_names = ('hero') unless @slot_names; | |
| 86 | ||
| 87 | # ---------- POST: rebuild variants JSON with the seller's input ------ | |
| 88 | if (($ENV{REQUEST_METHOD} || '') eq 'POST') { | |
| 89 | my @new_variants; | |
| 90 | foreach my $v (@variants) { | |
| 91 | my $vid = $v->{id} || ''; | |
| 92 | $vid =~ s/[^A-Za-z0-9]//g; | |
| 93 | my %slot_vals; | |
| 94 | foreach my $slot (@slot_names) { | |
| 95 | my $val = $form->{"v_${vid}_${slot}"}; | |
| 96 | $val = '' unless defined $val; | |
| 97 | $val = substr($val, 0, 8000); | |
| 98 | $slot_vals{$slot} = $val; | |
| 99 | } | |
| 100 | # Encode the per-variant block_overrides JSON. Single-level | |
| 101 | # {key:val} flat map keeps the parser simple. | |
| 102 | my @kv; | |
| 103 | foreach my $k (@slot_names) { | |
| 104 | my $v = $slot_vals{$k} // ''; | |
| 105 | $v =~ s/\\/\\\\/g; | |
| 106 | $v =~ s/"/\\"/g; | |
| 107 | $v =~ s/\r/\\r/g; | |
| 108 | $v =~ s/\n/\\n/g; | |
| 109 | push @kv, qq~"$k":"$v"~; | |
| 110 | } | |
| 111 | my $blocks = '{' . join(',', @kv) . '}'; | |
| 112 | ||
| 113 | push @new_variants, { | |
| 114 | %$v, | |
| 115 | block_overrides => $blocks, | |
| 116 | }; | |
| 117 | } | |
| 118 | ||
| 119 | my $variants_json = _build_variants_json(\@new_variants); | |
| 120 | my $sql_json = $variants_json; | |
| 121 | $sql_json =~ s/\\/\\\\/g; | |
| 122 | $sql_json =~ s/'/\\'/g; | |
| 123 | $db->db_readwrite($dbh, qq~ | |
| 124 | UPDATE `${DB}`.ab_tests | |
| 125 | SET variants='$sql_json' | |
| 126 | WHERE id='$tid' LIMIT 1 | |
| 127 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 128 | # Wipe events tied to old slot values -- they'd mix apples and | |
| 129 | # oranges on the post-save dashboard. | |
| 130 | $db->db_readwrite($dbh, qq~ | |
| 131 | DELETE FROM `${DB}`.ab_test_events WHERE ab_test_id='$tid' | |
| 132 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 133 | $db->db_disconnect($dbh); | |
| 134 | print "Status: 302 Found\nLocation: /storefront.cgi?saved_mvt=1#tests\n\n"; | |
| 135 | exit; | |
| 136 | } | |
| 137 | ||
| 138 | # ---------- GET: render the slot editor ------------------------------- | |
| 139 | my @variant_rows; | |
| 140 | foreach my $v (@variants) { | |
| 141 | my $vid = $v->{id} || ''; | |
| 142 | # Parse this variant's existing block_overrides into a slot->value map. | |
| 143 | my %m; | |
| 144 | my $b = $v->{block_overrides} || ''; | |
| 145 | while ($b =~ /"([^"\\]+)"\s*:\s*"((?:[^"\\]|\\.)*)"/g) { | |
| 146 | my ($k, $val) = ($1, $2); | |
| 147 | $val =~ s/\\"/"/g; | |
| 148 | $val =~ s/\\\\/\\/g; | |
| 149 | $val =~ s/\\n/\n/g; | |
| 150 | $val =~ s/\\r/\r/g; | |
| 151 | $m{$k} = $val; | |
| 152 | } | |
| 153 | my @slot_inputs; | |
| 154 | foreach my $slot (@slot_names) { | |
| 155 | push @slot_inputs, { | |
| 156 | slot => $slot, | |
| 157 | field_name => "v_${vid}_${slot}", | |
| 158 | value => _h($m{$slot} // ''), | |
| 159 | placeholder => "Text shown for slot \"$slot\" in variant $vid", | |
| 160 | }; | |
| 161 | } | |
| 162 | push @variant_rows, { | |
| 163 | id => $vid, | |
| 164 | is_control => ($vid eq 'A') ? 1 : 0, | |
| 165 | label => 'Variant ' . $vid . ($vid eq 'A' ? ' (Control)' : ''), | |
| 166 | traffic_pct => $v->{traffic_pct} || 0, | |
| 167 | slot_inputs => \@slot_inputs, | |
| 168 | }; | |
| 169 | } | |
| 170 | ||
| 171 | my $tvars = { | |
| 172 | test_id => $row->{id}, | |
| 173 | test_name => _h($row->{name} || ''), | |
| 174 | test_status => $row->{status} || 'draft', | |
| 175 | page_title => _h($row->{page_title} || ''), | |
| 176 | page_slug => _h($row->{page_slug} || ''), | |
| 177 | page_edit_url => $row->{page_id} ? '/page.cgi?id=' . $row->{page_id} : '', | |
| 178 | storefront_url => '/store.cgi?id=' . $row->{storefront_id} . '&page=' . ($row->{page_slug} || ''), | |
| 179 | slot_names_csv => join(', ', @slot_names), | |
| 180 | slot_names => [ map { { name => $_ } } @slot_names ], | |
| 181 | variants => \@variant_rows, | |
| 182 | is_draft => (($row->{status} || '') eq 'draft') ? 1 : 0, | |
| 183 | is_running => (($row->{status} || '') eq 'running') ? 1 : 0, | |
| 184 | }; | |
| 185 | ||
| 186 | $db->db_disconnect($dbh); | |
| 187 | ||
| 188 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-store, no-cache, must-revalidate, max-age=0\nPragma: no-cache\nExpires: 0\n\n"; | |
| 189 | ||
| 190 | my $body = join('', $tfile->template('shopcart_mvt_slots.html', $tvars, $userinfo)); | |
| 191 | ||
| 192 | $wrap->render({ | |
| 193 | userinfo => $userinfo, | |
| 194 | page_key => 'storefront', | |
| 195 | title => 'Edit MVT slots', | |
| 196 | body => $body, | |
| 197 | }); | |
| 198 | exit; | |
| 199 | ||
| 200 | #====================================================================== | |
| 201 | # Helpers | |
| 202 | #====================================================================== | |
| 203 | ||
| 204 | sub _h { | |
| 205 | my ($s) = @_; | |
| 206 | $s //= ''; | |
| 207 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 208 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 209 | return $s; | |
| 210 | } | |
| 211 | ||
| 212 | # Mirror the writer in optimization_action.cgi so the JSON shape | |
| 213 | # stays compatible with the central parser in Experiments.pm. | |
| 214 | sub _build_variants_json { | |
| 215 | my ($variants) = @_; | |
| 216 | my @parts; | |
| 217 | foreach my $v (@$variants) { | |
| 218 | my $id = _json_str($v->{id} // ''); | |
| 219 | my $name = _json_str($v->{name} // ''); | |
| 220 | my $pct = ($v->{traffic_pct} || 0) + 0; | |
| 221 | my $tid_model = ($v->{target_model_id} || 0) + 0; | |
| 222 | my $text = _json_str($v->{text} // ''); | |
| 223 | my $img = _json_str($v->{image_url} // ''); | |
| 224 | my $lid = ($v->{layout_id} || 0) + 0; | |
| 225 | my $tid_theme = ($v->{theme_id} || 0) + 0; | |
| 226 | my $ctid = ($v->{custom_theme_id} || 0) + 0; | |
| 227 | my $vpid = ($v->{variant_page_id} || 0) + 0; | |
| 228 | my $blocks = _json_str($v->{block_overrides} // ''); | |
| 229 | push @parts, | |
| 230 | qq~{"id":"$id","name":"$name","traffic_pct":$pct,~ | |
| 231 | . qq~"target_model_id":$tid_model,~ | |
| 232 | . qq~"changes":{"text":"$text","image_url":"$img",~ | |
| 233 | . qq~"layout_id":$lid,"theme_id":$tid_theme,"custom_theme_id":$ctid,~ | |
| 234 | . qq~"variant_page_id":$vpid,"block_overrides":"$blocks"}}~; | |
| 235 | } | |
| 236 | return '[' . join(',', @parts) . ']'; | |
| 237 | } | |
| 238 | ||
| 239 | sub _json_str { | |
| 240 | my $s = shift; | |
| 241 | $s = '' unless defined $s; | |
| 242 | $s =~ s/\\/\\\\/g; | |
| 243 | $s =~ s/"/\\"/g; | |
| 244 | $s =~ s/\r/\\r/g; | |
| 245 | $s =~ s/\n/\\n/g; | |
| 246 | $s =~ s/\t/\\t/g; | |
| 247 | return $s; | |
| 248 | } |