# Vend::Interpolate - Interpret Interchange tags # # Copyright (C) 2002-2021 Interchange Development Group # Copyright (C) 1996-2002 Red Hat, Inc. # # This program was originally based on Vend 0.2 and 0.3 # Copyright 1995 by Andrew M. Wilcox # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public # License along with this program; if not, write to the Free # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, # MA 02110-1301 USA. package Vend::Interpolate; require Exporter; @ISA = qw(Exporter); $VERSION = '2.316'; @EXPORT = qw ( interpolate_html subtotal tag_data tag_attr_list $Tag $CGI $Session $Values $Discounts $Sub ); =head1 NAME Vend::Interpolate -- Interchange tag interpolation routines =head1 SYNOPSIS (no external use) =head1 DESCRIPTION The Vend::Interpolate contains the majority of the Interchange Tag Language implementation rouines. Historically, it contained the entire tag language implementation for MiniVend, accounting for its name. It contains most of the handler routines pointed to by Vend::Parse, which accepts the parsing output of Vend::Parser. (Vend::Parser was originally based on HTML::Parser 1.x). There are two interpolative parsers in Vend::Interpolate, iterate_array_list() and iterate_hash_list() -- these routines parse the lists used in the widely employed [loop ..], [search-region ...], [item-list], and [query ..] ITL tag constructs. This module makes heavy use of precompiled regexes. You will notice variables being used in the regular expression constructs. For example, C<$All> is a a synonym for C<(?s:.)*>, C<$Some> is equivalent to C<(?s:.)*?>, etc. This is not only for clarity of the regular expression, but for speed. =cut # SQL push @EXPORT, 'tag_sql_list'; # END SQL use Vend::Safe; my $hole; BEGIN { eval { require Safe::Hole; $hole = new Safe::Hole; }; } # We generally know when we are testing these things, but be careful no warnings qw(uninitialized numeric); use strict; use Vend::Util; use Vend::File; use Vend::Data; use Vend::Form; require Vend::Cart; use HTML::Entities; use Vend::Server; use Vend::Scan; use Vend::Tags; use Vend::Subs; use Vend::Document; use Vend::Parse; use POSIX qw(ceil strftime LC_CTYPE); use vars qw(%Data_cache); my $wantref = 1; # MVASP my @Share_vars; my @Share_routines; BEGIN { @Share_vars = qw/ $s $q $item $CGI_array $CGI $Discounts $Document %Db $DbSearch %Filter $Search $Carts $Config %Sql $Items $Row $Scratch $Shipping $Session $Tag $Tmp $TextSearch $Values $Variable $Sub /; @Share_routines = qw/ &tag_data &errmsg &Log &Debug &uneval &get_option_hash &dotted_hash &encode_entities &HTML &interpolate_html /; } use vars @Share_vars, @Share_routines, qw/$ready_safe $safe_safe $always_global $loop_calc/; use vars qw/%Filter %Ship_handler $Safe_data/; $ready_safe = new Vend::Safe; $ready_safe->trap(qw/:base_io/); $ready_safe->untrap(qw/sort ftfile/); sub reset_calc { #::logDebug("reset_state=$Vend::Calc_reset -- resetting calc from " . caller); if(! $Global::Foreground and $Vend::Cfg->{ActionMap}{_mvsafe}) { #::logDebug("already made"); $ready_safe = $Vend::Cfg->{ActionMap}{_mvsafe}; } else { my $pkg = 'MVSAFE' . int(rand(100000)); undef $MVSAFE::Safe; $ready_safe = new Vend::Safe $pkg; $ready_safe->share_from('MVSAFE', ['$safe']); #::logDebug("new safe made=$ready_safe->{Root}"); $ready_safe->trap(@{$Global::SafeTrap}); $ready_safe->untrap(@{$Global::SafeUntrap}); no strict 'refs'; $Document = new Vend::Document; *Log = \&Vend::Util::logError; *Debug = \&Vend::Util::logDebug; *uneval = \&Vend::Util::uneval_it; *HTML = \&Vend::Document::HTML; $ready_safe->share(@Share_vars, @Share_routines); $DbSearch = new Vend::DbSearch; $TextSearch = new Vend::TextSearch; $Tag = new Vend::Tags; $Sub = new Vend::Subs; } $always_global = $Global::PerlAlwaysGlobal->{$Vend::Cat}; $loop_calc = $always_global ? sub { tag_perl('', {}, @_) }: \&tag_calc; $Tmp = {}; undef $s; undef $q; undef $item; %Db = (); %Sql = (); undef $Shipping; $Vend::Calc_reset = 1; undef $Vend::Calc_initialized; return $ready_safe; } sub init_calc { #::logDebug("reset_state=$Vend::Calc_reset init_state=$Vend::Calc_initialized -- initting calc from " . caller); reset_calc() unless $Vend::Calc_reset; $CGI_array = \%CGI::values_array; $CGI = \%CGI::values; $Carts = $::Carts; $Discounts = $::Discounts; $Items = $Vend::Items; $Config = $Vend::Cfg; $Scratch = $::Scratch; $Values = $::Values; $Session = $Vend::Session; $Search = $::Instance->{SearchObject} ||= {}; $Variable = $::Variable; $Vend::Calc_initialized = 1; return; } # Define conditional ops my %cond_op = ( eq => sub { $_[0] eq $_[1] }, ne => sub { $_[0] ne $_[1] }, gt => sub { $_[0] gt $_[1] }, ge => sub { $_[0] ge $_[1] }, le => sub { $_[0] le $_[1] }, lt => sub { $_[0] lt $_[1] }, '>' => sub { $_[0] > $_[1] }, '<' => sub { $_[0] < $_[1] }, '>=' => sub { $_[0] >= $_[1] }, '<=' => sub { $_[0] <= $_[1] }, '==' => sub { $_[0] == $_[1] }, '!=' => sub { $_[0] != $_[1] }, '=~' => sub { my $re; $_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:; $2 and substr($_[1], 0, 0) = "(?$2)"; eval { $re = qr/$_[1]/ }; if($@) { logError("bad regex %s in if-PREFIX-data", $_[1]); return undef; } return $_[0] =~ $re; }, '!~' => sub { my $re; $_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:; $2 and substr($_[1], 0, 0) = "(?$2)"; eval { $re = qr/$_[1]/ }; if($@) { logError("bad regex %s in if-PREFIX-data", $_[1]); return undef; } return $_[0] !~ $re; }, 'filter' => sub { my ($string, $filter) = @_; my $newval = filter_value($filter, $string); return $string eq $newval ? 1 : 0; }, 'length' => sub { my ($string, $lenspec) = @_; my ($min,$max) = split /-/, $lenspec; if($min and length($string) < $min) { return 0; } elsif($max and length($string) > $max) { return 0; } else { return 0 unless length($string) > 0; } return 1; }, ); my %file_op = ( A => sub { -A $_[0] }, B => sub { -B $_[0] }, d => sub { -d $_[0] }, e => sub { -e $_[0] }, f => sub { -f $_[0] }, g => sub { -g $_[0] }, l => sub { -l $_[0] }, M => sub { -M $_[0] }, r => sub { -r $_[0] }, s => sub { -s $_[0] }, T => sub { -T $_[0] }, u => sub { -u $_[0] }, w => sub { -w $_[0] }, x => sub { -x $_[0] }, ); $cond_op{len} = $cond_op{length}; # Regular expression pre-compilation my %T; my %QR; my $All = '(?s:.)*'; my $Some = '(?s:.)*?'; my $Codere = '[-\w#/.]+'; my $Coderex = '[-\w:#=/.%]+'; my $Filef = '(?:%20|\s)+([^]]+)'; my $Mandx = '\s+([-\w:#=/.%]+)'; my $Mandf = '(?:%20|\s)+([-\w#/.]+)'; my $Spacef = '(?:%20|\s)+'; my $Spaceo = '(?:%20|\s)*'; my $Optx = '\s*([-\w:#=/.%]+)?'; my $Optr = '(?:\s+([^]]+))?'; my $Mand = '\s+([-\w#/.]+)'; my $Opt = '\s*([-\w#/.]+)?'; my $T = '\]'; my $D = '[-_]'; my $XAll = qr{(?s:.)*}; my $XSome = qr{(?s:.)*?}; my $XCodere = qr{[-\w#/.]+}; my $XCoderex = qr{[-\w:#=/.%]+}; my $XMandx = qr{\s+([-\w:#=/.%]+)}; my $XMandf = qr{(?:%20|\s)+([-\w#/.]+)}; my $XSpacef = qr{(?:%20|\s)+}; my $XSpaceo = qr{(?:%20|\s)*}; my $XOptx = qr{\s*([-\w:#=/.%]+)?}; my $XMand = qr{\s+([-\w#/.]+)}; my $XOpt = qr{\s*([-\w#/.]+)?}; my $XD = qr{[-_]}; my $Gvar = qr{\@\@([A-Za-z0-9]\w+[A-Za-z0-9])\@\@}; my $Evar = qr{\@_([A-Za-z0-9]\w+[A-Za-z0-9])_\@}; my $Cvar = qr{__([A-Za-z0-9]\w*?[A-Za-z0-9])__}; my @th = (qw! /_alternate /_calc /_change /_exec /_filter /_header_param /_last /_modifier /_next /_param /_pos /_sub /col /comment /condition /else /elsif /more_list /no_match /on_match /sort /then _accessories _alternate _calc _change _code _common _data _description _discount _exec _field _filter _header_param _include _increment _last _line _match _modifier _next _options _param _parent _pos _price _quantity _sku _subtotal _sub col comment condition discount_price _discount_price _discount_subtotal _difference else elsif matches match_count _modifier_name more more_list no_match on_match _quantity_name sort then ! ); my $shown = 0; my $tag; for (@th) { $tag = $_; s/([A-Za-z0-9])/[\u$1\l$1]/g; s/[-_]/[-_]/g; $T{$tag} = $_; next if $tag =~ m{^_}; $T{$tag} = "\\[$T{$tag}"; next unless $tag =~ m{^/}; $T{$tag} = "$T{$tag}\]"; } %QR = ( '/_alternate' => qr($T{_alternate}\]), '/_calc' => qr($T{_calc}\]), '/_change' => qr([-_]change\s+)i, '/_data' => qr($T{_data}\]), '/_exec' => qr($T{_exec}\]), '/_field' => qr($T{_field}\]), '/_filter' => qr($T{_filter}\]), '/_last' => qr($T{_last}\]), '/_modifier' => qr($T{_modifier}\]), '/_next' => qr($T{_next}\]), '/_pos' => qr($T{_pos}\]), '/_sub' => qr($T{_sub}\]), '_accessories' => qr($T{_accessories}($Spacef[^\]]+)?\]), '_alternate' => qr($T{_alternate}$Opt\]($Some)), '_calc' => qr($T{_calc}\]($Some)), '_exec' => qr($T{_exec}$Mand\]($Some)), '_filter' => qr($T{_filter}\s+($Some)\]($Some)), '_sub' => qr($T{_sub}$Mand\]($Some)), '_change' => qr($T{_change}$Mand$Opt\] \s* $T{condition}\] ($Some) $T{'/condition'} ($Some))xi, '_code' => qr($T{_code}\]), '_sku' => qr($T{_sku}\]), 'col' => qr(\[col(?:umn)?\s+ ([^\]]+) \] ($Some) \[/col(?:umn)?\] )ix, 'comment' => qr($T{comment}(?:\s+$Some)?\] (?!$All$T{comment}\]) $Some $T{'/comment'})x, '_description' => qr($T{_description}\]), '_difference' => qr($T{_difference}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]), '_discount' => qr($T{_discount}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]), '_field_if' => qr($T{_field}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), '_field_if_wo' => qr($T{_field}$Spacef(!?)\s*($Codere$Optr)\]), '_field' => qr($T{_field}$Mandf\]), '_common' => qr($T{_common}$Mandf\]), '_include' => qr($T{_include}$Filef\]), '_increment' => qr($T{_increment}\]), '_last' => qr($T{_last}\]\s*($Some)\s*), '_line' => qr($T{_line}$Opt\]), '_next' => qr($T{_next}\]\s*($Some)\s*), '_options' => qr($T{_options}($Spacef[^\]]+)?\]), '_header_param' => qr($T{_header_param}$Mandf$Optr\]), '_header_param_if' => qr($T{_header_param}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), '_param_if' => qr((?:$T{_param}|$T{_modifier})(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), '_param' => qr((?:$T{_param}|$T{_modifier})$Mandf\]), '_parent_if' => qr($T{_parent}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), '_parent' => qr($T{_parent}$Mandf\]), '_pos_if' => qr($T{_pos}(\d*)$Spacef(!?)\s*(-?\d+)$Optr\]($Some)), '_pos' => qr($T{_pos}$Spacef(-?\d+)\]), '_price' => qr!$T{_price}(?:\s+(\d+))?$Optx\]!, '_quantity' => qr($T{_quantity}\]), '_subtotal' => qr($T{_subtotal}$Optx\]), '_tag' => qr([-_] tag [-_] ([-\w]+) \s+)x, 'condition' => qr($T{condition}$T($Some)$T{'/condition'}), 'condition_begin' => qr(^\s*$T{condition}\]($Some)$T{'/condition'}), '_discount_price' => qr($T{_discount_price}(?:\s+(\d+))?$Optx\]), 'discount_price' => qr($T{discount_price}(?:\s+(\d+))?$Optx\]), '_discount_subtotal' => qr($T{_discount_subtotal}$Optx\]), 'has_else' => qr($T{'/else'}\s*$), 'else_end' => qr($T{else}\]($All)$T{'/else'}\s*$), 'elsif_end' => qr($T{elsif}\s+($All)$T{'/elsif'}\s*$), 'matches' => qr($T{matches}\]), 'match_count' => qr($T{match_count}\]), 'more' => qr($T{more}\]), 'more_list' => qr($T{more_list}$Optx$Optx$Optx$Optx$Optx\]($Some)$T{'/more_list'}), 'no_match' => qr($T{no_match}\]($Some)$T{'/no_match'}), 'on_match' => qr($T{on_match}\]($Some)$T{'/on_match'}), '_quantity_name' => qr($T{_quantity_name}\]), '_modifier_name' => qr($T{_modifier_name}$Spacef(\w+)\]), 'then' => qr(^\s*$T{then}$T($Some)$T{'/then'}), ); FINTAG: { for(keys %T) { $QR{$_} = qr($T{$_}) if ! defined $QR{$_}; } } undef @th; undef %T; sub get_joiner { my ($joiner, $default) = @_; return $default unless defined $joiner and length $joiner; if($joiner eq '\n') { $joiner = "\n"; } elsif($joiner =~ m{\\}) { $joiner = $safe_safe->reval("qq{$joiner}"); } return length($joiner) ? $joiner : $default; } sub substitute_image { my ($text) = @_; ## Allow no substitution of downloads return if $::Pragma->{download}; ## If post_page routine processor returns true, return. Otherwise, ## continue image rewrite if($::Pragma->{post_page}) { Vend::Dispatch::run_macro($::Pragma->{post_page}, $text) and return; } unless ( $::Pragma->{no_image_rewrite} ) { my $dir = $CGI::secure ? ($Vend::Cfg->{ImageDirSecure} || $Vend::Cfg->{ImageDir}) : $Vend::Cfg->{ImageDir}; if ($dir) { $$text =~ s#(]*?src=")(?!\w+:)([^/'][^"]+)# $1 . $dir . $2#ige; $$text =~ s#(]*?background=")(?!\w+:)([^/'][^"]+)# $1 . $dir . $2#ige; $$text =~ s#(]*?background=")(?!\w+:)([^/'][^"]+)# $1 . $dir . $2#ige; } } if($Vend::Cfg->{ImageAlias}) { for (keys %{$Vend::Cfg->{ImageAlias}} ) { $$text =~ s#(]*?src=")($_)# $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige; $$text =~ s#(]*?background=")($_)# $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige; $$text =~ s#(]*?background=")($_)# $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige; } } } sub dynamic_var { my $varname = shift; return readfile($Vend::Cfg->{DirConfig}{Variable}{$varname}) if $Vend::Cfg->{DirConfig} and defined $Vend::Cfg->{DirConfig}{Variable}{$varname}; VARDB: { last VARDB if $::Pragma->{dynamic_variables_file_only}; last VARDB unless $Vend::Cfg->{VariableDatabase}; if($Vend::VarDatabase) { last VARDB unless $Vend::VarDatabase->record_exists($varname); return $Vend::VarDatabase->field($varname, 'Variable'); } else { $Vend::VarDatabase = database_exists_ref($Vend::Cfg->{VariableDatabase}) or undef $Vend::Cfg->{VariableDatabase}; redo VARDB; } } return $::Variable->{$varname}; } sub vars_and_comments { my $html = shift; ## We never want to interpolate vars if in restricted mode return if $Vend::restricted; local($^W) = 0; # Set whole-page pragmas from [pragma] tags 1 while $$html =~ s/\[pragma\s+(\w+)(?:\s+(\w+))?\]/ $::Pragma->{$1} = (length($2) ? $2 : 1), ''/ige; undef $Vend::PageInit unless $::Pragma->{init_page}; if(defined $Vend::PageInit and ! $Vend::PageInit++) { Vend::Dispatch::run_macro($::Pragma->{init_page}, $html); } # Substitute in Variable values $$html =~ s/$Gvar/$Global::Variable->{$1}/g; if($::Pragma->{dynamic_variables}) { $$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge and $$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge; $$html =~ s/$Cvar/dynamic_var($1)/ge; } else { $$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge and $$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge; $$html =~ s/$Cvar/$::Variable->{$1}/g; } if($::Pragma->{pre_page}) { Vend::Dispatch::run_macro($::Pragma->{pre_page}, $html); } # Strip out [comment] [/comment] blocks 1 while $$html =~ s%$QR{comment}%%go; # Translate Interchange tags embedded in HTML comments like ! $::Pragma->{no_html_comment_embed} and $$html =~ s/ $routine"); $Vend::Cfg->{Sub}{$name} = $sub; } my $oexec = { %$opt }; if($opt->{iterator}) { my $sub; $sub = $opt->{iterator} if ref($opt->{iterator}) eq 'CODE'; $sub ||= $Vend::Cfg->{Sub}{$opt->{iterator}} || $Global::GlobalSub->{$opt->{iterator}}; if(! $sub) { logError( "list iterator subroutine '%s' called but not defined. Skipping.", $opt->{iterator}, ); return ''; } for( ; $i <= $end ; $i++ ) { $r .= $sub->($text, $ary->[$i], $oexec); } return $r; } 1 while $text =~ s{(\[(if[-_]$Prefix[-_][a-zA-Z]+)(?=.*\[\2)\s.*\[/\2\])} { resolve_nested_if($1, $2) }se; # log helpful errors if any unknown field names are # used in if-prefix-param or prefix-param tags my @field_msg = ('error', "Unknown field name '%s' used in tag %s"); $run = $text; if(! $opt->{ignore_undefined}) { $run =~ s#$B$QR{_param}# defined $fh->{$1} || logOnce(@field_msg, $1, "$Orig_prefix-param") #ige; $run =~ s#$IB$QR{_param_if}# defined $fh->{$3} || logOnce(@field_msg, $3, "if-$Orig_prefix-param") #ige; } for( ; $i <= $end ; $i++, $count++ ) { $row = $ary->[$i]; last unless defined $row; $code = $row->[0]; #::logDebug("Doing $code substitution, count $count"); #::logDebug("Doing '" . substr($code, 0, index($code, "\n") + 1) . "' substitution, count $count"); $run = $text; $run =~ s#$B$QR{_alternate}$E$QR{'/_alternate'}# alternate($count, $1, $end, $page_start, $array_last) ? pull_else($2) : pull_if($2)#ige; 1 while $run =~ s#$IB$QR{_param_if}$IE[-_](?:param|modifier)\1\]# (defined $fh->{$3} ? $row->[$fh->{$3}] : '') ? pull_if($5,$2,$4,$row->[$fh->{$3}]) : pull_else($5,$2,$4,$row->[$fh->{$3}])#ige; $run =~ s#$B$QR{_param}#defined $fh->{$1} ? ed($row->[$fh->{$1}]) : ''#ige; 1 while $run =~ s#$IB$QR{_pos_if}$IE[-_]pos\1\]# $row->[$3] ? pull_if($5,$2,$4,$row->[$3]) : pull_else($5,$2,$4,$row->[$3])#ige; $run =~ s#$B$QR{_pos}#ed($row->[$1])#ige; #::logDebug("fh: " . uneval($fh) . uneval($row)) unless $once++; 1 while $run =~ s#$IB$QR{_field_if}$IE[-_]field\1\]# my $tmp = product_field($3, $code); $tmp ? pull_if($5,$2,$4,$tmp) : pull_else($5,$2,$4,$tmp)#ige; $run =~ s:$B$QR{_line}:join "\t", @{$row}[ ($1 || 0) .. $#$row]:ige; $run =~ s:$B$QR{_increment}:$count:ig; $run =~ s:$B$QR{_accessories}: $Ary_code{accessories}->($code,$1,{}):ige; $run =~ s:$B$QR{_options}: $Ary_code{options}->($code,$1):ige; $run =~ s:$B$QR{_code}:$code:ig; $run =~ s:$B$QR{_description}:ed($Ary_code{description}->($code)):ige; $run =~ s:$B$QR{_field}:ed($Ary_code{field}->($1, $code)):ige; $run =~ s:$B$QR{_common}:ed($Ary_code{common}->($1, $code)):ige; tag_labeled_data_row($code, \$run); $run =~ s!$B$QR{_price}! currency(product_price($code,$1), $2)!ige; 1 while $run =~ s!$B$QR{_change}$E$QR{'/_change'}\1\]! check_change($1,$3,undef,$2) ? pull_if($4) : pull_else($4)!ige; $run =~ s#$B$QR{_tag}($Some$E[-_]tag[-_]\1\])# tag_dispatch($1,$count, $row, $ary, $2)#ige; $run =~ s#$B$QR{_calc}$E$QR{'/_calc'}# unless ($Row) { $Row = {}; @{$Row}{@$fa} = @$row; } $loop_calc->($1) #ige; $run =~ s#$B$QR{_exec}$E$QR{'/_exec'}# init_calc() if ! $Vend::Calc_initialized; ( $Vend::Cfg->{Sub}{$1} || $Global::GlobalSub->{$1} || sub { logOnce('error', "subroutine $1 missing for PREFIX-exec"); errmsg('ERROR') } )->($2,$row,$oexec) #ige; $run =~ s#$B$QR{_filter}$E$QR{'/_filter'}#filter_value($1,$2)#ige; $run =~ s#$B$QR{_last}$E$QR{'/_last'}# my $tmp = $Ary_code{last}->($1); $tmp =~ s/^\s+//; $tmp =~ s/\s+$//; if($tmp && $tmp < 0) { last; } elsif($tmp) { $return = 1; } '' #ixge; $run =~ s#$B$QR{_next}$E$QR{'/_next'}# $Ary_code{next}->($1) != 0 ? (undef $Row, next) : '' #ixge; $run =~ s/($code); undef $Row; $r .= $run; last if $return; } return $r; } sub iterate_hash_list { my($i, $end, $count, $text, $hash, $opt_select, $opt) = @_; my $r = ''; $opt ||= {}; # Optimize for no-match, on-match, etc if(! $opt->{iterator} and $text !~ /\[/) { for(; $i <= $end; $i++) { $r .= $text; } return $r; } my $code_field = $opt->{code_field} || 'mv_sku'; my ($run, $code, $return, $item); my $nc = map_list_routines('HashCode', $opt); $nc and local(@Hash_code{keys %$nc}) = values %$nc; #::logDebug("iterating hash $i to $end. count=$count opt_select=$opt_select hash=" . uneval($hash)); $text =~ s{ $B$QR{_include} }{ my $filename = $1; $Data_cache{"/$filename"} or do { my $content = Vend::Util::readfile($filename); vars_and_comments(\$content); $Data_cache{"/$filename"} = $content; }; }igex; 1 while $text =~ s#$IB$QR{_header_param_if}$IE[-_]header[-_]param\1\]# (defined $opt->{$3} ? $opt->{$3} : '') ? pull_if($5,$2,$4,$opt->{$3}) : pull_else($5,$2,$4,$opt->{$3})#ige; $text =~ s#$B$QR{_header_param}#defined $opt->{$1} ? ed($opt->{$1}) : ''#ige; while($text =~ s#$B$QR{_sub}$E$QR{'/_sub'}##i) { my $name = $1; my $routine = $2; ## Not necessary? ## $Vend::Cfg->{Sub}{''} = sub { errmsg('undefined sub') } ## unless defined $Vend::Cfg->{Sub}{''}; $routine = 'sub { ' . $routine . ' }' unless $routine =~ /^\s*sub\s*{/; my $sub; eval { $sub = $ready_safe->reval($routine); }; if($@) { logError( errmsg("syntax error on %s-sub %s]: $@", $B, $name) ); $sub = sub { errmsg('ERROR') }; } $Vend::Cfg->{Sub}{$name} = $sub; } #::logDebug("subhidden: $opt->{subhidden}"); my $oexec = { %$opt }; if($opt->{iterator}) { my $sub; $sub = $opt->{iterator} if ref($opt->{iterator}) eq 'CODE'; $sub ||= $Vend::Cfg->{Sub}{$opt->{iterator}} || $Global::GlobalSub->{$opt->{iterator}}; if(! $sub) { logError( "list iterator subroutine '%s' called but not defined. Skipping.", $opt->{iterator}, ); return ''; } for( ; $i <= $end ; $i++ ) { $r .= $sub->($text, $hash->[$i], $oexec); } return $r; } 1 while $text =~ s{(\[(if[-_]$Prefix[-_][a-zA-Z]+)(?=.*\[\2)\s.*\[/\2\])} { resolve_nested_if($1, $2) }se; # undef the $Row object, as it should only be set as needed by [PREFIX-calc] undef $Row; for ( ; $i <= $end; $i++, $count++) { $item = $hash->[$i]; $item->{mv_ip} = $opt->{reverse} ? ($end - $i) : $i; if($opt->{modular}) { if($opt->{master}) { next unless $item->{mv_mi} eq $opt->{master}; } if($item->{mv_mp} and $item->{mv_si} and ! $opt->{subitems}) { # $r .= <{subhidden}; # #EOF next; } } $item->{mv_cache_price} = undef; $code = $item->{$code_field} || $item->{code}; $code = '' unless defined $code; #::logDebug("Doing $code (variant $item->{code}) substitution, count $count"); $run = $text; $run =~ s#$B$QR{_alternate}$E$QR{'/_alternate'}# alternate($i + 1, $1, $end) ? pull_else($2) : pull_if($2)#ge; tag_labeled_data_row($code,\$run); $run =~ s:$B$QR{_line}:join "\t", @{$hash}:ge; 1 while $run =~ s#$IB$QR{_param_if}$IE[-_](?:param|modifier)\1\]# $item->{$3} ? pull_if($5,$2,$4,$item->{$3}) : pull_else($5,$2,$4,$item->{$3})#ige; 1 while $run =~ s#$IB$QR{_parent_if}$IE[-_]parent\1\]# $item->{$3} ? pull_if($5,$2,$4,$opt->{$3}) : pull_else($5,$2,$4,$opt->{$3})#ige; 1 while $run =~ s#$IB$QR{_field_if}$IE[-_]field\1\]# my $tmp = item_field($item, $3); $tmp ? pull_if($5,$2,$4,$tmp) : pull_else($5,$2,$4,$tmp)#ge; $run =~ s:$B$QR{_increment}:$i + 1:ge; $run =~ s:$B$QR{_accessories}: $Hash_code{accessories}->($code,$1,{},$item):ge; $run =~ s:$B$QR{_options}: $Hash_code{options}->($item,$1):ige; $run =~ s:$B$QR{_sku}:$code:ig; $run =~ s:$B$QR{_code}:$item->{code}:ig; $run =~ s:$B$QR{_quantity}:$item->{quantity}:g; $run =~ s:$B$QR{_param}:ed($item->{$1}):ge; $run =~ s:$B$QR{_parent}:ed($opt->{$1}):ge; $run =~ s:$B$QR{_quantity_name}:quantity$item->{mv_ip}:g; $run =~ s:$B$QR{_modifier_name}:$1$item->{mv_ip}:g; $run =~ s!$B$QR{_subtotal}!currency(item_subtotal($item),$1)!ge; $run =~ s!$B$QR{_discount_subtotal}! currency( discount_subtotal($item), $1 )!ge; $run =~ s:$B$QR{_code}:$code:g; $run =~ s:$B$QR{_field}:ed($Hash_code{field}->($item, $1) || $item->{$1}):ge; $run =~ s:$B$QR{_common}:ed($Hash_code{common}->($item, $1) || $item->{$1}):ge; $run =~ s:$B$QR{_description}: ed($Hash_code{description}->($item) || $item->{description}) :ge; $run =~ s!$B$QR{_price}!currency(item_price($item,$1), $2)!ge; $run =~ s!$B$QR{_discount_price}! currency( discount_price($item, item_price($item,$1), $1 || 1) , $2 )!ge or $run =~ s!$QR{discount_price}! currency( discount_price($item, item_price($item,$1), $1 || 1) , $2 )!ge; $run =~ s!$B$QR{_difference}! currency( item_difference( $item->{code}, item_price($item, $item->{quantity}), $item->{quantity}, $item, ), $2, )!ge; $run =~ s!$B$QR{_discount}! currency( item_discount( $item->{code}, item_price($item, $item->{quantity}), $item->{quantity}, ), $2, )!ge; 1 while $run =~ s!$B$QR{_change}$E$QR{'/_change'}\1\]! check_change($1,$3,undef,$2) ? pull_if($4) : pull_else($4)!ige; $run =~ s#$B$QR{_tag}($Some$E[-_]tag[-_]\1\])# tag_dispatch($1,$count, $item, $hash, $2)#ige; $Row = $item; $run =~ s#$B$QR{_calc}$E$QR{'/_calc'}#$loop_calc->($1)#ige; $run =~ s#$B$QR{_exec}$E$QR{'/_exec'}# init_calc() if ! $Vend::Calc_initialized; ( $Vend::Cfg->{Sub}{$1} || $Global::GlobalSub->{$1} || sub { 'ERROR' } )->($2,$item,$oexec) #ige; $run =~ s#$B$QR{_filter}$E$QR{'/_filter'}#filter_value($1,$2)#ige; $run =~ s#$B$QR{_last}$E$QR{'/_last'}# my $tmp = interpolate_html($1); if($tmp && $tmp < 0) { last; } elsif($tmp) { $return = 1; } '' #ixge; $run =~ s#$B$QR{_next}$E$QR{'/_next'}# interpolate_html($1) != 0 ? next : '' #ixge; $run =~ s/($code); $r .= $run; undef $Row; #::logDebug("item $code mv_cache_price: $item->{mv_cache_price}"); delete $item->{mv_cache_price}; last if $return; } return $r; } sub error_opt { my ($opt, @args) = @_; return undef unless ref $opt; my $msg = errmsg(@args); $msg = "$opt->{error_id}: $msg" if $opt->{error_id}; if($opt->{log_error}) { logError($msg); } return $msg if $opt->{show_error}; return undef; } sub query { if(ref $_[0]) { unshift @_, ''; } my ($query, $opt, $text) = @_; $opt = {} if ! $opt; $opt->{prefix} = 'sql' unless $opt->{prefix}; if($opt->{more} and $Vend::More_in_progress) { undef $Vend::More_in_progress; return region($opt, $text); } $opt->{table} = $Vend::Cfg->{ProductFiles}[0] unless $opt->{table}; my $db = $Vend::Database{$opt->{table}} ; return $opt->{failure} if ! $db; $opt->{query} = $query if $query; $opt->{query} =~ s: \[\Q$opt->{prefix}\E[_-]quote\](.*?)\[/\Q$opt->{prefix}\E[_-]quote\] : $db->quote($1) :xisge; $opt->{query} =~ s{ \[\Q$opt->{prefix}\E[_-]quote[-_](ident(?:ifier)?)\](.*?)\[/\Q$opt->{prefix}\E[_-]quote[_-]\1\] }{ $db->quote_identifier($2) }xisge; if (! $opt->{wantarray} and ! defined $MVSAFE::Safe) { my $result = $db->query($opt, $text); return (ref $result) ? '' : $result; } $db->query($opt, $text); } sub html_table { my($opt, $ary, $na) = @_; if (!$na) { $na = [ split /\s+/, $opt->{columns} ]; } if(! ref $ary) { $ary =~ s/^\s+//; $ary =~ s/\s+$//; my $delimiter = quotemeta $opt->{delimiter} || "\t"; my $splittor = quotemeta $opt->{record_delim} || "\n"; my (@rows) = split /$splittor/, $ary; $na = [ split /$delimiter/, shift @rows ] if $opt->{th}; $ary = []; my $count = scalar @$na || -1; for (@rows) { push @$ary, [split /$delimiter/, $_, $count]; } } my ($tr, $td, $th, $fc, $fr) = @{$opt}{qw/tr td th fc fr/}; for($tr, $td, $th, $fc, $fr) { next unless defined $_; s/(.)/ $1/; } my $r = ''; $tr = '' if ! defined $tr; $td = '' if ! defined $td; if(! defined $th || $th and scalar @$na ) { $th = '' if ! defined $th; $r .= ""; for(@$na) { $r .= "$_"; } $r .= "\n"; } my $row; if($fr) { $r .= ""; my $val; $row = shift @$ary; if($fc) { $val = (shift @$row) || ' '; $r .= "$val"; } foreach (@$row) { $val = $_ || ' '; $r .= "$val"; } $r .= "\n"; } foreach $row (@$ary) { $r .= ""; my $val; if($fc) { $val = (shift @$row) || ' '; $r .= "$val"; } foreach (@$row) { $val = $_ || ' '; $r .= "$val"; } $r .= "\n"; } return $r; } # # Tests of above routines # #print html_table( { # td => "BGCOLOR=#FFFFFF", # }, #[ # [qw/ data1a data2a data3a/], # [qw/ data1b data2b data3b/], # [qw/ data1c data2c data3c/], #], #[ qw/cell1 cell2 cell3/ ], #); # #print html_table( { # td => "BGCOLOR=#FFFFFF", # columns => "cell1 cell2 cell3", # }, <{prefix} = 'sql' if ! defined $opt->{prefix}; $opt->{list_prefix} = 'sql[-_]list' if ! defined $opt->{prefix}; my $object = { mv_results => $ary, mv_field_hash => $nh, mv_return_fields => $na, mv_more_id => $opt->{mv_more_id}, matches => scalar @$ary, }; # Scans the option hash for more search settings if mv_more_alpha # is set in [query ...] tag.... if($opt->{ma}) { # Find the sort field and alpha options.... Vend::Scan::parse_profile_ref($object, $opt); # We need to turn the hash reference into a search object $object = new Vend::Search (%$object); # Delete this so it will meet conditions for creating a more delete $object->{mv_matchlimit}; } $opt->{object} = $object; return region($opt, $text); } # END SQL # Displays a search page with the special [search-list] tag evaluated. sub opt_region { my $opt = pop @_; my $new = { %$opt }; my $out = iterate_hash_list(@_,[$new]); $Prefix = $Orig_prefix; return $out; } sub region { my($opt,$page) = @_; my $obj; if($opt->{object}) { ### The caller supplies the object, no search to be done $obj = $opt->{object}; } else { ### We need to run a search to get an object my $c; if($CGI::values{mv_more_matches} || $CGI::values{MM}) { ### It is a more function, we need to get the parameters find_search_params(\%CGI::values); delete $CGI::values{mv_more_matches}; } elsif ($opt->{search}) { ### Explicit search in tag parameter, run just like any if($opt->{more} and $::Instance->{SearchObject}{''}) { $obj = $::Instance->{SearchObject}{''}; #::logDebug("cached search"); } else { $c = { mv_search_immediate => 1, mv_search_label => $opt->{label} || 'current', }; my $params = escape_scan($opt->{search}); Vend::Scan::find_search_params($c, $params); $c->{mv_no_more} = ! $opt->{more}; $obj = perform_search($c); } } else { ### See if we have a search already done for this label $obj = $::Instance->{SearchObject}{$opt->{label}}; } # If none of the above happen, we need to perform a search # based on the passed CGI parameters if(! $obj) { $obj = perform_search(); $obj = { mv_results => [], matches => 0, mv_search_error => [ errmsg('No search was found') ], } if ! $obj; } finish_search($obj); # Label it for future reference $::Instance->{SearchObject}{$opt->{label}} = $opt->{object} = $obj; } my $lprefix; my $mprefix; if($opt->{list_prefix}) { $lprefix = $opt->{list_prefix}; $mprefix = "(?:$opt->{list_prefix}-)?"; } elsif ($opt->{prefix}) { $lprefix = "(?:$opt->{prefix}-)?list"; $mprefix = "(?:$opt->{prefix}-)?"; } else { $lprefix = "list"; $mprefix = ""; } #::logDebug("region: opt:\n" . uneval($opt) . "\npage:" . substr($page,0,100)); my $save_more; if($opt->{ml} and ! defined $obj->{mv_matchlimit} ) { $obj->{mv_matchlimit} = $opt->{ml}; $obj->{mv_more_decade} = $opt->{md}; $obj->{matches} = scalar @{$obj->{mv_results}}; $obj->{mv_cache_key} = generate_key($opt->{query} || substr($page,0,100)); $obj->{mv_more_permanent} = $opt->{pm}; $obj->{mv_first_match} = $opt->{fm} if $opt->{fm}; $obj->{mv_search_page} = $opt->{sp} if $opt->{sp}; $obj->{prefix} = $opt->{prefix} if $opt->{prefix}; $save_more = 1; } $opt->{prefix} = $obj->{prefix} if $obj->{prefix}; $Orig_prefix = $Prefix = $opt->{prefix} || 'item'; $B = qr(\[$Prefix)i; $E = qr(\[/$Prefix)i; $IB = qr(\[if[-_]$Prefix)i; $IE = qr(\[/if[-_]$Prefix)i; my $new; $page =~ s! \[ ( $mprefix more[-_]list ) $Optx$Optx$Optx$Optx$Optx \] ($Some) \[/\1\] ! tag_more_list($2,$3,$4,$5,$6,$opt,$7) !xige; $page =~ s! \[ ( $mprefix on[-_]match )\] ($Some) \[/\1\] ! $obj->{matches} > 0 ? opt_region(0,0,1,$2,$opt) : '' !xige; $page =~ s! \[ ( $mprefix no[-_]match )\] ($Some) \[/\1\] ! $obj->{matches} > 0 ? '' : opt_region(0,0,1,$2,$opt) !xige; $page =~ s:\[($lprefix)\]($Some)\[/\1\]:labeled_list($opt,$2,$obj):ige or $page = labeled_list($opt,$page,$obj); #::logDebug("past labeled_list"); if ($save_more) { my $out = delete $obj->{mv_results}; Vend::Search::save_more($obj, $out); $obj->{mv_results} = $out; } return $page; } sub tag_loop_list { my ($list, $opt, $text) = @_; my $fn; my @rows; $opt->{prefix} ||= 'loop'; $opt->{label} ||= "loop" . ++$::Instance->{List_it} . $Global::Variable->{MV_PAGE}; #::logDebug("list is: " . uneval($list) ); ## Thanks to Kaare Rasmussen for this suggestion ## about passing embedded Perl objects to a list # Can pass object.mv_results=$ary object.mv_field_names=$ary if ($opt->{object}) { my $obj = $opt->{object}; # ensure that number of matches is always set # so [on-match] / [no-match] works if (ref($obj->{mv_results}) ne 'ARRAY') { logError("loop was not passed an arrayref in object.mv_results=`...` argument. Got " . ref($obj->{mv_results}) . " instead."); return; } $obj->{matches} = scalar(@{$obj->{mv_results}}); return region($opt, $text); } # Here we can take the direct results of an op like # @set = $db->query() && return \@set; # Called with # [loop list=`$Scratch->{ary}`] [loop-code] # [/loop] if (ref $list) { #::logDebug("opt->list in: " . uneval($list) ); unless (ref $list eq 'ARRAY' and ref $list->[0] eq 'ARRAY') { logError("loop was passed invalid list=`...` argument"); return; } my ($ary, $fh, $fa) = @$list; my $obj = $opt->{object} ||= {}; $obj->{mv_results} = $ary; $obj->{matches} = scalar @$ary; $obj->{mv_field_names} = $fa if $fa; $obj->{mv_field_hash} = $fh if $fh; if($opt->{ml}) { $obj->{mv_matchlimit} = $opt->{ml}; $obj->{mv_no_more} = ! $opt->{more}; $obj->{mv_first_match} = $opt->{mv_first_match} || 0; $obj->{mv_next_pointer} = $opt->{mv_first_match} + $opt->{ml}; } return region($opt, $text); } my $delim; if($opt->{search}) { #::logDebug("loop resolve search"); if($opt->{more} and $Vend::More_in_progress) { undef $Vend::More_in_progress; return region($opt, $text); } else { return region($opt, $text); } } elsif ($opt->{file}) { #::logDebug("loop resolve file"); $list = Vend::Util::readfile($opt->{file}); $opt->{lr} = 1 unless defined $opt->{lr} or $opt->{quoted}; } elsif ($opt->{extended}) { ### ### This returns ### my ($view, $tab, $key) = split /:+/, $opt->{extended}, 3; if(! $key) { $key = $tab; $tab = $view; undef $view; } my $id = $tab; $id .= "::$key" if $key; my $meta = Vend::Table::Editor::meta_record( $id, $view, $opt->{table}, $opt->{extended_only}, ); if(! $meta) { $opt->{object} = { matches => 1, mv_results => [], mv_field_names => [], }; } else { $opt->{object} = { matches => 1, mv_results => [ $meta ], }; } return region($opt, $text); } if ($fn = $opt->{fn} || $opt->{mv_field_names}) { $fn = [ grep /\S/, split /[\s,]+/, $fn ]; } if ($opt->{lr}) { #::logDebug("loop resolve line"); $list =~ s/^\s+//; $list =~ s/\s+$//; if ($list) { $delim = $opt->{delimiter} || "\t"; my $splittor = $opt->{record_delim} || "\n"; if ($splittor eq "\n") { $list =~ s/\r\n/\n/g; } eval { @rows = map { [ split /\Q$delim/, $_ ] } split /\Q$splittor/, $list; }; } else { # clear errors since we didn't run an eval undef $@; } } elsif($opt->{acclist}) { #::logDebug("loop resolve acclist"); $fn = [ qw/option label/ ] unless $fn; eval { my @items = split /\s*,\s*/, $list; for(@items) { my ($o, $l) = split /=/, $_; $l = $o unless defined $l && $l =~ /\S/; push @rows, [ $o, $l ]; } }; #::logDebug("rows:" . uneval(\@rows)); } elsif($opt->{quoted}) { #::logDebug("loop resolve quoted"); my @l = Text::ParseWords::shellwords($list); produce_range(\@l) if $opt->{ranges}; eval { @rows = map { [$_] } @l; }; } else { #::logDebug("loop resolve default"); $delim = $opt->{delimiter} || '[,\s]+'; my @l = split /$delim/, $list; produce_range(\@l) if $opt->{ranges}; eval { @rows = map { [$_] } @l; }; } if($@) { my $err = $@; logError("bad split delimiter in loop list: $err"); #::logDebug("loop resolve error $err"); } # head_skip pulls rows off the top, and uses the last row to # set the field names if mv_field_names/fn option was not set if ($opt->{head_skip}) { my $i = 0; my $last_row; $last_row = shift(@rows) while $i++ < $opt->{head_skip}; $fn ||= $last_row; } $opt->{object} = { matches => scalar(@rows), mv_results => \@rows, mv_field_names => $fn, }; #::logDebug("loop object: " . uneval($opt)); return region($opt, $text); } # Tries to display the on-the-fly page if page is missing sub fly_page { my($code, $opt, $page) = @_; my ($selector, $subname, $base, $listref); return $page if (! $code and $Vend::Flypart eq $Vend::FinalPath); $code = $Vend::FinalPath unless $code; $Vend::Flypart = $code; if ($subname = $Vend::Cfg->{SpecialSub}{flypage}) { my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname}; $listref = $sub->($code); return unless defined $listref; if (ref $listref) { $base = $listref; } else { $code = $listref; $listref = { mv_results => [[$listref]] }; $base = product_code_exists_ref($code); } } else { $listref = {mv_results => [[$code]]}; $base = product_code_exists_ref($code); } #::logDebug("fly_page: code=$code base=$base page=" . substr($page, 0, 100)); return undef unless $base || $opt->{onfly}; $base = $Vend::Cfg->{ProductFiles}[0] unless $base; if($page) { $selector = 'passed in tag'; } elsif( $Vend::ForceFlypage ) { $selector = $Vend::ForceFlypage; undef $Vend::ForceFlypage; } elsif( $selector = $Vend::Cfg->{PageSelectField} and db_column_exists($base,$selector) ) { $selector = database_field($base, $code, $selector) } $selector = find_special_page('flypage') unless $selector; #::logDebug("fly_page: selector=$selector"); unless (defined $page) { unless( allowed_file($selector) ) { log_file_violation($selector, 'fly_page'); return undef; } $page = readin($selector); if (defined $page) { vars_and_comments(\$page); } else { logError("attempt to display code=$code with bad flypage '$selector'"); return undef; } } # This allows access from embedded Perl $Tmp->{flycode} = $code; # TRACK $Vend::Track->view_product($code) if $Vend::Track; # END TRACK $opt->{prefix} ||= 'item'; # LEGACY list_compat($opt->{prefix}, \$page) if $page; # END LEGACY return labeled_list( $opt, $page, $listref); } sub item_difference { my($code,$price,$q,$item) = @_; return $price - discount_price($item || $code,$price,$q); } sub item_discount { my($code,$price,$q) = @_; return ($price * $q) - discount_price($code,$price,$q) * $q; } sub discount_subtotal { my ($item, $price) = @_; unless (ref $item) { ::logError("Bad call to discount price, item is not reference: %s", $item); return 0; } my $quantity = $item->{quantity} || 1; $price ||= item_price($item); my $new_price = discount_price($item, $price); return $new_price * $quantity; } sub discount_price { my ($item, $price, $quantity) = @_; my $extra; my $code; unless (ref $item) { $code = $item; $item = { code => $code, quantity => ($quantity || 1) }; } ($code, $extra) = ($item->{code}, $item->{mv_discount}); if ($extra and ! $::Discounts) { my $dspace = $Vend::DiscountSpaceName ||= 'main'; $Vend::Session->{discount_space}{main} = $Vend::Session->{discount} ||= {} unless $Vend::Session->{discount_space}{main}; $::Discounts = $Vend::Session->{discount} = $Vend::Session->{discount_space}{$dspace} ||= {} if $Vend::Cfg->{DiscountSpacesOn}; } return $price unless $extra or $::Discounts && %$::Discounts; $quantity = $item->{quantity}; $Vend::Interpolate::item = $item; $Vend::Interpolate::q = $quantity || 1; $Vend::Interpolate::s = $price; my $subtotal = $price * $quantity; #::logDebug("quantity=$q code=$item->{code} price=$s"); my ($discount, $return); for($code, 'ALL_ITEMS') { next unless $discount = $::Discounts->{$_}; $Vend::Interpolate::s = $return ||= $subtotal; $return = $ready_safe->reval($discount); if($@) { ::logError("Bad discount code for %s: %s", $discount, $@); $return = $subtotal; next; } $price = $return / $q; } if($extra) { EXTRA: { $return = $ready_safe->reval($extra); last EXTRA if $@; $price = $return; } } return $price; } sub apply_discount { my($item) = @_; my($formula, $cost); my(@formulae); # Check for individual item discount push(@formulae, $::Discounts->{$item->{code}}) if defined $::Discounts->{$item->{code}}; # Check for all item discount push(@formulae, $::Discounts->{ALL_ITEMS}) if defined $::Discounts->{ALL_ITEMS}; push(@formulae, $item->{mv_discount}) if defined $item->{mv_discount}; my $subtotal = item_subtotal($item); init_calc() unless $Vend::Calc_initialized; # Calculate any formalas found foreach $formula (@formulae) { next unless $formula; $Vend::Interpolate::q = $item->{quantity}; $Vend::Interpolate::s = $subtotal; $Vend::Interpolate::item = $item; # $formula =~ s/\$q\b/$item->{quantity}/g; # $formula =~ s/\$s\b/$subtotal/g; $cost = $ready_safe->reval($formula); if($@) { logError "Discount for $item->{code} has bad formula. Not applied.\n$@"; next; } $subtotal = $cost; } $subtotal; } # 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 { my($var,$val) = @_; $::Scratch->{$var} = $val; return ''; } # Sets the value of a temporary scratchpad field sub set_tmp { my($var,$val) = @_; push @Vend::TmpScratch, $var; $::Scratch->{$var} = $val; return ''; } sub timed_build { my $file = shift; my $opt = shift; my $abort; if ($Vend::LockedOut) { $abort = 1; delete $opt->{new}; } elsif (defined $opt->{if}) { $abort = 1 if ! $opt->{if}; } my $saved_file; if($opt->{scan}) { $saved_file = $Vend::ScanPassed; $abort = 1 if ! $saved_file || $file =~ m:MM=:; } $opt->{login} = 1 if $opt->{auto}; my $save_scratch; if($opt->{new} and $Vend::new_session and !$Vend::Session->{logged_in}) { #::logDebug("we are new"); $save_scratch = $::Scratch; $Vend::Cookie = 1; $Vend::Session->{scratch} = { %{$Vend::Cfg->{ScratchDefault}}, mv_no_session_id => 1, mv_no_count => 1, mv_force_cache => 1 }; } else { return Vend::Interpolate::interpolate_html($_[0]) if $abort or ( ! $opt->{force} and ( ! $Vend::Cookie or ! $opt->{login} && $Vend::Session->{logged_in} ) ); } local ($Scratch->{mv_no_session_id}); $Scratch->{mv_no_session_id} = 1; if($opt->{auto}) { $opt->{minutes} = 60 unless defined $opt->{minutes}; my $dir = "$Vend::Cfg->{ScratchDir}/auto-timed"; unless (allowed_file($dir)) { log_file_violation($dir, 'timed_build'); return; } if(! -d $dir) { require File::Path; File::Path::mkpath($dir); } $file = "$dir/" . generate_key(@_); } my $secs; CHECKDIR: { last CHECKDIR if Vend::File::file_name_is_absolute($file); last CHECKDIR if $file and $file !~ m:/:; my $dir; if ($file) { $dir = '.'; } else { $dir = 'timed'; $file = $saved_file || $Vend::Flypart || $Global::Variable->{MV_PAGE}; #::logDebug("static=$file"); if($saved_file) { $file = $saved_file; $file =~ s:^scan/::; $file = generate_key($file); $file = "scan/$file"; } else { $saved_file = $file = ($Vend::Flypart || $Global::Variable->{MV_PAGE}); } $file .= $Vend::Cfg->{HTMLsuffix}; } $dir .= "/$1" if $file =~ s:(.*)/::; unless (allowed_file($dir)) { log_file_violation($dir, 'timed_build'); return; } if(! -d $dir) { require File::Path; File::Path::mkpath($dir); } $file = Vend::Util::catfile($dir, $file); } #::logDebug("saved=$saved_file"); #::logDebug("file=$file exists=" . -f $file); if($opt->{minutes}) { $secs = int($opt->{minutes} * 60); } elsif ($opt->{period}) { $secs = Vend::Config::time_to_seconds($opt->{period}); } $file = Vend::Util::escape_chars($file); if(! $opt->{auto} and ! allowed_file($file)) { log_file_violation($file, 'timed_build'); return undef; } if( ! -f $file or $secs && (stat(_))[9] < (time() - $secs) ) { my $out = Vend::Interpolate::interpolate_html(shift); $opt->{umask} //= '22'; Vend::File::writefile_atomic($file, $out, $opt); $Vend::Session->{scratch} = $save_scratch if $save_scratch; return $out; } $Vend::Session->{scratch} = $save_scratch if $save_scratch; return Vend::Util::readfile($file); } sub update { my ($func, $opt) = @_; if($func eq 'quantity') { Vend::Order::update_quantity(); } elsif($func eq 'cart') { my $cart; if($opt->{name}) { $cart = $::Carts->{$opt->{name}}; } else { $cart = $Vend::Items; } return if ! ref $cart; Vend::Cart::toss_cart($cart, $opt->{name}); } elsif ($func eq 'process') { Vend::Dispatch::do_process(); } elsif ($func eq 'values') { Vend::Dispatch::update_user(); } elsif ($func eq 'data') { Vend::Data::update_data(); } return; } my $Ship_its = 0; sub push_warning { $Vend::Session->{warnings} = [$Vend::Session->{warnings}] if ! ref $Vend::Session->{warnings}; push @{$Vend::Session->{warnings}}, errmsg(@_); return; } sub taxable_amount { my($cart, $dspace) = @_; return subtotal($cart || undef, $dspace || undef) unless $Vend::Cfg->{NonTaxableField}; my ($taxable, $i, $code, $item, $quantity, $save, $oldspace); if ($cart) { $save = $Vend::Items; tag_cart($cart); } # Support for discount namespaces. $oldspace = switch_discount_space($dspace) if $dspace; $taxable = 0; foreach $i (0 .. $#$Vend::Items) { $item = $Vend::Items->[$i]; next if is_yes( $item->{mv_nontaxable} ); next if is_yes( item_field($item, $Vend::Cfg->{NonTaxableField}) ); if (%$::Discounts or $item->{mv_discount}) { $taxable += apply_discount($item); } else { $taxable += item_subtotal($item); } } if (defined $::Discounts->{ENTIRE_ORDER}) { $Vend::Interpolate::q = tag_nitems(); $Vend::Interpolate::s = $taxable; my $cost = $Vend::Interpolate::ready_safe->reval( $::Discounts->{ENTIRE_ORDER}, ); if($@) { logError "Discount ENTIRE_ORDER has bad formula. Returning normal subtotal."; $cost = $taxable; } $taxable = $cost; } $Vend::Items = $save if defined $save; # Restore initial discount namespace if appropriate. switch_discount_space($oldspace) if defined $oldspace; return $taxable; } sub fly_tax { my ($area, $opt) = @_; if(my $country_check = $::Variable->{TAXCOUNTRY}) { $country_check =~ /\b$::Values->{country}\b/ or return 0; } if(! $area) { my $zone = $Vend::Cfg->{SalesTax}; while($zone =~ m/(\w+)/g) { last if $area = $::Values->{$1}; } } #::logDebug("flytax area=$area"); return 0 unless $area; my $rates = $::Variable->{TAXRATE}; my $taxable_shipping = $::Variable->{TAXSHIPPING} || ''; my $taxable_handling = $::Variable->{TAXHANDLING} || ''; $rates =~ s/^\s+//; $rates =~ s/\s+$//; $area =~ s/^\s+//; $area =~ s/\s+$//; my (@rates) = split /\s*,\s*/, $rates; my $rate; for(@rates) { my ($k,$v) = split /\s*=\s*/, $_, 2; next unless "\U$k" eq "\U$area"; $rate = $v; $rate = $rate / 100 if $rate > 1; last; } #::logDebug("flytax rate=$rate"); return 0 unless $rate; my ($oldcart, $oldspace); if ($opt->{cart}) { $oldcart = $Vend::Items; tag_cart($opt->{cart}); } if ($opt->{discount_space}) { $oldspace = switch_discount_space($opt->{discount_space}); } my $amount = taxable_amount(); #::logDebug("flytax before shipping amount=$amount"); $amount += tag_shipping() if $taxable_shipping =~ m{(^|[\s,])$area([\s,]|$)}i; $amount += tag_handling() if $taxable_handling =~ m{(^|[\s,])$area([\s,]|$)}i; $Vend::Items = $oldcart if defined $oldcart; switch_discount_space($oldspace) if defined $oldspace; #::logDebug("flytax amount=$amount return=" . $amount*$rate); return $amount * $rate; } sub percent_rate { my $rate = shift; $rate =~ s/\s*%\s*$// and $rate /= 100; return $rate; } sub tax_vat { my($type, $opt) = @_; #::logDebug("entering VAT, opts=" . uneval($opt)); my $cfield = $::Variable->{MV_COUNTRY_TAX_VAR} || 'country'; my $country = $opt->{country} || $::Values->{$cfield}; return 0 if ! $country; my $ctable = $opt->{country_table} || $::Variable->{MV_COUNTRY_TABLE} || 'country'; my $c_taxfield = $opt->{country_tax_field} || $::Variable->{MV_COUNTRY_TAX_FIELD} || 'tax'; #::logDebug("ctable=$ctable c_taxfield=$c_taxfield country=$country"); $type ||= tag_data($ctable, $c_taxfield, $country) or return 0; #::logDebug("tax type=$type"); $type =~ s/^\s+//; $type =~ s/\s+$//; my @taxes; if($type =~ /^(\w+)$/) { my $sfield = $1; my $state = $opt->{state} || $::Values->{$sfield}; return 0 if ! $state; my $stable = $opt->{state_table} || $::Variable->{MV_STATE_TABLE} || 'state'; my $s_taxfield = $opt->{state_tax_field} || $::Variable->{MV_STATE_TAX_FIELD} || 'tax'; my $s_taxtype = $opt->{tax_type_field} || $::Variable->{MV_TAX_TYPE_FIELD} || 'tax_name'; my $db = database_exists_ref($stable) or return 0; my $addl = ''; if($opt->{tax_type}) { $addl = " AND $s_taxtype = " . $db->quote($opt->{tax_type}, $s_taxtype); } my $q = qq{ SELECT $s_taxfield FROM $stable WHERE $cfield = '$country' AND $sfield = '$state' $addl }; #::logDebug("tax state query=$q"); my $ary; eval { $ary = $db->query($q); }; if($@) { logError("error on state tax query %s", $q); } #::logDebug("query returns " . uneval($ary)); return 0 unless ref $ary; for(@$ary) { next unless $_->[0]; push @taxes, $_->[0]; } } else { @taxes = $type; } my $total = 0; foreach my $t (@taxes) { $t =~ s/^\s+//; $t =~ s/\s+$//; if ($t =~ /simple:(.*)/) { $total += fly_tax($::Values->{$1}); next; } elsif ($t =~ /handling:(.*)/) { my @modes = grep /\S/, split /[\s,]+/, $1; my $cost = 0; $cost += tag_handling($_) for @modes; $total += $cost; next; } my $tax; #::logDebug("tax type=$t"); if($t =~ /^(\d+(?:\.\d+)?)\s*(\%)$/) { my $rate = $1; $rate /= 100 if $2; $rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive}; my $amount = Vend::Interpolate::taxable_amount(); $total += ($rate * $amount); } else { $tax = Vend::Util::get_option_hash($t); } #::logDebug("tax hash=" . uneval($tax)); my $pfield = $opt->{tax_category_field} || $::Variable->{MV_TAX_CATEGORY_FIELD} || 'tax_category'; my @pfield = split /:+/, $pfield; for my $item (@$Vend::Items) { my ($tab, $col); if($pfield[1]) { ($tab, $col) = @pfield; } else { $tab = $item->{mv_ib}; $col = $pfield[0]; } my $cat = tag_data($tab, $col, $item->{code}); my $rate = defined $tax->{$cat} ? $tax->{$cat} : $tax->{default}; #::logDebug("item $item->{code} cat=$cat rate=$rate"); $rate = percent_rate($rate); next if $rate <= 0; $rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive}; my $sub = discount_subtotal($item); #::logDebug("item $item->{code} subtotal=$sub"); $total += $sub * $rate; #::logDebug("tax total=$total"); } my $tax_shipping_rate = 0; ## Add some tax on shipping ONLY IF TAXABLE ITEMS ## if rate for mv_shipping_when_taxable category is set if ($tax->{mv_shipping_when_taxable} and $total > 0) { $tax_shipping_rate += percent_rate($tax->{mv_shipping_when_taxable}); } ## Add some tax on shipping if rate for mv_shipping category is set if ($tax->{mv_shipping} > 0) { $tax_shipping_rate += percent_rate($tax->{mv_shipping}); } if($tax_shipping_rate > 0) { my $rate = $tax_shipping_rate; $rate =~ s/\s*%\s*$// and $rate /= 100; my $sub = tag_shipping() * $rate; #::logDebug("applying shipping tax rate of $rate, tax of $sub"); $total += $sub; } ## Add some tax on handling if rate for mv_handling category is set if ($tax->{mv_handling} > 0) { my $rate = $tax->{mv_handling}; $rate =~ s/\s*%\s*$// and $rate /= 100; $rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive}; my $sub = tag_handling() * $rate; #::logDebug("applying handling tax rate of $rate, tax of $sub"); $total += $sub; } } return $total; } # Calculate the sales tax sub salestax { my($cart, $opt) = @_; $opt ||= {}; my($save, $oldspace); ### If the user has assigned to salestax, ### we use their value come what may, no rounding if($Vend::Session->{assigned}) { return $Vend::Session->{assigned}{salestax} if defined $Vend::Session->{assigned}{salestax} && length( $Vend::Session->{assigned}{salestax}); } if ($cart) { $save = $Vend::Items; tag_cart($cart); } $oldspace = switch_discount_space( $opt->{discount_space} ) if $opt->{discount_space}; #::logDebug("salestax entered, cart=$cart"); my $tax_hash; my $cost; if($Vend::Cfg->{SalesTax} eq 'multi') { $cost = tax_vat($opt->{type}, $opt); } elsif($Vend::Cfg->{SalesTax} =~ /\[/) { $cost = interpolate_html($Vend::Cfg->{SalesTax}); } elsif($Vend::Cfg->{SalesTaxFunction}) { $tax_hash = tag_calc($Vend::Cfg->{SalesTaxFunction}); #::logDebug("found custom tax function: " . uneval($tax_hash)); } else { $tax_hash = $Vend::Cfg->{SalesTaxTable}; #::logDebug("looking for tax function: " . uneval($tax_hash)); } # if we have a cost from previous routines, return it if(defined $cost) { $Vend::Items = $save if $save; switch_discount_space($oldspace) if defined $oldspace; if($cost < 0 and $::Pragma->{no_negative_tax}) { $cost = 0; } return Vend::Util::round_to_frac_digits($cost); } #::logDebug("got to tax function: " . uneval($tax_hash)); my $amount = taxable_amount(); # Restore the original discount namespace if appropriate; no other routines need the discount info. switch_discount_space($oldspace) if defined $oldspace; my($r, $code); # Make it upper case for state and overseas postal # codes, zips don't matter my(@code) = map { (uc $::Values->{$_}) || '' } split /[,\s]+/, $Vend::Cfg->{SalesTax}; push(@code, 'DEFAULT'); $tax_hash = { DEFAULT => } if ! ref($tax_hash) =~ /HASH/; if(! defined $tax_hash->{DEFAULT}) { #::logDebug("Sales tax failed, no tax source, returning 0"); return 0; } CHECKSHIPPING: { last CHECKSHIPPING unless $Vend::Cfg->{TaxShipping}; foreach $code (@code) { next unless $Vend::Cfg->{TaxShipping} =~ /\b\Q$code\E\b/i; $amount += tag_shipping(); last; } } foreach $code (@code) { next unless $code; # Trim the zip+4 #::logDebug("salestax: check code '$code'"); $code =~ s/(\d{5})-\d{4}/$1/; next unless defined $tax_hash->{$code}; my $tax = $tax_hash->{$code}; #::logDebug("salestax: found tax='$tax' for code='$code'"); if($tax =~ /^-?(?:\d+(?:\.\d*)?|\.\d+)$/) { $r = $amount * $tax; } else { $r = Vend::Data::chain_cost( { mv_price => $amount, code => $code, quantity => $amount, }, $tax); } #::logDebug("salestax: final tax='$r' for code='$code'"); last; } $Vend::Items = $save if defined $save; if($r < 0 and ! $::Pragma->{no_negative_tax}) { $r = 0; } return Vend::Util::round_to_frac_digits($r); } # Returns just subtotal of items ordered, with discounts # applied sub subtotal { my($cart, $dspace, $nodiscount) = @_; ### If the user has assigned to salestax, ### we use their value come what may, no rounding if($Vend::Session->{assigned}) { return $Vend::Session->{assigned}{subtotal} if defined $Vend::Session->{assigned}{subtotal} && length( $Vend::Session->{assigned}{subtotal}); } my ($save, $subtotal, $i, $item, $cost, $formula, $oldspace); if ($cart) { $save = $Vend::Items; tag_cart($cart); } levies() unless $Vend::Levying; $subtotal = 0; if ($nodiscount) { foreach $i (0 .. $#$Vend::Items) { $item = $Vend::Items->[$i]; $subtotal += Vend::Data::item_subtotal($item); } } else { # Use switch_discount_space unconditionally to guarantee existance of proper discount structures. $oldspace = switch_discount_space($dspace || $Vend::DiscountSpaceName); my $discount = (ref($::Discounts) eq 'HASH' and %$::Discounts); foreach $i (0 .. $#$Vend::Items) { $item = $Vend::Items->[$i]; if ($discount || $item->{mv_discount}) { $subtotal += apply_discount($item); } else { $subtotal += Vend::Data::item_subtotal($item); } } if (defined $::Discounts->{ENTIRE_ORDER}) { $formula = $::Discounts->{ENTIRE_ORDER}; $formula =~ s/\$q\b/tag_nitems()/eg; $formula =~ s/\$s\b/$subtotal/g; $cost = $Vend::Interpolate::ready_safe->reval($formula); if ($@) { logError "Discount ENTIRE_ORDER has bad formula. Returning normal subtotal.\n$@"; $cost = $subtotal; } $subtotal = $cost; } $Vend::Session->{latest_subtotal} = $subtotal; # Switch to original discount space if an actual switch occured. switch_discount_space($oldspace) if $dspace and defined $oldspace; } $Vend::Items = $save if defined $save; return $subtotal; } # Returns the total cost of items ordered. sub total_cost { my ($cart, $dspace) = @_; my ($total, $i, $save, $oldspace); $oldspace = switch_discount_space($dspace) if $dspace; if ($cart) { $save = $Vend::Items; tag_cart($cart); } $total = 0; if($Vend::Cfg->{Levies}) { $total = subtotal(); $total += levies(); } else { my $shipping = 0; $shipping += tag_shipping() if $::Values->{mv_shipmode}; $shipping += tag_handling() if $::Values->{mv_handling}; $total += subtotal(); $total += $shipping; $total += salestax() unless $Vend::Cfg->{TaxInclusive}; } $Vend::Items = $save if defined $save; $Vend::Session->{latest_total} = $total; switch_discount_space($oldspace) if defined $oldspace; return $total; } sub levy_sum { my ($set, $levies, $repos) = @_; $set ||= $Vend::CurrentCart || 'main'; $levies ||= $Vend::Cfg->{Levies}; $repos ||= $Vend::Cfg->{Levy_repository}; my $icart = $Vend::Session->{carts}{$set} || []; my @sums; for(@$icart) { push @sums, @{$_}{sort keys %$_}; } my $items; for(@$levies) { next unless $items = $repos->{$_}{check_status}; push @sums, @{$::Values}{ split /[\s,\0]/, $items }; } return generate_key(@sums); } sub levies { my($recalc, $set, $opt) = @_; my $levies; return unless $levies = $Vend::Cfg->{Levies}; $opt ||= {}; my $repos = $Vend::Cfg->{Levy_repository}; #::logDebug("Calling levies, recalc=$recalc group=$opt->{group}"); if(! $repos) { logOnce('error', "Levies set but no levies defined! No tax or shipping."); return; } $Vend::Levying = 1; $set ||= $Vend::CurrentCart; $set ||= 'main'; $Vend::Session->{levies} ||= {}; my $lcheck = $Vend::Session->{latest_levy} ||= {}; $lcheck = $lcheck->{$set} ||= {}; if($Vend::LeviedOnce and ! $recalc and ! $opt->{group} and $lcheck->{sum}) { my $newsum = levy_sum($set, $levies, $repos); #::logDebug("did levy check, new=$newsum old=$lcheck->{sum}"); if($newsum eq $lcheck->{sum}) { undef $Vend::Levying; #::logDebug("levy returning cached value"); return $lcheck->{total}; } } my $lcart = $Vend::Session->{levies}{$set} = []; my $run = 0; for my $name (@$levies) { my $l = $repos->{$name}; #::logDebug("Levying $name, repos => " . uneval($l)); if(! $l) { logOnce('error', "Levy '%s' called but not defined. Skipping.", $name); next; } if(my $if = $l->{include_if}) { if($if =~ /^\w+$/) { next unless $::Values->{$if}; } elsif($if =~ /__[A-Z]\w+__|[[a-zA-Z]/) { my $val = interpolate_html($if); $val =~ s/^\s+//; $val =~ s/^s+$//; next unless $val; } else { next unless tag_calc($if); } } if(my $if = $l->{exclude_if}) { if($if =~ /^\w+$/) { next if $::Values->{$if}; } elsif($if =~ /__[A-Z]\w+__|[[a-zA-Z]/) { my $val = interpolate_html($if); $val =~ s/^\s+//; $val =~ s/^s+$//; next if $val; } else { next if tag_calc($if); } } my $type = $l->{type} || ($name eq 'salestax' ? 'salestax' : 'shipping'); my $mode; if($l->{mode_from_values}) { $mode = $::Values->{$l->{mode_from_values}}; } elsif($l->{mode_from_scratch}) { $mode = $::Scratch->{$l->{mode_from_scratch}}; } $mode ||= ($l->{mode} || $name); my $group = $l->{group} || $type; my $cost = 0; my $sort; my $desc; my $lab_field = $l->{label_value}; if($type eq 'salestax') { my $save; $sort = $l->{sort} || '010'; $lab_field ||= $Vend::Cfg->{SalesTax}; if($l->{tax_fields}) { $save = $Vend::Cfg->{SalesTax}; $Vend::Cfg->{SalesTax} = $l->{tax_fields}; } elsif ($l->{multi}) { $save = $Vend::Cfg->{SalesTax}; $Vend::Cfg->{SalesTax} = 'multi'; } $cost = salestax(undef, { tax_type => $l->{tax_type} } ); $l->{description} ||= 'Sales Tax'; $Vend::Cfg->{SalesTax} = $save if defined $save; } elsif ($type eq 'shipping' or $type eq 'handling') { if(not $sort = $l->{sort}) { $sort = $type eq 'handling' ? 100 : 500; } my @modes = split /\0/, $mode; for my $m (@modes) { $cost += shipping($m); if($l->{description}) { if($l->{multi_description}) { $l->{description} = $l->{multi_description}; } else { $l->{description} .= ', ' if $l->{description}; $l->{description} .= tag_shipping_desc($m); } } else { $l->{description} = tag_shipping_desc($m); } } } elsif($type eq 'custom') { my $sub; SUBFIND: { $sub = $Vend::Cfg->{Sub}{$mode} || $Global::GlobalSub->{$mode} and last SUBFIND; eval { $sub = $Vend::Cfg->{UserTag}{Routine}{$mode}; }; last SUBFIND if ! $@ and $sub; eval { $sub = $Global::UserTag->{Routine}{$mode}; }; } if( ref($sub) eq 'CODE') { ($cost, $desc, $sort) = $sub->($l); } else { logError("No subroutine found for custom levy '%s'", $name); } } $desc = errmsg( $l->{description}, $::Values->{$lab_field}, ); my $cost_format; my $item = { code => $name, mode => $mode, type => $type, sort => $sort || $l->{sort}, cost => round_to_frac_digits($cost), currency => currency($cost), group => $group, inclusive => $l->{inclusive}, label => $l->{label} || $desc, part_number => $l->{part_number}, description => $desc, }; if($cost == 0) { next unless $l->{keep_if_zero}; $item->{free} = 1; $item->{free_message} = $l->{free_message} || $cost; } if(my $target = $l->{add_to}) { my $found; foreach my $lev (@$lcart) { next unless $lev->{code} eq $target; $lev->{cost} += $item->{cost}; $lev->{cost} = round_to_frac_digits($lev->{cost}); $lev->{currency} = currency($lev->{cost}); $found = 1; last; } unless($found) { push @$lcart, $item; } } else { push @$lcart, $item; } } @$lcart = sort { $a->{sort} cmp $b->{sort} } @$lcart; for(@$lcart) { next if $opt->{group} and $opt->{group} ne $_->{group}; next if $_->{inclusive}; next if $_->{type} eq 'salestax' and $Vend::Cfg->{TaxInclusive}; $run += $_->{cost}; } $run = round_to_frac_digits($run); if(! $opt->{group}) { $lcheck = $Vend::Session->{latest_levy}{$set} = {}; $lcheck->{sum} = levy_sum($set, $levies, $repos); $lcheck->{total} = $run; $Vend::LeviedOnce = 1; } undef $Vend::Levying; return $run; } 1;