[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/,/&#44;/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