Diff -- /var/www/vhosts/3dshawn.com/shop.3dshawn.com/MODS/ShopCart/Shipping.pm
Diff

/var/www/vhosts/3dshawn.com/shop.3dshawn.com/MODS/ShopCart/Shipping.pm

added on local at 2026-07-01 22:09:39

Added
+679
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to b79a54340d47
Restore this content →
Unified diff
Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.
1package MODS::ShopCart::Shipping;
2#======================================================================
3# ShopCart -- fulfillment + shipping helpers.
4#
5# Backs four pages:
6# /fulfill.cgi list of physical orders by status
7# /fulfill_order.cgi one-order detail (address, items, label,
8# tracking, notes, status changes)
9# /shipping_settings.cgi origin address, carriers, zones
10# /print_label.cgi printable label + packing slip view
11#
12# Tables: seller_shipping_settings, shipping_carriers, shipping_zones,
13# shipping_labels, shipment_events, fulfillment_notes
14# (plus existing orders + order_items columns).
15#
16# Until live carrier APIs land, rate estimation is rule-based: walk
17# shipping_zones in sort_order, take the first whose country_codes CSV
18# matches the destination, return base + per_kg * weight (clamped to
19# free_over_cents if set).
20#======================================================================
21use strict;
22use warnings;
23
24sub new { bless {}, shift }
25
26#----------------------------------------------------------------------
27# Schema probes -- each new table is optional in the sense that the
28# UI shouldn't 500 if the migration hasn't run yet.
29#----------------------------------------------------------------------
30sub schema_ready {
31 my ($self, $db, $dbh, $DB) = @_;
32 return $self->{_ready} if exists $self->{_ready};
33 foreach my $t (qw(seller_shipping_settings shipping_carriers shipping_zones
34 shipping_labels shipment_events fulfillment_notes)) {
35 my $r = $db->db_readwrite($dbh, qq~
36 SELECT COUNT(*) AS n FROM information_schema.tables
37 WHERE table_schema='$DB' AND table_name='$t'
38 ~, $ENV{SCRIPT_NAME}, __LINE__);
39 unless ($r && $r->{n}) { $self->{_ready} = 0; return 0; }
40 }
41 $self->{_ready} = 1;
42 return 1;
43}
44
45sub _esc { my $s = shift // ''; $s =~ s/\\/\\\\/g; $s =~ s/'/''/g; return $s; }
46sub _int { my $n = shift; $n = 0 unless defined $n; $n =~ s/[^0-9-]//g; return $n + 0; }
47sub _uint { my $n = _int($_[0]); $n < 0 ? 0 : $n }
48
49#----------------------------------------------------------------------
50# Carrier reference data. Static for now; eventually each carrier
51# block carries an api_class string the dispatcher loads.
52#----------------------------------------------------------------------
53my %CARRIERS = (
54 usps => { name => 'USPS', full => 'United States Postal Service',
55 default_service => 'Priority Mail',
56 services => ['First-Class Package', 'Priority Mail', 'Priority Mail Express', 'Ground Advantage', 'Media Mail'],
57 connect_help => 'Get an API key from usps.com/business/web-tools-apis/' },
58 ups => { name => 'UPS', full => 'United Parcel Service',
59 default_service => 'Ground',
60 services => ['Ground', '3 Day Select', '2nd Day Air', 'Next Day Air Saver', 'Next Day Air', 'Worldwide Expedited', 'Worldwide Saver'],
61 connect_help => 'Get OAuth credentials from developer.ups.com' },
62 fedex => { name => 'FedEx', full => 'FedEx',
63 default_service => 'Ground',
64 services => ['Ground', 'Home Delivery', 'Express Saver', '2Day', 'Standard Overnight', 'Priority Overnight', 'International Economy', 'International Priority'],
65 connect_help => 'Get API credentials from developer.fedex.com' },
66 dhl => { name => 'DHL', full => 'DHL Express',
67 default_service => 'Express Worldwide',
68 services => ['Express Worldwide', 'Express 12:00', 'Express 9:00', 'eCommerce'],
69 connect_help => 'Get API credentials from developer.dhl.com' },
70 other => { name => 'Other', full => 'Other carrier / manual entry',
71 default_service => '',
72 services => [],
73 connect_help => 'Use for any carrier not on the list -- you enter the tracking number manually.' },
74);
75
76sub carriers_static { return \%CARRIERS }
77
78sub carrier_label {
79 my ($self, $slug) = @_;
80 return ($CARRIERS{$slug || ''} || { name => uc($slug || 'Manual') })->{name};
81}
82
83#----------------------------------------------------------------------
84# seller_shipping_settings -- one row per user
85#----------------------------------------------------------------------
86sub get_settings {
87 my ($self, $db, $dbh, $DB, $uid) = @_;
88 return undef unless $uid && $self->schema_ready($db, $dbh, $DB);
89 $uid =~ s/[^0-9]//g; return undef unless length $uid;
90 my $r = $db->db_readwrite($dbh, qq~
91 SELECT * FROM `${DB}`.seller_shipping_settings WHERE user_id='$uid' LIMIT 1
92 ~, $ENV{SCRIPT_NAME}, __LINE__);
93 return ($r && $r->{user_id}) ? $r : undef;
94}
95
96sub save_settings {
97 my ($self, $db, $dbh, $DB, $uid, %f) = @_;
98 return 0 unless $uid && $self->schema_ready($db, $dbh, $DB);
99 $uid =~ s/[^0-9]//g; return 0 unless length $uid;
100 my $exists = $self->get_settings($db, $dbh, $DB, $uid);
101
102 my @cols = qw(origin_name origin_company origin_line1 origin_line2
103 origin_city origin_region origin_postal origin_country
104 origin_phone origin_email default_carrier default_service);
105 my %vals;
106 foreach my $c (@cols) {
107 my $v = $f{$c}; $v = '' unless defined $v;
108 $v = substr($v, 0, 255);
109 $vals{$c} = _esc($v);
110 }
111 # Normalize country to 2-char upper.
112 $vals{origin_country} = substr(uc $vals{origin_country}, 0, 2);
113 # Carrier enum guard.
114 $vals{default_carrier} = 'manual' unless $CARRIERS{$f{default_carrier} || ''};
115
116 my $aet = $f{auto_email_tracking} ? 1 : 0;
117 my $rsi = $f{require_signature} ? 1 : 0;
118 my $hfc = _uint($f{handling_fee_cents});
119 my $dhd = _uint($f{default_handling_days});
120 my $ins = exists $f{insurance_default_cents} && $f{insurance_default_cents} ne ''
121 ? _uint($f{insurance_default_cents}) : undef;
122 my $ins_sql = defined $ins ? "'$ins'" : 'NULL';
123
124 my $set_pairs = join(',', map { "$_='" . $vals{$_} . "'" } @cols)
125 . ", auto_email_tracking='$aet'"
126 . ", require_signature='$rsi'"
127 . ", handling_fee_cents='$hfc'"
128 . ", default_handling_days='$dhd'"
129 . ", insurance_default_cents=$ins_sql";
130
131 if ($exists) {
132 $db->db_readwrite($dbh, qq~
133 UPDATE `${DB}`.seller_shipping_settings SET $set_pairs
134 WHERE user_id='$uid' LIMIT 1
135 ~, $ENV{SCRIPT_NAME}, __LINE__);
136 } else {
137 $db->db_readwrite($dbh, qq~
138 INSERT INTO `${DB}`.seller_shipping_settings SET user_id='$uid', $set_pairs
139 ~, $ENV{SCRIPT_NAME}, __LINE__);
140 }
141 return 1;
142}
143
144#----------------------------------------------------------------------
145# shipping_carriers -- per-seller per-carrier rows. Auto-creates a
146# "manual" row on demand so the UI always has a list to render.
147#----------------------------------------------------------------------
148sub list_carriers {
149 my ($self, $db, $dbh, $DB, $uid) = @_;
150 return [] unless $uid && $self->schema_ready($db, $dbh, $DB);
151 $uid =~ s/[^0-9]//g; return [] unless length $uid;
152 my @rows = $db->db_readwrite_multiple($dbh, qq~
153 SELECT * FROM `${DB}`.shipping_carriers WHERE user_id='$uid'
154 ORDER BY FIELD(carrier,'usps','ups','fedex','dhl','other')
155 ~, $ENV{SCRIPT_NAME}, __LINE__);
156 return \@rows;
157}
158
159sub upsert_carrier {
160 my ($self, $db, $dbh, $DB, $uid, %f) = @_;
161 return 0 unless $uid && $self->schema_ready($db, $dbh, $DB);
162 $uid =~ s/[^0-9]//g; return 0 unless length $uid;
163 my $c = $f{carrier} || '';
164 return 0 unless $CARRIERS{$c};
165 my $name = substr($f{display_name} || $CARRIERS{$c}{name}, 0, 80);
166 my $en = $f{is_enabled} ? 1 : 0;
167 my $live = $f{is_live} ? 1 : 0;
168 my $acct = substr($f{account_number} || '', 0, 120);
169 my $key = substr($f{api_key} || '', 0, 255);
170 my $sec = substr($f{api_secret} || '', 0, 255);
171 my $svc = substr($f{default_service}|| '', 0, 80);
172 my $note = substr($f{notes} || '', 0, 1024);
173
174 my $r = $db->db_readwrite($dbh, qq~
175 SELECT id FROM `${DB}`.shipping_carriers
176 WHERE user_id='$uid' AND carrier='$c' LIMIT 1
177 ~, $ENV{SCRIPT_NAME}, __LINE__);
178
179 my $set = "display_name='" . _esc($name) . "',"
180 . "is_enabled='$en',is_live='$live',"
181 . "account_number='" . _esc($acct) . "',"
182 . "api_key='" . _esc($key) . "',"
183 . "api_secret='" . _esc($sec) . "',"
184 . "default_service='" . _esc($svc) . "',"
185 . "notes='" . _esc($note) . "'";
186
187 if ($r && $r->{id}) {
188 $db->db_readwrite($dbh, qq~
189 UPDATE `${DB}`.shipping_carriers SET $set WHERE id='$r->{id}'
190 ~, $ENV{SCRIPT_NAME}, __LINE__);
191 } else {
192 $db->db_readwrite($dbh, qq~
193 INSERT INTO `${DB}`.shipping_carriers SET
194 user_id='$uid', carrier='$c', $set, created_at=NOW()
195 ~, $ENV{SCRIPT_NAME}, __LINE__);
196 }
197 return 1;
198}
199
200#----------------------------------------------------------------------
201# shipping_zones
202#----------------------------------------------------------------------
203sub list_zones {
204 my ($self, $db, $dbh, $DB, $uid) = @_;
205 return [] unless $uid && $self->schema_ready($db, $dbh, $DB);
206 $uid =~ s/[^0-9]//g; return [] unless length $uid;
207 my @rows = $db->db_readwrite_multiple($dbh, qq~
208 SELECT * FROM `${DB}`.shipping_zones WHERE user_id='$uid'
209 ORDER BY sort_order ASC, name ASC
210 ~, $ENV{SCRIPT_NAME}, __LINE__);
211 return \@rows;
212}
213
214sub zone_by_id {
215 my ($self, $db, $dbh, $DB, $id, $uid) = @_;
216 $id =~ s/[^0-9]//g; return undef unless length $id;
217 $uid =~ s/[^0-9]//g; return undef unless length $uid;
218 my $r = $db->db_readwrite($dbh, qq~
219 SELECT * FROM `${DB}`.shipping_zones
220 WHERE id='$id' AND user_id='$uid' LIMIT 1
221 ~, $ENV{SCRIPT_NAME}, __LINE__);
222 return ($r && $r->{id}) ? $r : undef;
223}
224
225sub zone_create {
226 my ($self, $db, $dbh, $DB, $uid, %f) = @_;
227 return 0 unless $uid && $self->schema_ready($db, $dbh, $DB);
228 $uid =~ s/[^0-9]//g; return 0 unless length $uid;
229 my $name = substr($f{name} || '', 0, 120);
230 return 0 unless length $name;
231 my $cc = substr($f{country_codes} || '', 0, 2000);
232 $cc =~ s/[^A-Za-z, ]//g;
233 $cc =~ s/\s+//g;
234 $cc = uc $cc;
235 my $base = _uint($f{base_cents});
236 my $per = _uint($f{per_kg_cents});
237 my $fov = $f{free_over_cents} && $f{free_over_cents} ne '' ? _uint($f{free_over_cents}) : undef;
238 my $dmin = $f{delivery_days_min} && $f{delivery_days_min} ne '' ? _uint($f{delivery_days_min}) : undef;
239 my $dmax = $f{delivery_days_max} && $f{delivery_days_max} ne '' ? _uint($f{delivery_days_max}) : undef;
240 my $ch = substr($f{carrier_hint} || '', 0, 40);
241 my $sort = _uint($f{sort_order});
242 my $en = exists $f{is_enabled} ? ($f{is_enabled} ? 1 : 0) : 1;
243
244 my $fov_sql = defined $fov ? "'$fov'" : 'NULL';
245 my $dmin_sql = defined $dmin ? "'$dmin'" : 'NULL';
246 my $dmax_sql = defined $dmax ? "'$dmax'" : 'NULL';
247
248 $db->db_readwrite($dbh, qq~
249 INSERT INTO `${DB}`.shipping_zones SET
250 user_id='$uid',
251 name='~ . _esc($name) . qq~',
252 country_codes='~ . _esc($cc) . qq~',
253 base_cents='$base', per_kg_cents='$per',
254 free_over_cents=$fov_sql,
255 delivery_days_min=$dmin_sql, delivery_days_max=$dmax_sql,
256 carrier_hint='~ . _esc($ch) . qq~',
257 sort_order='$sort', is_enabled='$en',
258 created_at=NOW()
259 ~, $ENV{SCRIPT_NAME}, __LINE__);
260 my $r = $db->db_readwrite($dbh, qq~SELECT LAST_INSERT_ID() AS id~, $ENV{SCRIPT_NAME}, __LINE__);
261 return ($r && $r->{id}) ? $r->{id} : 0;
262}
263
264sub zone_update {
265 my ($self, $db, $dbh, $DB, $id, $uid, %f) = @_;
266 return 0 unless $self->zone_by_id($db, $dbh, $DB, $id, $uid);
267 $id =~ s/[^0-9]//g;
268 $uid =~ s/[^0-9]//g;
269 my @sets;
270 if (defined $f{name}) { push @sets, "name='" . _esc(substr($f{name}, 0, 120)) . "'"; }
271 if (defined $f{country_codes}) {
272 my $cc = $f{country_codes};
273 $cc =~ s/[^A-Za-z, ]//g; $cc =~ s/\s+//g; $cc = uc $cc;
274 push @sets, "country_codes='" . _esc(substr($cc, 0, 2000)) . "'";
275 }
276 if (defined $f{base_cents}) { push @sets, "base_cents='" . _uint($f{base_cents}) . "'"; }
277 if (defined $f{per_kg_cents}) { push @sets, "per_kg_cents='" . _uint($f{per_kg_cents}) . "'"; }
278 if (defined $f{free_over_cents}) {
279 if (length $f{free_over_cents}) {
280 push @sets, "free_over_cents='" . _uint($f{free_over_cents}) . "'";
281 } else {
282 push @sets, "free_over_cents=NULL";
283 }
284 }
285 if (defined $f{delivery_days_min}) {
286 push @sets, length $f{delivery_days_min}
287 ? "delivery_days_min='" . _uint($f{delivery_days_min}) . "'"
288 : "delivery_days_min=NULL";
289 }
290 if (defined $f{delivery_days_max}) {
291 push @sets, length $f{delivery_days_max}
292 ? "delivery_days_max='" . _uint($f{delivery_days_max}) . "'"
293 : "delivery_days_max=NULL";
294 }
295 if (defined $f{carrier_hint}) { push @sets, "carrier_hint='" . _esc(substr($f{carrier_hint}, 0, 40)) . "'"; }
296 if (defined $f{sort_order}) { push @sets, "sort_order='" . _uint($f{sort_order}) . "'"; }
297 if (defined $f{is_enabled}) { push @sets, "is_enabled='" . ($f{is_enabled} ? 1 : 0) . "'"; }
298 return 1 unless @sets;
299 $db->db_readwrite($dbh, qq~
300 UPDATE `${DB}`.shipping_zones SET ~ . join(',', @sets) . qq~
301 WHERE id='$id' AND user_id='$uid' LIMIT 1
302 ~, $ENV{SCRIPT_NAME}, __LINE__);
303 return 1;
304}
305
306sub zone_delete {
307 my ($self, $db, $dbh, $DB, $id, $uid) = @_;
308 return 0 unless $self->zone_by_id($db, $dbh, $DB, $id, $uid);
309 $id =~ s/[^0-9]//g;
310 $uid =~ s/[^0-9]//g;
311 $db->db_readwrite($dbh, qq~
312 DELETE FROM `${DB}`.shipping_zones
313 WHERE id='$id' AND user_id='$uid' LIMIT 1
314 ~, $ENV{SCRIPT_NAME}, __LINE__);
315 return 1;
316}
317
318#----------------------------------------------------------------------
319# Rate estimation -- walks zones in sort_order, takes the first whose
320# country_codes CSV contains the destination ISO. Returns:
321# { cents, zone_id, zone_name, delivery_days_min, delivery_days_max,
322# formula => 'base + per_kg * weight_kg', source => 'rule' }
323# or undef if no zone matched / weight unknown / no zones configured.
324#----------------------------------------------------------------------
325sub estimate_rate {
326 my ($self, $db, $dbh, $DB, $uid, %f) = @_;
327 return undef unless $uid && $self->schema_ready($db, $dbh, $DB);
328 my $country = uc(substr($f{country} || '', 0, 2));
329 my $weight = _uint($f{weight_grams});
330 my $zones = $self->list_zones($db, $dbh, $DB, $uid);
331 return undef unless @$zones;
332 my $match;
333 foreach my $z (@$zones) {
334 next unless $z->{is_enabled};
335 my $codes = $z->{country_codes} || '';
336 my @list = split /,/, $codes;
337 # Empty list = any country
338 if (!@list || (grep { $_ eq $country } @list)) {
339 $match = $z; last;
340 }
341 }
342 return undef unless $match;
343 my $kg = $weight / 1000.0;
344 my $cents = $match->{base_cents} + int($match->{per_kg_cents} * $kg);
345 if (defined $match->{free_over_cents} && length $match->{free_over_cents}
346 && $f{order_subtotal_cents} && $f{order_subtotal_cents} >= $match->{free_over_cents}) {
347 $cents = 0;
348 }
349 return {
350 cents => $cents,
351 zone_id => $match->{id},
352 zone_name => $match->{name},
353 delivery_days_min => $match->{delivery_days_min},
354 delivery_days_max => $match->{delivery_days_max},
355 carrier_hint => $match->{carrier_hint} || '',
356 formula => sprintf("%d + %d * %.2f kg", $match->{base_cents}, $match->{per_kg_cents}, $kg),
357 source => 'rule',
358 };
359}
360
361#----------------------------------------------------------------------
362# Orders + items joined for the fulfillment list. Returns physical
363# orders only (orders that have at least one order_items row with
364# purchase_kind='physical'). The list page filters by fulfillment
365# bucket; we hydrate item summaries inline for fast list rendering.
366#----------------------------------------------------------------------
367sub list_orders {
368 my ($self, $db, $dbh, $DB, $uid, %f) = @_;
369 return [] unless $uid;
370 $uid =~ s/[^0-9]//g; return [] unless length $uid;
371
372 my $status = $f{status} || 'all';
373 $status =~ s/[^a-z_]//g;
374 my $q = $f{q} || '';
375 $q = substr($q, 0, 80);
376 $q =~ s/'/''/g;
377 my $limit = _uint($f{limit}) || 200;
378 $limit = 500 if $limit > 500;
379
380 my $status_where = '';
381 if ($status && $status ne 'all') {
382 $status_where = " AND o.fulfillment_status='$status'";
383 }
384 my $q_where = '';
385 if (length $q) {
386 my $like = "'%$q%'";
387 $q_where = " AND (o.buyer_email LIKE $like OR o.ship_name LIKE $like OR o.id=" . _uint($q) . ")";
388 }
389
390 my @rows = $db->db_readwrite_multiple($dbh, qq~
391 SELECT DISTINCT o.id, o.buyer_email, o.ship_name, o.ship_city,
392 o.ship_region, o.ship_country, o.created_at, o.paid_at,
393 o.fulfillment_status, o.total_amount_cents, o.shipping_cents,
394 o.currency, o.fulfilled_at
395 FROM `${DB}`.orders o
396 JOIN `${DB}`.order_items oi ON oi.order_id = o.id
397 JOIN `${DB}`.models m ON m.id = oi.model_id
398 WHERE m.user_id='$uid'
399 AND oi.purchase_kind='physical'
400 AND o.status IN ('paid','disputed')
401 $status_where $q_where
402 ORDER BY o.created_at DESC
403 LIMIT $limit
404 ~, $ENV{SCRIPT_NAME}, __LINE__);
405 return \@rows;
406}
407
408sub count_by_status {
409 my ($self, $db, $dbh, $DB, $uid) = @_;
410 my %out;
411 return \%out unless $uid;
412 $uid =~ s/[^0-9]//g; return \%out unless length $uid;
413 my @rows = $db->db_readwrite_multiple($dbh, qq~
414 SELECT o.fulfillment_status AS s, COUNT(DISTINCT o.id) AS n
415 FROM `${DB}`.orders o
416 JOIN `${DB}`.order_items oi ON oi.order_id = o.id
417 JOIN `${DB}`.models m ON m.id = oi.model_id
418 WHERE m.user_id='$uid'
419 AND oi.purchase_kind='physical'
420 AND o.status IN ('paid','disputed')
421 GROUP BY o.fulfillment_status
422 ~, $ENV{SCRIPT_NAME}, __LINE__);
423 foreach my $r (@rows) { $out{$r->{s}} = $r->{n}; }
424 return \%out;
425}
426
427sub get_order {
428 my ($self, $db, $dbh, $DB, $oid, $uid) = @_;
429 $oid =~ s/[^0-9]//g; return undef unless length $oid;
430 $uid =~ s/[^0-9]//g; return undef unless length $uid;
431 # Ownership: at least one of the items must belong to this seller.
432 my $own = $db->db_readwrite($dbh, qq~
433 SELECT m.user_id FROM `${DB}`.order_items oi
434 JOIN `${DB}`.models m ON m.id = oi.model_id
435 WHERE oi.order_id='$oid' AND m.user_id='$uid' LIMIT 1
436 ~, $ENV{SCRIPT_NAME}, __LINE__);
437 return undef unless $own && $own->{user_id};
438
439 my $o = $db->db_readwrite($dbh, qq~
440 SELECT * FROM `${DB}`.orders WHERE id='$oid' LIMIT 1
441 ~, $ENV{SCRIPT_NAME}, __LINE__);
442 return ($o && $o->{id}) ? $o : undef;
443}
444
445sub get_order_items {
446 my ($self, $db, $dbh, $DB, $oid, $uid) = @_;
447 $oid =~ s/[^0-9]//g; return [] unless length $oid;
448 $uid =~ s/[^0-9]//g; return [] unless length $uid;
449 my @rows = $db->db_readwrite_multiple($dbh, qq~
450 SELECT oi.*, m.title AS model_title, m.weight_grams,
451 m.dim_length_mm, m.dim_width_mm, m.dim_height_mm
452 FROM `${DB}`.order_items oi
453 JOIN `${DB}`.models m ON m.id = oi.model_id
454 WHERE oi.order_id='$oid' AND m.user_id='$uid'
455 ORDER BY oi.id ASC
456 ~, $ENV{SCRIPT_NAME}, __LINE__);
457 return \@rows;
458}
459
460#----------------------------------------------------------------------
461# Status transitions. We don't enforce a strict state machine -- the
462# UI is opinionated but the seller can override (e.g. flag "on_hold"
463# from any state). update_status writes both orders.fulfillment_status
464# and, if items are listed, the corresponding order_items rows.
465#----------------------------------------------------------------------
466my %VALID_ORDER_STATUS = map { $_ => 1 } qw(
467 new processing printing printed packed shipped partially_shipped
468 delivered completed on_hold cancelled returned
469);
470my %VALID_ITEM_STATUS = map { $_ => 1 } qw(
471 not_required new pending processing printing printed packed
472 shipped delivered completed on_hold cancelled canceled returned
473);
474
475sub update_order_status {
476 my ($self, $db, $dbh, $DB, $oid, $uid, $new_status, %opts) = @_;
477 $oid =~ s/[^0-9]//g; return 0 unless length $oid;
478 $uid =~ s/[^0-9]//g; return 0 unless length $uid;
479 return 0 unless $VALID_ORDER_STATUS{$new_status || ''};
480 return 0 unless $self->get_order($db, $dbh, $DB, $oid, $uid);
481
482 my @sets = ("fulfillment_status='$new_status'");
483 if ($new_status eq 'completed' || $new_status eq 'delivered') {
484 push @sets, "fulfilled_at=NOW()";
485 }
486 $db->db_readwrite($dbh, qq~
487 UPDATE `${DB}`.orders SET ~ . join(',', @sets) . qq~
488 WHERE id='$oid' LIMIT 1
489 ~, $ENV{SCRIPT_NAME}, __LINE__);
490
491 if ($opts{cascade_items}) {
492 $db->db_readwrite($dbh, qq~
493 UPDATE `${DB}`.order_items oi
494 JOIN `${DB}`.models m ON m.id = oi.model_id
495 SET oi.fulfillment_status='$new_status'
496 WHERE oi.order_id='$oid' AND m.user_id='$uid'
497 AND oi.purchase_kind='physical'
498 ~, $ENV{SCRIPT_NAME}, __LINE__);
499 }
500
501 $self->add_note($db, $dbh, $DB, $oid, $uid,
502 "Status changed to $new_status" . ($opts{by} ? " by $opts{by}" : ''),
503 is_internal => 1);
504 return 1;
505}
506
507sub update_item_status {
508 my ($self, $db, $dbh, $DB, $oid, $item_id, $uid, $new_status) = @_;
509 $oid =~ s/[^0-9]//g;
510 $item_id =~ s/[^0-9]//g;
511 $uid =~ s/[^0-9]//g;
512 return 0 unless length $oid && length $item_id && length $uid;
513 return 0 unless $VALID_ITEM_STATUS{$new_status || ''};
514
515 my $own = $db->db_readwrite($dbh, qq~
516 SELECT oi.id FROM `${DB}`.order_items oi
517 JOIN `${DB}`.models m ON m.id = oi.model_id
518 WHERE oi.id='$item_id' AND oi.order_id='$oid' AND m.user_id='$uid'
519 LIMIT 1
520 ~, $ENV{SCRIPT_NAME}, __LINE__);
521 return 0 unless $own && $own->{id};
522
523 my @sets = ("fulfillment_status='$new_status'");
524 if ($new_status eq 'shipped') { push @sets, "shipped_at=NOW()"; }
525 elsif ($new_status eq 'delivered') { push @sets, "delivered_at=NOW()"; }
526
527 $db->db_readwrite($dbh, qq~
528 UPDATE `${DB}`.order_items SET ~ . join(',', @sets) . qq~
529 WHERE id='$item_id' LIMIT 1
530 ~, $ENV{SCRIPT_NAME}, __LINE__);
531 return 1;
532}
533
534#----------------------------------------------------------------------
535# Labels -- one record per shipment. The label artifact (PDF/PNG/HTML)
536# can be generated by /print_label.cgi as a printable HTML page until
537# real carrier API integration is wired.
538#----------------------------------------------------------------------
539sub list_labels_for_order {
540 my ($self, $db, $dbh, $DB, $oid, $uid) = @_;
541 $oid =~ s/[^0-9]//g; return [] unless length $oid;
542 $uid =~ s/[^0-9]//g; return [] unless length $uid;
543 my @rows = $db->db_readwrite_multiple($dbh, qq~
544 SELECT * FROM `${DB}`.shipping_labels
545 WHERE order_id='$oid' AND user_id='$uid'
546 ORDER BY id DESC
547 ~, $ENV{SCRIPT_NAME}, __LINE__);
548 return \@rows;
549}
550
551sub create_label {
552 my ($self, $db, $dbh, $DB, $uid, $oid, %f) = @_;
553 return 0 unless $uid && $oid && $self->schema_ready($db, $dbh, $DB);
554 $uid =~ s/[^0-9]//g; $oid =~ s/[^0-9]//g;
555 return 0 unless $self->get_order($db, $dbh, $DB, $oid, $uid);
556
557 my $carrier = $f{carrier} || 'manual';
558 $carrier = 'manual' unless $CARRIERS{$carrier} || $carrier eq 'manual';
559 my $svc = substr($f{service} || '', 0, 80);
560 my $tn = substr($f{tracking_number} || '', 0, 120);
561 my $turl = substr($f{tracking_url} || '', 0, 500);
562 my $cost = $f{cost_cents} ne '' ? _uint($f{cost_cents}) : undef;
563 my $wt = $f{weight_grams} && $f{weight_grams} ne '' ? _uint($f{weight_grams}) : undef;
564 my $notes = substr($f{notes} || '', 0, 2048);
565
566 my $cost_sql = defined $cost ? "'$cost'" : 'NULL';
567 my $wt_sql = defined $wt ? "'$wt'" : 'NULL';
568
569 $db->db_readwrite($dbh, qq~
570 INSERT INTO `${DB}`.shipping_labels SET
571 user_id='$uid', order_id='$oid',
572 carrier='~ . _esc($carrier) . qq~',
573 service='~ . _esc($svc) . qq~',
574 tracking_number='~ . _esc($tn) . qq~',
575 tracking_url='~ . _esc($turl) . qq~',
576 cost_cents=$cost_sql,
577 weight_grams=$wt_sql,
578 notes='~ . _esc($notes) . qq~',
579 status='created',
580 purchased_at=NOW(),
581 created_at=NOW()
582 ~, $ENV{SCRIPT_NAME}, __LINE__);
583 my $r = $db->db_readwrite($dbh, qq~SELECT LAST_INSERT_ID() AS id~, $ENV{SCRIPT_NAME}, __LINE__);
584 my $lid = $r && $r->{id} ? $r->{id} : 0;
585
586 if ($lid && $f{apply_to_items}) {
587 $db->db_readwrite($dbh, qq~
588 UPDATE `${DB}`.order_items oi
589 JOIN `${DB}`.models m ON m.id = oi.model_id
590 SET oi.label_id='$lid',
591 oi.tracking_number='~ . _esc($tn) . qq~',
592 oi.tracking_carrier='~ . _esc($carrier) . qq~'
593 WHERE oi.order_id='$oid' AND m.user_id='$uid'
594 AND oi.purchase_kind='physical'
595 ~, $ENV{SCRIPT_NAME}, __LINE__);
596 }
597 return $lid;
598}
599
600sub get_label {
601 my ($self, $db, $dbh, $DB, $lid, $uid) = @_;
602 $lid =~ s/[^0-9]//g; return undef unless length $lid;
603 $uid =~ s/[^0-9]//g; return undef unless length $uid;
604 my $r = $db->db_readwrite($dbh, qq~
605 SELECT * FROM `${DB}`.shipping_labels
606 WHERE id='$lid' AND user_id='$uid' LIMIT 1
607 ~, $ENV{SCRIPT_NAME}, __LINE__);
608 return ($r && $r->{id}) ? $r : undef;
609}
610
611sub void_label {
612 my ($self, $db, $dbh, $DB, $lid, $uid) = @_;
613 return 0 unless $self->get_label($db, $dbh, $DB, $lid, $uid);
614 $lid =~ s/[^0-9]//g; $uid =~ s/[^0-9]//g;
615 $db->db_readwrite($dbh, qq~
616 UPDATE `${DB}`.shipping_labels
617 SET status='voided', voided_at=NOW()
618 WHERE id='$lid' AND user_id='$uid' LIMIT 1
619 ~, $ENV{SCRIPT_NAME}, __LINE__);
620 return 1;
621}
622
623sub mark_label_shipped {
624 my ($self, $db, $dbh, $DB, $lid, $uid) = @_;
625 return 0 unless $self->get_label($db, $dbh, $DB, $lid, $uid);
626 $lid =~ s/[^0-9]//g; $uid =~ s/[^0-9]//g;
627 $db->db_readwrite($dbh, qq~
628 UPDATE `${DB}`.shipping_labels
629 SET status='shipped', shipped_at=NOW()
630 WHERE id='$lid' AND user_id='$uid' LIMIT 1
631 ~, $ENV{SCRIPT_NAME}, __LINE__);
632 return 1;
633}
634
635#----------------------------------------------------------------------
636# Notes -- internal log on each order.
637#----------------------------------------------------------------------
638sub add_note {
639 my ($self, $db, $dbh, $DB, $oid, $uid, $note, %opts) = @_;
640 return 0 unless $oid && $uid && length($note || '');
641 $oid =~ s/[^0-9]//g; $uid =~ s/[^0-9]//g;
642 my $is_int = exists $opts{is_internal} ? ($opts{is_internal} ? 1 : 0) : 1;
643 $note = substr($note, 0, 8000);
644 $db->db_readwrite($dbh, qq~
645 INSERT INTO `${DB}`.fulfillment_notes SET
646 order_id='$oid', user_id='$uid',
647 note='~ . _esc($note) . qq~',
648 is_internal='$is_int',
649 created_at=NOW()
650 ~, $ENV{SCRIPT_NAME}, __LINE__);
651 return 1;
652}
653
654sub list_notes {
655 my ($self, $db, $dbh, $DB, $oid) = @_;
656 $oid =~ s/[^0-9]//g; return [] unless length $oid;
657 my @rows = $db->db_readwrite_multiple($dbh, qq~
658 SELECT * FROM `${DB}`.fulfillment_notes WHERE order_id='$oid'
659 ORDER BY created_at DESC LIMIT 200
660 ~, $ENV{SCRIPT_NAME}, __LINE__);
661 return \@rows;
662}
663
664#----------------------------------------------------------------------
665# Tracking URL helper -- best-effort link to the carrier's tracking
666# page so the seller (and buyer) can click through.
667#----------------------------------------------------------------------
668sub tracking_url {
669 my ($self, $carrier, $tn) = @_;
670 return '' unless $tn;
671 my $c = lc($carrier || '');
672 return "https://tools.usps.com/go/TrackConfirmAction?tLabels=$tn" if $c eq 'usps';
673 return "https://www.ups.com/track?tracknum=$tn" if $c eq 'ups';
674 return "https://www.fedex.com/fedextrack/?trknbr=$tn" if $c eq 'fedex';
675 return "https://www.dhl.com/en/express/tracking.html?AWB=$tn" if $c eq 'dhl';
676 return '';
677}
678
6791;
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help