added on local at 2026-07-01 21:47:34
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # RePricer - public Van Westendorp survey response page. | |
| 4 | # | |
| 5 | # GET /price_survey.cgi?t=TOKEN | |
| 6 | # Render the 4-question form for an anonymous respondent. | |
| 7 | # POST /price_survey.cgi | |
| 8 | # Persist the response via PricingExperiments->record_survey_response, | |
| 9 | # then show a thank-you page (no auto-redirect; the buyer can also | |
| 10 | # close the tab). | |
| 11 | # | |
| 12 | # No login required -- the token IS the access control. Sellers share | |
| 13 | # the URL via email, storefront link, or social. Closed surveys reject | |
| 14 | # new responses with a "no longer open" message. | |
| 15 | #====================================================================== | |
| 16 | use strict; | |
| 17 | use warnings; | |
| 18 | ||
| 19 | use lib '/var/www/vhosts/3dshawn.com/repricer.3dshawn.com'; | |
| 20 | use CGI; | |
| 21 | use MODS::Template; | |
| 22 | use MODS::DBConnect; | |
| 23 | use MODS::RePricer::Config; | |
| 24 | use MODS::RePricer::PricingExperiments; | |
| 25 | ||
| 26 | my $q = CGI->new; | |
| 27 | my $form = $q->Vars; | |
| 28 | my $tfile = MODS::Template->new; | |
| 29 | my $db = MODS::DBConnect->new; | |
| 30 | my $cfg = MODS::RePricer::Config->new; | |
| 31 | my $px = MODS::RePricer::PricingExperiments->new; | |
| 32 | my $DB = $cfg->settings('database_name'); | |
| 33 | ||
| 34 | $|=1; | |
| 35 | ||
| 36 | my $token = defined $form->{t} ? $form->{t} : ''; | |
| 37 | $token =~ s/[^a-f0-9]//gi; | |
| 38 | $token = substr($token, 0, 40); | |
| 39 | ||
| 40 | my $dbh = $db->db_connect(); | |
| 41 | ||
| 42 | # Schema probe -- pre-migration installs render a graceful notice | |
| 43 | # rather than crashing on the missing tables. | |
| 44 | unless ($px->schema_ready($db, $dbh, $DB)) { | |
| 45 | $db->db_disconnect($dbh); | |
| 46 | print "Content-Type: text/html; charset=utf-8\n\n"; | |
| 47 | print "<h1>Pricing surveys not enabled on this install yet.</h1>"; | |
| 48 | exit; | |
| 49 | } | |
| 50 | ||
| 51 | my $survey = $px->survey_for_token($db, $dbh, $DB, $token); | |
| 52 | my $submitted = 0; | |
| 53 | my $error_msg = ''; | |
| 54 | ||
| 55 | if ($survey && ($ENV{REQUEST_METHOD} || '') eq 'POST') { | |
| 56 | if (($survey->{status} || '') ne 'open') { | |
| 57 | $error_msg = 'This survey is no longer accepting responses.'; | |
| 58 | } else { | |
| 59 | my $r = $px->record_survey_response($db, $dbh, $DB, $token, | |
| 60 | too_cheap => $form->{too_cheap}, | |
| 61 | bargain => $form->{bargain}, | |
| 62 | expensive => $form->{expensive}, | |
| 63 | too_expensive => $form->{too_expensive}, | |
| 64 | email => $form->{email}, | |
| 65 | ); | |
| 66 | if ($r->{ok}) { | |
| 67 | $submitted = 1; | |
| 68 | } else { | |
| 69 | $error_msg = $r->{error} || 'Could not record your response.'; | |
| 70 | } | |
| 71 | } | |
| 72 | } | |
| 73 | ||
| 74 | $db->db_disconnect($dbh); | |
| 75 | ||
| 76 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-cache\n\n"; | |
| 77 | ||
| 78 | # Inline-render so this stays a single page (no Wrapper.pm header chrome | |
| 79 | # -- this is a public-facing form, not a logged-in surface). | |
| 80 | my $brand = _h($cfg->settings('brand_name') || 'RePricer'); | |
| 81 | my $title = $survey ? _h($survey->{title} || 'Pricing survey') : 'Pricing survey'; | |
| 82 | my $model = $survey ? _h($survey->{model_title} || '') : ''; | |
| 83 | ||
| 84 | my $body; | |
| 85 | if (!$survey) { | |
| 86 | $body = qq~ | |
| 87 | <h1>Survey not found</h1> | |
| 88 | <p>The link you used does not match any open survey. The seller may have closed it, or the URL may be incomplete.</p> | |
| 89 | ~; | |
| 90 | } elsif ($submitted) { | |
| 91 | $body = qq~ | |
| 92 | <h1>Thank you!</h1> | |
| 93 | <p>Your response has been recorded. You can close this tab.</p> | |
| 94 | ~; | |
| 95 | } elsif (($survey->{status} || '') ne 'open') { | |
| 96 | $body = qq~ | |
| 97 | <h1>This survey is closed</h1> | |
| 98 | <p>The seller has stopped accepting new responses. Thanks for your interest.</p> | |
| 99 | ~; | |
| 100 | } else { | |
| 101 | my $err_block = $error_msg | |
| 102 | ? qq~<div class="err">~ . _h($error_msg) . qq~</div>~ | |
| 103 | : ''; | |
| 104 | $body = qq~ | |
| 105 | <h1>$title</h1> | |
| 106 | <p class="lead">Help us price <strong>$model</strong>. Your answers are anonymous (we collect an optional email only if you want a follow-up).</p> | |
| 107 | <p class="lead">Enter prices in USD. Please answer all four to make the result useful.</p> | |
| 108 | $err_block | |
| 109 | <form method="POST" action="/price_survey.cgi" autocomplete="off"> | |
| 110 | <input type="hidden" name="t" value="~ . _h($token) . qq~"> | |
| 111 | ||
| 112 | <div class="q"> | |
| 113 | <label>At what price would this be <strong>so cheap</strong> that you would doubt its quality?</label> | |
| 114 | <div class="row"><span class="dollar">\$</span><input type="number" name="too_cheap" step="0.01" min="0" required></div> | |
| 115 | </div> | |
| 116 | <div class="q"> | |
| 117 | <label>At what price would this be a <strong>bargain</strong> -- a great deal for the money?</label> | |
| 118 | <div class="row"><span class="dollar">\$</span><input type="number" name="bargain" step="0.01" min="0" required></div> | |
| 119 | </div> | |
| 120 | <div class="q"> | |
| 121 | <label>At what price would this be starting to get <strong>expensive</strong> -- but still worth considering?</label> | |
| 122 | <div class="row"><span class="dollar">\$</span><input type="number" name="expensive" step="0.01" min="0" required></div> | |
| 123 | </div> | |
| 124 | <div class="q"> | |
| 125 | <label>At what price would this be <strong>so expensive</strong> that you would not consider buying it?</label> | |
| 126 | <div class="row"><span class="dollar">\$</span><input type="number" name="too_expensive" step="0.01" min="0" required></div> | |
| 127 | </div> | |
| 128 | <div class="q"> | |
| 129 | <label>Email (optional — for a follow-up coupon or product update only)</label> | |
| 130 | <input type="email" name="email" placeholder="you\@example.com"> | |
| 131 | </div> | |
| 132 | <button type="submit">Submit response</button> | |
| 133 | </form> | |
| 134 | ~; | |
| 135 | } | |
| 136 | ||
| 137 | print qq~<!DOCTYPE html> | |
| 138 | <html lang="en"><head> | |
| 139 | <meta charset="utf-8"> | |
| 140 | <meta name="viewport" content="width=device-width,initial-scale=1"> | |
| 141 | <title>$title — $brand</title> | |
| 142 | <style> | |
| 143 | body { font: 15px/1.6 system-ui, sans-serif; background:#0f172a; color:#e2e8f0; | |
| 144 | max-width:560px; margin:0 auto; padding:32px 18px; } | |
| 145 | h1 { color:#fff; font-size:24px; margin:0 0 14px; } | |
| 146 | p.lead { color:#94a3b8; margin:0 0 18px; } | |
| 147 | .err { background:rgba(239,68,68,0.12); border:1px solid rgba(239,68,68,0.4); | |
| 148 | color:#fca5a5; padding:10px 14px; border-radius:8px; margin:0 0 16px; | |
| 149 | font-size:14px; } | |
| 150 | .q { margin:0 0 18px; } | |
| 151 | .q label { display:block; font-size:13px; color:#cbd5e1; margin-bottom:6px; line-height:1.45; } | |
| 152 | .row { display:flex; align-items:center; gap:8px; } | |
| 153 | .dollar { color:#94a3b8; font-size:18px; font-family:monospace; } | |
| 154 | input[type=number], input[type=email] { | |
| 155 | flex:1; width:100%; padding:10px 12px; border-radius:8px; | |
| 156 | background:#1e293b; border:1px solid #334155; color:#fff; | |
| 157 | font-size:16px; font-family:inherit; | |
| 158 | } | |
| 159 | button { display:block; width:100%; padding:12px 18px; margin-top:8px; | |
| 160 | background:#4f46e5; color:#fff; border:0; border-radius:8px; | |
| 161 | font-weight:700; font-size:15px; cursor:pointer; } | |
| 162 | button:hover { background:#4338ca; } | |
| 163 | </style> | |
| 164 | </head><body> | |
| 165 | $body | |
| 166 | <p style="margin-top:32px;font-size:11px;color:#475569;text-align:center">Powered by $brand pricing surveys</p> | |
| 167 | </body></html> | |
| 168 | ~; | |
| 169 | ||
| 170 | sub _h { | |
| 171 | my $s = shift; $s = '' unless defined $s; | |
| 172 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 173 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 174 | return $s; | |
| 175 | } |