lib/Vend/Order.pm

   1 # Vend::Order - Interchange order routing routines
   2 #
   3 # Copyright (C) 2002-2009 Interchange Development Group
   4 # Copyright (C) 1996-2002 Red Hat, Inc.
   5 #
   6 # This program was originally based on Vend 0.2 and 0.3
   7 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public
  20 # License along with this program; if not, write to the Free
  21 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  22 # MA  02110-1301  USA.
  23
  24 package Vend::Order;
  25 require Exporter;
  26
  27 $VERSION = '2.109';
  28
  29 @ISA = qw(Exporter);
  30
  31 @EXPORT = qw (
  32         add_items
  33         do_order
  34         check_order
  35         check_required
  36         encrypt_standard_cc
  37         mail_order
  38         onfly
  39         route_order
  40         update_quantity
  41         validate_whole_cc
  42 );
  43
  44 push @EXPORT, qw (
  45         send_mail
  46 );
  47
  48 use Vend::Util;
  49 use Vend::File;
  50 use Vend::Interpolate;
  51 use Vend::Session;
  52 use Vend::Data;
  53 use Text::ParseWords;
  54 use Errno qw/:POSIX/;
  55 use strict;
  56 no warnings qw(uninitialized numeric);
  57
  58 use autouse 'Vend::Error' => qw/do_lockout/;
  59
  60 # Instance variables
  61 my (
  62         @Errors,
  63         $Update,
  64         $Fatal,
  65         $And,
  66         $Final,
  67         $Success,
  68         $Profile,
  69         $Tables,
  70         $Fail_page,
  71         $Success_page,
  72         $No_error,
  73         $OrderCheck,
  74 );
  75
  76 sub reset_order_vars {
  77         @Errors = ();
  78         $Update = 0;
  79         $Fatal = 0;
  80         undef $And;
  81         $Final = 0;
  82         undef $Success;
  83         undef $Profile;
  84         undef $Tables;
  85         undef $Fail_page;
  86         undef $Success_page;
  87         undef $No_error;
  88
  89         # copy global order check routines
  90         $OrderCheck = { %{$Global::OrderCheck || {} }};
  91
  92         # overlay any catalog order check routines
  93         my $r;
  94         if ($r = $Vend::Cfg->{CodeDef}{OrderCheck} and $r = $r->{Routine}) {
  95                 for (keys %$r) {
  96                         $OrderCheck->{$_} = $r->{$_};
  97                 }
  98         }
  99
 100         return;
 101 }
 102
 103 my %Parse = (
 104
 105         '&charge'       =>      \&_charge,
 106         '&credit_card'  =>      \&_credit_card,
 107         '&return'       =>      \&_return,
 108         '&update'       =>      \&_update,
 109         '&fatal'        =>      \&_fatal,
 110         '&and'          =>      \&_and_check,
 111         '&or'           =>      \&_or_check,
 112         '&format'               =>      \&_format,
 113         '&tables'               =>      sub { $Tables = $_[1]; return 1; },
 114         '&noerror'              =>      sub { $No_error = $_[1] },
 115         '&success'              =>      sub { $Success_page = $_[1] },
 116         '&fail'         =>  sub { $Fail_page    = $_[1] },
 117         '&final'                =>      \&_final,
 118         '&calc'                 =>  sub { Vend::Interpolate::tag_calc($_[1]) },
 119         '&perl'                 =>  sub { Vend::Interpolate::tag_perl($Tables, {}, $_[1]) },
 120         '&test'                 =>      sub {
 121                                                                 my($ref,$params) = @_;
 122                                                                 $params =~ s/\s+//g;
 123                                                                 return $params;
 124                                                         },
 125         '&set'                  =>      sub {
 126                                                                 my($ref,$params) = @_;
 127                                                                 my ($var, $value) = split /\s+/, $params, 2;
 128                                                                 $::Values->{$var} = $value;
 129                                                                 return 1;
 130                                                         },
 131         '&setcheck'                     =>      sub {
 132                                                                 my($ref,$params) = @_;
 133                                                                 my ($var, $value) = split /\s+/, $params, 2;
 134                                                                 $::Values->{$var} = $value;
 135                                                                 my $msg = errmsg("%s set failed.", $var);
 136                                                                 return ($value, $var, $msg);
 137                                                         },
 138 );
 139
 140 sub _update {
 141         $Update = is_yes($_[1]);
 142         return 1;
 143 }
 144
 145 sub _fatal {
 146         $Fatal = ( defined($_[1]) && ($_[1] =~ /^[yYtT1]/) ) ? 1 : 0;
 147         return 1;
 148 }
 149
 150 sub _final {
 151         $Final = ( defined($_[1]) && ($_[1] =~ /^[yYtT1]/) ) ? 1 : 0;
 152         return 1;
 153 }
 154
 155 sub _return {
 156         $Success = ( defined($_[1]) && ($_[1] =~ /^[yYtT1]/) ) ? 1 : 0;
 157 }
 158
 159 sub _format {
 160         my($ref, $params, $message) = @_;
 161         no strict 'refs';
 162         my ($routine, $var, $val) = split /\s+/, $params, 3;
 163
 164         my (@return);
 165
 166 #::logDebug("OrderCheck = $OrderCheck routine=$routine");
 167         my $sub;
 168         my @args;
 169         if( $sub = $Parse{$routine}) {
 170                 @args = ($var, $val, $message);
 171                 undef $message;
 172         }
 173         elsif ($OrderCheck and $sub = $OrderCheck->{$routine}) {
 174 #::logDebug("Using coderef OrderCheck = $sub");
 175                 @args = ($ref,$var,$val,$message);
 176                 undef $message;
 177         }
 178         elsif (defined &{"_$routine"}) {
 179                 $sub = \&{"_$routine"};
 180                 @args = ($ref,$var,$val,$message);
 181         }
 182         else {
 183                 return (undef, $var, errmsg("No format check routine for '%s'", $routine));
 184         }
 185
 186         @return = $sub->(@args);
 187
 188         if(! $return[0] and $message) {
 189                 $return[2] = $message;
 190         }
 191         return @return;
 192 }
 193
 194 sub chain_checks {
 195         my ($or, $ref, $checks, $err, $vref) = @_;
 196         my ($var, $val, $mess, $message);
 197         my $result = 1;
 198         $mess = "$checks $err";
 199         while($mess =~ s/(\S+=\w+)[\s,]*//) {
 200                 my $check = $1;
 201                 ($val, $var, $message) = do_check($check, $vref);
 202                 return undef if ! defined $var;
 203                 if($val and $or) {
 204                         1 while $mess =~ s/(\S+=\w+)[\s,]*//;
 205                         return ($val, $var, $message)
 206                 }
 207                 elsif ($val) {
 208                         $result = 1;
 209                         next;
 210                 }
 211                 else {
 212                         next if $or;
 213                         1 while $mess =~ s/(\S+=\w+)[\s,]*//;
 214                         return($val, $var, $mess);
 215                 }
 216         }
 217         return ($val, $var, $mess);
 218 }
 219
 220 sub _and_check {
 221         if(! length($_[1]) ) {
 222                 $And = 1;
 223                 return (1);
 224         }
 225         return chain_checks(0, @_);
 226 }
 227
 228 sub _or_check {
 229         if(! length($_[1]) ) {
 230                 $And = 0;
 231                 return (1);
 232         }
 233         return chain_checks(1, @_);
 234 }
 235
 236 sub _charge {
 237         my ($ref, $params, $message) = @_;
 238         my $result;
 239         my $opt;
 240         if ($params =~ /^custom\s+/) {
 241                 $opt = {};
 242         }
 243         else {
 244                 $params =~ s/(\w+)\s*(.*)/$1/s;
 245                 $opt = get_option_hash($2);
 246         }
 247
 248         eval {
 249                 $result = Vend::Payment::charge($params, $opt);
 250         };
 251         if($result) {
 252                 # do nothing, OK
 253         }
 254         elsif($@) {
 255                 my $msg = errmsg("Fatal error on charge operation '%s': %s", $params, $@);
 256                 ::logError($msg);
 257                 $message = $msg;
 258         }
 259         elsif( $Vend::Session->{payment_error} ) {
 260                 # do nothing, no extended messages
 261                 $message = errmsg(
 262                                                 "Charge failed, reason: %s",
 263                                                 $Vend::Session->{payment_error},
 264                                         )
 265                         if ! $message;
 266         }
 267         else {
 268                 $message = errmsg(
 269                                         "Charge operation '%s' failed.",
 270                                         ($ref->{mv_cyber_mode} || $params),
 271                                         )
 272                         if ! $message;
 273         }
 274 #::logDebug("charge result: result=$result params=$params message=$message");
 275         return ($result, $params, $message);
 276 }
 277
 278 sub _credit_card {
 279         my($ref, $params) = @_;
 280         my $subname;
 281         my $sub;
 282         my $opt;
 283
 284         $params =~ s/^\s+//;
 285         $params =~ s/\s+$//;
 286
 287         # Make a copy if we need to keep the credit card number in memory for
 288         # a while
 289
 290         # New or Compatibility to get options
 291
 292         if($params =~ /=/) {            # New
 293                 $params =~ s/^\s*(\w+)(\s+|$)//
 294                         and $subname = $1;
 295                 $subname = 'standard' if ! $subname;
 296                 $opt = get_option_hash($params);
 297         }
 298         else {                                  # Compat
 299                 $opt = {};
 300                 $opt->{keep} = 1 if $params =~ s/\s+keep//i;
 301
 302                 if($params =~ s/\s+(.*)//) {
 303                         $opt->{accepted} = $1;
 304                 }
 305                 $subname = $params;
 306         }
 307
 308         $sub = $subname eq 'standard'
 309                  ? \&encrypt_standard_cc
 310                  :      $Global::GlobalSub->{$subname};
 311
 312         if(! $sub) {
 313                 ::logError("bad credit card check GlobalSub: '%s'", $subname);
 314                 return undef;
 315         }
 316
 317         if($opt->{keep}) {
 318                 my (%cgi) = %$ref;
 319                 $ref = \%cgi;
 320         }
 321
 322         eval {
 323                 @{$::Values}{ qw/
 324                                         mv_credit_card_valid
 325                                         mv_credit_card_info
 326                                         mv_credit_card_exp_month
 327                                         mv_credit_card_exp_year
 328                                         mv_credit_card_exp_all
 329                                         mv_credit_card_type
 330                                         mv_credit_card_reference
 331                                         mv_credit_card_error
 332                                         /}
 333                                 = $sub->($ref, undef, $opt );
 334         };
 335
 336         if($@) {
 337                 ::logError("credit card check (%s) error: %s", $subname, $@);
 338                 return undef;
 339         }
 340         elsif(! $::Values->{mv_credit_card_valid}) {
 341                 return (0, 'mv_credit_card_valid', $::Values->{mv_credit_card_error});
 342         }
 343         else {
 344                 return (1, 'mv_credit_card_valid');
 345         }
 346 }
 347
 348 sub valid_exp_date {
 349         my ($expire) = @_;
 350         my $month;
 351         my $year;
 352         if($expire) {
 353                 $expire =~ /(\d\d?)(.*)/;
 354                 $month = $1;
 355                 $year = $2;
 356                 $year =~ s/\D+//;
 357         }
 358         else {
 359                 $month = $CGI::values{mv_credit_card_exp_month};
 360                 $year = $CGI::values{mv_credit_card_exp_year};
 361         }
 362         return '' if $month !~ /^\d+$/ || $year !~ /^\d+$/;
 363         return '' if $month <1 || $month > 12;
 364         $year += ($year < 70) ? 2000 : 1900 if $year < 1900;
 365         my (@now) = localtime();
 366         $now[5] += 1900;
 367         return '' if ($year < $now[5]) || ($year == $now[5] && $month <= $now[4]);
 368         return 1;
 369 }
 370
 371 sub validate_whole_cc {
 372         my($mess) = join " ", @_;
 373         $mess =~ s:[^\sA-Za-z0-9/]::g ;
 374         my (@tok) = split /\s+/, $mess;
 375         my($num,$expire) = ('', '', '');
 376         for(@tok) {
 377                 next if /^[A-Za-z]/;
 378                 $num .= $_ if /^\d+$/;
 379                 $expire = $_ if m:/: ;
 380         }
 381         return 0 unless valid_exp_date($expire);
 382         return luhn($num);
 383
 384 }
 385
 386
 387 # Validate credit card routine
 388 # by Jon Orwant, from Business::CreditCard and well-known algorithms
 389
 390 sub luhn {
 391         my ($number,$min_digits) = @_;
 392         my ($i, $sum, $weight);
 393
 394         $min_digits ||= 13;
 395         $min_digits = 2 if $min_digits < 2;
 396
 397         $number =~ s/\D//g;
 398
 399         return 0 unless length($number) >= $min_digits && 0+$number;
 400
 401         for ($i = 0; $i < length($number) - 1; $i++) {
 402                 $weight = substr($number, -1 * ($i + 2), 1) * (2 - ($i % 2));
 403                 $sum += (($weight < 10) ? $weight : ($weight - 9));
 404         }
 405
 406         return 1 if substr($number, -1) == (10 - $sum % 10) % 10;
 407         return 0;
 408 }
 409
 410
 411 sub build_cc_info {
 412         my ($cardinfo, $template) = @_;
 413
 414         if (ref $cardinfo eq 'SCALAR') {
 415                 $cardinfo = { MV_CREDIT_CARD_NUMBER => $$cardinfo };
 416         } elsif (! ref $cardinfo) {
 417                 $cardinfo = { MV_CREDIT_CARD_NUMBER => $cardinfo };
 418         } elsif (ref $cardinfo eq 'ARRAY') {
 419                 my $i = 0;
 420                 my %c = map { $_ => $cardinfo->[$i++] } qw(
 421                         MV_CREDIT_CARD_NUMBER
 422                         MV_CREDIT_CARD_EXP_MONTH
 423                         MV_CREDIT_CARD_EXP_YEAR
 424                         MV_CREDIT_CARD_CVV2
 425                         MV_CREDIT_CARD_TYPE
 426                 );
 427                 $cardinfo = \%c;
 428         } elsif (ref $cardinfo ne 'HASH') {
 429                 return;
 430         }
 431
 432         if(my $num = $cardinfo->{MV_CREDIT_CARD_NUMBER}) {
 433                 my @quads;
 434                 $num =~ s/\D//g;
 435                 @quads = $num =~ m{(\d\d\d\d)(\d\d\d\d)(\d\d\d\d)(\d+)};
 436                 $cardinfo->{MV_CREDIT_CARD_QUADS} = join "-", @quads;
 437         }
 438
 439         $template = $template ||
 440                 $::Variable->{MV_CREDIT_CARD_INFO_TEMPLATE} ||
 441                 join("\t", qw(
 442                         {MV_CREDIT_CARD_TYPE}
 443                         {MV_CREDIT_CARD_NUMBER}
 444                         {MV_CREDIT_CARD_EXP_MONTH}/{MV_CREDIT_CARD_EXP_YEAR}
 445                 )) . "\n";
 446
 447         $cardinfo->{MV_CREDIT_CARD_TYPE} ||=
 448                 guess_cc_type($cardinfo->{MV_CREDIT_CARD_NUMBER});
 449
 450         return Vend::Interpolate::tag_attr_list($template, $cardinfo);
 451 }
 452
 453
 454 sub guess_cc_type {
 455         my ($ccnum) = @_;
 456         $ccnum =~ s/\D+//g;
 457
 458         my $country = uc($::Values->{$::Variable->{MV_COUNTRY_FIELD} || 'country'} || '');
 459
 460         if(my $subname = $Vend::Cfg->{SpecialSub}{guess_cc_type}) {
 461                 my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
 462                 my $guess;
 463                 if( $sub and $guess = $sub->($ccnum) ) {
 464                         return $guess;
 465                 }
 466         }
 467
 468         # based on logic from Business::CreditCard
 469         if ($ccnum eq '')
 470         { return '' }
 471
 472         elsif ($ccnum =~ /^4(?:\d{12}|\d{15})$/)
 473         { return 'visa' }
 474
 475         elsif ($ccnum =~ /^5[1-5]\d{14}$/)
 476         { return 'mc' }
 477
 478         elsif (
 479                 $ccnum =~ /^30[0-5]\d{11}(?:\d{2})?$/   # Diners Club: 300-305
 480                 or $ccnum =~ /^3095\d{10}(?:\d{2})?$/   # Diners Club: 3095
 481                 or $ccnum =~ /^3[68]\d{12}(?:\d{2})?$/  # Diners Club: 36
 482                 or $ccnum =~ /^6011\d{12}$/
 483                 or $ccnum =~ /^64[4-9]\d{13}$/
 484                 or $ccnum =~ /^65\d{14}$/
 485                 or ( $ccnum =~ /^62[24-68]\d{13}$/ and $country ne 'CN' )  # China Unionpay
 486                 or ( $ccnum =~ /^35(?:2[89]|[3-8]\d)\d{10}$/ and $country eq 'US' )  # JCB
 487         )
 488         { return 'discover' }
 489
 490         elsif ($ccnum =~ /^3[47]\d{13}$/)
 491         { return 'amex' }
 492
 493         elsif ($ccnum =~ /^3(?:6\d{12}|0[0-5]\d{11})$/)
 494         { return 'dinersclub' }
 495
 496         elsif ($ccnum =~ /^38\d{12}$/)
 497         { return 'carteblanche' }
 498
 499         elsif ($ccnum =~ /^2(?:014|149)\d{11}$/)
 500         { return 'enroute' }
 501
 502         elsif ($ccnum =~ /^(?:3\d{15}|2131\d{11}|1800\d{11})$/)
 503         { return 'jcb' }
 504
 505         elsif (
 506                 $ccnum =~ /^49(?:03(?:0[2-9]|3[5-9])|11(?:0[1-2]|7[4-9]|8[1-2])|36[0-9]{2})\d{10}(?:\d{2,3})?$/
 507                 or $ccnum =~ /^564182\d{10}(?:\d{2,3})?$/
 508                 or $ccnum =~ /^6(?:3(?:33[0-4][0-9])|759[0-9]{2})\d{10}(?:\d{2,3})?$/
 509         )
 510         { return 'switch' }
 511
 512         elsif ($ccnum =~ /^56(?:10\d\d|022[1-5])\d{10}$/)
 513         { return 'bankcard' }
 514
 515         elsif ($ccnum =~ /^6(?:3(?:34[5-9][0-9])|767[0-9]{2})\d{10}(?:\d{2,3})?$/)
 516         { return 'solo' }
 517
 518         elsif ($ccnum =~ /^62[24-68]\d{13}$/)
 519         { return 'chinaunionpay' }
 520
 521         elsif ($ccnum =~ /^6(?:304|7(?:06|09|71))\d{12,15}$/)
 522         { return 'laser' }
 523
 524         else
 525         { return $::Variable->{MV_PAYMENT_OTHER_CARD} || 'other' }
 526 }
 527
 528
 529 # Takes a reference to a hash (usually %CGI::values) that contains
 530 # the following:
 531 #
 532 #    mv_credit_card_number      The actual credit card number
 533 #    mv_credit_card_exp_all     A combined expiration MM/YY
 534 #    mv_credit_card_exp_month   Month only, used if _all not present
 535 #    mv_credit_card_exp_year    Year only, used if _all not present
 536 #    mv_credit_card_cvv2        CVV2 verification number from back of card
 537 #    mv_credit_card_type        A = Amex, D = Discover, etc. Attempts
 538 #                               to guess from number if not there
 539 #    mv_credit_card_separate    Causes mv_credit_card_info to contain only number, must
 540 #                               then develop expiration from the above
 541
 542 sub encrypt_standard_cc {
 543         my($ref, $nodelete, $opt) = @_;
 544         my($valid, $info);
 545
 546         $opt = {} unless ref $opt;
 547         my @deletes = qw /
 548                                         mv_credit_card_type             mv_credit_card_number
 549                                         mv_credit_card_exp_year mv_credit_card_exp_month
 550                                         mv_credit_card_force    mv_credit_card_exp_reference
 551                                         mv_credit_card_exp_all  mv_credit_card_exp_separate
 552                                         mv_credit_card_cvv2
 553                                         /;
 554
 555         my $month       = $ref->{mv_credit_card_exp_month}      || '';
 556         my $type        = $ref->{mv_credit_card_type}           || '';
 557         my $num         = $ref->{mv_credit_card_number}         || '';
 558         my $year        = $ref->{mv_credit_card_exp_year}       || '';
 559         my $all         = $ref->{mv_credit_card_exp_all}        || '';
 560         my $cvv2        = $ref->{mv_credit_card_cvv2}           || '';
 561         my $force       = $ref->{mv_credit_card_force}          || '';
 562         my $separate = $ref->{mv_credit_card_separate}  || $opt->{separate} || '';
 563
 564         delete @$ref{@deletes}        unless ($opt->{nodelete} or $nodelete);
 565
 566         # remove unwanted chars from card number
 567         $num =~ tr/0-9//cd;
 568
 569         # error will be pushed on this if present
 570         my @return = (
 571                                 '',                     # 0- Whether it is valid
 572                                 '',                     # 1- Encrypted credit card information
 573                                 '',                     # 2- Month
 574                                 '',                     # 3- Year
 575                                 '',                     # 4- Month/year
 576                                 '',         # 5- type
 577                                 '',         # 6- Reference number in form 41**1111
 578         );
 579
 580         # Get the expiration
 581         if ($all =~ m!(\d\d?)[-/](\d\d)(\d\d)?! ){
 582                 $month = $1;
 583                 $year  = "$2$3";
 584         }
 585         elsif ($month >= 1  and $month <= 12 and $year) {
 586                 $all = "$month/$year";
 587         }
 588         else {
 589                 $all = '';
 590         }
 591
 592         if ($all) {
 593                 $return[2] = $month;
 594                 $return[3] = $year;
 595                 $return[4] = $all;
 596         }
 597         else {
 598                 my $msg = errmsg("Can't figure out credit card expiration.");
 599                 $Vend::Session->{errors}{mv_credit_card_valid} = $msg;
 600                 push @return, $msg;
 601                 return @return;
 602         }
 603
 604         if(! valid_exp_date($all) ) {
 605                 my $msg = errmsg("Card is expired.");
 606                 $Vend::Session->{errors}{mv_credit_card_valid} = $msg;
 607                 push @return, $msg;
 608                 return @return;
 609         }
 610
 611         unless ($num) {
 612                 my $msg = errmsg("Missing credit card number");
 613                 $Vend::Session->{errors}{mv_credit_card_valid} = $msg;
 614                 push @return, $msg;
 615                 return @return;
 616         }
 617
 618         $type = guess_cc_type($num) unless $type;
 619
 620         if ($type and $opt->{accepted} and $opt->{accepted} !~ /\b$type\b/i) {
 621                 my $msg = errmsg("Sorry, we don't accept credit card type '%s'.", $type);
 622                 $Vend::Session->{errors}{mv_credit_card_valid} = $msg;
 623                 push @return, $msg;
 624                 return @return;
 625         }
 626         elsif ($type) {
 627                 $return[5] = $type;
 628         }
 629         elsif(! $opt->{any}) {
 630                 my $msg = errmsg("Can't figure out credit card type from number.");
 631                 $Vend::Session->{errors}{mv_credit_card_valid} = $msg;
 632                 push @return, $msg;
 633                 return @return;
 634         }
 635
 636         unless ($valid = luhn($num) || $force ) {
 637                 my $msg = errmsg("Credit card number fails LUHN-10 check.");
 638                 $Vend::Session->{errors}{mv_credit_card_valid} = $msg;
 639                 push @return, $msg;
 640                 return @return;
 641         }
 642
 643         $return[0] = $valid;
 644
 645         my $check_string = $num;
 646         $check_string =~ s/(\d\d).*(\d\d\d\d)$/$1**$2/;
 647
 648         my $encrypt_string = $separate ? $num :
 649                 build_cc_info( [$num, $month, $year, $cvv2, $type] );
 650         $info = pgp_encrypt ($encrypt_string);
 651
 652         unless (defined $info) {
 653                 my $msg = errmsg("Credit card encryption failed: %s", $! );
 654                 $Vend::Session->{errors}{mv_credit_card_valid} = $msg;
 655                 push @return, $msg;
 656                 $return[0] = 0;
 657                 return @return;
 658         }
 659         $return[1] = $info;
 660         $return[6] = $check_string;
 661
 662         return @return;
 663
 664 }
 665
 666 sub onfly {
 667         my ($code, $qty, $opt) = @_;
 668         my $item_text;
 669         if (ref $opt) {
 670                 $item_text = $opt->{text} || '';
 671         }
 672         else {
 673                 $item_text = $opt;
 674                 $opt = {};
 675         }
 676
 677 #       return create_onfly() if $opt->{create};
 678
 679         my $joiner              = $::Variable->{MV_ONFLY_JOINER} || '|';
 680         my $split_fields= $::Variable->{MV_ONFLY_FIELDS} || undef;
 681
 682         $item_text =~ s/\s+$//;
 683         $item_text =~ s/^\s+//;
 684         my @parms;
 685         my @fields;
 686         $joiner = quotemeta $joiner;
 687         @parms = split /$joiner|\0/, $item_text;
 688         my ($k, $v);
 689         my $item = {};
 690         if(defined $split_fields) {
 691                 @fields = split /[,\s]+/, $split_fields;
 692                 @{$item}{@fields} = @parms;
 693         }
 694         else {
 695                 for(@parms) {
 696                         ($k, $v)  = split /=/, $_;
 697                         $item->{$k} = $v;
 698                 }
 699         }
 700         $item->{mv_price} = $item->{price}
 701                 if ! $item->{mv_price};
 702         $item->{code}     = $code       if ! $item->{code};
 703         $item->{quantity} = $qty        if ! $item->{quantity};
 704         return $item;
 705 }
 706
 707 # Email the processed order. This is a legacy routine, not normally used
 708 # any more. Order email is normally sent via Route.
 709 sub mail_order {
 710         my ($email, $order_no) = @_;
 711         $email = $Vend::Cfg->{MailOrderTo} unless $email;
 712         my($body, $ok);
 713         my($subject);
 714 # LEGACY
 715         if ($::Values->{mv_order_report}) {
 716                 unless( allowed_file($::Values->{mv_order_report}) ) {
 717                         log_file_violation ($::Values->{mv_order_report}, 'mail_order');
 718                         return undef;
 719                 }
 720                 $body = readin($::Values->{mv_order_report})
 721         }
 722 # END LEGACY
 723         $body = readfile($Vend::Cfg->{OrderReport})
 724                 if ! $body;
 725         unless (defined $body) {
 726                 ::logError(
 727                         q{Cannot find order report in:
 728
 729                         OrderReport=%s
 730                         mv_order_report=%s
 731
 732 trying one more time. Fix this.},
 733                                 $Vend::Cfg->{OrderReport},
 734                                 $::Values->{mv_order_report},
 735                         );
 736                 unless( allowed_file($Vend::Cfg->{OrderReport}) ) {
 737                         log_file_violation($Vend::Cfg->{OrderReport}, 'mail_order');
 738                         return undef;
 739                 }
 740                 $body = readin($Vend::Cfg->{OrderReport});
 741                 return undef if ! $body;
 742         }
 743         return undef unless defined $body;
 744
 745         $order_no = update_order_number() unless $order_no;
 746
 747         $body = interpolate_html($body);
 748
 749         $body = pgp_encrypt($body) if $Vend::Cfg->{PGP};
 750
 751         track_order($order_no, $body);
 752
 753         $subject = $::Values->{mv_order_subject} || "ORDER %n";
 754
 755         if(defined $order_no) {
 756                 $subject =~ s/%n/$order_no/;
 757         }
 758         else { $subject =~ s/\s*%n\s*//g; }
 759
 760         $ok = send_mail($email, $subject, $body);
 761         return $ok;
 762 }
 763
 764 sub pgp_encrypt {
 765         my($body, $key, $cmd) = @_;
 766 #::logDebug("called pgp_encrypt key=$key cmd=$cmd");
 767         $cmd = $Vend::Cfg->{EncryptProgram} unless $cmd;
 768         $key = $Vend::Cfg->{EncryptKey}     unless $key;
 769 #::logDebug("pgp_encrypt using key=$key cmd=$cmd");
 770
 771         $key =~ s/,/ /g;        # turn commas to spaces
 772         $key =~ s/^\s+//;       # strip leading spaces
 773         $key =~ s/\s+$//;       # strip trailing spaces
 774         $key =~ s/\s+/ /g;      # convert multiple spaces to single spaces
 775
 776         my @keys = split /\s/, $key;
 777
 778         my $keyparam;
 779
 780         if("\L$cmd" eq 'none') {
 781                 return ::errmsg("NEED ENCRYPTION ENABLED.");
 782         }
 783         elsif(! $key) {
 784                 return ::errmsg("NEED ENCRYPTION KEY POINTER.");
 785         }
 786         elsif($cmd =~ m{^(?:/\S+/)?\bgpg$}) {
 787                 $cmd .= " --batch --always-trust -e -a ";
 788                 $keyparam = ' -r ';
 789         }
 790         elsif($cmd =~ m{^(?:/\S+/)?pgpe$}) {
 791                 $cmd .= " -fat ";
 792                 $keyparam = ' -r ';
 793         }
 794         elsif($cmd =~ m{^(?:/\S+/)?\bpgp$}) {
 795                 $cmd .= " -fat - ";
 796                 $keyparam = ' ';
 797         }
 798
 799         if($cmd =~ /[;|]/) {
 800                 die ::errmsg("Illegal character in encryption command: %s", $cmd);
 801         }
 802
 803
 804         $cmd =~ s/%%/:~PERCENT~:/g;
 805
 806         foreach my $thiskey (@keys) {
 807                 $thiskey =~ s/'/\\'/g;
 808                 $cmd .= "$keyparam '$thiskey' ";
 809         }
 810         $cmd =~ s/:~PERCENT~:/%/g;
 811
 812 #::logDebug("after  pgp_encrypt key=$key cmd=$cmd");
 813
 814         my $fpre = $Vend::Cfg->{ScratchDir} . "/pgp.$Vend::Session->{id}.$$";
 815         $cmd .= " >$fpre.out";
 816         $cmd .= " 2>$fpre.err" unless $cmd =~ /2>/;
 817         open(PGP, "|$cmd")
 818                         or die "Couldn't fork: $!";
 819         print PGP $body;
 820         close PGP;
 821
 822         if($?) {
 823                 my $errno = $?;
 824                 my $status = $errno;
 825                 if($status > 255) {
 826                         $status = $status >> 8;
 827                         $! = $status;
 828                 }
 829                 logError("PGP failed with error level %s, status %s: $!", $?, $status);
 830                 if($status) {
 831                         logError("PGP hard failure, command that failed: %s", $cmd);
 832                         return;
 833                 }
 834         }
 835         $body = readfile("$fpre.out");
 836         unlink "$fpre.out";
 837         unlink "$fpre.err";
 838         return $body;
 839 }
 840
 841 sub do_check {
 842                 local($_) = shift;
 843                 my $ref = \%CGI::values;
 844                 my $vref = shift || $::Values;
 845
 846                 my $conditional_update;
 847                 my $parameter = $_;
 848                 my($var, $val, $m, $message);
 849                 if (/^&/) {
 850                         ($var,$val) = split /[\s=]+/, $parameter, 2;
 851                 }
 852                 elsif ($parameter =~ /(\w+)[\s=]+(.*)/) {
 853                         my $k = $1;
 854                         my $v = $2;
 855                         $conditional_update = $Update;
 856                         $m = $v =~ s/\s+(.*)// ? $1 : undef;
 857                         ($var,$val) =
 858                                 ('&format',
 859                                   $v . ' ' . $k  . ' ' .  $vref->{$k}
 860                                   );
 861                 }
 862                 else {
 863                         logError("Unknown order check '%s' in profile %s", $parameter, $Profile);
 864                         return undef;
 865                 }
 866                 $val =~ s/&#(\d+);/chr($1)/ge;
 867
 868                 if ($Parse{$var}) {
 869                         ## $vref added for chained checks only
 870                         ($val, $var, $message) = $Parse{$var}->($ref, $val, $m, $vref);
 871                 }
 872                 else {
 873                         logError( "Unknown order check parameter in profile %s: %s=%s",
 874                                         $Profile,
 875                                         $var,
 876                                         $val,
 877                                         );
 878                         return undef;
 879                 }
 880 #::logDebug("&Vend::Order::do_check returning val=$val, var=$var, message=$message");
 881                 if($conditional_update and $val) {
 882                         ::update_values($var);
 883                 }
 884                 return ($val, $var, $message);
 885 }
 886
 887 sub check_order {
 888         my ($profiles, $vref, $individual) = @_;
 889         reset_order_vars();
 890         my $status;
 891         $Vend::Session->{errors} = {}
 892                 unless ref $Vend::Session->{errors} eq 'HASH';
 893
 894         ## Must have some security on mv_individual_profile because data
 895         ## lookups can be done via filter and/or unique
 896         if($individual and ! delete($::Scratch->{mv_individual_profile})) {
 897                 ::logError("Individual profile supplied without scratch authorization");
 898                 undef $individual;
 899         }
 900
 901 #::logDebug("nextpage=$CGI::values{mv_nextpage}");
 902         for my $profile (split /\0+/, $profiles) {
 903
 904                 $status = check_order_each($profile, $vref, $individual);
 905
 906                 # only do the individual checks once
 907                 undef $individual;
 908
 909                 my $np = $CGI::values{mv_nextpage};
 910                 if ($status) {
 911                         if($Success_page) {
 912                                 $np = $CGI::values{mv_nextpage} = $Success_page;
 913                         }
 914                         elsif ($CGI::values{mv_success_href}) {
 915                                 $np = $CGI::values{mv_nextpage} = $CGI::values{mv_success_href};
 916                         }
 917
 918                         my $f = $CGI::values{mv_success_form};
 919
 920                         if($CGI::values{mv_success_zero}) {
 921                                 %CGI::values = ();
 922                                 $CGI::values{mv_nextpage} ||= $np;
 923                         }
 924
 925                         if($f) {
 926                                 my $r = Vend::Util::scalar_to_hash($f);
 927                                 while (my ($k, $v) = each %$r) {
 928                                         $CGI::values{$k} = $v;
 929                                 }
 930                         }
 931                 }
 932                 else {
 933 #::logDebug("Got to status=$status on profile=$profile");
 934                         if($Fail_page) {
 935                                 $np = $CGI::values{mv_nextpage} = $Fail_page;
 936                         }
 937                         elsif ($CGI::values{mv_fail_href}) {
 938                                 $np = $CGI::values{mv_nextpage} = $CGI::values{mv_fail_href};
 939                         }
 940
 941                         my $f = $CGI::values{mv_fail_form};
 942
 943                         if($CGI::values{mv_fail_zero}) {
 944                                 %CGI::values = ();
 945                                 $CGI::values{mv_nextpage} ||= $np;
 946                         }
 947
 948                         if($f) {
 949                                 my $r = Vend::Util::scalar_to_hash($f);
 950                                 while (my ($k, $v) = each %$r) {
 951                                         $CGI::values{$k} = $v;
 952                                 }
 953                         }
 954                 }
 955
 956                 if ($Final and ! scalar @{$Vend::Items}) {
 957                         $status = 0;
 958                         $::Values->{"mv_error_items"}           =
 959                                 $Vend::Session->{errors}{items} =
 960                                         errmsg(
 961                                                 "You might want to order something! No items in cart.",
 962                                         );
 963                 }
 964 #::logDebug("FINISH checking profile $profile: Fatal=$Fatal Final=$Final Status=$status");
 965
 966                 # first profile to fail prevents all other profiles from running
 967                 last unless $status;
 968
 969         }
 970
 971         my $errors = join "\n", @Errors;
 972 #::logDebug("Errors after checking profile(s):\n$errors") if $errors;
 973         $errors = '' unless defined $errors and ! $Success;
 974 #::logDebug("status=$status nextpage=$CGI::values{mv_nextpage}");
 975         return ($status, $Final, $errors);
 976 }
 977
 978 sub check_order_each {
 979         my ($profile, $vref, $individual) = @_;
 980         my $params;
 981         $Profile = $profile;
 982         if(defined $Vend::Cfg->{OrderProfileName}->{$profile}) {
 983                 $profile = $Vend::Cfg->{OrderProfileName}->{$profile};
 984                 $params = $Vend::Cfg->{OrderProfile}->[$profile];
 985         }
 986         elsif($profile =~ /^\d+$/) {
 987                 $params = $Vend::Cfg->{OrderProfile}->[$profile];
 988         }
 989         elsif(defined $::Scratch->{$profile}) {
 990                 $params = $::Scratch->{$profile};
 991         }
 992         else {
 993                 ::logError("Order profile %s not found", $profile);
 994                 return undef;
 995         }
 996         return undef unless $params;
 997
 998         $params = interpolate_html($params);
 999         $params =~ s/\\\n//g;
1000
1001         $And = 1;
1002         $Fatal = $Final = 0;
1003
1004         my($var,$val,$message);
1005         my $status = 1;
1006         my(@param) = split /[\r\n]+/, $params;
1007
1008         ## Find marker for individual insertion
1009         if($individual) {
1010                 my $mark;
1011                 my $i = -1;
1012                 for(@param) {
1013                         $i++;
1014                         next unless /^\s*\&fatal\s*=\s*(.*)/i and is_yes($1);
1015                         $mark = $i;
1016                         last;
1017                 }
1018                 if(! defined  $mark) {
1019                         $i = -1;
1020                         for(@param) {
1021                                 $i++;
1022                                 next unless /^\s*\&update\s*=\s*(.*)/i and is_yes($1);
1023                                 $mark = $i + 1;
1024                                 last;
1025                         }
1026                 }
1027                 $mark = 0 unless defined $mark;
1028                 my @newparams = split /\0/, $individual;
1029                 splice(@param, $mark, 0, @newparams);
1030         }
1031
1032 #::logDebug("Total profile:\n" . join ("\n", @param));
1033         my $m;
1034         my $join;
1035         my $here;
1036         my $last_one = 1;
1037
1038         for(@param) {
1039                 if(/^$here$/) {
1040                         $_ = $join;
1041                         undef $here;
1042                         undef $join;
1043                 }
1044                 ($join .= "$_\n", next) if $here;
1045                 if($join) {
1046                         $_ = "$join$_";
1047                         undef $join;
1048                 }
1049                 if(s/<<(\w+);?\s*$//) {
1050                         $here = $1;
1051                         $join = "$_\n";
1052                         next;
1053                 }
1054                 next unless /\S/;
1055                 next if /^\s*#/;
1056                 if(s/\\$//) {
1057                         $join = $_;
1058                         next;
1059                 }
1060                 s/^\s+//;
1061                 s/\s+$//;
1062                 ($val, $var, $message) = do_check($_, $vref);
1063
1064                 # no actual check on this line, skip to next
1065                 next if /^&(?:and|or)\s*$/i;
1066
1067                 if(defined $And) {
1068                         if($And) {
1069                                 $val = ($last_one && $val);
1070                         }
1071                         else {
1072                                 $val = ($last_one || $val);
1073                         }
1074                         undef $And;
1075                 }
1076                 $last_one = $val;
1077                 $status = 0 unless $val;
1078                 if ($var) {
1079                         if ($val) {
1080                                 $::Values->{"mv_status_$var"} = $message
1081                                         if defined $message and $message;
1082                                 delete $Vend::Session->{errors}{$var};
1083                                 delete $::Values->{"mv_error_$var"};
1084                         }
1085                         else {
1086 # LEGACY
1087                                 $::Values->{"mv_error_$var"} = $message;
1088 # END LEGACY
1089                                 if( $No_error ) {
1090                                         # do nothing
1091                                 }
1092                                 elsif( $Vend::Session->{errors}{$var} ) {
1093                                         if ($message and $Vend::Session->{errors}{$var} !~ /\Q$message/) {
1094                                                 $Vend::Session->{errors}{$var} = errmsg(
1095                                                         '%s and %s',
1096                                                         $Vend::Session->{errors}{$var},
1097                                                         $message
1098                                                 );
1099                                         }
1100                                 }
1101                                 else {
1102                                         $Vend::Session->{errors}{$var} = $message ||
1103                                                 errmsg('%s: failed check', $var);
1104                                 }
1105                                 push @Errors, "$var: $message";
1106                         }
1107                 }
1108                 if (defined $Success) {
1109                         $status = $Success;
1110                         last;
1111                 }
1112                 last if $Fatal && ! $status;
1113         }
1114         return $status;
1115 }
1116
1117 use vars qw/ %state_template %state_error %zip_routine %zip_error /;
1118 $state_error{US} = "'%s' not a two-letter state code";
1119 $state_error{CA} = "'%s' not a two-letter province code";
1120 $state_template{US} = <<EOF;
1121 | AL AK AZ AR CA CO CT DE FL GA HI ID IL IN IA KS KY LA ME MD MA MI MN MS MO |
1122 | MT NE NV NH NJ NM NY NC ND OH OK OR PA RI SC SD TN TX UT VT VA WA WV WI WY |
1123 | PR DC AA AE GU VI AS MP FM MH PW AP FP FPO APO |
1124 EOF
1125
1126 # NF = Newfoundland is deprecated and will be removed at some point;
1127 # use NL instead
1128 $state_template{CA} = <<EOF;
1129 | AB BC MB NB NF NL NS NT NU ON PE QC SK YT YK |
1130 EOF
1131
1132 $zip_error{US} = "'%s' not a US zip code";
1133 $zip_routine{US} = sub { $_[0] =~ /^\s*\d\d\d\d\d(?:-?\d\d\d\d)?\s*$/ };
1134
1135 $zip_error{CA} = "'%s' not a Canadian postal code";
1136 $zip_routine{CA} = sub {
1137         my $val = shift;
1138         return undef unless defined $val;
1139         $val =~ s/[_\W]+//g;
1140         $val =~ /^[ABCEGHJKLMNPRSTVXYabceghjklmnprstvxy]\d[A-Za-z]\d[A-Za-z]\d$/;
1141 };
1142
1143 sub _state_province {
1144         my($ref,$var,$val) = @_;
1145         my $error;
1146         if(length($val) != 2) {
1147                 $error = 1;
1148         }
1149         else {
1150                 my $pval        = $::Variable->{MV_VALID_PROVINCE}
1151                                         ? " $::Variable->{MV_VALID_PROVINCE} "
1152                                         : $state_template{CA};
1153                 my $sval        = $::Variable->{MV_VALID_STATE}
1154                                         ? " $::Variable->{MV_VALID_STATE} "
1155                                         : $state_template{US};
1156                 $error = 1
1157                         unless  $sval =~ /\s$val\s/i or $pval =~ /\s$val\s/i ;
1158         }
1159         if($error) {
1160                 return (undef, $var,
1161                         errmsg( "'%s' not a two-letter state or province code", $val )
1162                 );
1163         }
1164         return (1, $var, '');
1165 }
1166
1167 sub _state {
1168         my($ref,$var,$val) = @_;
1169         my $sval        = $::Variable->{MV_VALID_STATE}
1170                                 ? " $::Variable->{MV_VALID_STATE} "
1171                                 : $state_template{US};
1172
1173         if( $val =~ /\S/ and $sval =~ /\s$val\s/i ) {
1174                 return (1, $var, '');
1175         }
1176         else {
1177                 return (undef, $var,
1178                         errmsg( $state_error{US}, $val )
1179                 );
1180         }
1181 }
1182
1183 sub _province {
1184         my($ref,$var,$val) = @_;
1185         my $pval        = $::Variable->{MV_VALID_PROVINCE}
1186                                 ? " $::Variable->{MV_VALID_PROVINCE} "
1187                                 : $state_template{CA};
1188         if( $val =~ /\S/ and $pval =~ /\s$val\s/i) {
1189                 return (1, $var, '');
1190         }
1191         else {
1192                 return (undef, $var,
1193                         errmsg( $state_error{CA}, $val )
1194                 );
1195         }
1196 }
1197
1198 sub _get_cval {
1199         my ($ref, $var) = @_;
1200         my $cfield = $::Variable->{MV_COUNTRY_FIELD} || 'country';
1201         my $cval = $ref->{$cfield} || $::Values->{$cfield};
1202
1203         if($var =~ /^b_/ and $ref->{"b_$cfield"} || $::Values->{"b_$cfield"}) {
1204                 $cval = $ref->{"b_$cfield"} || $::Values->{"b_$cfield"};
1205         }
1206         return $cval;
1207 }
1208
1209 sub _multizip {
1210         my($ref,$var,$val) = @_;
1211
1212         $val =~ s/^\s+//;
1213         my $error;
1214         my $cval = _get_cval($ref, $var);
1215
1216         if (my $sub = $zip_routine{$cval}) {
1217                 $sub->($val) or $error = 1;
1218         }
1219         elsif($::Variable->{MV_ZIP_REQUIRED}) {
1220             " $::Variable->{MV_ZIP_REQUIRED} " =~ /\s$cval\s/
1221                         and
1222                 length($val) < 4 and $error = 1;
1223         }
1224
1225         if($error) {
1226                 my $tpl = $zip_error{$cval} || "'%s' not a valid post code for country '%s'";
1227                 my $msg = errmsg( $tpl, $val, $cval );
1228                 return (undef, $var, $msg );
1229         }
1230         return (1, $var, '');
1231 }
1232
1233 sub _multistate {
1234         my($ref,$var,$val) = @_;
1235
1236         my $error;
1237         my $cval = _get_cval($ref, $var);
1238
1239         if(my $sval = $state_template{$cval}) {
1240                 $error = 1 unless $sval =~ /\s$val\s/;
1241         }
1242         elsif($::Variable->{MV_STATE_REQUIRED}) {
1243             " $::Variable->{MV_STATE_REQUIRED} " =~ /\s$cval\s/
1244                         and
1245                 length($val) < 2 and $error = 1;
1246         }
1247
1248         if($error) {
1249                 my $tpl = $state_error{$cval} || "'%s' not a valid state for country '%s'";
1250                 my $msg = errmsg( $tpl, $val, $cval );
1251                 return (undef, $var, $msg );
1252         }
1253         return (1, $var, '');
1254 }
1255
1256 sub _array {
1257         return undef unless defined $_[1];
1258         [split /\s*[,\0]\s*/, $_[1]]
1259 }
1260
1261 sub _yes {
1262         return( defined($_[2]) && ($_[2] =~ /^[yYtT1]/));
1263 }
1264
1265 sub _postcode {
1266         my($ref,$var,$val) = @_;
1267         ((_zip(@_))[0] or (_ca_postcode(@_))[0])
1268                 and return (1, $var, '');
1269         return (undef, $var, errmsg("'%s' not a US zip or Canadian postal code", $val));
1270 }
1271
1272 sub _ca_postcode {
1273         my($ref,$var,$val) = @_;
1274         $val =~ s/[_\W]+//g;
1275         defined $val
1276                 and
1277         $val =~ /^[ABCEGHJKLMNPRSTVXYabceghjklmnprstvxy]\d[A-Za-z]\d[A-Za-z]\d$/
1278                 and return (1, $var, '');
1279         return (undef, $var, errmsg("'%s' not a Canadian postal code", $val));
1280 }
1281
1282 sub _zip {
1283         my($ref,$var,$val) = @_;
1284         defined $val and $val =~ /^\s*\d{5}(?:-?\d{4})?\s*$/
1285                 and return (1, $var, '');
1286         return (undef, $var, errmsg("'%s' not a US zip code", $val));
1287 }
1288
1289 *_us_postcode = \&_zip;
1290
1291 sub _phone {
1292         my($ref,$var,$val) = @_;
1293         defined $val and $val =~ /\d{3}.*\d{3}/
1294                 and return (1, $var, '');
1295         return (undef, $var, errmsg("'%s' not a phone number", $val));
1296 }
1297
1298 sub _phone_us {
1299         my($ref, $var,$val) = @_;
1300         if($val and $val =~ /\d{3}.*?\d{4}/) {
1301                 return (1, $var, '');
1302         }
1303         else {
1304                 return (undef, $var, errmsg("'%s' not a US phone number", $val));
1305         }
1306 }
1307
1308 sub _phone_us_with_area {
1309         my($ref, $var,$val) = @_;
1310         if($val and $val =~ /\d{3}\D*\d{3}\D*\d{4}/) {
1311                 return (1, $var, '');
1312         }
1313         else {
1314                 return (undef, $var, errmsg("'%s' not a US phone number with area code", $val));
1315         }
1316 }
1317
1318 sub _phone_us_with_area_strict {
1319         my($ref, $var,$val) = @_;
1320         if($val and $val =~ /^\d{3}-\d{3}-\d{4}$/) {
1321                 return (1, $var, '');
1322         }
1323         else {
1324                 return (undef, $var,
1325                         errmsg("'%s' not a US phone number with area code (strict formatting)", $val)
1326                 );
1327         }
1328 }
1329
1330 sub _email {
1331         my($ref, $var, $val) = @_;
1332         if($val and $val =~ /[\040-\077\101-\176]+\@[-A-Za-z0-9.]+\.[A-Za-z]+/) {
1333                 return (1, $var, '');
1334         }
1335         else {
1336                 return (undef, $var,
1337                         errmsg( "'%s' not an email address", $val )
1338                 );
1339         }
1340 }
1341
1342 sub _mandatory {
1343         my($ref,$var,$val) = @_;
1344         return (1, $var, '')
1345                 if (defined $ref->{$var} and $ref->{$var} =~ /\S/);
1346         return (undef, $var, errmsg("blank"));
1347 }
1348
1349 sub _true {
1350         my($ref,$var,$val) = @_;
1351         return (1, $var, '') if is_yes($val);
1352         return (undef, $var, errmsg("false"));
1353 }
1354
1355 sub _false {
1356         my($ref,$var,$val) = @_;
1357         return (1, $var, '') if is_no($val);
1358         return (undef, $var, errmsg("true"));
1359 }
1360
1361 sub _defined {
1362         my($ref,$var,$val) = @_;
1363         return (1, $var, '')
1364                 if defined $::Values->{$var};
1365         return (undef, $var, errmsg("undefined"));
1366 }
1367
1368 sub _required {
1369         my($ref,$var,$val) = @_;
1370         return (1, $var, '')
1371                 if (defined $val and $val =~ /\S/);
1372         return (1, $var, '')
1373                 if (defined $ref->{$var} and $ref->{$var} =~ /\S/);
1374         return (undef, $var, errmsg("blank"));
1375 }
1376
1377 sub _luhn {
1378         my($ref, $var, $val) = @_;
1379
1380         return (1, $var, '') if luhn($val,2);
1381         return (undef, $var, errmsg('failed the LUHN-10 check'));
1382 }
1383
1384 sub counter_number {
1385         my $file = shift || $Vend::Cfg->{OrderCounter};
1386         my $sql = shift;
1387         my $start = shift || '000000';
1388         my $date = shift;
1389         return Vend::Interpolate::tag_counter(
1390                                                                                         $file,
1391                                                                                         {
1392                                                                                                 sql => $sql,
1393                                                                                                 start => $start,
1394                                                                                                 date => $date
1395                                                                                         }
1396                                                                                 );
1397 }
1398
1399 sub update_order_number {
1400
1401         my($c,$order_no);
1402
1403         if($Vend::Cfg->{OrderCounter}) {
1404                 $order_no = counter_number();
1405         }
1406         else {
1407                 $order_no = $Vend::SessionID . '.' . time;
1408         }
1409
1410         $::Values->{mv_order_number} = $order_no;
1411         $order_no;
1412 }
1413
1414 # Places the order report in the AsciiTrack file
1415 sub track_order {
1416         my ($order_no,$order_report) = @_;
1417
1418         if ($Vend::Cfg->{AsciiTrack}) {
1419                 logData ($Vend::Cfg->{AsciiTrack}, <<EndOOrder);
1420 ##### BEGIN ORDER $order_no #####
1421 $order_report
1422 ##### END ORDER $order_no #####
1423
1424 EndOOrder
1425         }
1426 }
1427
1428 sub route_profile_check {
1429         my (@routes) = @_;
1430         my $failed;
1431         my $errors = '';
1432         my ($status, $final, $missing);
1433         my $value_save = { %{$::Values} };
1434         local(%SIG);
1435         undef $SIG{__DIE__};
1436         foreach my $c (@routes) {
1437                 $Vend::Interpolate::Values = $::Values = { %$value_save };
1438                 eval {
1439                         my $route = $Vend::Cfg->{Route_repository}{$c}
1440                                 or do {
1441                                         # Change to ::logDebug because of dynamic routes
1442                                         ::logDebug("Non-existent order route %s, skipping.", $c);
1443                                         next;
1444                                 };
1445                         if($route->{profile}) {
1446                                 ($status, $final, $missing) = check_order($route->{profile});
1447                                 if(! $status) {
1448                                         die errmsg(
1449                                         "Route %s failed order profile %s. Final=%s. Errors:\n\n%s\n\n",
1450                                         $c,
1451                                         $route->{profile},
1452                                         $final,
1453                                         $missing,
1454                                         )
1455                                 }
1456                         }
1457                 };
1458                 if($@) {
1459                         $errors .= $@;
1460                         $failed = 1;
1461                         last if $final;
1462                 }
1463         }
1464 #::logDebug("check_only -- profile=$c status=$status final=$final failed=$failed errors=$errors missing=$missing");
1465         $Vend::Interpolate::Values = $::Values = { %$value_save };
1466         return (! $failed, $final, $errors);
1467 }
1468
1469 sub route_order {
1470         my ($route, $save_cart, $check_only) = @_;
1471         my $main = $Vend::Cfg->{Route};
1472         return unless $main;
1473         $route = 'default' unless $route;
1474
1475         my $cart = [ @$save_cart ];
1476
1477         my $save_mime = $::Instance->{MIME} || undef;
1478
1479         my $encrypt_program = $main->{encrypt_program};
1480
1481         my (@routes);
1482         my $shelf = { };
1483         my $item;
1484         foreach $item (@$cart) {
1485                 $shelf = { } unless $shelf;
1486                 next unless $item->{mv_order_route};
1487                 my(@r) = split /[\s\0,]+/, $item->{mv_order_route};
1488                 for(@r) {
1489                         next unless /\S/;
1490                         $shelf->{$_} = [] unless defined $shelf->{$_};
1491                         push @routes, $_;
1492                         push @{$shelf->{$_}}, $item;
1493                 }
1494         }
1495         my %seen;
1496
1497         @routes = grep !$seen{$_}++, @routes;
1498         my (@main) = grep /\S/, split /[\s\0,]+/, $route;
1499         for(@main) {
1500                 next unless $_;
1501                 $shelf->{$_} = [ @$cart ];
1502         }
1503
1504         # We empty @main so that we can push more routes on with cascade option
1505         push @routes, splice @main;
1506
1507         my ($c,@out);
1508         my $status;
1509         my $errors = '';
1510
1511         my @route_complete;
1512         my @route_failed;
1513         my @route_done;
1514         my $route_checked;
1515         $Vend::Session->{routes_run} = [];
1516
1517         # Careful! If you set it on one order and not on another,
1518         # you must delete in between.
1519
1520         my $no_increment = $check_only
1521                                                 || $main->{no_increment}
1522                                                 || $main->{counter_tid}
1523                                                 || $Vend::Session->{mv_order_number};
1524
1525         unless($no_increment) {
1526                 $::Values->{mv_order_number} = counter_number(
1527                                                                                         $main->{counter},
1528                                                                                         $main->{sql_counter},
1529                                                                                         $main->{first_order_number},
1530                                                                                         $main->{date_counter},
1531                                                                                 );
1532         }
1533
1534         my $value_save = { %{$::Values} };
1535
1536         # We aren't going to allow encrypt_program setting from database as
1537         # that is a security problem
1538         my %override_key = qw/
1539                 encrypt_program 1
1540         /;
1541
1542         # Settable by user to indicate failure
1543         delete $::Scratch->{mv_route_failed};
1544
1545         ## Allow setting of a master transaction route. This allows
1546         ## setting tables in transaction mode, then only committing
1547         ## once all routes have completed.
1548         my $master_transactions;
1549
1550         ROUTES: {
1551                 BUILD:
1552         foreach $c (@routes) {
1553                 my $route = $Vend::Cfg->{Route_repository}{$c} || {};
1554                 $main = $route if $route->{master};
1555                 my $old;
1556
1557                 ## Record the routes run
1558                 push @{$Vend::Session->{routes_run}}, $c;
1559
1560 #::logDebug("route $c is: " . ::uneval($route));
1561                 ##### OK, can put variables in DB all the time. It can be dynamic
1562                 ##### from the database if $main->{dynamic_routes} is set. ITL only if
1563                 ##### $main->{expandable}.
1564                 #####
1565                 ##### The encrypt_program key cannot be dynamic. You can set the
1566                 ##### key substition value instead.
1567
1568                 if($Vend::Cfg->{RouteDatabase} and $main->{dynamic_routes}) {
1569                         my $ref = tag_data( $Vend::Cfg->{RouteDatabase},
1570                                                                 undef,
1571                                                                 $c,
1572                                                                 { hash => 1 }
1573                                                                 );
1574 #::logDebug("Read dynamic route %s from database, got: %s", $c, $ref );
1575                         if($ref) {
1576                                 $old = $route;
1577                                 $route = $ref;
1578                                 for(keys %override_key) {
1579                                         $route->{$_} = $old->{$_};
1580                                 }
1581                         }
1582                 }
1583
1584                 if(! %$route) {
1585                         ::logError("Non-existent order routing %s, skipping.", $c);
1586                         next;
1587                 }
1588
1589                 # Tricky, tricky
1590                 if($route->{extended}) {
1591                         my $ref = get_option_hash($route->{extended});
1592                         if(ref $ref) {
1593                                 for(keys %$ref) {
1594 #::logDebug("setting extended $_ = $ref->{$_}");
1595                                         $route->{$_} = $ref->{$_}
1596                                                 unless $override_key{$_};
1597                                 }
1598                         }
1599                 }
1600
1601                 for(keys %$route) {
1602                         $route->{$_} =~ s/^\s*__([A-Z]\w+)__\s*$/$::Variable->{$1}/;
1603                         next unless $main->{expandable};
1604                         next if $override_key{$_};
1605                         next unless $route->{$_} =~ /\[/;
1606                         $route->{$_} = ::interpolate_html($route->{$_});
1607                 }
1608                 #####
1609                 #####
1610                 #####
1611
1612                 ## Make route available to subsidiary files
1613                 $Vend::Session->{current_route} = $route;
1614
1615                 # Compatibility
1616                 if($route->{cascade}) {
1617                         my @extra = grep /\S/, split /[\s,\0]+/, $route->{cascade};
1618                         for(@extra) {
1619                                 $shelf->{$_} = [ @$cart ];
1620                                 push @main, $_;
1621                         }
1622                 }
1623
1624                 if($Vend::Session->{mv_order_number}) {
1625                         $value_save->{mv_order_number} =
1626                                 $::Values->{mv_order_number} =
1627                                         $Vend::Session->{mv_order_number};
1628                 }
1629
1630                 $Vend::Interpolate::Values = $::Values = { %$value_save };
1631                 $::Values->{mv_current_route} = $c;
1632                 my $pre_encrypted;
1633                 my $credit_card_info;
1634
1635                 $Vend::Items = $shelf->{$c};
1636
1637                 Vend::Interpolate::flag( 'write', {}, $route->{write_tables})
1638                         if $route->{write_tables};
1639
1640                 Vend::Interpolate::flag( 'transactions', {}, $route->{transactions})
1641                         if $route->{transactions};
1642
1643         eval {
1644
1645           PROCESS: {
1646                 if(! $check_only and $route->{inline_profile}) {
1647                         my $status;
1648                         my $err;
1649                         ($status, undef, $err) = check_order($route->{inline_profile});
1650 #::logDebug("inline profile returned status=$status errors=$err");
1651                         die "$err\n" unless $status;
1652                 }
1653
1654                 if ($CGI::values{mv_credit_card_number}) {
1655                         $CGI::values{mv_credit_card_type} ||=
1656                                 guess_cc_type($CGI::values{mv_credit_card_number});
1657                         my %attrlist = map { uc($_) => $CGI::values{$_} } keys %CGI::values;
1658                         $::Values->{mv_credit_card_info} = build_cc_info(\%attrlist);
1659                 }
1660                 elsif ($::Values->{mv_credit_card_info}) {
1661                         $::Values->{mv_credit_card_info} =~ /BEGIN\s+[PG]+\s+MESSAGE/
1662                                 and $pre_encrypted = 1;
1663                 }
1664
1665                 if ($check_only and $route->{profile}) {
1666                         $route_checked = 1;
1667                         my ($status, $final, $missing) = check_order($route->{profile});
1668                         if(! $status) {
1669                                 die errmsg(
1670                                 "Route %s failed order profile %s. Final=%s. Errors:\n\n%s\n\n",
1671                                 $c,
1672                                 $route->{profile},
1673                                 $final,
1674                                 $missing,
1675                                 )
1676                         }
1677                 }
1678
1679                 last PROCESS if $check_only;
1680
1681                 if($route->{payment_mode}) {
1682                         my $ok;
1683                         $ok = Vend::Payment::charge($route->{payment_mode});
1684                         if (! $ok) {
1685                                 die errmsg("Failed online charge for routing %s: %s",
1686                                                                 $c,
1687                                                                 $Vend::Session->{mv_payment_error}
1688                                                         );
1689                         }
1690                         else {
1691                                 $Vend::Session->{route_payment_id} ||= {};
1692                                 $Vend::Session->{route_payment_id}{$c} = $Vend::Session->{payment_id};
1693                         }
1694                 }
1695                 if(  $route->{credit_card}
1696                                 and ! $pre_encrypted
1697                             and $::Values->{mv_credit_card_info}
1698                                 )
1699                 {
1700                         $::Values->{mv_credit_card_info} = pgp_encrypt(
1701                                                                 $::Values->{mv_credit_card_info},
1702                                                                 ($route->{pgp_cc_key} || $route->{pgp_key}),
1703                                                                 ($route->{encrypt_program} || $main->{encrypt_program} || $encrypt_program),
1704                                                         );
1705                 }
1706
1707                 if($route->{counter_tid}) {
1708                         ## This is designed to allow order number setting in
1709                         ## the report code file
1710                         $Vend::Session->{mv_transaction_id} = counter_number(
1711                                                                                                 $route->{counter_tid},
1712                                                                                                 $route->{sql_counter},
1713                                                                                                 $route->{first_order_number},
1714                                                                                                 $route->{date_counter},
1715                                                                                         );
1716                 }
1717                 elsif($Vend::Session->{mv_order_number}) {
1718                         $::Values->{mv_order_number} = $Vend::Session->{mv_order_number};
1719                 }
1720                 elsif(defined $route->{increment}) {
1721                         $::Values->{mv_order_number} = counter_number(
1722                                                                                                 $main->{counter},
1723                                                                                                 $main->{sql_counter},
1724                                                                                                 $main->{first_order_number},
1725                                                                                                 $main->{date_counter},
1726                                                                                         )
1727                                 if $route->{increment};
1728                 }
1729                 elsif($route->{counter}) {
1730                         $::Values->{mv_order_number} = counter_number(
1731                                                                                                 $route->{counter},
1732                                                                                                 $route->{sql_counter},
1733                                                                                                 $route->{first_order_number},
1734                                                                                                 $route->{date_counter},
1735                                                                                         );
1736                 }
1737
1738                 # Pick up transaction ID if already set
1739                 if($Vend::Session->{mv_transaction_id}) {
1740                         $::Values->{mv_transaction_id} = $Vend::Session->{mv_transaction_id};
1741                 }
1742
1743                 my $pagefile;
1744                 my $page;
1745                 if($route->{empty} and ! $route->{report}) {
1746                         $page = '';
1747                 }
1748                 else {
1749                         $pagefile = $route->{'report'} || $main->{'report'};
1750                         $page = readfile($pagefile);
1751                 }
1752                 unless (defined $page) {
1753                         my $msg = errmsg("No order report %s or %s found.",
1754                                                          $route->{'report'},
1755                                                          $main->{'report'});
1756                         ::logError("$msg\n");
1757                         die("$msg\n");
1758                 }
1759
1760                 my $use_mime;
1761                 undef $::Instance->{MIME};
1762                 if(not ($pre_encrypted || $route->{credit_card} || $route->{encrypt}) ) {
1763                     unless ($::Values->{mv_credit_card_info}
1764                             =~ s/^(\s*\w+\s+)(\d\d)[\d ]+(\d\d\d\d.*?)(?:\s+\d{3,4})?$/$1$2 NEED ENCRYPTION $3/) {
1765                         $::Values->{mv_credit_card_info} = 'NEED ENCRYPTION';
1766                     }
1767                 }
1768                 eval {
1769                         $page = interpolate_html($page) if $page;
1770                 };
1771                 if ($@) {
1772                         die "Error while interpolating page $pagefile:\n $@";
1773                 }
1774                 $use_mime   = $::Instance->{MIME} || undef;
1775                 $::Instance->{MIME} = $save_mime  || undef;
1776
1777                 if($route->{encrypt}) {
1778                         $page = pgp_encrypt($page,
1779                                                                 $route->{pgp_key},
1780                                                                 ($route->{encrypt_program} || $main->{encrypt_program} || $encrypt_program),
1781                                                                 );
1782                 }
1783                 my ($address, $reply, $to, $subject, $template);
1784                 if($route->{attach}) {
1785                         $Vend::Items->[0]{mv_order_report} = $page;
1786                 }
1787                 elsif ($route->{empty}) {
1788                         # Do nothing
1789                 }
1790                 elsif ($address = $route->{email}) {
1791                         $address = $::Values->{$address} if $address =~ /^\w+$/;
1792                         $subject = $route->{subject} || $::Values->{mv_order_subject} || 'ORDER %s';
1793                         $subject =~ s/%n/%s/;
1794                         $subject = sprintf "$subject", $::Values->{mv_order_number};
1795                         $reply   = $route->{reply} || $main->{reply};
1796                         $reply   = $::Values->{$reply} if $reply =~ /^\w+$/;
1797                         $to              = $route->{email};
1798                         my $ary = [$to, $subject, $page, $reply, $use_mime];
1799                         for (qw/from bcc cc/) {
1800                                 if ($route->{$_}) {
1801                                         push @$ary, ucfirst($_) . ": $route->{$_}";
1802                                 }
1803                         }
1804                         push @out, $ary;
1805                 }
1806                 else {
1807                         die "Empty order routing $c (and not explicitly empty).\nEither attach or email are required in the route setting.\n";
1808                 }
1809                 if ($route->{supplant}) {
1810                         track_order($::Values->{mv_order_number}, $page);
1811                 }
1812                 if ($route->{track}) {
1813                         my $fn = escape_chars($route->{track});
1814                         Vend::Util::writefile($fn, $page)
1815                                 or ::logError("route tracking error writing %s: %s", $fn, $!);
1816                         my $mode = $route->{track_mode} || '';
1817                         if ($mode =~ s/^0+//) {
1818                                 chmod oct($mode), $fn;
1819                         }
1820                         elsif ($mode) {
1821                                 chmod $mode, $fn;
1822                         }
1823                 }
1824                 if ($route->{individual_track}) {
1825                         my $fn = Vend::Util::catfile(
1826                                                         $route->{individual_track},
1827                                                         $::Values->{mv_order_number} .
1828                                                         $route->{individual_track_ext},
1829                                                 );
1830                         Vend::Util::writefile( $fn, $page,      )
1831                                 or ::logError("route tracking error writing $fn: $!");
1832                         my $mode = $route->{track_mode} || '';
1833                         if ($mode =~ s/^0+//) {
1834                                 chmod oct($mode), $fn;
1835                         }
1836                         elsif ($mode) {
1837                                 chmod $mode, $fn;
1838                         }
1839                 }
1840                 if($::Scratch->{mv_route_failed}) {
1841                         my $msg = delete $::Scratch->{mv_route_error}
1842                                         || ::errmsg('Route %s failed.', $c);
1843                         ::logError($msg);
1844                         die $msg;
1845                 }
1846           } # end PROCESS
1847         };
1848                 if($@) {
1849 #::logDebug("route failed: $c");
1850                         my $err = $@;
1851                         $errors .=  errmsg(
1852                                                         "Error during creation of order routing %s:\n%s",
1853                                                         $c,
1854                                                         $err,
1855                                                 );
1856                         if ($route->{error_ok}) {
1857                                 push @route_complete, $c;
1858                                 next BUILD;
1859                         }
1860                         next BUILD if $route->{continue};
1861                         push @route_failed, $c;
1862                         @out = ();
1863                         @route_done = @route_complete;
1864                         @route_complete = ();
1865                         last ROUTES;
1866                 }
1867
1868                 push @route_complete, $c;
1869
1870         } #BUILD
1871
1872         if(@main and ! @route_failed) {
1873                 @routes = splice @main;
1874                 redo ROUTES;
1875         }
1876
1877   } #ROUTES
1878
1879         my $msg;
1880
1881         if($check_only) {
1882                 $Vend::Interpolate::Values = $::Values = $value_save;
1883                 $Vend::Items = $save_cart;
1884                 if(@route_failed) {
1885                         return (0, 0, $errors);
1886                 }
1887                 elsif($route_checked) {
1888                         return (1, 1, '');
1889                 }
1890                 else {
1891                         return (1, undef, '');
1892                 }
1893         }
1894
1895         foreach $msg (@out) {
1896                 eval {
1897                         send_mail(@$msg);
1898                 };
1899                 if($@) {
1900                         my $err = $@;
1901                         $errors .=  errmsg(
1902                                                         "Error sending mail to %s:\n%s",
1903                                                         $msg->[0],
1904                                                         $err,
1905                                                 );
1906                         $status = 0;
1907                         next;
1908                 }
1909                 else {
1910                         $status = 1;
1911                 }
1912         }
1913
1914         $::Instance->{MIME} = $save_mime  || undef;
1915         $Vend::Interpolate::Values = $::Values = $value_save;
1916         $Vend::Items = $save_cart;
1917
1918         for(@route_failed) {
1919                 my $route = $Vend::Cfg->{Route_repository}{$_};
1920
1921 #::logDebug("checking route $_ for transactions");
1922                 ## We only want to roll back the master at the end
1923                 next if $route->{master};
1924
1925
1926                 if($route->{transactions}) {
1927 #::logDebug("rolling back route $_");
1928                         Vend::Interpolate::flag( 'rollback', {}, $route->{transactions})
1929                 }
1930                 next unless $route->{rollback};
1931                 Vend::Interpolate::tag_perl(
1932                                         $route->{rollback_tables},
1933                                         {},
1934                                         $route->{rollback}
1935                 );
1936         }
1937
1938         for(@route_complete) {
1939                 my $route = $Vend::Cfg->{Route_repository}{$_};
1940 #::logDebug("checking route $_ for transactions");
1941                 ## We only want to commit the master if nothing failed
1942                 next if $route->{master};
1943
1944                 if($route->{transactions}) {
1945 #::logDebug("committing route $_");
1946                         Vend::Interpolate::flag( 'commit', {}, $route->{transactions})
1947                 }
1948                 next unless $route->{commit};
1949                 Vend::Interpolate::tag_perl(
1950                                         $route->{commit_tables},
1951                                         {},
1952                                         $route->{commit}
1953                 );
1954         }
1955
1956         if(! $errors) {
1957                 delete $Vend::Session->{order_error};
1958 #::logDebug("no errors, commiting main route");
1959                 if($main->{transactions}) {
1960                         Vend::Interpolate::flag( 'commit', {}, $main->{transactions})
1961                 }
1962                 if($main->{commit}) {
1963                         Vend::Interpolate::tag_perl(
1964                                                 $main->{commit_tables},
1965                                                 {},
1966                                                 $main->{commit}
1967                         );
1968                 }
1969         }
1970         else {
1971                 if($main->{transactions}) {
1972 #::logDebug("errors, rolling back main route");
1973                         Vend::Interpolate::flag( 'rollback', {}, $main->{transactions})
1974                 }
1975                 if($main->{rollback}) {
1976                         Vend::Interpolate::tag_perl(
1977                                                 $main->{rollback_tables},
1978                                                 {},
1979                                                 $main->{rollback}
1980                         );
1981                 }
1982         $Vend::Session->{order_error} = $errors;
1983         ::logError("ERRORS on ORDER %s:\n%s", $::Values->{mv_order_number}, $errors);
1984
1985                 if ($main->{errors_to}) {
1986                         send_mail(
1987                                 $main->{errors_to},
1988                                 errmsg("ERRORS on ORDER %s", $::Values->{mv_order_number}),
1989                                 $errors
1990                                 );
1991                 }
1992         }
1993
1994         # Get rid of this puppy
1995         $::Values->{mv_credit_card_info}
1996                         =~ s/^(\s*\w+\s+)(\d\d)[\d ]+(\d\d\d\d)/$1$2 NEED ENCRYPTION $3/;
1997
1998         # Clear these, we are done with them
1999         delete $Vend::Session->{mv_transaction_id};
2000         delete $Vend::Session->{current_route};
2001
2002         # If we give a defined value, the regular mail_order routine will not
2003         # be called
2004 #::logDebug("route errors=$errors supplant=$main->{supplant}");
2005         if($main->{supplant}) {
2006                 return ($status, $::Values->{mv_order_number}, $main);
2007         }
2008         return (undef, $::Values->{mv_order_number}, $main);
2009 }
2010
2011 ## DO ORDER
2012
2013 # Order an item
2014 sub do_order {
2015     my($path) = @_;
2016         my $code        = $CGI::values{mv_arg};
2017 #::logDebug("do_order: path=$path");
2018         my $cart;
2019         my $page;
2020 # LEGACY
2021         if($path =~ s:/(.*)::) {
2022                 $cart = $1;
2023                 if($cart =~ s:/(.*)::) {
2024                         $page = $1;
2025                 }
2026         }
2027 # END LEGACY
2028         if(defined $CGI::values{mv_pc} and $CGI::values{mv_pc} =~ /_(\d+)/) {
2029                 $CGI::values{mv_order_quantity} = $1;
2030         }
2031         $CGI::values{mv_cartname} = $cart if $cart;
2032         $CGI::values{mv_nextpage} = $page if $page;
2033 # LEGACY
2034         $CGI::values{mv_nextpage} = $CGI::values{mv_orderpage}
2035                                                                 || find_special_page('order')
2036                 if ! $CGI::values{mv_nextpage};
2037 # END LEGACY
2038         add_items($code);
2039     return 1;
2040 }
2041
2042 my @Scan_modifiers = qw/
2043                 mv_ad
2044                 mv_an
2045                 mv_bd
2046                 mv_bd
2047 /;
2048
2049 # Returns undef if interaction error
2050 sub update_quantity {
2051     return 1 unless defined  $CGI::values{"quantity0"}
2052                 || $CGI::values{mv_quantity_update};
2053         my ($h, $i, $quantity, $modifier, $cart, $cartname, %altered_items, %old_items);
2054
2055         if ($CGI::values{mv_cartname}) {
2056                 $cart = $::Carts->{$cartname = $CGI::values{mv_cartname}} ||= [];
2057         }
2058         else {
2059                 $cart = $Vend::Items;
2060                 $cartname = $Vend::CurrentCart;
2061         }
2062
2063         my ($raise_event, $quantity_raise_event)
2064                 = @{$Vend::Cfg}{qw/CartTrigger CartTriggerQuantity/};
2065         $quantity_raise_event = $raise_event && $quantity_raise_event;
2066
2067         my @mods;
2068         @mods = @{$Vend::Cfg->{UseModifier}} if $Vend::Cfg->{UseModifier};
2069
2070 #::logDebug("adding modifiers");
2071         push(@mods, (grep $_ !~ /^mv_/, split /\0/, $CGI::values{mv_item_option}))
2072                 if defined $CGI::values{mv_item_option};
2073
2074         my %seen;
2075         push @mods, grep defined $CGI::values{"${_}0"}, @Scan_modifiers;
2076         @mods = grep ! $seen{$_}++, @mods;
2077
2078         foreach $h (@mods) {
2079                 delete @{$::Values}{grep /^$h\d+$/, keys %$::Values};
2080                 foreach $i (0 .. $#$cart) {
2081 #::logDebug("updating line $i modifiers: " . ::uneval($cart->[$i]));
2082 #::logDebug(qq{CGI value=$CGI::values{"$h$i"}});
2083                         next if
2084                                 !   defined $CGI::values{"$h$i"}
2085                                 and defined $cart->[$i]{$h};
2086                         $old_items{$i} ||= { %{$cart->[$i]} } if $raise_event;
2087                         $modifier = $CGI::values{"$h$i"}
2088                                           || (defined $cart->[$i]{$h} ? '' : undef);
2089 #::logDebug("line $i modifier $h now $modifier");
2090                         if (defined($modifier)) {
2091                                 $modifier =~ s/\0+/\0/g;
2092                                 $modifier =~ s/\0$//;
2093                                 $modifier =~ s/^\0//;
2094                                 $modifier =~ s/\0/, /g;
2095                                 $altered_items{$i} = 1
2096                                         if $raise_event
2097                                         and $cart->[$i]->{$h} ne $modifier;
2098                                 $cart->[$i]->{$h} = $modifier;
2099                                 $::Values->{"$h$i"} = $modifier;
2100                                 delete $CGI::values{"$h$i"};
2101                         }
2102                 }
2103         }
2104
2105         foreach $i (0 .. $#$cart) {
2106 #::logDebug("updating line $i quantity: " . ::uneval($cart->[$i]));
2107                 my $line = $cart->[$i];
2108                 $line->{mv_ip} = $i;
2109         $quantity = $CGI::values{"quantity$i"};
2110         next unless defined $quantity;
2111                 my $do_update;
2112                 my $old_item = $old_items{$i} ||= { %$line } if $raise_event;
2113         if ($quantity =~ m/^\d*$/) {
2114                 $line->{'quantity'} = $quantity || 0;
2115                         $do_update = 1;
2116                         $altered_items{$i} = 1
2117                                 if $quantity_raise_event
2118                                 and $line->{quantity} != $old_item->{quantity};
2119         }
2120         elsif ($quantity =~ m/^[\d.]+$/
2121                                 and $Vend::Cfg->{FractionalItems} ) {
2122                 $line->{'quantity'} = $quantity;
2123                         $do_update = 1;
2124                         $altered_items{$i} = 1
2125                                 if $quantity_raise_event
2126                                 and $line->{quantity} != $old_item->{quantity};
2127         }
2128                 # This allows a last-positioned input of item quantity to
2129                 # remove the item
2130                 elsif ($quantity =~ s/.*\00$/0/) {
2131                         $CGI::values{"quantity$i"} = $quantity;
2132                         redo;
2133                 }
2134                 # This allows a multiple input of item quantity to
2135                 # pass -- FIRST ONE CONTROLS
2136                 elsif ($quantity =~ s/\0.*//) {
2137                         $CGI::values{"quantity$i"} = $quantity;
2138                         redo;
2139                 }
2140                 else {
2141                         my $item = $line->{'code'};
2142                         $line->{quantity} = int $line->{quantity};
2143                 $Vend::Session->{errors}{mv_order_quantity} =
2144                                 errmsg("'%s' for item %s is not numeric/integer", $quantity, $item);
2145         }
2146
2147                 if($do_update and my $oe = $Vend::Cfg->{OptionsAttribute}) {
2148                   eval {
2149                         my $loc = $Vend::Cfg->{Options_repository}{$line->{$oe}};
2150                         if($loc and $loc->{item_update_routine}) {
2151                                 no strict 'refs';
2152                                 my $sub = \&{"$loc->{item_update_routine}"};
2153                                 if(defined $sub) {
2154                                         $sub->($line, $loc);
2155                                 }
2156                         }
2157                   };
2158                   if($@) {
2159                         ::logError(
2160                                 "error during %s (option type %s) item_update_routine: %s",
2161                                 $line->{code},
2162                                 $line->{$oe},
2163                                 $@,
2164                         );
2165                   }
2166                 }
2167
2168         $::Values->{"quantity$i"} = delete $CGI::values{"quantity$i"};
2169                 SKUSET: {
2170                         my $sku;
2171                         my $found_option;
2172                         last SKUSET unless $sku = delete $CGI::values{"mv_sku$i"};
2173                         my @sku = split /\0/, $sku, -1;
2174                         for(@sku[1..$#sku]) {
2175                                 if (not length $_) {
2176                                 $_ = $::Variable->{MV_VARIANT_JOINER} || '0';
2177                                 next;
2178                                 }
2179                                 $found_option++;
2180                         }
2181
2182                         if(@sku > 1 and ! $found_option) {
2183                                 splice @sku, 1;
2184                         }
2185
2186                         $sku = join "-", @sku;
2187
2188                         my $ib;
2189                         unless($ib      = ::product_code_exists_tag($sku)) {
2190                                 push @{$Vend::Session->{warnings} ||= []},
2191                                         errmsg("Not a valid option combination: %s", $sku);
2192                                         last SKUSET;
2193                         }
2194
2195                         $line->{mv_ib} = $ib;
2196
2197                         if($sku ne $line->{code}) {
2198                                 if($line->{mv_mp}) {
2199                                         $line->{mv_sku} = $line->{code} = $sku;
2200                                 }
2201                                 elsif (! $line->{mv_sku}) {
2202                                         $line->{mv_sku} = $line->{code};
2203                                         $line->{code}   = $sku;
2204                                 }
2205                                 else {
2206                                         $line->{code}   = $sku;
2207                                 }
2208                                 $altered_items{$i} = 1 if $raise_event;
2209                         }
2210                 }
2211         }
2212
2213         Vend::Cart::trigger_update(
2214                         $cart,
2215                         $cart->[$_], # new item version
2216                         $old_items{$_}, # old item version
2217                         $cartname
2218                 ) for sort { $a <=> $b } keys %altered_items;
2219 #::logDebug("after update, cart is: " . ::uneval($cart));
2220
2221         # If the user has put in "0" for any quantity, delete that item
2222     # from the order list. Handles sub-items.
2223     Vend::Cart::toss_cart($cart, $CGI::values{mv_cartname});
2224
2225 #::logDebug("after toss, cart is: " . ::uneval($cart));
2226
2227         1;
2228
2229 }
2230
2231 ## This routine loads AutoModifier values
2232 ## The $recalc parameter indicates it is a recalc load and not
2233 ## an initial load, so that you don't reload all parameters only ones
2234 ## that should change based on an option setting (different SKU)
2235
2236 sub auto_modifier {
2237         my ($item, $recalc) = @_;
2238         my $code = $item->{code};
2239         for my $mod (@{$Vend::Cfg->{AutoModifier}}) {
2240                 my $attr;
2241                 my ($table,$key,$foreign) = split /:+/, $mod, 3;
2242
2243                 if($table =~ s/^!\s*//) {
2244                         # This is an auto-recalculating attribute
2245                 }
2246                 elsif($recalc) {
2247                         # Don't want to reload non-auto-recalculating attributes
2248                         next;
2249                 }
2250
2251                 if($table =~ /=/) {
2252                         ($attr, $table) = split /\s*=\s*/, $table, 2;
2253                 }
2254
2255                 if(! $key and ! $foreign) {
2256                         $attr ||= $table;
2257                         $item->{$attr} = item_common($item, $table);
2258                         next;
2259                 }
2260
2261                 unless ($key) {
2262                         $key = $table;
2263                         $table = $item->{mv_ib};
2264                 }
2265
2266                 $attr ||= $key;
2267
2268
2269                 my $select = $foreign ? $item->{$foreign} : $code;
2270                 $select ||= $code;
2271
2272                 $item->{$attr} = ::tag_data($table, $key, $select);
2273         }
2274 }
2275
2276 sub add_items {
2277         my($items,$quantities) = @_;
2278
2279         $items = delete $CGI::values{mv_order_item} if ! defined $items;
2280         return unless $items;
2281
2282         my($code,$found,$item,$base,$quantity,$i,$j,$q);
2283         my(@items);
2284         my(@skus);
2285         my(@quantities);
2286         my(@bases);
2287         my(@lines);
2288         my(@fly);
2289         my($attr,%attr);
2290
2291         my $value;
2292         if ($value = delete $Vend::Session->{scratch}{mv_UseModifier}) {
2293                 $Vend::Cfg->{UseModifier} = [split /[\s\0,]+/, $value];
2294         }
2295
2296         ::update_quantity() if ! defined $CGI::values{mv_orderline};
2297
2298         my ($cart, $cartname);
2299         if ($cartname = $CGI::values{mv_cartname}) {
2300                 $cart = $::Carts->{$cartname} ||= [];
2301         }
2302         else {
2303                 $cart = $Vend::Items;
2304                 $cartname = $Vend::CurrentCart;
2305         }
2306
2307         my ($raise_event,$track_quantity)
2308                 = @{$Vend::Cfg}{qw/CartTrigger CartTriggerQuantity/};
2309         $raise_event = @$raise_event if ref $raise_event eq 'ARRAY';
2310
2311         @items      = split /\0/, ($items);
2312         @quantities = split /\0/, ($quantities || delete $CGI::values{mv_order_quantity} || '');
2313         @bases      = split /\0/, delete $CGI::values{mv_order_mv_ib}
2314                 if defined $CGI::values{mv_order_mv_ib};
2315         @lines      = split /\0/, delete $CGI::values{mv_orderline}
2316                 if defined $CGI::values{mv_orderline};
2317
2318         if($CGI::values{mv_order_fly} and $Vend::Cfg->{OnFly}) {
2319                 if(scalar @items == 1) {
2320                         @fly = $CGI::values{mv_order_fly};
2321                 }
2322                 else {
2323                         @fly = split /\0/, $CGI::values{mv_order_fly};
2324                 }
2325         }
2326
2327         if(defined $CGI::values{mv_item_option}) {
2328                 $Vend::Cfg->{UseModifier} = [] if ! $Vend::Cfg->{UseModifier};
2329                 my %seen;
2330                 my @mods = (grep $_ !~ /^mv_/, split /\0/, $CGI::values{mv_item_option});
2331                 @mods = grep ! $seen{$_}++, @mods;
2332                 push @{$Vend::Cfg->{UseModifier}}, @mods;
2333         }
2334
2335         if($CGI::values{mv_sku}) {
2336                 my @sku = split /\0/, $CGI::values{mv_sku};
2337                 for (@sku) {
2338                         $_ = $::Variable->{MV_VARIANT_JOINER} || '0' if ! length($_);
2339                 }
2340                 $items[0] = join '-', @sku;
2341                 my $sku_field = $Vend::Cfg->{Options_repository}{Matrix}->{sku} || 'sku';
2342                 $skus[0] = Vend::Data::product_field($sku_field, $items[0]);
2343         }
2344
2345         if ($Vend::Cfg->{UseModifier}) {
2346                 foreach $attr (@{$Vend::Cfg->{UseModifier} || []}) {
2347                         $attr{$attr} = [];
2348                         next unless defined $CGI::values{"mv_order_$attr"};
2349                         @{$attr{$attr}} = split /\0/, $CGI::values{"mv_order_$attr"};
2350                 }
2351         }
2352
2353         my ($group, $found_master, $mv_mi, $mv_si, $mv_mp, @group, @modular);
2354
2355         my $separate;
2356         if( $CGI::values{mv_order_modular} ) {
2357                 @modular = split /\0/, delete $CGI::values{mv_order_modular};
2358                 for( my $i = 0; $i < @modular; $i++ ) {
2359                    $attr{mv_mp}->[$i] = $modular[$i] if $modular[$i];
2360                 }
2361                 $separate = 1;
2362         }
2363         else {
2364                 $separate = defined $CGI::values{mv_separate_items}
2365                                         ? is_yes($CGI::values{mv_separate_items})
2366                                         : (
2367                                                 $Vend::Cfg->{SeparateItems} ||
2368                                                 (
2369                                                         defined $Vend::Session->{scratch}->{mv_separate_items}
2370                                                  && is_yes( $Vend::Session->{scratch}->{mv_separate_items} )
2371                                                  )
2372                                                 );
2373         }
2374
2375         @group   = split /\0/, (delete $CGI::values{mv_order_group} || '');
2376
2377         my $inc;
2378         for( my $i = 0; $i < @group; $i++ ) {
2379 #::logDebug("processing order group=$group[$i]");
2380                 if($group[$i]) {
2381                         $inc ||= time();
2382                         my $add = sprintf('%06d', ++$Vend::Session->{pageCount});
2383                         $attr{mv_mi}->[$i] = $inc . $add;
2384                 }
2385                 else {
2386                         $attr{mv_mi}->[$i] = 0;
2387                 }
2388         }
2389
2390         $j = 0;
2391         my $set;
2392         my %group_seen;
2393
2394         foreach $code (@items) {
2395                 undef $item;
2396                 $quantity = defined $quantities[$j] ? $quantities[$j] : 1;
2397                 $set = $quantity =~ s/^=//;
2398                 $quantity =~ s/^(-?)\D+/$1/;
2399                 $quantity =~ s/^(-?\d*)\D.*/$1/
2400                         unless $Vend::Cfg->{FractionalItems};
2401                 ($j++,next) unless $quantity;
2402                 if(! $fly[$j]) {
2403                         $base = product_code_exists_tag($code, $bases[$j] || undef);
2404                 }
2405                 else {
2406                         $base = 'mv_fly';
2407                         my $ref;
2408 #::logError("onfly call=$Vend::Cfg->{OnFly} ($code, $quantity, $fly[$j])");
2409                         eval {
2410                                 $item = Vend::Parse::do_tag($Vend::Cfg->{OnFly},
2411                                                                                                 $code,
2412                                                                                                 $quantity,
2413                                                                                                 $fly[$j],
2414                                                                                         );
2415                         };
2416                         if($@) {
2417                                 ::logError(
2418                                         "failed on-the-fly item add with error %s for: tag=%s sku=%s, qty=%s, passed=%s",
2419                                         $@,
2420                                         $Vend::Cfg->{OnFly},
2421                                         $code,
2422                                         $quantity,
2423                                         $fly[$j],
2424                                 );
2425                                 next;
2426                         }
2427                 }
2428                 if (! $base ) {
2429                         my ($subname, $sub, $ret);
2430
2431                         if ($subname = $Vend::Cfg->{SpecialSub}{order_missing}) {
2432                                 $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
2433                                 eval {
2434                                         $ret = $sub->($code, $quantity);
2435                                 };
2436
2437                                 if ($@) {
2438                                         ::logError("Error running %s subroutine %s: %s", 'order_missing', $subname, $@);
2439                                 }
2440                         }
2441
2442                         unless ($ret) {
2443                                 logError( "Attempt to order missing product code: %s", $code);
2444                         }
2445
2446                         next;
2447                 }
2448
2449                 INCREMENT: {
2450                         # Check that the item has not been already ordered.
2451                         # But let us order separates if so configured
2452                         $found = -1;
2453                         last INCREMENT if $separate;
2454                         last INCREMENT if defined $lines[$j] and length($lines[$j]);
2455
2456                         foreach $i (0 .. $#$cart) {
2457                                 if ($cart->[$i]->{'code'} eq $code) {
2458                                         next unless $base eq $cart->[$i]->{mv_ib};
2459                                         next if $cart->[$i]->{mv_free_item};
2460                                         $found = $i;
2461                                         # Increment quantity. This is different than
2462                                         # the standard handling because we are ordering
2463                                         # accessories, and may want more than 1 of each
2464                                         my %old_item = %{$cart->[$i]} if $raise_event and $track_quantity;
2465                                         $cart->[$i]{quantity} = $set ? $quantity : $cart->[$i]{quantity} + $quantity;
2466                                         Vend::Cart::trigger_update(
2467                                                         $cart,
2468                                                         $cart->[$i], # new row
2469                                                         \%old_item, # old row
2470                                                         $cartname
2471                                                 ) if $raise_event and $track_quantity;
2472                                 }
2473                         }
2474                 } # INCREMENT
2475
2476                 # And if not, start with a whole new line.
2477                 # If mv_orderline is set, will replace a line.
2478                 if ($found == -1) {
2479                         $item = {'code' => $code, 'quantity' => $quantity, mv_ib => $base}
2480                                 if ! $item;
2481
2482                         # Add the master item/sub item ids if appropriate
2483                         if(@group) {
2484 #::logDebug("processing order_group");
2485                                 if(! $group_seen{ $group[$j] }++ ) {
2486                                         $item->{mv_mi} = $mv_mi = $attr{mv_mi}->[$j];
2487 #::logDebug("processing new master item=$mv_mi");
2488                                         $item->{mv_mp} = $mv_mp = $attr{mv_mp}->[$j];
2489                                         $item->{mv_si} = $mv_si = 0;
2490                                 }
2491                                 else {
2492                                         $item->{mv_mi} = $mv_mi;
2493                                         $item->{mv_si} = ++$mv_si;
2494 #::logDebug("processing sub item=$mv_si");
2495                                         $item->{mv_mp} = $attr{mv_mp}->[$j] || $mv_mp;
2496                                 }
2497                         }
2498
2499                         $item->{mv_sku} = $skus[$i] if defined $skus[$i];
2500
2501                         if($Vend::Cfg->{UseModifier}) {
2502                                 foreach $i (@{$Vend::Cfg->{UseModifier}}) {
2503                                         $item->{$i} = $attr{$i}->[$j];
2504                                 }
2505                         }
2506
2507                         auto_modifier($item) if $Vend::Cfg->{AutoModifier};
2508
2509                         if(my $oe = $Vend::Cfg->{OptionsAttribute}) {
2510                           eval {
2511                                 my $loc = $Vend::Cfg->{Options_repository}{$item->{$oe}};
2512                                 if($loc and $loc->{item_add_routine}) {
2513                                         no strict 'refs';
2514                                         my $sub = \&{"$loc->{item_add_routine}"};
2515                                         if(defined $sub) {
2516                                                 $sub->($item, $loc);
2517                                         }
2518                                 }
2519                           };
2520                           if($@) {
2521                                 ::logError(
2522                                         "error during %s (option type %s) item_add_routine: %s",
2523                                         $code,
2524                                         $item->{$oe},
2525                                         $@,
2526                                 );
2527                           }
2528                         }
2529
2530                         if($lines[$j] =~ /^\d+$/ and defined $cart->[$lines[$j]] ) {
2531                                 my %old = %{$cart->[$lines[$j]]} if $raise_event;
2532                                 $cart->[$lines[$j]] = $item;
2533                                 Vend::Cart::trigger_update(
2534                                                 $cart,
2535                                                 $item, # new item
2536                                                 \%old, # old item
2537                                                 $cartname,
2538                                         ) if $raise_event;
2539                         }
2540                         else {
2541 # TRACK
2542                                 $Vend::Track->add_item($cart,$item) if $Vend::Track;
2543 # END TRACK
2544                                 push @$cart, $item;
2545                                 Vend::Cart::trigger_add(
2546                                                 $cart,
2547                                                 $item, # new item
2548                                                 $cartname,
2549                                         ) if $raise_event;
2550                         }
2551                 }
2552                 $j++;
2553         }
2554
2555         if($Vend::Cfg->{OrderLineLimit} and $#$cart >= $Vend::Cfg->{OrderLineLimit}) {
2556                 @$cart = ();
2557                 my $msg = errmsg(
2558                         "WARNING:\n" .
2559                         "Possible bad robot. Cart limit of %s exceeded. Cart emptied.\n",
2560                         $Vend::Cfg->{OrderLineLimit}
2561                 );
2562                 do_lockout($msg);
2563         }
2564         Vend::Cart::toss_cart($cart, $CGI::values{mv_cartname});
2565 }
2566
2567
2568 # Compatibility with old globalsub payment
2569 *send_mail = \&Vend::Util::send_mail;
2570
2571 # Compatibility with old globalsub payment
2572 *map_actual = \&Vend::Payment::map_actual;
2573
2574 1;
2575 __END__