added on local at 2026-07-01 22:09:40
| 1 | package MODS::ShopCart::TestCards; | |
| 2 | #====================================================================== | |
| 3 | # ShopCart - Sandbox test card simulator. | |
| 4 | # | |
| 5 | # Admin staff manage a list of fake credit cards via | |
| 6 | # /admin_test_cards.cgi. When one of those cards is attached to a user | |
| 7 | # (payment_methods.stripe_payment_method_id = "test_pm_<id>"), every | |
| 8 | # call to Stripe's create_subscription_charge intercepts BEFORE hitting | |
| 9 | # the network and returns a synthetic PaymentIntent response that looks | |
| 10 | # exactly like what Stripe would have sent. Lets staff verify the full | |
| 11 | # billing flow (upgrade -> charge -> invoice marked paid; declined -> | |
| 12 | # invoice marked failed; etc.) without real money or real test cards | |
| 13 | # from Stripe's docs. | |
| 14 | # | |
| 15 | # The 5 supported behaviors map to: | |
| 16 | # approve -> { status => 'succeeded', id => 'test_pi_<n>' } | |
| 17 | # decline -> { error => 'Your card was declined.' } | |
| 18 | # insufficient_funds -> { error => 'Insufficient funds.' } | |
| 19 | # expired_card -> { error => 'Your card has expired.' } | |
| 20 | # processing_error -> { error => 'Card processing failed.' } | |
| 21 | # | |
| 22 | # Caller signature mirrors create_subscription_charge so the interception | |
| 23 | # in Stripe.pm is a clean drop-in. | |
| 24 | #====================================================================== | |
| 25 | use strict; | |
| 26 | use warnings; | |
| 27 | ||
| 28 | use MODS::DBConnect; | |
| 29 | use MODS::ShopCart::Config; | |
| 30 | ||
| 31 | # Decline-reason copy keyed by the behavior enum. Surfaced verbatim to | |
| 32 | # the seller / admin so they recognize which simulated path fired. | |
| 33 | my %DECLINE_TEXT = ( | |
| 34 | decline => 'Your card was declined.', | |
| 35 | insufficient_funds => 'Insufficient funds.', | |
| 36 | expired_card => 'Your card has expired.', | |
| 37 | processing_error => 'Card processing failed.', | |
| 38 | ); | |
| 39 | ||
| 40 | # Look up the test card row that backs payment_method id "test_pm_N". | |
| 41 | # Returns the row hash or undef. Schema-guarded so admin pages on | |
| 42 | # installs without the migration still load. | |
| 43 | sub _row_for_pm { | |
| 44 | my ($class, $pm_id) = @_; | |
| 45 | return undef unless defined $pm_id; | |
| 46 | return undef unless $pm_id =~ /^test_pm_(\d+)$/; | |
| 47 | my $id = $1; | |
| 48 | ||
| 49 | my $cfg = MODS::ShopCart::Config->new; | |
| 50 | my $DB = $cfg->settings('database_name'); | |
| 51 | my $db = MODS::DBConnect->new; | |
| 52 | my $dbh = $db->db_connect(); | |
| 53 | my $r; | |
| 54 | eval { | |
| 55 | my $chk = $db->db_readwrite($dbh, qq~ | |
| 56 | SHOW TABLES LIKE 'admin_test_cards' | |
| 57 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 58 | if ($chk && %$chk) { | |
| 59 | $r = $db->db_readwrite($dbh, qq~ | |
| 60 | SELECT id, card_brand, last4, exp_month, exp_year, | |
| 61 | holder_name, behavior, label | |
| 62 | FROM `${DB}`.admin_test_cards | |
| 63 | WHERE id='$id' LIMIT 1 | |
| 64 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 65 | } | |
| 66 | }; | |
| 67 | $db->db_disconnect($dbh); | |
| 68 | return ($r && $r->{id}) ? $r : undef; | |
| 69 | } | |
| 70 | ||
| 71 | # Synthesize a PaymentIntent response. Always returns a flat hashref | |
| 72 | # that matches the shape create_subscription_charge would have produced | |
| 73 | # from a real Stripe call -- callers should not have to special-case. | |
| 74 | sub simulate_charge { | |
| 75 | my ($class, %p) = @_; | |
| 76 | my $row = $class->_row_for_pm($p{payment_method}); | |
| 77 | unless ($row) { | |
| 78 | # Stale or unknown test_pm_ id -- behave like an unknown PM | |
| 79 | # rather than silently succeed. | |
| 80 | return { error => 'Sandbox card not found. Re-attach in admin Test Cards.' }; | |
| 81 | } | |
| 82 | ||
| 83 | my $behavior = $row->{behavior} || 'approve'; | |
| 84 | ||
| 85 | if ($behavior ne 'approve') { | |
| 86 | return { | |
| 87 | error => ($DECLINE_TEXT{$behavior} || 'Card was declined.'), | |
| 88 | _test => 1, | |
| 89 | _behavior => $behavior, | |
| 90 | }; | |
| 91 | } | |
| 92 | ||
| 93 | # Approve: emit a succeeded PaymentIntent with a deterministic but | |
| 94 | # unique-per-call fake id. The "test_pi_" prefix mirrors the | |
| 95 | # "test_pm_" convention so anything downstream that wants to know | |
| 96 | # "did this come from the sandbox?" can substring-match. | |
| 97 | my $pi = 'test_pi_' . $row->{id} . '_' . time() . '_' . int(rand(1_000_000)); | |
| 98 | return { | |
| 99 | id => $pi, | |
| 100 | status => 'succeeded', | |
| 101 | amount => int($p{amount_cents} || 0), | |
| 102 | amount_received => int($p{amount_cents} || 0), | |
| 103 | currency => ($p{currency} || 'usd'), | |
| 104 | payment_method => $p{payment_method}, | |
| 105 | _test => 1, | |
| 106 | _behavior => 'approve', | |
| 107 | }; | |
| 108 | } | |
| 109 | ||
| 110 | 1; |