[interchange-cvs] interchange - heins modified 5 files
interchange-core@icdevgroup.org
interchange-core@icdevgroup.org
Tue May 13 15:06:01 2003
User: heins
Date: 2003-05-13 19:05:18 GMT
Modified: lib/Vend Config.pm Interpolate.pm
Modified: scripts interchange.PL
Modified: code/UserTag ups_query.tag
Added: lib/Vend Ship.pm
Log:
* Break out shipping stuff from Vend::Interpolate. Add stubs so
custom code doesn't break.
* Add ability to put custom shipping modules in, called with
"cost" field of "s Module".
* Improve [ups-query ...] to aggregate shipments and cache prior
lookups.
* Document [ups-query].
Revision Changes Path
2.114 +37 -2 interchange/lib/Vend/Config.pm
rev 2.114, prev_rev 2.113
Index: Config.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Config.pm,v
retrieving revision 2.113
retrieving revision 2.114
diff -u -r2.113 -r2.114
--- Config.pm 5 May 2003 21:06:46 -0000 2.113
+++ Config.pm 13 May 2003 19:05:18 -0000 2.114
@@ -1,6 +1,6 @@
# Vend::Config - Configure Interchange
#
-# $Id: Config.pm,v 2.113 2003/05/05 21:06:46 racke Exp $
+# $Id: Config.pm,v 2.114 2003/05/13 19:05:18 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
# Copyright (C) 2003 ICDEVGROUP <interchange@icdevgroup.org>
@@ -48,7 +48,7 @@
use Vend::File;
use Vend::Data;
-$VERSION = substr(q$Revision: 2.113 $, 10);
+$VERSION = substr(q$Revision: 2.114 $, 10);
my %CDname;
my %CPname;
@@ -2426,6 +2426,41 @@
}
}
$C->{Options} = $o->{default} || $o->{Simple};
+ },
+ Shipping => sub {
+ my $o = $C->{Shipping_repository} ||= {};
+
+ my @base = qw/Postal/;
+ my %base;
+ @base{@base} = @base;
+
+ my %seen;
+ my @types = grep !$seen{$_}, keys %$o, @base;
+
+ for(@types) {
+ my $loc = $o->{$_} ||= {};
+ eval "require Vend::Ship::$_;";
+ if($@) {
+ my $msg = $@;
+ config_warn(
+ "Unable to use options type %s, no module. Error: %s",
+ $_,
+ $msg,
+ );
+ undef $o->{$_};
+ next;
+ }
+ eval {
+ my $name = "Vend::Ship::${_}::Default";
+ no strict;
+ while(my ($k,$v) = each %{"$name"}) {
+ next unless $k;
+ next if exists $loc->{$k};
+ $loc->{$k} = $v;
+ }
+ };
+ }
+ $C->{Shipping} = $o->{default} || $o->{Postal};
},
UserDB => sub {
shift;
2.167 +11 -960 interchange/lib/Vend/Interpolate.pm
rev 2.167, prev_rev 2.166
Index: Interpolate.pm
===================================================================
RCS file: /var/cvs/interchange/lib/Vend/Interpolate.pm,v
retrieving revision 2.166
retrieving revision 2.167
diff -u -r2.166 -r2.167
--- Interpolate.pm 13 May 2003 14:04:50 -0000 2.166
+++ Interpolate.pm 13 May 2003 19:05:18 -0000 2.167
@@ -1,6 +1,6 @@
# Vend::Interpolate - Interpret Interchange tags
#
-# $Id: Interpolate.pm,v 2.166 2003/05/13 14:04:50 mheins Exp $
+# $Id: Interpolate.pm,v 2.167 2003/05/13 19:05:18 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.com>
#
@@ -27,7 +27,7 @@
require Exporter;
@ISA = qw(Exporter);
-$VERSION = substr(q$Revision: 2.166 $, 10);
+$VERSION = substr(q$Revision: 2.167 $, 10);
@EXPORT = qw (
@@ -104,16 +104,6 @@
use Vend::Parse;
use POSIX qw(ceil strftime);
-use constant MAX_SHIP_ITERATIONS => 100;
-use constant MODE => 0;
-use constant DESC => 1;
-use constant CRIT => 2;
-use constant MIN => 3;
-use constant MAX => 4;
-use constant COST => 5;
-use constant QUERY => 6;
-use constant OPT => 7;
-
use vars qw(%Data_cache);
my $wantref = 1;
@@ -2895,15 +2885,6 @@
return '';
}
-# Returns the shipping description.
-
-sub tag_shipping_desc {
- my $mode = shift;
- $mode = $mode || $::Values->{mv_shipmode} || 'default';
- return '' unless defined $Vend::Cfg->{Shipping_desc}{$mode};
- return errmsg($Vend::Cfg->{Shipping_desc}{$mode});
-}
-
sub tag_calc {
my($body) = @_;
my $result;
@@ -5173,316 +5154,14 @@
$subtotal;
}
-my %Ship_remap = ( qw/
- CRITERION CRIT
- CRITERIA CRIT
- MAXIMUM MAX
- MINIMUM MIN
- PRICE COST
- QUALIFIER QUAL
- CODE PERL
- SUB PERL
- UPS_TYPE TABLE
- DESCRIPTION DESC
- ZIP GEO
- LOOKUP TABLE
- DEFAULT_ZIP DEFAULT_GEO
- SQL QUERY
- /);
-
-sub make_three {
- my ($zone, $len) = @_;
- $len = 3 if ! $len;
- while ( length($zone) < $len ) {
- $zone = "0$zone";
- }
- return $zone;
-}
-
-%Ship_handler = (
- TYPE =>
- sub {
- my ($v,$k) = @_;
- $$v =~ s/^(.).*/$1/;
- $$v = lc $$v;
- $$k = 'COST';
- }
- ,
-);
-
-sub read_shipping {
- my ($file, $opt) = @_;
- $opt = {} unless $opt;
- my($code, $desc, $min, $criterion, $max, $cost, $mode);
-
- if ($file) {
- #nada
- }
- elsif($opt->{add} or $Vend::Cfg->{Variable}{MV_SHIPPING}) {
- $file = "$Vend::Cfg->{ScratchDir}/shipping.asc";
- Vend::Util::writefile(">$file", $opt->{add} || $Vend::Cfg->{Variable}{MV_SHIPPING});
- }
- else {
- $file = $Vend::Cfg->{Special}{'shipping.asc'}
- || Vend::Util::catfile($Vend::Cfg->{ProductDir},'shipping.asc');
- }
-
- my @flines = split /\n/, readfile($file);
- if ($Vend::Cfg->{CustomShipping} =~ /^select\s+/i) {
- ($Vend::Cfg->{SQL_shipping} = 1, return)
- if $Global::Foreground;
- my $ary;
- my $query = interpolate_html($Vend::Cfg->{CustomShipping});
- eval {
- $ary = query($query, { wantarray => 1} );
- };
- if(! ref $ary) {
- logError("Could not make shipping query %s: %s" ,
- $Vend::Cfg->{CustomShipping},
- $@);
- return undef;
- }
- my $out;
- for(@$ary) {
- push @flines, join "\t", @$_;
- }
- }
-
- $Vend::Cfg->{Shipping_desc} = {}
- if ! $Vend::Cfg->{Shipping_desc};
- my %seen;
- my $append = '00000';
- my @line;
- my $prev = '';
- my $waiting;
- my @shipping;
- my $first;
- for(@flines) {
-
- # Strip CR, we hope
- s/\s+$//;
-
- # Handle continued lines
- if(s/\\$//) {
- $prev .= $_;
- next;
- }
- elsif($waiting) {
- if($_ eq $waiting) {
- undef $waiting;
- $_ = $prev;
- $prev = '';
- s/\s+$//;
- }
- else {
- $prev .= "$_\n";
- next;
- }
- }
- elsif($prev) {
- $_ = "$prev$_";
- $prev = '';
- }
-
- if (s/<<(\w+)$//) {
- $waiting = $1;
- $prev .= $_;
- next;
- }
-
- next unless /\S/;
- s/\s+$//;
- if(/^[^\s:]+\t/) {
- push (@shipping, [@line]) if @line;
- @line = split(/\t/, $_);
- $Vend::Cfg->{Shipping_desc}->{$line[0]} = $line[1]
- unless $seen{$line[0]}++;
- push @shipping, [@line];
- @line = ();
- }
- elsif(/^(\w+)\s*:\s*(.*)/s) {
- push (@shipping, [@line]) if @line;
- @line = ($1, $2, 'quantity', 0, 999999999, 0);
- $first = 1;
- $Vend::Cfg->{Shipping_desc}->{$line[0]} = $line[1]
- unless $seen{$line[0]}++;
- next;
- }
- elsif(/^\s+min(?:imum)?\s+(\S+)/i) {
- my $min = $1;
- if ($first) {
- undef $first;
- $line[MIN] = $min;
- }
- else {
- push @shipping, [ @line ];
- $line[MIN] = $min;
- if(ref $line[OPT]) {
- my $ref = $line[OPT];
- $line[OPT] = { %$ref };
- }
-
- }
- }
- else {
- no strict 'refs';
- s/^\s+//;
- my($k, $v) = split /\s+/, $_, 2;
- my $prospect;
- $k = uc $k;
- $k = $Ship_remap{$k}
- if defined $Ship_remap{$k};
- $Ship_handler{$k}->(\$v, \$k, \@line)
- if defined $Ship_handler{$k};
- eval {
- if(defined &{"$k"}) {
- $line[&{"$k"}] = $v;
- }
- else {
- $line[OPT] = {} unless $line[OPT];
- $k = lc $k;
- $line[OPT]->{$k} = $v;
- }
- };
- logError(
- "bad shipping index %s for mode %s in $file",
- $k,
- $line[0],
- ) if $@;
- }
- }
-
- push @shipping, [ @line ]
- if @line;
-
- if($waiting) {
- logError(
- "Failed to find end-of-line termination '%s' in shipping read",
- $waiting,
- );
- }
-
- my $row;
- my %zones;
- my %def_opts;
- $def_opts{PriceDivide} = 1 if $Vend::Cfg->{Locale};
-
- foreach $row (@shipping) {
- my $cost = $row->[COST];
- my $o = get_option_hash($row->[OPT]);
- for(keys %def_opts) {
- $o->{$_} = $def_opts{$_}
- unless defined $o->{$_};
- }
- $row->[OPT] = $o;
- my $zone;
- if ($cost =~ s/^\s*o\s+//) {
- $o = get_option_hash($cost);
- %def_opts = %$o;
- }
- elsif ($zone = $o->{zone} or $cost =~ s/^\s*c\s+(\w+)\s*//) {
- $zone = $1 if ! $zone;
- next if defined $zones{$zone};
- my $ref;
- if ($o->{zone}) {
- $ref = {};
- my @common = qw/
- mult_factor
- str_length
- zone_data
- zone_file
- zone_name
- /;
- @{$ref}{@common} = @{$o}{@common};
- $ref->{zone_name} = $zone
- if ! $ref->{zone_name};
- }
- elsif ($cost =~ /^{[\000-\377]+}$/ ) {
- eval { $ref = eval $cost };
- }
- else {
- $ref = {};
- my($name, $file, $length, $multiplier) = split /\s+/, $cost;
- $ref->{zone_name} = $name || undef;
- $ref->{zone_file} = $file if $file;
- $ref->{mult_factor} = $multiplier if defined $multiplier;
- $ref->{str_length} = $length if defined $length;
- }
- if ($@
- or ref($ref) !~ /HASH/
- or ! $ref->{zone_name}) {
- logError(
- "Bad shipping configuration for mode %s, skipping.",
- $row->[MODE]
- );
- $row->[MODE] = 'ERROR';
- next;
- }
- $ref->{zone_key} = $zone;
- $ref->{str_length} = 3 unless defined $ref->{str_length};
- $zones{$zone} = $ref;
- }
- }
-
- if($Vend::Cfg->{UpsZoneFile} and ! defined $Vend::Cfg->{Shipping_zone}{'u'} ) {
- $zones{'u'} = {
- zone_file => $Vend::Cfg->{UpsZoneFile},
- zone_key => 'u',
- zone_name => 'UPS',
- };
- }
- UPSZONE: {
- for (keys %zones) {
- my $ref = $zones{$_};
- if (! $ref->{zone_data}) {
- $ref->{zone_file} = Vend::Util::catfile(
- $Vend::Cfg->{ProductDir},
- "$ref->{zone_name}.csv",
- ) if ! $ref->{zone_file};
- $ref->{zone_data} = readfile($ref->{zone_file});
- }
- unless ($ref->{zone_data}) {
- logError( "Bad shipping file for zone '%s', lookup disabled.",
- $ref->{zone_key},
- );
- next;
- }
- my (@zone) = grep /\S/, split /[\r\n]+/, $ref->{zone_data};
- shift @zone while @zone and $zone[0] !~ /^(Postal|Dest.*Z)/;
- if($zone[0] =~ /^Postal/) {
- $zone[0] =~ s/,,/,/;
- for(@zone[1 .. $#zone]) {
- s/,/-/;
- }
- }
- if($zone[0] !~ /\t/) {
- my $len = $ref->{str_length} || 3;
- @zone = grep /\S/, @zone;
- @zone = grep /^[^"]/, @zone;
- $zone[0] =~ s/[^\w,]//g;
- $zone[0] =~ s/^\w+/low,high/;
- @zone = grep /,/, @zone;
- $zone[0] =~ s/\s*,\s*/\t/g;
-my $i = 1;
- for(@zone[1 .. $#zone]) {
- s/^\s*(\w+)\s*,/make_three($1, $len) . ',' . make_three($1, $len) . ','/e;
- s/^\s*(\w+)\s*-\s*(\w+),/make_three($1, $len) . ',' . make_three($2, $len) . ','/e;
- s/\s*,\s*/\t/g;
- }
- }
- $ref->{zone_data} = \@zone;
- }
- }
- for (keys %zones) {
- $Vend::Cfg->{Shipping_zone}{$_} = $zones{$_};
- }
- $Vend::Cfg->{Shipping_line} = []
- if ! $Vend::Cfg->{Shipping_line};
- unshift @{$Vend::Cfg->{Shipping_line}}, @shipping;
- 1;
-}
-
-*custom_shipping = \&shipping;
+# Stubs for relocated shipping stuff in case of legacy code
+*read_shipping = \&Vend::Ship::read_shipping;
+*custom_shipping = \&Vend::Ship::shipping;
+*tag_shipping_desc = \&Vend::Ship::tag_shipping_desc;
+*shipping = \&Vend::Ship::shipping;
+*tag_handling = \&Vend::Ship::tag_handling;
+*tag_shipping = \&Vend::Ship::tag_shipping;
+*tag_ups = \&Vend::Ship::tag_ups;
# Sets the value of a scratchpad field
sub set_scratch {
@@ -5658,412 +5337,6 @@
return;
}
-sub shipping {
- my($mode, $opt) = @_;
- return undef unless $mode;
- my $save = $Vend::Items;
- my $qual;
- my $final;
-
- $Vend::Session->{ship_message} = '' if ! $Ship_its;
- die "Too many levels of shipping recursion ($Ship_its)"
- if $Ship_its++ > MAX_SHIP_ITERATIONS;
- my @bin;
-
-#::logDebug("Check BEGIN, must get to FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
- if ($opt->{cart}) {
- my @carts = grep /\S/, split /[\s,]+/, $opt->{cart};
- for(@carts) {
- next unless $::Carts->{$_};
- push @bin, @{$::Carts->{$_}};
- }
- }
- else {
- @bin = @$Vend::Items;
- }
-#::logDebug("doing shipping, mode=$mode bin=" . uneval(\@bin));
-
- $Vend::Session->{ship_message} = '' if $opt->{reset_message};
-
- my($field, $code, $i, $total, $cost, $multiplier, $formula, $error_message);
-
-# my $ref = $Vend::Cfg;
-#
-# if(defined $Vend::Cfg->{Shipping_criterion}->{$mode}) {
-# $ref = $Vend::Cfg;
-# }
-# elsif($Vend::Cfg->{Shipping}) {
-# my $locale = $::Scratch->{mv_currency}
-# || $::Scratch->{mv_locale}
-# || $::Vend::Cfg->{DefaultLocale}
-# || 'default';
-# $ref = $Vend::Cfg->{Shipping}{$locale};
-# $field = $ref->{$mode};
-# }
-#
-# if(defined $ref->{Shipping_code}{$mode}) {
-# $final = tag_perl($opt->{table}, $opt, $Vend::Cfg->{Shipping_code});
-# goto SHIPFORMAT;
-# }
-
- $@ = 1;
-
- # Security hole if we don't limit characters
- $mode !~ /[\s,;{}]/ and
- eval {'what' =~ /$mode/};
-
- if ($@) {
-#::logDebug("Check ERROR, must get to FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
- logError("Bad character(s) in shipping mode '$mode', returning 0");
- goto SHIPFORMAT;
- }
-
- my $row;
- my @lines;
- @lines = grep $_->[0] =~ /^$mode/, @{$Vend::Cfg->{Shipping_line}};
- goto SHIPFORMAT unless @lines;
-#::logDebug("shipping lines selected: " . uneval(\@lines));
- my $q;
- if($lines[0][QUERY]) {
- my $q = interpolate_html($lines[0][QUERY]);
- $q =~ s/=\s+?\s*/= '$mode' /g;
- $q =~ s/\s+like\s+?\s*/ LIKE '%$mode%' /ig;
- my $ary = query($q, { wantarray => 1 });
- if(ref $ary) {
- @lines = @$ary;
-#::logDebug("shipping lines reselected with SQL: " . uneval(\@lines));
- }
- else {
-#::logDebug("shipping lines failed reselect with SQL query '$q'");
- }
- }
-
- my $o = get_option_hash($lines[0][OPT]) || {};
-
-#::logDebug("shipping opt=" . uneval($o));
-
- if($o->{limit}) {
- $o->{filter} = '(?i)\s*[1ty]' if ! $o->{filter};
-#::logDebug("limiting, filter=$o->{filter} limit=$o->{limit}");
- my $patt = qr{$o->{filter}};
- @bin = grep $_->{$o->{limit}} =~ $patt, @bin;
- }
- $::Carts->{mv_shipping} = \@bin;
-
- tag_cart('mv_shipping');
-
-#::logDebug("Check 2, must get to FINAL. Vend::Items=" . uneval($Vend::Items) . " main=" . uneval($::Carts->{main}) . " mv_shipping=" . uneval($::Carts->{mv_shipping}));
-
- if($o->{perl}) {
- $Vend::Interpolate::Shipping = $lines[0];
- $field = $lines[0][CRIT];
- $field = tag_perl($opt->{tables}, $opt, $field)
- if $field =~ /[^\w:]/;
- $qual = tag_perl($opt->{tables}, $opt, $o->{qual})
- if $o->{qual};
- }
- elsif ($o->{mml}) {
- $Vend::Interpolate::Shipping = $lines[0];
- $field = tag_perl($opt->{tables}, $opt, $lines[0][CRIT]);
- $qual = tag_perl($opt->{tables}, $opt, $o->{qual})
- if $o->{qual};
- }
- elsif($lines[0][CRIT] =~ /[[\s]|__/) {
- ($field, $qual) = split /\s+/, interpolate_html($lines[0][CRIT]), 2;
- if($qual =~ /{}/) {
- logError("Bad qualification code '%s', returning 0", $qual);
- goto SHIPFORMAT;
- }
- }
- else {
- $field = $lines[0][CRIT];
- }
-
- goto SHIPFORMAT unless $field;
-
- # See if the field needs to be returned by a Interchange function.
- # If a space is encountered, a qualification code
- # will be set up, with any characters after the first space
- # used to determine geography or other qualifier for the mode.
-
- # Uses the quantity on the order form if the field is 'quantity',
- # otherwise goes to the database.
- $total = 0;
-
- if($field =~ /^[\d.]+$/) {
-#::logDebug("Is a number selection");
- $total = $field;
- }
- elsif($field eq 'quantity') {
-#::logDebug("quantity selection");
- foreach $i (0 .. $#$Vend::Items) {
- $total = $total + $Vend::Items->[$i]->{$field};
- }
- }
- elsif ( index($field, ':') != -1) {
-#::logDebug("outboard field selection");
- my ($base, $field) = split /:+/, $field;
- my $db = database_exists_ref($base);
- unless ($db and db_column_exists($db,$field) ) {
- logError("Bad shipping field '$field' or table '$base'. Returning 0");
- goto SHIPFORMAT;
- }
- foreach $i (0 .. $#$Vend::Items) {
- my $item = $Vend::Items->[$i];
- $total += (database_field($base, $item->{code}, $field) || 0) *
- $item->{quantity};
- }
- }
- else {
-#::logDebug("standard field selection");
- my $use_modifier;
-
- if ($::Variable->{MV_SHIP_MODIFIERS}){
- my @pieces = grep {$_ = quotemeta $_} split(/[\s,|]+/,$::Variable->{MV_SHIP_MODIFIERS});
- my $regex = join('|',@pieces);
- $use_modifier = 1 if ($regex && $field =~ /^($regex)$/);
- }
-
- my $col_checked = 0;
- foreach my $item (@$Vend::Items){
- my $value;
- if ($use_modifier && defined $item->{$field}){
- $value = $item->{$field};
- }else{
- unless ($col_checked++ || column_exists $field){
- logError("Custom shipping field '$field' doesn't exist. Returning 0");
- $total = 0;
- goto SHIPFORMAT;
- }
- my $base = $item->{mv_ib} || $Vend::Cfg->{ProductFiles}[0];
- $value = tag_data($base, $field, $item->{code});
- }
- $total += ($value * $item->{quantity});
- }
- }
-
- # We will LAST this loop and go to SHIPFORMAT if a match is found
- SHIPIT:
- foreach $row (@lines) {
-#::logDebug("processing mode=$row->[MODE] field=$field total=$total min=$row->[MIN] max=$row->[MAX]");
-
- next unless $total <= $row->[MAX] and $total >= $row->[MIN];
-
- if($qual) {
- next unless
- $row->[CRIT] =~ m{(^|\s)$qual(\s|$)} or
- $row->[CRIT] !~ /\S/;
- }
-
- $o = get_option_hash($row->[OPT], $o)
- if $row->[OPT];
- # unless field begins with 'x' or 'f', straight cost is returned
- # - otherwise the quantity is multiplied by the cost or a formula
- # is applied
- my $what = $row->[COST];
- if($what !~ /^[a-zA-Z]\w+$/) {
- $what =~ s/^\s+//;
- $what =~ s/[ \t\r]+$//;
- }
- if($what =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+))$/) {
- $final += $1;
- last SHIPIT unless $o->{continue};
- }
- elsif ($what =~ /^f\s*(.*)/i) {
- $formula = $o->{formula} || $1;
- $formula =~ s/\@\@TOTAL\@\\?\@/$total/ig;
- $formula = interpolate_html($formula)
- if $formula =~ /__\w+__|\[\w/;
- $cost = $Vend::Interpolate::ready_safe->reval($formula);
- if($@) {
- $error_message = errmsg(
- "Shipping mode '%s': bad formula. Returning 0.",
- $mode,
- );
- logError($error_message);
- last SHIPIT;
- }
- $final += $cost;
- last SHIPIT unless $o->{continue};
- }
- elsif ($what =~ /^>>(\w+)/) {
- my $newmode = $1;
- local($opt->{redirect_from});
- $opt->{redirect_from} = $mode;
- return shipping($newmode, $opt);
- }
- elsif ($what eq 'x') {
- $final += ($o->{multiplier} * $total);
- last SHIPIT unless $o->{continue};
- }
- elsif ($what =~ s/^x\s*(-?[\d.]+)\s*$/$1/) {
- $final += ($what * $total);
- last SHIPIT unless $o->{continue};
- }
- elsif ($what =~ s/^([uA-Z])\s*//) {
- my $zselect = $o->{zone} || $1;
- my ($type, $geo, $adder, $mod, $sub);
- ($type, $adder) = @{$o}{qw/table adder/};
- $o->{geo} ||= 'zip';
- if(! $type) {
- $what = interpolate_html($what);
- ($type, $geo, $adder, $mod, $sub) = split /\s+/, $what, 5;
- $o->{adder} = $adder;
- $o->{round} = 1 if $mod =~ /round/;
- $o->{at_least} = $1 if $mod =~ /min\s*([\d.]+)/;
- }
- else {
- $geo = $::Values->{$o->{geo}} || $o->{default_geo};
- }
-#::logDebug("ready to tag_ups type=$type geo=$geo total=$total zone=$zselect options=$o");
- $cost = tag_ups($type,$geo,$total,$zselect,$o);
- $final += $cost;
- last SHIPIT unless $o->{continue};
- }
- elsif ($what =~ s/^([im])\s*//) {
- my $select = $1;
- $what =~ s/\@\@TOTAL\@\@/$total/g;
- my ($item, $field, $sum);
- my (@items) = @{$Vend::Items};
- my @fields = split /\s+/, $qual;
- if ($select eq 'm') {
- $sum = { code => $mode, quantity => $total };
- }
- foreach $item (@items) {
- for(@fields) {
- if(s/(.*):+//) {
- $item->{$_} = tag_data($1, $_, $item->{code});
- }
- else {
- $item->{$_} = product_field($_, $item->{code});
- }
- $sum->{$_} += $item->{$_} if defined $sum;
- }
- }
- @items = ($sum) if defined $sum;
- for(@items) {
- $cost = Vend::Data::chain_cost($_, $what);
- if($cost =~ /[A-Za-z]/) {
- $cost = shipping($cost);
- }
- $final += $cost;
- }
- last SHIPIT unless $o->{continue};
- }
- elsif ($what =~ s/^e\s*//) {
- $error_message = $what;
- $error_message =~ s/\@\@TOTAL\@\@/$total/ig;
- $final = 0 unless $final;
- last SHIPIT unless $o->{continue};
- }
- else {
- $error_message = errmsg( "Unknown shipping call '%s'", $what);
- undef $final;
- last SHIPIT;
- }
- }
-
- if ($final == 0 and $o->{'next'}) {
- return shipping($o->{'next'}, $opt);
- }
- elsif(defined $o->{additional}) {
- my @extra = grep /\S/, split /[\s\0,]+/, $row->[OPT]->{additional};
- for(@extra) {
- $final += shipping($_, {});
- }
- }
-
-#::logDebug("Check 3, must get to FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
-
-
- SHIPFORMAT: {
- $Vend::Session->{ship_message} .= $error_message
- if defined $error_message;
- undef $::Carts->{mv_shipping};
- $Vend::Items = $save;
-#::logDebug("Check FINAL. Vend::Items=$Vend::Items main=$::Carts->{main}");
- last SHIPFORMAT unless defined $final;
-#::logDebug("ship options: " . uneval($o) );
- $final /= $Vend::Cfg->{PriceDivide}
- if $o->{PriceDivide} and $Vend::Cfg->{PriceDivide} != 0;
- unless ($o->{free}) {
- return '' if $final == 0;
- $o->{adder} =~ s/\bx\b/$final/g;
- $o->{adder} =~ s/\@\@TOTAL\@\\?\@/$final/g;
- $o->{adder} = $ready_safe->reval($o->{adder});
- $final += $o->{adder} if $o->{adder};
- $final = POSIX::ceil($final) if is_yes($o->{round});
- if($o->{at_least}) {
- $final = $final > $o->{at_least} ? $final : $o->{at_least};
- }
- }
- if($opt->{default}) {
- if(! $opt->{handling}) {
- $::Values->{mv_shipmode} = $mode;
- }
- else {
- $::Values->{mv_handling} = $mode;
- }
- undef $opt->{default};
- }
- return $final unless $opt->{label};
- my $number;
- if($o->{free} and $final == 0) {
- $number = $opt->{free} || $o->{free};
-#::logDebug("This is free, mode=$mode number=$number");
- }
- else {
- return $final unless $opt->{label};
-#::logDebug("actual options: " . uneval($o));
- $number = Vend::Util::currency(
- $final,
- $opt->{noformat},
- );
- }
-
- $opt->{format} ||= '%M=%D (%F)' if $opt->{output_options};
-
- my $label = $opt->{format} || '<OPTION VALUE="%M"%S>%D (%F)';
- my $sel = $::Values->{mv_shipmode} eq $mode;
-#::logDebug("label start: $label");
- my %subst = (
- '%' => '%',
- M => $opt->{redirect_from} || $mode,
- T => $total,
- S => $sel ? ' SELECTED' : '',
- C => $sel ? ' CHECKED' : '',
- D => $row->[DESC] || $Vend::Cfg->{Shipping_desc}{$mode},
- L => $row->[MIN],
- H => $row->[MAX],
- O => '$O',
- F => $number,
- N => $final,
- E => defined $error_message ? "(ERROR: $error_message)" : '',
- e => $error_message,
- Q => $qual,
- );
-#::logDebug("labeling, subst=" . ::uneval(\%subst));
- $subst{D} = errmsg($subst{D});
- if($opt->{output_options}) {
- for(qw/ D E F f /) {
- next unless $subst{$_};
- $subst{$_} =~ s/,/,/g;
- }
- }
- $label =~ s/(%(.))/exists $subst{$2} ? $subst{$2} : $1/eg;
-#::logDebug("label intermediate: $label");
- $label =~ s/(\$O{(.*?)})/$o->{$2}/eg;
-#::logDebug("label returning: $label");
- return $label;
- }
-
- # If we got here, the mode and quantity fit was not found
- $Vend::Session->{ship_message} .=
- "No match found for mode '$mode', quantity '$total', " .
- ($qual ? "qualifier '$qual', " : '') .
- "returning 0. ";
- return undef;
-}
sub taxable_amount {
my($cart) = @_;
@@ -6112,91 +5385,6 @@
return $taxable;
}
-sub tag_handling {
- my ($mode, $opt) = @_;
- $opt = { noformat => 1, convert => 1 } unless $opt;
-
- if($opt->{default}) {
- undef $opt->{default}
- if tag_shipping( undef, {handling => 1});
- }
-
- $opt->{handling} = 1;
- if(! $mode) {
- $mode = $::Values->{mv_handling} || undef;
- }
- return tag_shipping($mode, $opt);
-}
-
-sub tag_shipping {
- my($mode, $opt) = @_;
- $opt = { noformat => 1, convert => 1 } unless $opt;
- $Ship_its = 0;
- if(! $mode) {
- $mode = $opt->{handling}
- ? ($::Values->{mv_handling})
- : ($::Values->{mv_shipmode} || 'default');
- }
- $Vend::Cfg->{Shipping_line} = []
- if $opt->{reset_modes};
- read_shipping(undef, $opt) if $Vend::Cfg->{SQL_shipping};
- read_shipping(undef, $opt) if $opt->{add};
- read_shipping($opt->{file}) if $opt->{file};
- my $out;
-
-
- my (@modes) = grep /\S/, split /[\s,\0]+/, $mode;
- if($opt->{default}) {
- undef $opt->{default}
- if tag_shipping($::Values->{mv_shipmode});
- }
- if($opt->{label} || $opt->{widget}) {
- my @out;
- if($opt->{widget}) {
- $opt->{label} = 1;
- $opt->{output_options} = 1;
- }
- for(@modes) {
- push @out, shipping($_, $opt);
- }
- @out = grep /=.+/, @out;
- if($opt->{widget}) {
- my $o = { %$opt };
- $o->{type} = delete $o->{widget};
- $o->{passed} = join ",", @out;
- $o->{name} ||= 'mv_shipmode';
- $o->{value} ||= $::Values->{mv_shipmode};
- $out = Vend::Form::display($o);
- }
- else {
- $out = join "", @out;
- }
- }
- else {
- ### If the user has assigned to shipping or handling,
- ### we use their value
- if($Vend::Session->{assigned}) {
- my $tag = $opt->{handling} ? 'handling' : 'shipping';
- $out = $Vend::Session->{assigned}{$tag}
- if defined $Vend::Session->{assigned}{$tag}
- && length( $Vend::Session->{assigned}{$tag});
- }
- ### If no assignment has been made, we read the shipmodes
- ### and use their value
- unless (defined $out) {
- $out = 0;
- for(@modes) {
- $out += shipping($_, $opt) || 0;
- }
- }
- $out = Vend::Util::round_to_frac_digits($out);
- ## Conversion would have been done above, force to 0, as
- ## found by Frederic Steinfels
- $out = currency($out, $opt->{noformat}, 0, $opt);
- }
- return $out unless $opt->{hide};
- return;
-}
sub fly_tax {
@@ -6562,144 +5750,6 @@
return $total;
}
-sub tag_ups {
- my($type,$zip,$weight,$code,$opt) = @_;
- my(@data);
- my(@fieldnames);
- my($i,$point,$zone);
-
-#::logDebug("tag_ups: type=$type zip=$zip weight=$weight code=$code opt=" . uneval($opt));
-
- if(my $modulo = $opt->{aggregate}) {
- $modulo = 150 if $modulo < 10;
- if($weight > $modulo) {
- my $cost = 0;
- my $w = $weight;
- while($w > $modulo) {
- $w -= $modulo;
- $cost += tag_ups($type, $zip, $modulo, $code, $opt);
- }
- $cost += tag_ups($type, $zip, $w, $code, $opt);
- return $cost;
- }
- }
-
- $code = 'u' unless $code;
-
-
- unless (defined $Vend::Database{$type}) {
- logError("Shipping lookup called, no database table named '%s'", $type);
- return undef;
- }
- unless (ref $Vend::Cfg->{Shipping_zone}{$code}) {
- logError("Shipping '%s' lookup called, no zone defined", $code);
- return undef;
- }
- my $zref = $Vend::Cfg->{Shipping_zone}{$code};
-
- unless (defined $zref->{zone_data}) {
- logError("$zref->{zone_name} lookup called, zone data not found");
- return undef;
- }
-
- my $zdata = $zref->{zone_data};
- # UPS doesn't like fractional pounds, rounds up
-
- # here we can adapt for pounds/kg
- if ($zref->{mult_factor}) {
- $weight = $weight * $zref->{mult_factor};
- }
- $weight = POSIX::ceil($weight);
-
- unless($opt->{no_zip_process}) {
- $zip =~ s/\W+//g;
- $zip = uc $zip;
- }
-
- my $rawzip = $zip;
-
- $zip = substr($zip, 0, ($zref->{str_length} || 3));
-
- @fieldnames = split /\t/, $zdata->[0];
- for($i = 2; $i < @fieldnames; $i++) {
- next unless $fieldnames[$i] eq $type;
- $point = $i;
- last;
- }
-
- unless (defined $point) {
- logError("Zone '$code' lookup failed, type '$type' not found");
- return undef;
- }
-
- my $eas_point;
- my $eas_zone;
- if($zref->{eas}) {
- for($i = 2; $i < @fieldnames; $i++) {
- next unless $fieldnames[$i] eq $zref->{eas};
- $eas_point = $i;
- last;
- }
- }
-
-#::logDebug("tag_ups looking in zone data.");
- for(@{$zdata}[1..$#{$zdata}]) {
- @data = split /\t/, $_;
- next unless ($zip ge $data[0] and $zip le $data[1]);
- $zone = $data[$point];
- $eas_zone = $data[$eas_point] if defined $eas_point;
- return 0 unless $zone;
- last;
- }
-
- if (! defined $zone) {
- $Vend::Session->{ship_message} .=
- "No zone found for geo code $zip, type $type. ";
-#::logDebug("tag_ups no zone $zone.");
- return undef;
- }
- elsif (!$zone or $zone eq '-') {
- $Vend::Session->{ship_message} .=
- "No $type shipping allowed for geo code $zip.";
-#::logDebug("tag_ups empty zone $zone.");
- return undef;
- }
-
- my $cost;
- $cost = tag_data($type,$zone,$weight);
- $cost += tag_data($type,$zone,$eas_zone) if defined $eas_point;
- $Vend::Session->{ship_message} .=
- errmsg(
- "Zero cost returned for mode %s, geo code %s.",
- $type,
- $zip,
- )
- unless $cost;
-#::logDebug("tag_ups cost: $cost");
- if($cost > 0) {
- if($opt->{surcharge_table}) {
- $opt->{surcharge_field} ||= 'surcharge';
- my $xarea = tag_data(
- $opt->{surcharge_table},
- $opt->{surcharge_field},
- $rawzip);
- $cost += $xarea if $xarea;
- }
- if($opt->{residential}) {
- my $v = length($opt->{residential}) > 2
- ? $opt->{residential}
- : 'mv_ship_residential';
- my $f = $opt->{residential_field} || 'res';
-#::logDebug("residential check, f=$f v=$v");
- if( $Values->{$v} ) {
- my $rescharge = tag_data($type,$f,$weight);
-#::logDebug("residential check type=$type weight=$weight, rescharge: $rescharge");
- $cost += $rescharge if $rescharge;
- }
- }
- }
- return $cost;
-}
sub levy_sum {
my ($set, $levies, $repos) = @_;
@@ -6909,4 +5959,5 @@
undef $Vend::Levying;
return $run;
}
+
1;
2.1 interchange/lib/Vend/Ship.pm
rev 2.1, prev_rev 2.0
2.72 +2 -1 interchange/scripts/interchange.PL
rev 2.72, prev_rev 2.71
Index: interchange.PL
===================================================================
RCS file: /var/cvs/interchange/scripts/interchange.PL,v
retrieving revision 2.71
retrieving revision 2.72
diff -u -r2.71 -r2.72
--- interchange.PL 26 Apr 2003 15:00:51 -0000 2.71
+++ interchange.PL 13 May 2003 19:05:18 -0000 2.72
@@ -3,7 +3,7 @@
#
# Interchange version 4.9.7
#
-# $Id: interchange.PL,v 2.71 2003/04/26 15:00:51 mheins Exp $
+# $Id: interchange.PL,v 2.72 2003/05/13 19:05:18 mheins Exp $
#
# Copyright (C) 1996-2002 Red Hat, Inc. and others.
# http://www.icdevgroup.org/
@@ -239,6 +239,7 @@
use Vend::Session;
use Vend::Config;
use Vend::Payment;
+use Vend::Ship;
# You might try commenting out these lines and uncommenting the ones
# below to compact memory size
1.3 +203 -5 interchange/code/UserTag/ups_query.tag
rev 1.3, prev_rev 1.2
Index: ups_query.tag
===================================================================
RCS file: /var/cvs/interchange/code/UserTag/ups_query.tag,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ups_query.tag 1 Feb 2002 04:50:41 -0000 1.2
+++ ups_query.tag 13 May 2003 19:05:18 -0000 1.3
@@ -1,7 +1,9 @@
UserTag ups-query Order mode origin zip weight country
+UserTag ups-query addAttr
UserTag ups-query Routine <<EOR
sub {
- my( $mode, $origin, $zip, $weight, $country) = @_;
+ my( $mode, $origin, $zip, $weight, $country, $opt) = @_;
+ $opt ||= {};
BEGIN {
eval {
require Business::UPS;
@@ -16,15 +18,107 @@
$zip = $::Values->{$::Variable->{UPS_POSTCODE_FIELD}}
if ! $zip;
+ my $modulo = $opt->{aggregate};
+
+ if($modulo and $modulo < 10) {
+ $modulo = $::Variable->{UPS_QUERY_MODULO} || 150;
+ }
+ elsif(! $modulo) {
+ $modulo = 9999999;
+ }
+
$country = uc $country;
# In the U.S., UPS only wants the 5-digit base ZIP code, not ZIP+4
$country eq 'US' and $zip =~ /^(\d{5})/ and $zip = $1;
-#::logGlobal("calling with: " . join("|", $mode, $origin, $zip, $weight, $country));
- my ($shipping, $zone, $error) =
- getUPS( $mode, $origin, $zip, $weight, $country);
-#::logGlobal("received back: " . join("|", $shipping, $zone, $error));
+::logGlobal("calling with: " . join("|", $mode, $origin, $zip, $weight, $country,$modulo));
+
+ my $cache;
+ my $cache_code;
+ my $db;
+ my $now;
+ my $updated;
+ my %cline;
+ my $shipping;
+ my $zone;
+ my $error;
+
+ my $ctable = $opt->{cache_table} || 'ups_cache';
+
+
+ if($Vend::Database{$ctable}) {
+ $Vend::WriteDatabase{$ctable} = 1;
+ CACHE: {
+ $db = dbref($ctable)
+ or last CACHE;
+ my $tname = $db->name();
+ $cache = 1;
+ %cline = (
+ weight => $weight,
+ origin => $origin,
+ country => $country,
+ zip => $zip,
+ shipmode => $mode,
+ );
+
+ my @items;
+ # reverse sort makes zip first
+ for(reverse sort keys %cline) {
+ push @items, "$_ = " . $db->quote($cline{$_}, $_);
+ }
+
+ my $string = join " AND ", @items;
+ my $q = qq{SELECT code,cost,updated from $tname WHERE $string};
+ my $ary = $db->query($q);
+ if($ary and $ary->[0] and $cache_code = $ary->[0][0]) {
+ $shipping = $ary->[0][1];
+ $updated = $ary->[0][2];
+ $now = time();
+ if($now - $updated > 86000) {
+ undef $shipping;
+ $updated = $now;
+ }
+ if($shipping <= 0) {
+ $error = $shipping;
+ $updated = $now;
+ $shipping = 0;
+ }
+ }
+ }
+ }
+
+ my $w = $weight;
+ my $maxcost;
+ my $tmpcost;
+
+ unless(defined $shipping) {
+ $shipping = 0;
+ while($w > $modulo) {
+ $w -= $modulo;
+ if($maxcost) {
+ $shipping += $maxcost;
+ next;
+ }
+
+ ($maxcost, $zone, $error) = getUPS( $mode, $origin, $zip, $modulo, $country);
+ if($error) {
+ $Vend::Session->{ship_message} .= " $mode: $error";
+ return 0;
+ }
+ $shipping += $maxcost;
+ }
+
+ undef $error;
+ ($tmpcost, $zone, $error) = getUPS( $mode, $origin, $zip, $w, $country);
+
+ $shipping += $tmpcost;
+ if($cache) {
+ $cline{updated} = $now || time();
+ $cline{cost} = $shipping || $error;
+ $db->set_slice($cache_code, \%cline);
+ }
+ }
if($error) {
$Vend::Session->{ship_message} .= " $mode: $error";
@@ -34,3 +128,107 @@
}
EOR
+UserTag ups-query Documentation <<EOD
+
+=head1 NAME
+
+ups-query tag -- calculate UPS costs via www
+
+=head1 SYNOPSIS
+
+ [ups-query
+ weight=NNN
+ origin=45056*
+ zip=61821*
+ country=US*
+ mode=MODE
+ aggregate=N*
+ ]
+
+=head1 DESCRIPTION
+
+Calculates UPS costs via the WWW using Business::UPS.
+
+Options:
+
+=over 4
+
+=item weight
+
+Weight in pounds. (required)
+
+=item mode
+
+Any valid Business::UPS mode (required). Example: 1DA,2DA,GNDCOM
+
+=item origin
+
+Origin zip code. Default is $Variable->{UPS_ORIGION}.
+
+=item zip
+
+Destination zip code. Default $Values->{zip}.
+
+=item country
+
+Destination country. Default $Values->{country}.
+
+=item aggregate
+
+If 1, aggregates by a call to weight=150 (or $Variable->{UPS_QUERY_MODULO}).
+Multiplies that times number necessary, then runs a call for the
+remainder. In other words:
+
+ [ups-query weight=400 mode=GNDCOM aggregate=1]
+
+is equivalent to:
+
+ [calc]
+ [ups-query weight=150 mode=GNDCOM] +
+ [ups-query weight=150 mode=GNDCOM] +
+ [ups-query weight=100 mode=GNDCOM];
+ [/calc]
+
+If set to a number above 10, will be the modulo to do repeated calls by. So:
+
+ [ups-query weight=400 mode=GNDCOM aggregate=100]
+
+is equivalent to:
+
+ [calc]
+ [ups-query weight=100 mode=GNDCOM] +
+ [ups-query weight=100 mode=GNDCOM] +
+ [ups-query weight=100 mode=GNDCOM] +
+ [ups-query weight=100 mode=GNDCOM];
+ [/calc]
+
+=item cache_table
+
+Set to the name of a table (default ups_cache) which can cache the
+calls so repeated calls for the same values will not require repeated
+calls to UPS.
+
+Table needs to be set up with:
+
+ Database ups_cache ship/ups_cache.txt __SQLDSN__
+ Database ups_cache AUTO_SEQUENCE ups_cache_seq
+ Database ups_cache DEFAULT_TYPE varchar(12)
+ Database ups_cache INDEX weight origin zip shipmode country
+
+And have the fields:
+
+ code weight origin zip country shipmode cost updated
+
+Typical cached data will be like:
+
+ code weight origin zip country shipmode cost updated
+ 14 11 45056 99501 US 2DA 35.14 1052704130
+ 15 11 45056 99501 US 1DA 57.78 1052704130
+ 16 11 45056 99501 US 2DA 35.14 1052704132
+ 17 11 45056 99501 US 1DA 57.78 1052704133
+
+Cache expires in one day.
+
+=back
+
+EOD