lib/Vend/Ship.pm

   1 # Vend::Ship - Interchange shipping code
   2 #
   3 # $Id: Ship.pm,v 2.29 2008-11-05 22:38:52 mheins Exp $
   4 #
   5 # Copyright (C) 2002-2008 Interchange Development Group
   6 # Copyright (C) 1996-2002 Red Hat, Inc.
   7 #
   8 # This program was originally based on Vend 0.2 and 0.3
   9 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
  10 #
  11 # This program is free software; you can redistribute it and/or modify
  12 # it under the terms of the GNU General Public License as published by
  13 # the Free Software Foundation; either version 2 of the License, or
  14 # (at your option) any later version.
  15 #
  16 # This program is distributed in the hope that it will be useful,
  17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 # GNU General Public License for more details.
  20 #
  21 # You should have received a copy of the GNU General Public
  22 # License along with this program; if not, write to the Free
  23 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  24 # MA  02110-1301  USA.
  25
  26 package Vend::Ship;
  27
  28 require Exporter;
  29 @ISA = qw(Exporter);
  30
  31 @EXPORT = qw(
  32                                 do_error
  33                 );
  34
  35 use Vend::Util;
  36 use Vend::Interpolate;
  37 use Vend::Data;
  38 use strict;
  39 no warnings qw(uninitialized numeric);
  40
  41 use constant MAX_SHIP_ITERATIONS => 100;
  42 use constant MODE  => 0;
  43 use constant DESC  => 1;
  44 use constant CRIT  => 2;
  45 use constant MIN   => 3;
  46 use constant MAX   => 4;
  47 use constant COST  => 5;
  48 use constant QUERY => 6;
  49 use constant OPT   => 7;
  50
  51 my %Verbatim = ( qw/ PriceDivide 1 /);
  52 my %Ship_remap = ( qw/
  53                                                         CRITERION   CRIT
  54                                                         PRICEDIVIDE PriceDivide
  55                                                         CRITERIA    CRIT
  56                                                         MAXIMUM     MAX
  57                                                         MINIMUM     MIN
  58                                                         PRICE       COST
  59                                                         QUALIFIER   QUAL
  60                                                         CODE        PERL
  61                                                         SUB         PERL
  62                                                         UPS_TYPE    TABLE
  63                                                         DESCRIPTION DESC
  64                                                         ZIP         GEO
  65                                                         LOOKUP      TABLE
  66                                                         DEFAULT_ZIP DEFAULT_GEO
  67                                                         SQL         QUERY
  68                                         /);
  69
  70 sub do_error {
  71         my $msg = errmsg(@_);
  72         Vend::Tags->error({ name => 'shipping', set => $msg });
  73         unless ($::Limit->{no_ship_message}) {
  74                 $Vend::Session->{ship_message} ||= '';
  75                 $Vend::Session->{ship_message} .= $msg . ($msg =~ / $/ ? '' : ' ');
  76         }
  77         return undef;
  78 }
  79
  80 sub make_three {
  81         my ($zone, $len) = @_;
  82         $len = 3 if ! $len;
  83         while ( length($zone) < $len ) {
  84                 $zone = "0$zone";
  85         }
  86         return $zone;
  87 }
  88
  89 use vars qw/%Ship_handler/;
  90
  91 %Ship_handler = (
  92                 TYPE =>
  93                                         sub {
  94                                                         my ($v,$k) = @_;
  95                                                         $$v =~ s/^(.).*/$1/;
  96                                                         $$v = lc $$v;
  97                                                         $$k = 'COST';
  98                                         }
  99                 ,
 100 );
 101
 102 sub process_new_beginning {
 103         my ($shipping, $record, $line) = @_;
 104         my @new;
 105         my $first;
 106
 107         $line ||= '';
 108         if($line =~ /^[^\s:]+\t/) {
 109                 @new = split /\t/, $line;
 110         }
 111         elsif($line =~ /^(\w+)\s*:\s*(.*)/s) {
 112                 @new = ($1, $2, '', 0, 99999999, 0);
 113                 $first = 1;
 114         }
 115
 116         $Vend::Cfg->{Shipping_desc}{$new[MODE]} ||= $new[DESC] if @new;
 117
 118         if (@$record) {
 119                 my $old_mode = $record->[MODE];
 120                 if(! ref($record->[OPT]) ) {
 121                         $record->[OPT] = string_to_ref($record->[OPT]);
 122                 }
 123
 124                 if ($old_mode and ! $Vend::Cfg->{Shipping_hash}{$old_mode}) {
 125                         $record->[OPT]{description} ||= $Vend::Cfg->{Shipping_desc}{$old_mode};
 126                         $Vend::Cfg->{Shipping_hash}{$old_mode} = $record->[OPT];
 127                 }
 128                 else {
 129                         $record->[OPT]{description} ||= $record->[DESC];
 130                 }
 131
 132                 push @$shipping, [ @$record ];
 133         }
 134
 135         @$record = @new;
 136
 137         return $first;
 138 }
 139
 140 sub read_shipping {
 141         my ($file, $opt) = @_;
 142         $opt = {} unless $opt;
 143     my($code, $desc, $min, $criterion, $max, $cost, $mode);
 144
 145         my $loc;
 146         $loc = $Vend::Cfg->{Shipping_repository}{default}
 147                         if $Vend::Cfg->{Shipping_repository};
 148
 149         $loc ||= {};
 150
 151         my $base_dir = $loc->{directory} || $loc->{dir} || $Vend::Cfg->{ProductDir};
 152
 153         my @files;
 154         if ($file) {
 155                 push @files, $file;
 156         }
 157         elsif($opt->{add} or $Vend::Cfg->{Variable}{MV_SHIPPING}) {
 158                 $file = "$Vend::Cfg->{ScratchDir}/shipping.asc";
 159                 Vend::Util::writefile(">$file", $opt->{add} || $Vend::Cfg->{Variable}{MV_SHIPPING});
 160                 push @files, $file;
 161         }
 162         else {
 163                 my %found;
 164                 if($Vend::Cfg->{Shipping}) {
 165                         my $repos = $Vend::Cfg->{Shipping_repository};
 166                         for(keys %$repos) {
 167                                 next unless $file = $repos->{$_}{config_file};
 168                                 $file = Vend::Util::catfile($base_dir, $file)
 169                                         unless $file =~ m{/};
 170 #::logDebug("found shipping file=$file");
 171                                 $found{$file} = 1;
 172                                 push @files, $file;
 173                         }
 174                 }
 175                 $file = $Vend::Cfg->{Special}{'shipping.asc'}
 176                                 || Vend::Util::catfile($base_dir, 'shipping.asc');
 177
 178                 if(-f $file and !$found{$file}) {
 179                         push @files, $file;
 180                 }
 181         }
 182
 183 #::logDebug("shipping files=" . ::uneval(\@files));
 184         my @flines;
 185         for(@files) {
 186                 push @flines, split /\n/, readfile($_);
 187 #::logDebug("shipping lines=" . scalar(@flines));
 188         }
 189
 190         if ($Vend::Cfg->{CustomShipping} =~ /^select\s+/i) {
 191                 ($Vend::Cfg->{SQL_shipping} = 1, return)
 192                         if $Global::Foreground;
 193                 my $ary;
 194                 my $query = interpolate_html($Vend::Cfg->{CustomShipping});
 195                 eval {
 196                         $ary = query($query, { wantarray => 1} );
 197                 };
 198                 if(! ref $ary) {
 199                         logError("Could not make shipping query %s: %s" ,
 200                                                 $Vend::Cfg->{CustomShipping},
 201                                                 $@);
 202                         return undef;
 203                 }
 204                 my $out;
 205                 for(@$ary) {
 206                         push @flines, join "\t", @$_;
 207                 }
 208         }
 209
 210         $Vend::Cfg->{Shipping_desc} ||= {};
 211
 212         my %seen;
 213         my $append = '00000';
 214         my @line;
 215         my $prev = '';
 216         my $waiting;
 217         my @shipping;
 218         my $first;
 219     for(@flines) {
 220
 221                 # Strip CR, we hope
 222                 s/\s+$//;
 223
 224                 # Handle continued lines
 225                 if(s/\\$//) {
 226                         $prev .= $_;
 227                         next;
 228                 }
 229                 elsif($waiting) {
 230                         if($_ eq $waiting) {
 231                                 undef $waiting;
 232                                 $_ = $prev;
 233                                 $prev = '';
 234                                 s/\s+$//;
 235                         }
 236                         else {
 237                                 $prev .= "$_\n";
 238                                 next;
 239                         }
 240                 }
 241                 elsif($prev) {
 242                         $_ = "$prev$_";
 243                         $prev = '';
 244                 }
 245
 246                 if (s/<<(\w+)$//) {
 247                         $waiting = $1;
 248                         $prev .= $_;
 249                         next;
 250                 }
 251
 252                 next if ! /\S/ or /^\s*#/;
 253                 s/\s+$//;
 254
 255                 if(/^[^\s:]+\t/ or /^\w+\s*:/s) {
 256                         ## This along with process_new_beginning replaces
 257                         ## two previous branches that had same code doing
 258                         ## same thing.
 259
 260                         $first = process_new_beginning(\@shipping, \@line, $_);
 261                 }
 262                 else {
 263                         no strict 'refs';
 264                         s/^\s+//;
 265                         my($k, $v) = split /\s+/, $_, 2;
 266                         my $prospect;
 267                         $k = uc $k;
 268                         $k = $Ship_remap{$k}
 269                                 if defined $Ship_remap{$k};
 270
 271                         if ($k eq 'MIN') {
 272                                 # Special case handling for minimum line.
 273                                 if ($first) {
 274                                         undef $first;
 275                                 }
 276                                 else {
 277                                         # Push the record we have to this point.
 278                                         my @lcopy = @line;
 279                                         process_new_beginning(\@shipping, \@lcopy);
 280                                 }
 281                         }
 282
 283                         $Ship_handler{$k}->(\$v, \$k, \@line)
 284                                 if defined $Ship_handler{$k};
 285                         eval {
 286                                 if(defined &{"$k"}) {
 287                                                 $line[&{"$k"}] = $v;
 288                                 }
 289                                 else {
 290                                         $line[OPT] = {} unless $line[OPT];
 291                                         $k = lc $k unless $Verbatim{$k};
 292                                         $line[OPT]->{$k} = $v;
 293                                 }
 294                         };
 295                         logError(
 296                                 "bad shipping index %s for mode %s in $file",
 297                                 $k,
 298                                 $line[0],
 299                                 ) if $@;
 300                 }
 301         }
 302
 303         process_new_beginning(\@shipping, \@line);
 304
 305         if($waiting) {
 306                 logError(
 307                         "Failed to find end-of-line termination '%s' in shipping read",
 308                         $waiting,
 309                 );
 310         }
 311
 312         my $row;
 313         my %zones;
 314         my %def_opts;
 315         $def_opts{PriceDivide} = 1 if $Vend::Cfg->{Locale};
 316
 317         foreach $row (@shipping) {
 318                 my $cost = $row->[COST];
 319                 my $o = get_option_hash($row->[OPT]);
 320                 for(keys %def_opts) {
 321                         $o->{$_} = $def_opts{$_}
 322                                 unless defined $o->{$_};
 323                 }
 324                 $row->[OPT] = $o;
 325                 my $zone;
 326                 if ($cost =~ s/^\s*o\s+//) {
 327                         $o = get_option_hash($cost);
 328                         %def_opts = %$o;
 329                 }
 330                 elsif ($zone = $o->{zone} or $cost =~ s/^\s*c\s+(\w+)\s*//) {
 331                         $zone = $1 if ! $zone;
 332                         next if defined $zones{$zone};
 333                         my $ref;
 334                         if ($o->{zone}) {
 335                                 $ref = {};
 336                                 my @common = qw/
 337                                                         mult_factor
 338                                                         str_length
 339                                                         eas
 340                                                         quiet
 341                                                         zone_data
 342                                                         zone_file
 343                                                         zone_name
 344                                                 /;
 345                                 @{$ref}{@common} = @{$o}{@common};
 346                                 $ref->{zone_name} = $zone
 347                                         if ! $ref->{zone_name};
 348                         }
 349                         elsif ($cost =~ /^{(?s:.)+}$/ ) {
 350                                 eval { $ref = eval $cost };
 351                         }
 352                         else {
 353                                 $ref = {};
 354                                 my($name, $file, $length, $multiplier) = split /\s+/, $cost;
 355                                 $ref->{zone_name} = $name || undef;
 356                                 $ref->{zone_file} = $file if $file;
 357                                 $ref->{mult_factor} = $multiplier if defined $multiplier;
 358                                 $ref->{str_length} = $length if defined $length;
 359                         }
 360                         if ($@
 361                                 or ref($ref) !~ /HASH/
 362                                 or ! $ref->{zone_name}) {
 363                                 logError(
 364                                         "Bad shipping configuration for mode %s, skipping.",
 365                                         $row->[MODE]
 366                                 );
 367                                 $row->[MODE] = 'ERROR';
 368                                 next;
 369                         }
 370                         $ref->{zone_key} = $zone;
 371                         $ref->{str_length} = 3 unless defined $ref->{str_length};
 372                         $zones{$zone} = $ref;
 373                 }
 374     }
 375
 376         if($Vend::Cfg->{UpsZoneFile} and ! defined $Vend::Cfg->{Shipping_zone}{'u'} ) {
 377                          $zones{'u'} = {
 378                                 zone_file       => $Vend::Cfg->{UpsZoneFile},
 379                                 zone_key        => 'u',
 380                                 zone_name       => 'UPS',
 381                                 };
 382         }
 383         UPSZONE: {
 384
 385                 for (keys %zones) {
 386                         my $ref = $zones{$_};
 387                         if (! $ref->{zone_data}) {
 388                                 $ref->{zone_file} = Vend::Util::catfile(
 389                                                                                         $base_dir,
 390                                                                                         "$ref->{zone_name}.csv",
 391                                                                                 ) if ! $ref->{zone_file};
 392                                 $ref->{zone_data} =  readfile($ref->{zone_file});
 393                         }
 394                         unless ($ref->{zone_data}) {
 395                                 logError( "Bad shipping file for zone '%s', lookup disabled.",
 396                                                         $ref->{zone_key},
 397                                                 );
 398                                 next;
 399                         }
 400                         my (@zone) = grep /\S/, split /[\r\n]+/, $ref->{zone_data};
 401                         shift @zone while @zone and $zone[0] !~ /^(Postal|Dest.*Z|low)/;
 402                         if($zone[0] =~ /^Postal/) {
 403                                 $zone[0] =~ s/,,/,/;
 404                                 for(@zone[1 .. $#zone]) {
 405                                         s/,/-/;
 406                                 }
 407                         }
 408                         @zone = grep /\S/, @zone;
 409                         @zone = grep /^[^"]/, @zone;
 410                         if($zone[0] !~ /\t/) {
 411                                 my $len = $ref->{str_length} || 3;
 412                                 @zone = grep /\S/, @zone;
 413                                 @zone = grep /^[^"]/, @zone;
 414                                 $zone[0] =~ s/[^\w,]//g;
 415                                 $zone[0] =~ s/^\w+/low,high/;
 416                                 @zone = grep /,/, @zone;
 417                                 $zone[0] =~     s/\s*,\s*/\t/g;
 418                                 for(@zone[1 .. $#zone]) {
 419                                         s/^\s*(\w+)\s*,/make_three($1, $len) . ',' . make_three($1, $len) . ','/e;
 420                                         s/^\s*(\w+)\s*-\s*(\w+),/make_three($1, $len) . ',' . make_three($2, $len) . ','/e;
 421                                         s/\s*,\s*/\t/g;
 422                                 }
 423                         }
 424                         $ref->{zone_data} = \@zone;
 425                 }
 426         }
 427         for (keys %zones) {
 428                 $Vend::Cfg->{Shipping_zone}{$_} = $zones{$_};
 429         }
 430         $Vend::Cfg->{Shipping_line} = []
 431                 if ! $Vend::Cfg->{Shipping_line};
 432         unshift @{$Vend::Cfg->{Shipping_line}}, @shipping;
 433         1;
 434 }
 435
 436 sub resolve_shipmode {
 437         my ($type, $opt) = @_;
 438
 439 #::logDebug("Called resolve_shipmode");
 440         my $loc;
 441         if($loc = $Vend::Cfg->{Shipping_repository}{resolution}) {
 442                 while( my ($k, $v) = each %$loc) {
 443                         $opt->{$k} = $v unless defined $opt->{$k};
 444                 }
 445         }
 446
 447         my $sv = $opt->{shipmode_var} || 'mv_shipmode';
 448         my $current             = $::Values->{$sv};
 449
 450         my $state       = $::Values->{$opt->{state_var} || 'state'};
 451         my $country = $::Values->{$opt->{country_var} || 'country'};
 452
 453         my $sdb;
 454         $sdb = dbref($opt->{state_table} || 'state') unless $opt->{no_state};
 455
 456         $opt->{state_modes_field}       ||= 'shipmodes';
 457         $opt->{country_modes_field}     ||= 'shipmodes';
 458         $opt->{state_field}                     ||= 'state';
 459         $opt->{country_field}           ||= 'country';
 460
 461         my $cdb;
 462
 463         my $shipmodes;
 464         if($sdb and $state and $country) {
 465 #::logDebug("Trying state modes");
 466                 $shipmodes = $sdb->single(
 467                                                 $opt->{state_modes_field},
 468                                                 {
 469                                                         $opt->{state_field} => $state,
 470                                                         $opt->{country_field} => $country,
 471                                                 },
 472                                                 );
 473         }
 474 #::logDebug("Shipmodes now '$shipmodes'");
 475
 476         if(! $shipmodes and $country) {
 477 #::logDebug("Trying country modes");
 478                 $cdb = dbref($opt->{country_table} || 'country');
 479                 $shipmodes = $cdb->field($country, $opt->{country_modes_field});
 480         }
 481 #::logDebug("Shipmodes now '$shipmodes'");
 482
 483         my @modes = grep /\S/, split /[\s,\0]+/, $shipmodes;
 484
 485         my $current_ok;
 486         my $default;
 487         for(@modes) {
 488                 $default ||= $_;
 489                 $current_ok = 1         if $_ eq $current;
 490         }
 491
 492         my $mode;
 493         my $valid;
 494         if($current_ok) {
 495                 $mode = $current;
 496                 $valid = 1;
 497         }
 498         else {
 499                 $mode = $default;
 500         }
 501
 502         return $valid if $opt->{check_validity};
 503
 504         unless($opt->{no_set}) {
 505                 $::Values->{$sv} = $mode;
 506         }
 507
 508         if($opt->{possible}) {
 509                 my $out = join " ", @modes;
 510 #::logDebug("Returning possible '$out'");
 511                 return $out;
 512         }
 513         return $mode;
 514 }
 515
 516 my $Ship_its = 0;
 517
 518 sub push_warning {
 519         $Vend::Session->{warnings} = [$Vend::Session->{warnings}]
 520                 if ! ref $Vend::Session->{warnings};
 521         push @{$Vend::Session->{warnings}}, errmsg(@_);
 522         return;
 523 }
 524
 525 sub shipping {
 526         my($mode, $opt) = @_;
 527
 528         $opt ||= {};
 529
 530         return undef unless $mode;
 531     my $save = $Vend::Items;
 532         my $qual;
 533         my $final;
 534
 535         $Vend::Session->{ship_message} = '' if ! $Ship_its;
 536         die "Too many levels of shipping recursion ($Ship_its)"
 537                 if $Ship_its++ > MAX_SHIP_ITERATIONS;
 538         my @bin;
 539
 540 #::logDebug("Check BEGIN, must get to FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
 541         if ($opt->{cart}) {
 542                 my @carts = grep /\S/, split /[\s,]+/, $opt->{cart};
 543                 for(@carts) {
 544                         next unless $::Carts->{$_};
 545                         push @bin, @{$::Carts->{$_}};
 546                 }
 547         }
 548         else {
 549                 @bin = @$Vend::Items;
 550         }
 551 #::logDebug("doing shipping, mode=$mode");
 552 #::logDebug("doing shipping, mode=$mode bin=" . uneval(\@bin));
 553
 554         $Vend::Session->{ship_message} = '' if $opt->{reset_message};
 555
 556         my($field, $code, $i, $total, $cost, $multiplier, $formula, $error_message);
 557
 558 #       my $ref = $Vend::Cfg;
 559 #
 560 #       if(defined $Vend::Cfg->{Shipping_criterion}->{$mode}) {
 561 #               $ref = $Vend::Cfg;
 562 #       }
 563 #       elsif($Vend::Cfg->{Shipping}) {
 564 #               my $locale =    $::Scratch->{mv_currency}
 565 #                                               || $::Scratch->{mv_locale}
 566 #                                               || $::Vend::Cfg->{DefaultLocale}
 567 #                                               || 'default';
 568 #               $ref = $Vend::Cfg->{Shipping}{$locale};
 569 #               $field = $ref->{$mode};
 570 #       }
 571 #
 572 #       if(defined $ref->{Shipping_code}{$mode}) {
 573 #               $final = tag_perl($opt->{table}, $opt, $Vend::Cfg->{Shipping_code});
 574 #               goto SHIPFORMAT;
 575 #       }
 576
 577         $@ = 1;
 578
 579         # Security hole if we don't limit characters
 580         $mode !~ /[\s,;{}]/ and
 581                 eval {'what' =~ /$mode/};
 582
 583         if ($@) {
 584 #::logDebug("Check ERROR, must get to FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
 585                 logError("Bad character(s) in shipping mode '$mode', returning 0");
 586                 goto SHIPFORMAT;
 587         }
 588
 589         my $row;
 590         my @lines;
 591         @lines = grep $_->[0] =~ /^$mode/, @{$Vend::Cfg->{Shipping_line}};
 592         goto SHIPFORMAT unless @lines;
 593 #::logDebug("shipping lines selected: " . uneval(\@lines));
 594         my $q;
 595         if($lines[0][QUERY]) {
 596                 my $q = interpolate_html($lines[0][QUERY]);
 597                 $q =~ s/=\s+?\s*/= '$mode' /g;
 598                 $q =~ s/\s+like\s+?\s*/ LIKE '%$mode%' /ig;
 599                 my $ary = query($q, { wantarray => 1 });
 600                 if(ref $ary) {
 601                         @lines = @$ary;
 602 #::logDebug("shipping lines reselected with SQL: " . uneval(\@lines));
 603                 }
 604                 else {
 605 #::logDebug("shipping lines failed reselect with SQL query '$q'");
 606                 }
 607         }
 608
 609         my $lopt = $lines[0][OPT];
 610         if(ref($lopt) eq 'HASH') {
 611                 $lopt = { %$lopt };
 612         }
 613         my $o = get_option_hash($lopt) || {};
 614
 615 #::logDebug("shipping opt=" . uneval($o));
 616
 617         if($o->{limit}) {
 618                 $o->{filter} = '(?i)\s*[1ty]' if ! $o->{filter};
 619 #::logDebug("limiting, filter=$o->{filter} limit=$o->{limit}");
 620                 my $patt = qr{$o->{filter}};
 621                 @bin = grep $_->{$o->{limit}} =~ $patt, @bin;
 622         }
 623         $::Carts->{mv_shipping} = \@bin;
 624
 625         Vend::Interpolate::tag_cart('mv_shipping');
 626
 627 #::logDebug("Check 2, must get to FINAL. Vend::Items=" . uneval($Vend::Items) . " main=" . uneval($::Carts->{main}) . " mv_shipping=" . uneval($::Carts->{mv_shipping}));
 628
 629         if($o->{perl}) {
 630                 $Vend::Interpolate::Shipping   = $lines[0];
 631                 $field = $lines[0][CRIT];
 632                 $field = tag_perl($opt->{tables}, $opt, $field)
 633                         if $field =~ /[^\w:]/;
 634                 $qual  = tag_perl($opt->{tables}, $opt, $o->{qual})
 635                                         if $o->{qual};
 636         }
 637         elsif ($o->{mml}) {
 638                 $Vend::Interpolate::Shipping   = $lines[0];
 639                 $field = tag_perl($opt->{tables}, $opt, $lines[0][CRIT]);
 640                 $qual =  tag_perl($opt->{tables}, $opt, $o->{qual})
 641                                         if $o->{qual};
 642         }
 643         elsif($lines[0][CRIT] =~ /[[\s]|__/) {
 644                 ($field, $qual) = split /\s+/, interpolate_html($lines[0][CRIT]), 2;
 645                 if($qual =~ /{}/) {
 646                         logError("Bad qualification code '%s', returning 0", $qual);
 647                         goto SHIPFORMAT;
 648                 }
 649         }
 650         else {
 651                 $field = $lines[0][CRIT];
 652         }
 653
 654         goto SHIPFORMAT unless $field;
 655
 656         # See if the field needs to be returned by a Interchange function.
 657         # If a space is encountered, a qualification code
 658         # will be set up, with any characters after the first space
 659         # used to determine geography or other qualifier for the mode.
 660
 661         # Uses the quantity on the order form if the field is 'quantity',
 662         # otherwise goes to the database.
 663     $total = 0;
 664
 665         if($field =~ /^[\d.]+$/) {
 666 #::logDebug("Is a number selection");
 667                 $total = $field;
 668         }
 669         elsif($field eq 'quantity') {
 670 #::logDebug("quantity selection");
 671         for (@$Vend::Items) {
 672                         next unless $_->{quantity};
 673                         $total = $total + $_->{quantity};
 674         }
 675         }
 676         elsif ( index($field, ':') != -1) {
 677 #::logDebug("outboard field selection");
 678                 my ($base, $field) = split /:+/, $field;
 679                 my $db = database_exists_ref($base);
 680                 unless ($db and db_column_exists($db,$field) ) {
 681                         logError("Bad shipping field '$field' or table '$base'. Returning 0");
 682                         goto SHIPFORMAT;
 683                 }
 684         foreach $i (0 .. $#$Vend::Items) {
 685                         my $item = $Vend::Items->[$i];
 686                         $total += (database_field($base, $item->{code}, $field) || 0) *
 687                                                 $item->{quantity};
 688                 }
 689         }
 690         else {
 691 #::logDebug("standard field selection");
 692             my $use_modifier;
 693
 694             if ($::Variable->{MV_SHIP_MODIFIERS}){
 695                         my @pieces = grep {$_ = quotemeta $_} split(/[\s,|]+/,$::Variable->{MV_SHIP_MODIFIERS});
 696                         my $regex = join('|',@pieces);
 697                         $use_modifier = 1 if ($regex && $field =~ /^($regex)$/);
 698             }
 699
 700             my $col_checked = 0;
 701             foreach my $item (@$Vend::Items){
 702                 my $value;
 703                 if ($use_modifier && defined $item->{$field}){
 704                     $value = $item->{$field};
 705                 }
 706                 else{
 707                     unless ($col_checked++ || column_exists $field){
 708                         logError("Custom shipping field '$field' doesn't exist. Returning 0");
 709                         $total = 0;
 710                         goto SHIPFORMAT;
 711                     }
 712                     my $base = $item->{mv_ib} || $Vend::Cfg->{ProductFiles}[0];
 713                     $value = tag_data($base, $field, $item->{code});
 714                 }
 715                 $total += ($value * $item->{quantity});
 716             }
 717         }
 718
 719         if ($field eq 'weight') {
 720                 if (my $callout_name = $Vend::Cfg->{SpecialSub}{weight_callout}) {
 721 #::logDebug("Execute weight callout '$callout_name(...)'");
 722                         my $weight_callout_sub = $Vend::Cfg->{Sub}{$callout_name}
 723                                 || $Global::GlobalSub->{$callout_name};
 724                         eval {
 725                                 $total = $weight_callout_sub->($total) || 0;
 726                         };
 727                         ::logError("Weight callout '$callout_name' died: $@") if $@;
 728                 }
 729         }
 730
 731         # We will LAST this loop and go to SHIPFORMAT if a match is found
 732         SHIPIT:
 733         foreach $row (@lines) {
 734 #::logDebug("processing mode=$row->[MODE] field=$field total=$total min=$row->[MIN] max=$row->[MAX]");
 735
 736                 next unless  $total <= $row->[MAX] and $total >= $row->[MIN];
 737
 738                 if($qual) {
 739                         next unless
 740                                 $row->[CRIT] =~ m{(^|\s)$qual(\s|$)} or
 741                                 $row->[CRIT] !~ /\S/;
 742                 }
 743
 744                 my $ropt = $row->[OPT];
 745                 if(ref($ropt) eq 'HASH' ) {
 746                         $ropt = { %$ropt };
 747                 }
 748                 $o = get_option_hash($ropt, $o)
 749                         if $ropt;
 750                 # unless field begins with 'x' or 'f', straight cost is returned
 751                 # - otherwise the quantity is multiplied by the cost or a formula
 752                 # is applied
 753                 my $what = $row->[COST];
 754                 if($what !~ /^[a-zA-Z]\w+$/) {
 755                         $what =~ s/^\s+//;
 756                         $what =~ s/[ \t\r]+$//;
 757                 }
 758                 if($what =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+))$/) {
 759                         $final += $1;
 760                         last SHIPIT unless $o->{continue};
 761                 }
 762                 elsif ($what =~ /^f\s*(.*)/i) {
 763                         $formula = $o->{formula} || $1;
 764                         $formula =~ s/\@\@TOTAL\@\\?\@/$total/ig;
 765                         $formula =~ s/\@\@CRIT\@\\?\@/$total/ig;
 766                         $formula = interpolate_html($formula)
 767                                 if $formula =~ /__\w+__|\[\w/;
 768                         $cost = $Vend::Interpolate::ready_safe->reval($formula);
 769                         if($@) {
 770                                 $error_message   = errmsg(
 771                                                                 "Shipping mode '%s': bad formula. Returning 0.",
 772                                                                 $mode,
 773                                                         );
 774                                 logError($error_message);
 775                                 last SHIPIT;
 776                         }
 777                         $final += $cost;
 778                         last SHIPIT unless $o->{continue};
 779                 }
 780                 elsif ($what =~ /^>>(\w+)/) {
 781                         my $newmode = $1;
 782                         local($opt->{redirect_from});
 783                         $opt->{redirect_from} = $mode;
 784                         return shipping($newmode, $opt);
 785                 }
 786                 elsif ($what eq 'x') {
 787                         $final += ($o->{multiplier} * $total);
 788                         last SHIPIT unless $o->{continue};
 789                 }
 790                 elsif ($what =~ s/^x\s*(-?[\d.]+)\s*$/$1/) {
 791                         $final += ($what * $total);
 792                         last SHIPIT unless $o->{continue};
 793                 }
 794                 elsif ($what =~ s/^([uA-Z])\s*//) {
 795                         my $zselect = $o->{zone} || $1;
 796                         my ($type, $geo, $adder, $mod, $sub);
 797                         ($type, $adder) = @{$o}{qw/table adder/};
 798                         $o->{geo} ||= 'zip';
 799                         if(! $type) {
 800                                 $what = interpolate_html($what);
 801                                 ($type, $geo, $adder, $mod, $sub) = split /\s+/, $what, 5;
 802                                 $o->{adder}    = $adder;
 803                                 $o->{round}    = 1  if $mod =~ /round/;
 804                                 $o->{at_least} = $1 if $mod =~ /min\s*([\d.]+)/;
 805                         }
 806                         else {
 807                                 $geo = $::Values->{$o->{geo}} || $o->{default_geo};
 808                         }
 809 #::logDebug("ready to tag_ups type=$type geo=$geo total=$total zone=$zselect options=$o");
 810                         $cost = tag_ups($type,$geo,$total,$zselect,$o);
 811                         $final += $cost;
 812                         last SHIPIT unless $o->{continue};
 813                 }
 814                 elsif ($what =~ s/^s\s*//) {
 815                         $what =~ s/\s+(.*)//;
 816                         my $extra = $1;
 817                         my $loc = $Vend::Cfg->{Shipping_repository}{$what}
 818                                 or return do_error("Unknown custom shipping type '%s'", $what);
 819                         for(keys %$loc) {
 820                                 $o->{$_} = $loc->{$_} unless defined $o->{$_};
 821                         }
 822                         my $routine = $o->{cost_routine} || "Vend::Ship::${what}::calculate";
 823                         my $sub = \&{"$routine"};
 824                         if(! defined $sub) {
 825                                 ::logOnce(
 826                                         "Shipping type %s %s routine %s not found, aborting options for %s.",
 827                                         $what,
 828                                         $opt->{routine_description} || 'calculation',
 829                                         $routine,
 830                                         $mode,
 831                                         );
 832                                 return undef;
 833                         }
 834 #::logDebug("ready to calculate custom Ship type=$what total=$total options=$o");
 835                         $cost = $sub->($mode, $total, $row, $o, $opt, $extra);
 836                         $final += $cost;
 837                         last SHIPIT unless $o->{continue};
 838                 }
 839                 elsif ($what =~ s/^([im])\s*//) {
 840                         my $select = $1;
 841                         $what =~ s/\@\@TOTAL\@\@/$total/g;
 842                         my ($item, $field, $sum);
 843                         my (@items) = @{$Vend::Items};
 844                         my @fields = split /\s+/, $qual;
 845                         if ($select eq 'm') {
 846                                 $sum = { code => $mode, quantity => $total };
 847                         }
 848                         foreach $item (@items) {
 849                                 for(@fields) {
 850                                         if(s/(.*):+//) {
 851                                                 $item->{$_} = tag_data($1, $_, $item->{code});
 852                                         }
 853                                         else {
 854                                                 $item->{$_} = product_field($_, $item->{code});
 855                                         }
 856                                         $sum->{$_} += $item->{$_} if defined $sum;
 857                                 }
 858                         }
 859                         @items = ($sum) if defined $sum;
 860                         for(@items) {
 861                                 $cost = Vend::Data::chain_cost($_, $what);
 862                                 if($cost =~ /[A-Za-z]/) {
 863                                         $cost = shipping($cost);
 864                                 }
 865                                 $final += $cost;
 866                         }
 867                         last SHIPIT unless $o->{continue};
 868                 }
 869                 elsif ($what =~ s/^e\s*//) {
 870                         $error_message = $what;
 871                         $error_message =~ s/\@\@TOTAL\@\@/$total/ig;
 872                         $final = 0 unless $final;
 873                         last SHIPIT unless $o->{continue};
 874                 }
 875                 else {
 876                         $error_message = errmsg( "Unknown shipping call '%s'", $what);
 877                         undef $final;
 878                         last SHIPIT;
 879                 }
 880         }
 881
 882         if ($final == 0 and $o->{'next'}) {
 883                 return shipping($o->{'next'}, $opt);
 884         }
 885         elsif(defined $o->{additional}) {
 886                 my @extra = grep /\S/, split /[\s\0,]+/, $row->[OPT]->{additional};
 887                 for(@extra) {
 888                         $final += shipping($_, {});
 889                 }
 890         }
 891
 892 #::logDebug("Check 3, must get to FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
 893
 894
 895         SHIPFORMAT: {
 896                 $Vend::Session->{ship_message} .= $error_message . ($error_message =~ / $/ ? '' : ' ')
 897                         if defined $error_message;
 898                 delete $::Carts->{mv_shipping};
 899                 $Vend::Items = $save;
 900 #::logDebug("Check FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
 901                 last SHIPFORMAT unless defined $final;
 902 #::logDebug("ship options: " . uneval($o) );
 903                 $final /= $Vend::Cfg->{PriceDivide}
 904                         if $o->{PriceDivide} and $Vend::Cfg->{PriceDivide} != 0;
 905                 $o->{free} = interpolate_html($o->{free}) if $o->{free} =~ /[_@[]/;
 906                 unless ($o->{free}) {
 907                         return '' if $final == 0;
 908                         $o->{adder} =~ s/\@\@TOTAL\@\\?\@/$final/g;
 909                         $o->{adder} =~ s/\@\@CRIT\@\\?\@/$total/g;
 910                         $o->{adder} = $Vend::Interpolate::ready_safe->reval($o->{adder});
 911                         $final += $o->{adder} if $o->{adder};
 912                         $final = POSIX::ceil($final) if is_yes($o->{round});
 913                         if($o->{at_least}) {
 914                                 $final = $final > $o->{at_least} ? $final : $o->{at_least};
 915                         }
 916                 }
 917                 if($opt->{default}) {
 918                         if(! $opt->{handling}) {
 919                                 $::Values->{mv_shipmode} = $mode;
 920                         }
 921                         else {
 922                                 $::Values->{mv_handling} = $mode;
 923                         }
 924                         undef $opt->{default};
 925                 }
 926                 if (my $callout_name = $Vend::Cfg->{SpecialSub}{shipping_callout}) {
 927 #::logDebug("Execute shipping callout '$callout_name(...)'");
 928                         my $sub = $Vend::Cfg->{Sub}{$callout_name}
 929                                 || $Global::GlobalSub->{$callout_name};
 930                         eval {
 931                                 my $callout_result = $sub->($final, $mode, $opt, $o);
 932                                 $final = $callout_result if defined $callout_result;
 933                         };
 934                         ::logError("Shipping callout '$callout_name' died: $@") if $@;
 935                 }
 936                 return $final unless $opt->{label};
 937                 my $number;
 938                 if($o->{free} and $final == 0) {
 939                         $number = $opt->{free} || $o->{free};
 940 #::logDebug("This is free, mode=$mode number=$number");
 941                 }
 942                 else {
 943                         return $final unless $opt->{label};
 944 #::logDebug("actual options: " . uneval($o));
 945                         $number = Vend::Util::currency(
 946                                                                                         $final,
 947                                                                                         $opt->{noformat},
 948                                                                         );
 949                 }
 950
 951                 $opt->{format} ||= '%M=%D (%F)' if $opt->{output_options};
 952
 953                 my $label = $opt->{format} || '<option value="%M"%S>%D (%F)';
 954                 my $sel = $::Values->{mv_shipmode} eq $mode;
 955 #::logDebug("label start: $label");
 956                 my %subst = (
 957                                                 '%' => '%',
 958                                                 M => $opt->{redirect_from} || $mode,
 959                                                 T => $total,
 960                                                 S => $sel ? ' SELECTED' : '',
 961                                                 C => $sel ? ' CHECKED' : '',
 962                                                 D => $row->[DESC] || $Vend::Cfg->{Shipping_desc}{$mode},
 963                                                 L => $row->[MIN],
 964                                                 H => $row->[MAX],
 965                                                 O => '$O',
 966                                                 F => $number,
 967                                                 N => $final,
 968                                                 E => defined $error_message ? "(ERROR: $error_message)" : '',
 969                                                 e => $error_message,
 970                                                 Q => $qual,
 971                                         );
 972 #::logDebug("labeling, subst=" . ::uneval(\%subst));
 973                 $subst{D} = errmsg($subst{D});
 974                 if($opt->{output_options}) {
 975                         for(qw/ D E F f /) {
 976                                 next unless $subst{$_};
 977                                 $subst{$_} =~ s/,/&#44;/g;
 978                         }
 979                 }
 980                 $label =~ s/(%(.))/exists $subst{$2} ? $subst{$2} : $1/eg;
 981 #::logDebug("label intermediate: $label");
 982                 $label =~ s/(\$O{(.*?)})/$o->{$2}/eg;
 983 #::logDebug("label returning: $label");
 984                 return $label;
 985         }
 986
 987         # If we got here, the mode and quantity fit was not found
 988         $Vend::Session->{ship_message} ||= '';
 989         my $fmt = "No match found for mode '%s', quantity '%s', ";
 990         $fmt .= "qualifier '%s', " if $qual;
 991         $fmt .= "returning 0.";
 992         $Vend::Session->{ship_message} .= errmsg($fmt, $mode, $total, $qual);
 993         return undef;
 994 }
 995
 996 sub tag_handling {
 997         my ($mode, $opt) = @_;
 998         $opt = { noformat => 1, convert => 1 } unless $opt;
 999
1000         if($opt->{default}) {
1001                 undef $opt->{default}
1002                         if tag_shipping( undef, {handling => 1});
1003         }
1004
1005         $opt->{handling} = 1;
1006         if(! $mode) {
1007                 $mode = $::Values->{mv_handling} || undef;
1008         }
1009         return tag_shipping($mode, $opt);
1010 }
1011
1012 sub tag_shipping {
1013         my($mode, $opt) = @_;
1014         $opt = { noformat => 1, convert => 1 } unless $opt;
1015
1016         return resolve_shipmode($mode, $opt)
1017                 if $opt->{possible} || $opt->{resolve} || $opt->{check_validity};
1018
1019         $Ship_its = 0;
1020         if(! $mode) {
1021                 if($opt->{widget} || $opt->{label}) {
1022                         $mode = resolve_shipmode(undef, { no_set => $opt->{no_set}, possible => 1});
1023                 }
1024                 else {
1025                         $mode = $opt->{handling}
1026                                         ? ($::Values->{mv_handling})
1027                                         : ($::Values->{mv_shipmode} || 'default');
1028                 }
1029         }
1030
1031         my $loc = $Vend::Cfg->{Shipping_repository}
1032                         && $Vend::Cfg->{Shipping_repository}{default};
1033         $loc ||= {};
1034
1035         $Vend::Cfg->{Shipping_line} = []
1036                 if $opt->{reset_modes};
1037         read_shipping(undef, $opt) if $Vend::Cfg->{SQL_shipping};
1038         read_shipping(undef, $opt) if $opt->{add};
1039         read_shipping($opt->{file}) if $opt->{file};
1040         my $out;
1041
1042 #::logDebug("Shipping mode(s) $mode");
1043         my (@modes) = grep /\S/, split /[\s,\0]+/, $mode;
1044         if($opt->{default}) {
1045                 undef $opt->{default}
1046                         if tag_shipping($::Values->{mv_shipmode});
1047         }
1048         if($opt->{label} || $opt->{widget}) {
1049                 my @out;
1050                 if($opt->{widget}) {
1051                         $opt->{label} = 1;
1052                         $opt->{output_options} = 1;
1053                 }
1054                 for(@modes) {
1055                         my $return = shipping($_, $opt);
1056 #::logDebug("pushing $return");
1057                         #push @out, shipping($_, $opt);
1058                         push @out, $return;
1059                 }
1060                 @out = grep /=.+/, @out;
1061
1062                 if(! @out and ! $opt->{hide_error}) {
1063                         my $message = $loc->{no_modes_message} || 'Not enough information';
1064                         @out = "=" . errmsg($message);
1065                 }
1066
1067                 if($opt->{widget}) {
1068                         my $o = { %$opt };
1069                         $o->{type} = delete $o->{widget};
1070                         $o->{passed} = join ",", @out;
1071                         $o->{name} ||= 'mv_shipmode';
1072                         $o->{value} ||= $::Values->{mv_shipmode};
1073                         $out = Vend::Form::display($o);
1074                 }
1075                 else {
1076                         $out = join "", @out;
1077                 }
1078         }
1079         else {
1080                 ### If the user has assigned to shipping or handling,
1081                 ### we use their value
1082                 if($Vend::Session->{assigned}) {
1083                         my $tag = $opt->{handling} ? 'handling' : 'shipping';
1084                         $out = $Vend::Session->{assigned}{$tag}
1085                                 if defined $Vend::Session->{assigned}{$tag}
1086                                 && length( $Vend::Session->{assigned}{$tag});
1087                 }
1088                 ### If no assignment has been made, we read the shipmodes
1089                 ### and use their value
1090                 unless (defined $out) {
1091                         $out = 0;
1092                         for(@modes) {
1093                                 $out += shipping($_, $opt) || 0;
1094                         }
1095                 }
1096                 $out = Vend::Util::round_to_frac_digits($out);
1097                 ## Conversion would have been done above, force to 0, as
1098                 ## found by Frederic Steinfels
1099                 $out = currency($out, $opt->{noformat}, 0, $opt);
1100         }
1101         return $out unless $opt->{hide};
1102         return;
1103 }
1104
1105 sub tag_ups {
1106         my($type,$zip,$weight,$code,$opt) = @_;
1107         my(@data);
1108         my(@fieldnames);
1109         my($i,$point,$zone);
1110
1111         $weight += $opt->{packaging_weight} if $opt->{packaging_weight};
1112
1113         if($opt->{source_grams}) {
1114                 $weight *= 0.00220462;
1115         }
1116         elsif($opt->{source_kg}) {
1117                 $weight *= 2.20462;
1118         }
1119         elsif($opt->{source_oz}) {
1120                 $weight /= 16;
1121         }
1122
1123         if($opt->{oz}) {
1124                 $weight *= 16;
1125         }
1126
1127 #::logDebug("tag_ups: type=$type zip=$zip weight=$weight code=$code opt=" . uneval($opt));
1128
1129         if(my $modulo = $opt->{aggregate}) {
1130                 $modulo = 150 if $modulo < 10;
1131                 if($weight > $modulo) {
1132                         my $cost = 0;
1133                         my $w = $weight;
1134                         while($w > $modulo) {
1135                                 $w -= $modulo;
1136                                 $cost += tag_ups($type, $zip, $modulo, $code, $opt);
1137                         }
1138                         $cost += tag_ups($type, $zip, $w, $code, $opt);
1139                         return $cost;
1140                 }
1141         }
1142
1143         $code = 'u' unless $code;
1144
1145         unless (defined $Vend::Database{$type}) {
1146                 logError("Shipping lookup called, no database table named '%s'", $type);
1147                 return undef;
1148         }
1149         unless (ref $Vend::Cfg->{Shipping_zone}{$code}) {
1150                 logError("Shipping '%s' lookup called, no zone defined", $code);
1151                 return undef;
1152         }
1153         my $zref = $Vend::Cfg->{Shipping_zone}{$code};
1154
1155         unless (defined $zref->{zone_data}) {
1156                 logError("$zref->{zone_name} lookup called, zone data not found");
1157                 return undef;
1158         }
1159
1160         my $zdata = $zref->{zone_data};
1161         # UPS doesn't like fractional pounds, rounds up
1162
1163         # here we can adapt for pounds/kg
1164         if ($zref->{mult_factor}) {
1165                 $weight = $weight * $zref->{mult_factor};
1166         }
1167         $weight = POSIX::ceil($weight);
1168
1169         unless($opt->{no_zip_process}) {
1170                 $zip =~ s/\W+//g;
1171                 $zip = uc $zip;
1172         }
1173
1174         my $rawzip = $zip;
1175
1176         my $country;
1177         if($opt->{country_prefix}) {
1178                 $country = $::Values->{country} || '';
1179                 $country = uc $country;
1180                 $country =~ s/\W+//g;
1181                 $country =~ m{^\w\w$}
1182                         or do {
1183                                 logDebug('Country code not present with country_prefix');
1184                                 return undef;
1185                         };
1186                 $zip = $country . ":" . $zip;
1187         }
1188         else {
1189                 $zip = substr($zip, 0, ($zref->{str_length} || 3));
1190         }
1191
1192         @fieldnames = split /\t/, $zdata->[0];
1193         for($i = 2; $i < @fieldnames; $i++) {
1194                 next unless $fieldnames[$i] eq $type;
1195                 $point = $i;
1196                 last;
1197         }
1198
1199         unless (defined $point) {
1200                 logError("Zone '%s' lookup failed, type '%s' not found", $code, $type)
1201                         unless $zref->{quiet};
1202                 return undef;
1203         }
1204
1205         my $eas_point;
1206         my $eas_zone;
1207         if($zref->{eas}) {
1208                 for($i = 2; $i < @fieldnames; $i++) {
1209                         next unless $fieldnames[$i] eq $zref->{eas};
1210                         $eas_point = $i;
1211                         last;
1212                 }
1213         }
1214
1215 #::logDebug("tag_ups looking in zone data.");
1216         my $zip_trimmed;
1217         for(@{$zdata}[1..$#{$zdata}]) {
1218                 @data = split /\t/, $_;
1219
1220                 unless($zip_trimmed) {
1221                         if ( $data[0] =~ m{^(([A-Z][A-Z]):)?(\w+)} and $2 eq $country ) {
1222                                 $zip = substr($zip, 0, length($1.$3));
1223                                 $zip_trimmed++;
1224                         }
1225                 }
1226
1227                 next unless ($zip ge $data[0] and $zip le $data[1]);
1228                 $zone = $data[$point];
1229                 $eas_zone = $data[$eas_point] if defined $eas_point;
1230                 return 0 unless $zone;
1231                 last;
1232         }
1233
1234         if (! defined $zone) {
1235                 $Vend::Session->{ship_message} .=
1236                         "No zone found for geo code $zip, type $type. ";
1237 #::logDebug("tag_ups no zone $zone.");
1238                 return undef;
1239         }
1240         elsif (!$zone or $zone eq '-') {
1241                 $Vend::Session->{ship_message} .=
1242                         "No $type shipping allowed for geo code $zip. ";
1243 #::logDebug("tag_ups empty zone $zone.");
1244                 return undef;
1245         }
1246
1247         my $cost;
1248         $cost =  tag_data($type,$zone,$weight);
1249         $cost += tag_data($type,$zone,$eas_zone)  if defined $eas_point;
1250         $Vend::Session->{ship_message} .=
1251                                                                 errmsg(
1252                                                                         "Zero cost returned for mode %s, geo code %s. ",
1253                                                                         $type,
1254                                                                         $zip,
1255                                                                 )
1256                 unless $cost;
1257 #::logDebug("tag_ups cost: $cost");
1258         if($cost > 0) {
1259                 if($opt->{surcharge_table}) {
1260                         $opt->{surcharge_field} ||= 'surcharge';
1261                         my $xarea = tag_data(
1262                                                         $opt->{surcharge_table},
1263                                                         $opt->{surcharge_field},
1264                                                         $rawzip);
1265                         $cost += $xarea if $xarea;
1266                 }
1267                 if($opt->{residential}) {
1268                         my $v = length($opt->{residential}) > 2
1269                                         ? $opt->{residential}
1270                                         : 'mv_ship_residential';
1271                         my $f = $opt->{residential_field} || 'res';
1272 #::logDebug("residential check, f=$f v=$v");
1273                         if( $Values->{$v} ) {
1274                                 my $rescharge = tag_data($type,$f,$weight);
1275 #::logDebug("residential check type=$type weight=$weight, rescharge: $rescharge");
1276                                 $cost += $rescharge if $rescharge;
1277                         }
1278                 }
1279         }
1280         return $cost;
1281 }
1282
1283 sub tag_shipping_desc {
1284         my $mode =      shift;
1285         my $key = shift || 'description';
1286         $mode = $mode || $::Values->{mv_shipmode} || 'default';
1287         return errmsg($Vend::Cfg->{Shipping_hash}{$mode}{$key});
1288 }
1289
1290 =head1 NAME
1291
1292 Vend::Ship -- Shipping module for Interchange
1293
1294 =head1 DESCRIPTION
1295
1296 The behavior of this module is described in the Interchange documentation.
1297
1298 =head1 AUTHOR
1299
1300 Mike Heins, mike@perusion.net
1301
1302 =cut
1303 1;