1# Vend::Interpolate - Interpret Interchange tags
2#
3# $Id: Interpolate.pm,v 2.303.2.3 2008-07-28 21:27:03 mheins Exp $
4#
5# Copyright (C) 2002-2008 Interchange Development Group
6# Copyright (C) 1996-2002 Red Hat, Inc.
7#
8# This program was originally based on Vend 0.2 and 0.3
9# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
10#
11# This program is free software; you can redistribute it and/or modify
12# it under the terms of the GNU General Public License as published by
13# the Free Software Foundation; either version 2 of the License, or
14# (at your option) any later version.
15#
16# This program is distributed in the hope that it will be useful,
17# but WITHOUT ANY WARRANTY; without even the implied warranty of
18# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19# GNU General Public License for more details.
20#
21# You should have received a copy of the GNU General Public
22# License along with this program; if not, write to the Free
23# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
24# MA  02110-1301  USA.
25
26package Vend::Interpolate;
27
28require Exporter;
29@ISA = qw(Exporter);
30
31$VERSION = substr(q$Revision: 2.303.2.3 $, 10);
32
33@EXPORT = qw (
34
35interpolate_html
36subtotal
37tag_data
38tag_attr_list
39$Tag
40$CGI
41$Session
42$Values
43$Discounts
44$Sub
45);
46
47=head1 NAME
48
49Vend::Interpolate -- Interchange tag interpolation routines
50
51=head1 SYNOPSIS
52
53(no external use)
54
55=head1 DESCRIPTION
56
57The Vend::Interpolate contains the majority of the Interchange Tag
58Language implementation rouines. Historically, it contained the entire
59tag language implementation for MiniVend, accounting for its name.
60
61It contains most of the handler routines pointed to by Vend::Parse, which
62accepts the parsing output of Vend::Parser. (Vend::Parser was originally based
63on HTML::Parser 1.x).
64
65There are two interpolative parsers in Vend::Interpolate,
66iterate_array_list() and iterate_hash_list() -- these routines parse
67the lists used in the widely employed [loop ..], [search-region ...],
68[item-list], and [query ..] ITL tag constructs.
69
70This module makes heavy use of precompiled regexes. You will notice variables
71being used in the regular expression constructs. For example, C<$All> is a
72a synonym for C<[\000-\377]*>, C<$Some> is equivalent to C<[\000-\377]*?>, etc.
73This is not only for clarity of the regular expression, but for speed.
74
75=cut
76
77# SQL
78push @EXPORT, 'tag_sql_list';
79# END SQL
80
81use Safe;
82
83my $hole;
84BEGIN {
85	eval {
86		require Safe::Hole;
87		$hole = new Safe::Hole;
88	};
89}
90
91# We generally know when we are testing these things, but be careful
92no warnings qw(uninitialized numeric);
93
94use strict;
95use Vend::Util;
96use Vend::File;
97use Vend::Data;
98use Vend::Form;
99require Vend::Cart;
100
101use HTML::Entities;
102use Vend::Server;
103use Vend::Scan;
104use Vend::Tags;
105use Vend::Subs;
106use Vend::Document;
107use Vend::Parse;
108use POSIX qw(ceil strftime LC_CTYPE);
109
110use vars qw(%Data_cache);
111
112my $wantref = 1;
113
114# MVASP
115
116my @Share_vars;
117my @Share_routines;
118
119BEGIN {
120	@Share_vars = qw/
121							$s
122							$q
123							$item
124							$CGI_array
125							$CGI
126							$Discounts
127							$Document
128							%Db
129							$DbSearch
130							%Filter
131							$Search
132							$Carts
133							$Config
134							%Sql
135							$Items
136							$Row
137							$Scratch
138							$Shipping
139							$Session
140							$Tag
141							$Tmp
142							$TextSearch
143							$Values
144							$Variable
145							$Sub
146						/;
147	@Share_routines = qw/
148							&tag_data
149							&errmsg
150							&Log
151							&Debug
152							&uneval
153							&get_option_hash
154							&dotted_hash
155							&encode_entities
156							&HTML
157							&interpolate_html
158						/;
159}
160
161use vars @Share_vars, @Share_routines,
162		 qw/$ready_safe $safe_safe/;
163use vars qw/%Filter %Ship_handler $Safe_data/;
164
165$ready_safe = new Safe;
166$ready_safe->trap(qw/:base_io/);
167$ready_safe->untrap(qw/sort ftfile/);
168
169sub reset_calc {
170#::logDebug("reset_state=$Vend::Calc_reset -- resetting calc from " . caller);
171	if(! $Global::Foreground and $Vend::Cfg->{ActionMap}{_mvsafe}) {
172#::logDebug("already made");
173		$ready_safe = $Vend::Cfg->{ActionMap}{_mvsafe};
174	}
175	else {
176		my $pkg = 'MVSAFE' . int(rand(100000));
177		undef $MVSAFE::Safe;
178		$ready_safe = new Safe $pkg;
179		$ready_safe->share_from('MVSAFE', ['$safe']);
180#::logDebug("new safe made=$ready_safe->{Root}");
181
182		Vend::CharSet->utf8_safe_regex_workaround($ready_safe)
183		    if $::Variable->{MV_UTF8};
184
185		$ready_safe->trap(@{$Global::SafeTrap});
186		$ready_safe->untrap(@{$Global::SafeUntrap});
187		no strict 'refs';
188		$Document   = new Vend::Document;
189		*Log = \&Vend::Util::logError;
190		*Debug = \&Vend::Util::logDebug;
191		*uneval = \&Vend::Util::uneval_it;
192		*HTML = \&Vend::Document::HTML;
193		$ready_safe->share(@Share_vars, @Share_routines);
194		$DbSearch   = new Vend::DbSearch;
195		$TextSearch = new Vend::TextSearch;
196		$Tag        = new Vend::Tags;
197		$Sub        = new Vend::Subs;
198	}
199	$Tmp        = {};
200	undef $s;
201	undef $q;
202	undef $item;
203	%Db = ();
204	%Sql = ();
205	undef $Shipping;
206	$Vend::Calc_reset = 1;
207	undef $Vend::Calc_initialized;
208	return $ready_safe;
209}
210
211sub init_calc {
212#::logDebug("reset_state=$Vend::Calc_reset init_state=$Vend::Calc_initialized -- initting calc from " . caller);
213	reset_calc() unless $Vend::Calc_reset;
214	$CGI_array  = \%CGI::values_array;
215	$CGI        = \%CGI::values;
216	$Carts      = $::Carts;
217	$Discounts	= $::Discounts;
218	$Items      = $Vend::Items;
219	$Config     = $Vend::Cfg;
220	$Scratch    = $::Scratch;
221	$Values     = $::Values;
222	$Session    = $Vend::Session;
223	$Search     = $::Instance->{SearchObject} ||= {};
224	$Variable   = $::Variable;
225	$Vend::Calc_initialized = 1;
226	return;
227}
228
229# Define conditional ops
230my %cond_op = (
231	eq  => sub { $_[0] eq $_[1] },
232	ne  => sub { $_[0] ne $_[1] },
233	gt  => sub { $_[0] gt $_[1] },
234	ge  => sub { $_[0] ge $_[1] },
235	le  => sub { $_[0] le $_[1] },
236	lt  => sub { $_[0] lt $_[1] },
237   '>'  => sub { $_[0]  > $_[1] },
238   '<'  => sub { $_[0]  < $_[1] },
239   '>=' => sub { $_[0] >= $_[1] },
240   '<=' => sub { $_[0] <= $_[1] },
241   '==' => sub { $_[0] == $_[1] },
242   '!=' => sub { $_[0] != $_[1] },
243   '=~' => sub {
244   				 my $re;
245				 $_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:;
246				 $2 and substr($_[1], 0, 0) = "(?$2)";
247   				 eval { $re = qr/$_[1]/ };
248				 if($@) {
249					logError("bad regex %s in if-PREFIX-data", $_[1]);
250					return undef;
251				 }
252				 return $_[0] =~ $re;
253				},
254   '!~' => sub {
255   				 my $re;
256				 $_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:;
257				 $2 and substr($_[1], 0, 0) = "(?$2)";
258   				 eval { $re = qr/$_[1]/ };
259				 if($@) {
260					logError("bad regex %s in if-PREFIX-data", $_[1]);
261					return undef;
262				 }
263				 return $_[0] !~ $re;
264				},
265   'filter' => sub {
266   				 my ($string, $filter) = @_;
267				 my $newval = filter_value($filter, $string);
268				 return $string eq $newval ? 1 : 0;
269				},
270   'length' => sub {
271   				 my ($string, $lenspec) = @_;
272				 my ($min,$max) = split /-/, $lenspec;
273				 if($min and length($string) < $min) {
274				 	return 0;
275				 }
276				 elsif($max and length($string) > $max) {
277				 	return 0;
278				 }
279				 else {
280				 	return 0 unless length($string) > 0;
281				 }
282				 return 1;
283				},
284);
285
286my %file_op = (
287	A => sub { -A $_[0] },
288	B => sub { -B $_[0] },
289	d => sub { -d $_[0] },
290	e => sub { -e $_[0] },
291	f => sub { -f $_[0] },
292	g => sub { -g $_[0] },
293	l => sub { -l $_[0] },
294	M => sub { -M $_[0] },
295	r => sub { -r $_[0] },
296	s => sub { -s $_[0] },
297	T => sub { -T $_[0] },
298	u => sub { -u $_[0] },
299	w => sub { -w $_[0] },
300	x => sub { -x $_[0] },
301);
302
303
304$cond_op{len} = $cond_op{length};
305
306# Regular expression pre-compilation
307my %T;
308my %QR;
309
310my $All = '[\000-\377]*';
311my $Some = '[\000-\377]*?';
312my $Codere = '[-\w#/.]+';
313my $Coderex = '[-\w:#=/.%]+';
314my $Filef = '(?:%20|\s)+([^]]+)';
315my $Mandx = '\s+([-\w:#=/.%]+)';
316my $Mandf = '(?:%20|\s)+([-\w#/.]+)';
317my $Spacef = '(?:%20|\s)+';
318my $Spaceo = '(?:%20|\s)*';
319
320my $Optx = '\s*([-\w:#=/.%]+)?';
321my $Optr = '(?:\s+([^]]+))?';
322my $Mand = '\s+([-\w#/.]+)';
323my $Opt = '\s*([-\w#/.]+)?';
324my $T    = '\]';
325my $D    = '[-_]';
326
327my $XAll = qr{[\000-\377]*};
328my $XSome = qr{[\000-\377]*?};
329my $XCodere = qr{[-\w#/.]+};
330my $XCoderex = qr{[-\w:#=/.%]+};
331my $XMandx = qr{\s+([-\w:#=/.%]+)};
332my $XMandf = qr{(?:%20|\s)+([-\w#/.]+)};
333my $XSpacef = qr{(?:%20|\s)+};
334my $XSpaceo = qr{(?:%20|\s)*};
335my $XOptx = qr{\s*([-\w:#=/.%]+)?};
336my $XMand = qr{\s+([-\w#/.]+)};
337my $XOpt = qr{\s*([-\w#/.]+)?};
338my $XD    = qr{[-_]};
339my $Gvar  = qr{\@\@([A-Za-z0-9]\w+[A-Za-z0-9])\@\@};
340my $Evar  = qr{\@_([A-Za-z0-9]\w+[A-Za-z0-9])_\@};
341my $Cvar  = qr{__([A-Za-z0-9]\w*?[A-Za-z0-9])__};
342
343
344my @th = (qw!
345
346		/_alternate
347		/_calc
348		/_change
349		/_exec
350		/_filter
351		/_header_param
352		/_last
353		/_modifier
354		/_next
355		/_param
356		/_pos
357		/_sub
358		/col
359		/comment
360		/condition
361		/else
362		/elsif
363		/more_list
364		/no_match
365		/on_match
366		/sort
367		/then
368		_accessories
369		_alternate
370		_calc
371		_change
372		_code
373		_common
374		_data
375		_description
376		_discount
377		_exec
378		_field
379		_filter
380		_header_param
381		_include
382		_increment
383		_last
384		_line
385		_match
386		_modifier
387		_next
388		_options
389		_param
390		_parent
391		_pos
392		_price
393		_quantity
394		_sku
395		_subtotal
396		_sub
397		col
398		comment
399		condition
400		discount_price
401		_discount_price
402		_discount_subtotal
403		_difference
404		else
405		elsif
406		matches
407		match_count
408		_modifier_name
409		more
410		more_list
411		no_match
412		on_match
413		_quantity_name
414		sort
415		then
416
417		! );
418
419	my $shown = 0;
420	my $tag;
421	for (@th) {
422		$tag = $_;
423		s/([A-Za-z0-9])/[\u$1\l$1]/g;
424		s/[-_]/[-_]/g;
425		$T{$tag} = $_;
426		next if $tag =~ m{^_};
427		$T{$tag} = "\\[$T{$tag}";
428		next unless $tag =~ m{^/};
429		$T{$tag} = "$T{$tag}\]";
430	}
431
432%QR = (
433	'/_alternate'	=> qr($T{_alternate}\]),
434	'/_calc'		=> qr($T{_calc}\]),
435	'/_change'		=> qr([-_]change\s+)i,
436	'/_data'		=> qr($T{_data}\]),
437	'/_exec'		=> qr($T{_exec}\]),
438	'/_field'		=> qr($T{_field}\]),
439	'/_filter'		=> qr($T{_filter}\]),
440	'/_last'		=> qr($T{_last}\]),
441	'/_modifier'	=> qr($T{_modifier}\]),
442	'/_next'		=> qr($T{_next}\]),
443	'/_pos'			=> qr($T{_pos}\]),
444	'/_sub'			=> qr($T{_sub}\]),
445	'_accessories'  => qr($T{_accessories}($Spacef[^\]]+)?\]),
446	'_alternate'	=> qr($T{_alternate}$Opt\]($Some)),
447	'_calc' 		=> qr($T{_calc}\]($Some)),
448	'_exec' 		=> qr($T{_exec}$Mand\]($Some)),
449	'_filter' 		=> qr($T{_filter}\s+($Some)\]($Some)),
450	'_sub'	 		=> qr($T{_sub}$Mand\]($Some)),
451	'_change'		=> qr($T{_change}$Mand$Opt\] \s*
452						$T{condition}\]
453						($Some)
454						$T{'/condition'}
455						($Some))xi,
456	'_code'			=> qr($T{_code}\]),
457	'_sku'			=> qr($T{_sku}\]),
458	'col'			=> qr(\[col(?:umn)?\s+
459				 		([^\]]+)
460				 		\]
461				 		($Some)
462				 		\[/col(?:umn)?\] )ix,
463
464	'comment'		=> qr($T{comment}(?:\s+$Some)?\]
465						(?!$All$T{comment}\])
466						$Some
467						$T{'/comment'})x,
468
469	'_description'	=> qr($T{_description}\]),
470	'_difference'	=> qr($T{_difference}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]),
471	'_discount'		=> qr($T{_discount}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]),
472	'_field_if'		=> qr($T{_field}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
473	'_field_if_wo'	=> qr($T{_field}$Spacef(!?)\s*($Codere$Optr)\]),
474	'_field'		=> qr($T{_field}$Mandf\]),
475	'_common'		=> qr($T{_common}$Mandf\]),
476	'_include'		=> qr($T{_include}$Filef\]),
477	'_increment'	=> qr($T{_increment}\]),
478	'_last'			=> qr($T{_last}\]\s*($Some)\s*),
479	'_line'			=> qr($T{_line}$Opt\]),
480	'_next'			=> qr($T{_next}\]\s*($Some)\s*),
481	'_options'		=> qr($T{_options}($Spacef[^\]]+)?\]),
482	'_header_param'	=> qr($T{_header_param}$Mandf$Optr\]),
483	'_header_param_if'	=> qr($T{_header_param}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
484	'_param_if'		=> qr((?:$T{_param}|$T{_modifier})(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
485	'_param'		=> qr((?:$T{_param}|$T{_modifier})$Mandf\]),
486	'_parent_if'	=> qr($T{_parent}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
487	'_parent'		=> qr($T{_parent}$Mandf\]),
488	'_pos_if'		=> qr($T{_pos}(\d*)$Spacef(!?)\s*(-?\d+)$Optr\]($Some)),
489	'_pos' 			=> qr($T{_pos}$Spacef(-?\d+)\]),
490	'_price'		=> qr!$T{_price}(?:\s+(\d+))?$Optx\]!,
491	'_quantity'		=> qr($T{_quantity}\]),
492	'_subtotal'		=> qr($T{_subtotal}$Optx\]),
493	'_tag'			=> qr([-_] tag [-_] ([-\w]+) \s+)x,
494	'condition'		=> qr($T{condition}$T($Some)$T{'/condition'}),
495	'condition_begin' => qr(^\s*$T{condition}\]($Some)$T{'/condition'}),
496	'_discount_price' => qr($T{_discount_price}(?:\s+(\d+))?$Optx\]),
497	'discount_price' => qr($T{discount_price}(?:\s+(\d+))?$Optx\]),
498	'_discount_subtotal' => qr($T{_discount_subtotal}$Optx\]),
499	'has_else'		=> qr($T{'/else'}\s*$),
500	'else_end'		=> qr($T{else}\]($All)$T{'/else'}\s*$),
501	'elsif_end'		=> qr($T{elsif}\s+($All)$T{'/elsif'}\s*$),
502	'matches'		=> qr($T{matches}\]),
503	'match_count'		=> qr($T{match_count}\]),
504	'more'			=> qr($T{more}\]),
505	'more_list'		=> qr($T{more_list}$Optx$Optx$Optx$Optx$Optx\]($Some)$T{'/more_list'}),
506	'no_match'   	=> qr($T{no_match}\]($Some)$T{'/no_match'}),
507	'on_match'   	=> qr($T{on_match}\]($Some)$T{'/on_match'}),
508	'_quantity_name'	=> qr($T{_quantity_name}\]),
509	'_modifier_name'	=> qr($T{_modifier_name}$Spacef(\w+)\]),
510	'then'			=> qr(^\s*$T{then}$T($Some)$T{'/then'}),
511);
512
513FINTAG: {
514	for(keys %T) {
515		$QR{$_} = qr($T{$_})
516			if ! defined $QR{$_};
517	}
518}
519
520undef @th;
521undef %T;
522
523sub get_joiner {
524	my ($joiner, $default) = @_;
525	return $default      unless defined $joiner and length $joiner;
526	if($joiner eq '\n') {
527		$joiner = "\n";
528	}
529	elsif($joiner =~ m{\\}) {
530		$joiner = $safe_safe->reval("qq{$joiner}");
531	}
532	return length($joiner) ? $joiner : $default;
533}
534
535sub substitute_image {
536	my ($text) = @_;
537
538	## Allow no substitution of downloads
539	return if $::Pragma->{download};
540
541	## If post_page routine processor returns true, return. Otherwise,
542	## continue image rewrite
543	if($::Pragma->{post_page}) {
544		Vend::Dispatch::run_macro($::Pragma->{post_page}, $text)
545			and return;
546	}
547
548	unless ( $::Pragma->{no_image_rewrite} ) {
549		my $dir = $CGI::secure											?
550			($Vend::Cfg->{ImageDirSecure} || $Vend::Cfg->{ImageDir})	:
551			$Vend::Cfg->{ImageDir};
552
553		if ($dir) {
554			$$text =~ s#(<i\w+\s+[^>]*?src=")(?!\w+:)([^/'][^"]+)#
555						$1 . $dir . $2#ige;
556	        $$text =~ s#(<body\s+[^>]*?background=")(?!\w+:)([^/'][^"]+)#
557						$1 . $dir . $2#ige;
558	        $$text =~ s#(<t(?:[dhr]|able)\s+[^>]*?background=")(?!\w+:)([^/'][^"]+)#
559						$1 . $dir . $2#ige;
560		}
561	}
562
563    if($Vend::Cfg->{ImageAlias}) {
564		for (keys %{$Vend::Cfg->{ImageAlias}} ) {
565        	$$text =~ s#(<i\w+\s+[^>]*?src=")($_)#
566                         $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige;
567        	$$text =~ s#(<body\s+[^>]*?background=")($_)#
568                         $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige;
569        	$$text =~ s#(<t(?:[dhr]|able)\s+[^>]*?background=")($_)#
570                         $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige;
571		}
572    }
573}
574
575sub dynamic_var {
576	my $varname = shift;
577
578	return readfile($Vend::Cfg->{DirConfig}{Variable}{$varname})
579		if $Vend::Cfg->{DirConfig}
580			and defined $Vend::Cfg->{DirConfig}{Variable}{$varname};
581
582	VARDB: {
583		last VARDB if $::Pragma->{dynamic_variables_file_only};
584		last VARDB unless $Vend::Cfg->{VariableDatabase};
585		if($Vend::VarDatabase) {
586			last VARDB unless $Vend::VarDatabase->record_exists($varname);
587			return $Vend::VarDatabase->field($varname, 'Variable');
588		}
589		else {
590			$Vend::VarDatabase = database_exists_ref($Vend::Cfg->{VariableDatabase})
591				or undef $Vend::Cfg->{VariableDatabase};
592			redo VARDB;
593		}
594	}
595	return $::Variable->{$varname};
596}
597
598sub vars_and_comments {
599	my $html = shift;
600	## We never want to interpolate vars if in restricted mode
601	return if $Vend::restricted;
602	local($^W) = 0;
603
604	# Set whole-page pragmas from [pragma] tags
605	1 while $$html =~ s/\[pragma\s+(\w+)(?:\s+(\w+))?\]/
606		$::Pragma->{$1} = (length($2) ? $2 : 1), ''/ige;
607
608	undef $Vend::PageInit unless $::Pragma->{init_page};
609
610	if(defined $Vend::PageInit and ! $Vend::PageInit++) {
611		Vend::Dispatch::run_macro($::Pragma->{init_page}, $html);
612	}
613
614	# Substitute in Variable values
615	$$html =~ s/$Gvar/$Global::Variable->{$1}/g;
616	if($::Pragma->{dynamic_variables}) {
617		$$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge
618			and
619		$$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge;
620		$$html =~ s/$Cvar/dynamic_var($1)/ge;
621	}
622	else {
623		$$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge
624			and
625		$$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge;
626		$$html =~ s/$Cvar/$::Variable->{$1}/g;
627	}
628
629	if($::Pragma->{pre_page}) {
630		Vend::Dispatch::run_macro($::Pragma->{pre_page}, $html);
631	}
632
633	# Strip out [comment] [/comment] blocks
634	1 while $$html =~ s%$QR{comment}%%go;
635
636	# Translate Interchange tags embedded in HTML comments like <!--[tag ...]-->
637	! $::Pragma->{no_html_comment_embed}
638	and
639		$$html =~ s/<!--+\[/[/g
640			and $$html =~ s/\]--+>/]/g;
641
642	return;
643}
644
645sub interpolate_html {
646	my ($html, $wantref, $opt) = @_;
647	return undef if $Vend::NoInterpolate;
648	my ($name, @post);
649	my ($bit, %post);
650
651	local($^W);
652
653	my $toplevel;
654	if(defined $Vend::PageInit and ! $Vend::PageInit) {
655		defined $::Variable->{MV_AUTOLOAD}
656			and $html =~ s/^/$::Variable->{MV_AUTOLOAD}/;
657		$toplevel = 1;
658	}
659#::logDebug("opt=" . uneval($opt));
660
661	vars_and_comments(\$html)
662		unless $opt and $opt->{onfly};
663
664	$^W = 1 if $::Pragma->{perl_warnings_in_page};
665
666    # Returns, could be recursive
667	my $parse = new Vend::Parse $wantref;
668	$parse->parse($html);
669	while($parse->{_buf}) {
670		if($toplevel and $parse->{SEND}) {
671			delete $parse->{SEND};
672			::response();
673			$parse->destination($parse->{_current_output});
674		}
675		$parse->parse('');
676	}
677	return $parse->{OUT} if defined $wantref;
678	return ${$parse->{OUT}};
679}
680
681sub filter_value {
682	my($filter, $value, $tag, @passed_args) = @_;
683#::logDebug("filter_value: filter='$filter' value='$value' tag='$tag'");
684	my @filters = Text::ParseWords::shellwords($filter);
685	my @args;
686
687	if(! $Vend::Filters_initted++ and my $ref = $Vend::Cfg->{CodeDef}{Filter}) {
688		while (my($k, $v) = each %{$ref->{Routine}}) {
689			$Filter{$k} = $v;
690		}
691	}
692
693	for (@filters) {
694		next unless length($_);
695		@args = @passed_args;
696		if(/^[^.]*%/) {
697			$value = sprintf($_, $value);
698			next;
699		}
700		if (/^(\d+)([\.\$]?)$/) {
701			my $len;
702			return $value unless ($len = length($value)) > $1;
703			my ($limit, $mod) = ($1, $2);
704			unless($mod) {
705				substr($value, $limit) = '';
706			}
707			elsif($mod eq '.') {
708				substr($value, $1) = '...';
709			}
710			elsif($mod eq '$') {
711				substr($value, 0, $len - $limit) = '...';
712			}
713			return $value;
714			next;
715		}
716		while( s/\.([^.]+)$//) {
717			unshift @args, $1;
718		}
719		if(/^\d+$/) {
720			substr($value , $_) = ''
721				if length($value) > $_;
722			next;
723		}
724		if ( /^words(\d+)(\.?)$/ ) {
725			my @str = (split /\s+/, $value);
726			if (scalar @str > $1) {
727				my $num = $1;
728				$value = join(' ', @str[0..--$num]);
729				$value .= $2 ? '...' : '';
730			}
731			next;
732		}
733		my $sub;
734		unless ($sub = $Filter{$_} ||  Vend::Util::codedef_routine('Filter', $_) ) {
735			logError ("Unknown filter '%s'", $_);
736			next;
737		}
738		unshift @args, $value, $tag;
739		$value = $sub->(@args);
740	}
741#::logDebug("filter_value returns: value='$value'");
742	return $value;
743}
744
745sub try {
746	my ($label, $opt, $body) = @_;
747	$label = 'default' unless $label;
748	$Vend::Session->{try}{$label} = '';
749	my $out;
750	my $save;
751	$save = delete $SIG{__DIE__} if defined $SIG{__DIE__};
752	$Vend::Try = $label;
753	eval {
754		$out = interpolate_html($body);
755	};
756	undef $Vend::Try;
757	$SIG{__DIE__} = $save if defined $save;
758	if($@) {
759		$Vend::Session->{try}{$label} .= "\n"
760			if $Vend::Session->{try}{$label};
761		$Vend::Session->{try}{$label} .= $@;
762	}
763	if ($opt->{status}) {
764		return ($Vend::Session->{try}{$label}) ? 0 : 1;
765	}
766	elsif ($opt->{hide}) {
767		return '';
768	}
769	elsif ($opt->{clean}) {
770		return ($Vend::Session->{try}{$label}) ? '' : $out;
771	}
772
773	return $out;
774}
775
776# Returns the text of a configurable database field or a
777# session variable
778sub tag_data {
779	my($selector,$field,$key,$opt,$flag) = @_;
780
781	local($Safe_data);
782	$Safe_data = 1 if $opt->{safe_data};
783
784	my $db;
785
786	if ( not $db = database_exists_ref($selector) ) {
787		if($selector eq 'session') {
788			if(defined $opt->{value}) {
789				$opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
790					if $opt->{filter};
791				if ($opt->{increment}) {
792					$Vend::Session->{$field} += (+ $opt->{value} || 1);
793				}
794				elsif ($opt->{append}) {
795					$Vend::Session->{$field} .= $opt->{value};
796				}
797				else  {
798					$Vend::Session->{$field} = $opt->{value};
799				}
800				return '';
801			}
802			else {
803				my $value = $Vend::Session->{$field} || '';
804				$value = filter_value($opt->{filter}, $value, $field)
805					if $opt->{filter};
806				return $value;
807			}
808		}
809		else {
810			logError( "Bad data selector='%s' field='%s' key='%s'",
811						$selector,
812						$field,
813						$key,
814			);
815			return '';
816		}
817	}
818	elsif($opt->{increment}) {
819#::logDebug("increment_field: key=$key field=$field value=$opt->{value}");
820		return increment_field($Vend::Database{$selector},$key,$field,$opt->{value} || 1);
821	}
822	elsif (defined $opt->{value}) {
823#::logDebug("alter table: table=$selector alter=$opt->{alter} field=$field value=$opt->{value}");
824		if ($opt->{alter}) {
825			$opt->{alter} =~ s/\W+//g;
826			$opt->{alter} = lc($opt->{alter});
827			if ($opt->{alter} eq 'change') {
828				return $db->change_column($field, $opt->{value});
829			}
830			elsif($opt->{alter} eq 'add') {
831				return $db->add_column($field, $opt->{value});
832			}
833			elsif ($opt->{alter} eq 'delete') {
834				return $db->delete_column($field, $opt->{value});
835			}
836			else {
837				logError("alter function '%s' not found", $opt->{alter});
838				return undef;
839			}
840		}
841		else {
842			$opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
843				if $opt->{filter};
844#::logDebug("set_field: table=$selector key=$key field=$field foreign=$opt->{foreign} value=$opt->{value}");
845			my $orig = $opt->{value};
846			if($opt->{serial}) {
847				$field =~ s/\.(.*)//;
848				my $hk = $1;
849				my $current = database_field($selector,$key,$field,$opt->{foreign});
850				$opt->{value} = dotted_hash($current, $hk, $orig);
851			}
852			my $result = set_field(
853							$selector,
854							$key,
855							$field,
856							$opt->{value},
857							$opt->{append},
858							$opt->{foreign},
859						);
860			return $orig if $opt->{serial};
861			return $result
862		}
863	}
864	elsif ($opt->{serial}) {
865		$field =~ s/\.(.*)//;
866		my $hk = $1;
867		return ed(
868					dotted_hash(
869						database_field($selector,$key,$field,$opt->{foreign}),
870						$hk,
871					)
872				);
873	}
874	elsif ($opt->{hash}) {
875		return undef unless $db->record_exists($key);
876		return $db->row_hash($key);
877	}
878	elsif ($opt->{filter}) {
879		return filter_value(
880			$opt->{filter},
881			ed(database_field($selector,$key,$field,$opt->{foreign})),
882			$field,
883		);
884	}
885
886	#The most common , don't enter a block, no accoutrements
887	return ed(database_field($selector,$key,$field,$opt->{foreign}));
888}
889
890sub input_filter_do {
891	my($varname, $opt, $routine) = @_;
892#::logDebug("filter var=$varname opt=" . uneval_it($opt));
893	return undef unless defined $CGI::values{$varname};
894#::logDebug("before filter=$CGI::values{$varname}");
895	$routine = $opt->{routine} || ''
896		if ! $routine;
897	if($routine =~ /\S/) {
898		$routine = interpolate_html($routine);
899		$CGI::values{$varname} = tag_calc($routine);
900	}
901	if ($opt->{op}) {
902		$CGI::values{$varname} = filter_value($opt->{op}, $CGI::values{$varname}, $varname);
903	}
904#::logDebug("after filter=$CGI::values{$varname}");
905	return;
906}
907
908sub input_filter {
909	my ($varname, $opt, $routine) = @_;
910	if($opt->{remove}) {
911		return if ! ref $Vend::Session->{Filter};
912		delete $Vend::Session->{Filter}{$_};
913		return;
914	}
915	$opt->{routine} = $routine if $routine =~ /\S/;
916	$Vend::Session->{Filter} = {} if ! $Vend::Session->{Filter};
917	$Vend::Session->{Filter}{$varname} = $opt->{op} if $opt->{op};
918	return;
919}
920
921sub conditional {
922	my($base,$term,$operator,$comp, @addl) = @_;
923	my $reverse;
924
925	# Only lowercase the first word-characters part of the conditional so that
926	# file-T doesn't turn into file-t (which is something different).
927	$base =~ s/(\w+)/\L$1/;
928
929	$base =~ s/^!// and $reverse = 1;
930	my ($op, $status);
931	my $noop;
932	$noop = 1, $operator = '' unless defined $operator;
933
934	my $sub;
935	my $newcomp;
936
937	if($operator =~ /^([^\s.]+)\.(.+)/) {
938		$operator = $1;
939		my $tag = $2;
940		my $arg;
941		if($comp =~ /^\w[-\w]+=/) {
942			$arg = get_option_hash($comp);
943		}
944		else {
945			$arg = $comp;
946		}
947
948		$Tag ||= new Vend::Tags;
949#::logDebug("ready to call tag=$tag with arg=$arg");
950		$comp = $Tag->$tag($arg);
951	}
952
953	if($sub = $cond_op{$operator}) {
954		$noop = 1;
955		$newcomp = $comp;
956		undef $comp;
957		$newcomp =~ s/^(["'])(.*)\1$/$2/s or
958			$newcomp =~ s/^qq?([{(])(.*)[})]$/$2/s or
959				$newcomp =~ s/^qq?(\S)(.*)\1$/$2/s;
960	}
961
962	local($^W) = 0;
963	undef $@;
964#::logDebug("cond: base=$base term=$term op=$operator comp=$comp newcomp=$newcomp nooop=$noop\n");
965#::logDebug (($reverse ? '!' : '') . "cond: base=$base term=$term op=$operator comp=$comp");
966
967#::logDebug ("cond: base=$base term=$term op=$operator comp=$comp\n");
968
969	my $total;
970	if($base eq 'total') {
971		$base = $term;
972		$total = 1;
973	}
974
975	if($base eq 'session') {
976		$op =	qq%$Vend::Session->{$term}%;
977		$op = "q{$op}" unless defined $noop;
978		$op .=	qq%	$operator $comp%
979				if defined $comp;
980	}
981	elsif($base eq 'scratch') {
982		$op =	qq%$::Scratch->{$term}%;
983		$op = "q{$op}" unless defined $noop;
984		$op .=	qq%	$operator $comp%
985				if defined $comp;
986	}
987	elsif($base eq 'scratchd') {
988		$op =	qq%$::Scratch->{$term}%;
989		$op = "q{$op}" unless defined $noop;
990		$op .=	qq%	$operator $comp%
991				if defined $comp;
992		delete $::Scratch->{$term};
993	}
994	elsif($base =~ /^value/) {
995		$op =	qq%$::Values->{$term}%;
996		$op = "q{$op}" unless defined $noop;
997		$op .=	qq%	$operator $comp%
998				if defined $comp;
999	}
1000	elsif($base eq 'cgi') {
1001		$op =	qq%$CGI::values{$term}%;
1002		$op = "q{$op}" unless defined $noop;
1003		$op .=	qq%	$operator $comp%
1004				if defined $comp;
1005	}
1006	elsif($base eq 'pragma') {
1007		$op =	qq%$::Pragma->{$term}%;
1008		$op = "q{$op}" unless defined $noop;
1009		$op .=	qq%	$operator $comp%
1010				if defined $comp;
1011	}
1012	elsif($base eq 'explicit') {
1013		undef $noop;
1014		$status = $ready_safe->reval($comp);
1015	}
1016	elsif($base =~ /^var(?:iable)?$/) {
1017		$op =	qq%$::Variable->{$term}%;
1018		$op = "q{$op}" unless defined $noop;
1019		$op .=	qq%	$operator $comp%
1020				if defined $comp;
1021	}
1022	elsif($base eq 'global') {
1023		$op =	qq%$Global::Variable->{$term}%;
1024		$op = "q{$op}" unless defined $noop;
1025		$op .=	qq%	$operator $comp%
1026				if defined $comp;
1027	}
1028    elsif($base eq 'items') {
1029		my $cart;
1030        if($term) {
1031        	$cart = $::Carts->{$term} || undef;
1032		}
1033		else {
1034			$cart = $Vend::Items;
1035		}
1036		$op =   defined $cart ? scalar @{$cart} : 0;
1037
1038        $op .=  qq% $operator $comp%
1039                if defined $comp;
1040    }
1041	elsif($base eq 'data') {
1042		my($d,$f,$k) = split /::/, $term, 3;
1043		$op = database_field($d,$k,$f);
1044#::logDebug ("tag_if db=$d fld=$f key=$k\n");
1045		$op = "q{$op}" unless defined $noop;
1046		$op .=	qq%	$operator $comp%
1047				if defined $comp;
1048	}
1049	elsif($base eq 'field') {
1050		my($f,$k) = split /::/, $term;
1051		$op = product_field($f,$k);
1052#::logDebug("tag_if field fld=$f key=$k\n");
1053		$op = "q{$op}" unless defined $noop;
1054		$op .=	qq%	$operator $comp%
1055				if defined $comp;
1056	}
1057	elsif($base eq 'discount') {
1058		# Use switch_discount_space to ensure that the hash is set properly.
1059		switch_discount_space($Vend::DiscountSpaceName)
1060			unless ref $::Discounts eq 'HASH';
1061		$op =	qq%$::Discounts->{$term}%;
1062		$op = "q{$op}" unless defined $noop;
1063		$op .=	qq%	$operator $comp%
1064				if defined $comp;
1065	}
1066	elsif($base eq 'ordered') {
1067		$operator = 'main' unless $operator;
1068		my ($attrib, $i);
1069		$op = '';
1070		unless ($comp) {
1071			$attrib = 'quantity';
1072		}
1073		else {
1074			($attrib,$comp) = split /\s+/, $comp;
1075		}
1076		foreach $i (@{$::Carts->{$operator}}) {
1077			next unless $i->{code} eq $term;
1078			($op++, next) if $attrib eq 'lines';
1079			$op = $i->{$attrib};
1080			last;
1081		}
1082		$op = "q{$op}" unless defined $noop;
1083		$op .=  qq% $comp% if $comp;
1084	}
1085	elsif($base =~ /^file(-([A-Za-z]))?$/) {
1086		#$op =~ s/[^rwxezfdTsB]//g;
1087		#$op = substr($op,0,1) || 'f';
1088		my $fop = $2 || 'f';
1089		if(! $file_op{$fop}) {
1090			logError("Unrecognized file test '%s'. Returning false.", $fop);
1091			$status = 0;
1092		}
1093		else {
1094			$op = $file_op{$fop}->($term);
1095		}
1096	}
1097	elsif($base =~ /^errors?$/) {
1098		my $err;
1099		if(! $term or $total) {
1100			$err	= is_hash($Vend::Session->{errors})
1101					? scalar (keys %{$Vend::Session->{errors}})
1102					: 0;
1103		}
1104		else {
1105			$err	= is_hash($Vend::Session->{errors})
1106					? $Vend::Session->{errors}{$term}
1107					: 0;
1108		}
1109		$op = $err;
1110		$op .=	qq%	$operator $comp%
1111				if defined $comp;
1112	}
1113	elsif($base =~ /^warnings?$/) {
1114		my $warn = 0;
1115		if(my $ary = $Vend::Session->{warnings}) {
1116			ref($ary) eq 'ARRAY' and $warn = scalar(@$ary);
1117		}
1118		$op = $warn;
1119	}
1120	elsif($base eq 'validcc') {
1121		no strict 'refs';
1122		$status = Vend::Order::validate_whole_cc($term, $operator, $comp);
1123	}
1124    elsif($base eq 'config') {
1125		my @terms = split /::|->|\./, $term;
1126		eval {
1127			$op = $Vend::Cfg;
1128			while(my $t = shift(@terms)) {
1129				$op = $op->{$t};
1130			}
1131		};
1132
1133		$op = "q{$op}" unless defined $noop;
1134		$op .=	qq%	$operator $comp%
1135				if defined $comp;
1136    }
1137    elsif($base =~ /^module.version/) {
1138		eval {
1139			no strict 'refs';
1140			$op = ${"${term}::VERSION"};
1141			$op = "q{$op}" unless defined $noop;
1142			$op .=	qq%	$operator $comp%
1143					if defined $comp;
1144		};
1145    }
1146	elsif($base =~ /^accessor/) {
1147        if ($comp) {
1148            $op = qq%$Vend::Cfg->{Accessories}->{$term}%;
1149			$op = "q{$op}" unless defined $noop;
1150            $op .=  qq% $operator $comp%;
1151        }
1152        else {
1153            for(@{$Vend::Cfg->{UseModifier}}) {
1154                next unless product_field($_,$term);
1155                $status = 1;
1156                last;
1157            }
1158        }
1159	}
1160	elsif($base eq 'control') {
1161		$op = 0;
1162		if (defined $::Scratch->{control_index}
1163			and defined $::Control->[$Scratch->{control_index}]) {
1164			$op = qq%$::Control->[$::Scratch->{control_index}]{$term}%;
1165			$op = "q{$op}"
1166				unless defined $noop;
1167			$op .= qq% $operator $comp%
1168				if defined $comp;
1169		}
1170	}
1171	elsif($base eq 'env') {
1172		my $env;
1173		if (my $h = ::http()) {
1174			$env = $h->{env};
1175		}
1176		else {
1177			$env = \%ENV;
1178		}
1179		$op = qq%$env->{$term}%;
1180		$op = "q{$op}" unless defined $noop;
1181		$op .= qq% $operator $comp%
1182			if defined $comp;
1183	}
1184	else {
1185		$op =	qq%$term%;
1186		$op = "q{$op}" unless defined $noop;
1187		$op .=	qq%	$operator $comp%
1188				if defined $comp;
1189	}
1190
1191#::logDebug("noop='$noop' op='$op'");
1192
1193	RUNSAFE: {
1194		last RUNSAFE if defined $status;
1195
1196		if($sub) {
1197			$status = $sub->($op, $newcomp);
1198			last RUNSAFE;
1199		}
1200		elsif ($noop) {
1201			$status = $op ? 1 : 0;
1202			last RUNSAFE;
1203		}
1204
1205		Vend::CharSet->utf8_safe_regex_workaround($ready_safe)
1206		    if $::Variable->{MV_UTF8};
1207		$ready_safe->trap(@{$Global::SafeTrap});
1208		$ready_safe->untrap(@{$Global::SafeUntrap});
1209		$status = $ready_safe->reval($op) ? 1 : 0;
1210		if ($@) {
1211			logError "Bad if '@_': $@";
1212			$status = 0;
1213		}
1214	}
1215
1216	$status = $reverse ? ! $status : $status;
1217
1218	for(@addl) {
1219		my $chain = /^\[[Aa]/;
1220		last if ($chain ^ $status);
1221		$status = ${(new Vend::Parse)->parse($_)->{OUT}} ? 1 : 0;
1222	}
1223#::logDebug("if status=$status");
1224
1225	return $status;
1226}
1227
1228sub find_close_square {
1229    my $chunk = shift;
1230    my $first = index($chunk, ']');
1231    return undef if $first < 0;
1232    my $int = index($chunk, '[');
1233    my $pos = 0;
1234    while( $int > -1 and $int < $first) {
1235        $pos   = $int + 1;
1236        $first = index($chunk, ']', $first + 1);
1237        $int   = index($chunk, '[', $pos);
1238    }
1239    return substr($chunk, 0, $first);
1240}
1241
1242sub find_andor {
1243	my($text) = @_;
1244	return undef
1245		unless $$text =~ s# \s* \[
1246								( (?:[Aa][Nn][Dd]|[Oo][Rr]) \s+
1247									$All)
1248									#$1#x;
1249	my $expr = find_close_square($$text);
1250	return undef unless defined $expr;
1251	$$text = substr( $$text,length($expr) + 1 );
1252	return "[$expr]";
1253}
1254
1255sub split_if {
1256	my ($body) = @_;
1257
1258	my ($then, $else, $elsif, $andor, @addl);
1259	$else = $elsif = '';
1260
1261	push (@addl, $andor) while $andor = find_andor(\$body);
1262
1263	$body =~ s#$QR{then}##o
1264		and $then = $1;
1265
1266	$body =~ s#$QR{has_else}##o
1267		and $else = find_matching_else(\$body);
1268
1269	$body =~ s#$QR{elsif_end}##o
1270		and $elsif = $1;
1271
1272	$body = $then if defined $then;
1273
1274	return($body, $elsif, $else, @addl);
1275}
1276
1277sub tag_if {
1278	my ($cond,$body,$negate) = @_;
1279#::logDebug("Called tag_if: $cond\n$body\n");
1280	my ($base, $term, $op, $operator, $comp);
1281	my ($else, $elsif, $else_present, @addl);
1282
1283	($base, $term, $operator, $comp) = split /\s+/, $cond, 4;
1284	if ($base eq 'explicit') {
1285		$body =~ s#$QR{condition_begin}##o
1286			and ($comp = $1, $operator = '');
1287	}
1288#::logDebug("tag_if: base=$base term=$term op=$operator comp=$comp");
1289
1290	#Handle unless
1291	($base =~ s/^\W+// or $base = "!$base") if $negate;
1292
1293	$else_present = 1 if
1294		$body =~ /\[[EeTtAaOo][hHLlNnRr][SsEeDd\s]/;
1295
1296	($body, $elsif, $else, @addl) = split_if($body)
1297		if $else_present;
1298
1299#::logDebug("Additional ops found:\n" . join("\n", @addl) ) if @addl;
1300
1301	unless(defined $operator) {
1302		undef $operator;
1303		undef $comp;
1304	}
1305
1306	my $status = conditional ($base, $term, $operator, $comp, @addl);
1307
1308#::logDebug("Result of if: $status\n");
1309
1310	my $out;
1311	if($status) {
1312		$out = $body;
1313	}
1314	elsif ($elsif) {
1315		$else = '[else]' . $else . '[/else]' if length $else;
1316		my $pertinent = Vend::Parse::find_matching_end('elsif', \$elsif);
1317		unless(defined $pertinent) {
1318			$pertinent = $elsif;
1319			$elsif = '';
1320		}
1321		$elsif .= '[/elsif]' if $elsif =~ /\S/;
1322		$out = '[if ' . $pertinent . $elsif . $else . '[/if]';
1323	}
1324	elsif (length $else) {
1325		$out = $else;
1326	}
1327	return $out;
1328}
1329
1330# This generates a *session-based* Autoload routine based
1331# on the contents of a preset Profile (see the Profile directive).
1332#
1333# Normally used for setting pricing profiles with CommonAdjust,
1334# ProductFiles, etc.
1335#
1336sub restore_profile {
1337	my $save;
1338	return unless $save = $Vend::Session->{Profile_save};
1339	for(keys %$save) {
1340		$Vend::Cfg->{$_} = $save->{$_};
1341	}
1342	return;
1343}
1344
1345sub tag_profile {
1346	my($profile, $opt) = @_;
1347#::logDebug("in tag_profile=$profile opt=" . uneval_it($opt));
1348
1349	$opt = {} if ! $opt;
1350	my $tag = $opt->{tag} || 'default';
1351
1352	if(! $profile) {
1353		if($opt->{restore}) {
1354			restore_profile();
1355			if(ref $Vend::Session->{Autoload}) {
1356				 @{$Vend::Session->{Autoload}} =
1357					 grep $_ !~ /^$tag-/, @{$Vend::Session->{Autoload}};
1358			}
1359		}
1360		return if ! ref $Vend::Session->{Autoload};
1361		$opt->{joiner} = ' ' unless defined $opt->{joiner};
1362		return join $opt->{joiner},
1363			grep /^\w+-\w+$/, @{ $Vend::Session->{Autoload} };
1364	}
1365
1366	if($profile =~ s/(\w+)-//) {
1367		$opt->{tag} = $1;
1368		$opt->{run} = 1;
1369	}
1370	elsif (! $opt->{set} and ! $opt->{run}) {
1371		$opt->{set} = $opt->{run} = 1;
1372	}
1373
1374	if( "$profile$tag" =~ /\W/ ) {
1375		logError(
1376			"profile: invalid characters (tag=%s profile=%s), must be [A-Za-z_]+",
1377			$tag,
1378			$profile,
1379		);
1380		return $opt->{failure};
1381	}
1382
1383	if($opt->{run}) {
1384#::logDebug("running profile=$profile tag=$tag");
1385		my $prof = $Vend::Cfg->{Profile_repository}{$profile};
1386	    if (not $prof) {
1387			logError( "profile %s (%s) non-existant.", $profile, $tag );
1388			return $opt->{failure};
1389		}
1390#::logDebug("found profile=$profile");
1391		$Vend::Cfg->{Profile} = $prof;
1392		restore_profile();
1393#::logDebug("restored profile");
1394		PROFSET:
1395		for my $one (keys %$prof) {
1396#::logDebug("doing profile $one");
1397			next unless defined $Vend::Cfg->{$one};
1398			my $string;
1399			my $val = $prof->{$one};
1400			if( ! ref $Vend::Cfg->{$one} ) {
1401				# Do nothing
1402			}
1403			elsif( ref($Vend::Cfg->{$one}) eq 'HASH') {
1404				if( ref($val) ne 'HASH') {
1405				$string = '{' .  $prof->{$one}	. '}'
1406					unless	$prof->{$one} =~ /^{/
1407					and		$prof->{$one} =~ /}\s*$/;
1408			}
1409			}
1410			elsif( ref($Vend::Cfg->{$one}) eq 'ARRAY') {
1411				if( ref($val) ne 'ARRAY') {
1412				$string = '[' .  $prof->{$one}	. ']'
1413					unless	$prof->{$one} =~ /^\[/
1414					and		$prof->{$one} =~ /]\s*$/;
1415			}
1416			}
1417			else {
1418				logError( "profile: cannot handle object of type %s.",
1419							$Vend::Cfg->{$one},
1420							);
1421				logError("profile: profile for $one not changed.");
1422				next;
1423			}
1424
1425#::logDebug("profile value=$val, string=$string");
1426			undef $@;
1427			$val = $ready_safe->reval($string) if $string;
1428
1429			if($@) {
1430				logError( "profile: bad object %s: %s", $one, $string );
1431				next;
1432			}
1433			$Vend::Session->{Profile_save}{$one} = $Vend::Cfg->{$one}
1434				unless defined $Vend::Session->{Profile_save}{$one};
1435
1436#::logDebug("set $one to value=$val, string=$string");
1437			$Vend::Cfg->{$one} = $val;
1438		}
1439		return $opt->{success}
1440			unless $opt->{set};
1441	}
1442
1443#::logDebug("setting profile=$profile tag=$tag");
1444	my $al;
1445	if(! $Vend::Session->{Autoload}) {
1446		# Do nothing....
1447	}
1448	elsif(ref $Vend::Session->{Autoload}) {
1449		$al = $Vend::Session->{Autoload};
1450	}
1451	else {
1452		$al = [ $Vend::Session->{Autoload} ];
1453	}
1454
1455	if($al) {
1456		@$al = grep $_ !~ m{^$tag-\w+$}, @$al;
1457	}
1458	$al = [] if ! $al;
1459	push @$al, "$tag-$profile";
1460#::logDebug("profile=$profile Autoload=" . uneval_it($al));
1461	$Vend::Session->{Autoload} = $al;
1462
1463	return $opt->{success};
1464}
1465
1466*tag_options = \&Vend::Options::tag_options;
1467
1468sub produce_range {
1469	my ($ary, $max) = @_;
1470	$max = $::Limit->{option_list} if ! $max;
1471	my @do;
1472	for (my $i = 0; $i < scalar(@$ary); $i++) {
1473		$ary->[$i] =~ /^\s* ([a-zA-Z0-9]+) \s* \.\.+ \s* ([a-zA-Z0-9]+) \s* $/x
1474			or next;
1475		my @new = $1 .. $2;
1476		if(@new > $max) {
1477			logError(
1478				"Refuse to add %d options to option list via range, max %d.",
1479				scalar(@new),
1480				$max,
1481				);
1482			next;
1483		}
1484		push @do, $i, \@new;
1485	}
1486	my $idx;
1487	my $new;
1488	while($new = pop(@do)) {
1489		my $idx = pop(@do);
1490		splice @$ary, $idx, 1, @$new;
1491	}
1492	return;
1493}
1494
1495sub tag_accessories {
1496	my($code,$extra,$opt,$item) = @_;
1497
1498	my $ishash;
1499	if(ref $item) {
1500#::logDebug("tag_accessories: item is a hash");
1501		$ishash = 1;
1502	}
1503
1504	# Had extra if got here
1505#::logDebug("tag_accessories: code=$code opt=" . uneval_it($opt) . " item=" . uneval_it($item) . " extra=$extra");
1506	my($attribute, $type, $field, $db, $name, $outboard, $passed);
1507	$opt = {} if ! $opt;
1508	if($extra) {
1509		$extra =~ s/^\s+//;
1510		$extra =~ s/\s+$//;
1511		@{$opt}{qw/attribute type column table name outboard passed/} =
1512			split /\s*,\s*/, $extra;
1513	}
1514	($attribute, $type, $field, $db, $name, $outboard, $passed) =
1515		@{$opt}{qw/attribute type column table name outboard passed/};
1516
1517	## Code only passed when we are a product
1518	if($code) {
1519		GETACC: {
1520			my $col =  $opt->{column} || $opt->{attribute};
1521			my $key = $opt->{outboard} || $code;
1522			last GETACC if ! $col;
1523			if($opt->{table}) {
1524				$opt->{passed} ||= tag_data($opt->{table}, $col, $key);
1525			}
1526			else {
1527				$opt->{passed} ||= product_field($col, $key);
1528			}
1529		}
1530
1531		return unless $opt->{passed} || $opt->{type};
1532		$opt->{type} ||= 'select';
1533		return unless
1534			$opt->{passed}
1535				or
1536			$opt->{type} =~ /^(text|password|hidden)/i;
1537	}
1538
1539	return Vend::Form::display($opt, $item);
1540}
1541
1542# MVASP
1543
1544sub mvasp {
1545	my ($tables, $opt, $text) = @_;
1546	my @code;
1547	$opt->{no_return} = 1 unless defined $opt->{no_return};
1548
1549	while ( $text =~ s/(.*?)<%//s || $text =~ s/(.+)//s ) {
1550		push @code, <<EOF;
1551; my \$html = <<'_MV_ASP_EOF$^T';
1552$1
1553_MV_ASP_EOF$^T
1554chop(\$html);
1555		HTML( \$html );
1556EOF
1557		$text =~ s/(.*?)%>//s
1558			or last;;
1559		my $bit = $1;
1560		if ($bit =~ s/^\s*=\s*//) {
1561			$bit =~ s/;\s*$//;
1562			push @code, "; HTML( $bit );"
1563		}
1564		else {
1565			push @code, $bit, ";\n";
1566		}
1567	}
1568	my $asp = join "", @code;
1569#::logDebug("ASP CALL:\n$asp\n");
1570	return tag_perl ($tables, $opt, $asp);
1571}
1572
1573# END MVASP
1574
1575$safe_safe = new Safe;
1576
1577sub tag_perl {
1578	my ($tables, $opt,$body) = @_;
1579	my ($result,@share);
1580#::logDebug("tag_perl MVSAFE=$MVSAFE::Safe opts=" . uneval($opt));
1581
1582	if($Vend::NoInterpolate) {
1583		logGlobal({ level => 'alert' },
1584					"Attempt to interpolate perl/ITL from RPC, no permissions."
1585					);
1586		return undef;
1587	}
1588
1589	if ($MVSAFE::Safe) {
1590#::logDebug("tag_perl: Attempt to call perl from within Safe.");
1591		return undef;
1592	}
1593
1594#::logDebug("tag_perl: tables=$tables opt=" . uneval($opt) . " body=$body");
1595#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
1596	if($opt->{subs} or $opt->{arg} =~ /\bsub\b/) {
1597		no strict 'refs';
1598		for(keys %{$Global::GlobalSub}) {
1599#::logDebug("tag_perl share subs: GlobalSub=$_");
1600			next if defined $Global::AdminSub->{$_}
1601				and ! $Global::AllowGlobal->{$Vend::Cat};
1602			*$_ = \&{$Global::GlobalSub->{$_}};
1603			push @share, "&$_";
1604		}
1605		for(keys %{$Vend::Cfg->{Sub} || {}}) {
1606#::logDebug("tag_perl share subs: Sub=$_");
1607			*$_ = \&{$Vend::Cfg->{Sub}->{$_}};
1608			push @share, "&$_";
1609		}
1610	}
1611
1612	if($tables) {
1613		my (@tab) = grep /\S/, split /\s+/, $tables;
1614		foreach my $tab (@tab) {
1615			next if $Db{$tab};
1616			my $db = database_exists_ref($tab);
1617			next unless $db;
1618			my $dbh;
1619			$db = $db->ref();
1620			if($db->config('type') == 10) {
1621				my @extra_tabs = $db->_shared_databases();
1622				push (@tab, @extra_tabs);
1623				$dbh = $db->dbh();
1624			} elsif ($db->can('dbh')) {
1625				$dbh = $db->dbh();
1626			}
1627
1628			if($hole) {
1629				if ($dbh) {
1630					$Sql{$tab} = $hole->wrap($dbh);
1631				}
1632				$Db{$tab} = $hole->wrap($db);
1633				if($db->config('name') ne $tab) {
1634					$Db{$db->config('name')} = $Db{$tab};
1635				}
1636			}
1637			else {
1638				$Sql{$tab} = $db->[$Vend::Table::DBI::DBI]
1639					if $db =~ /::DBI/;
1640				$Db{$tab} = $db;
1641			}
1642		}
1643	}
1644
1645	$Tag = $hole->wrap($Tag) if $hole and ! $Vend::TagWrapped++;
1646
1647	init_calc() if ! $Vend::Calc_initialized;
1648	$ready_safe->share(@share) if @share;
1649
1650	if($Vend::Cfg->{Tie_Watch}) {
1651		eval {
1652			for(@{$Vend::Cfg->{Tie_Watch}}) {
1653				logGlobal("touching $_");
1654				my $junk = $Config->{$_};
1655			}
1656		};
1657	}
1658
1659	$Items = $Vend::Items;
1660
1661	$body = readfile($opt->{file}) . $body
1662		if $opt->{file};
1663
1664	# Skip costly eval of code entirely if perl tag was called with no code,
1665	# likely used only for the side-effect of opening database handles
1666	return if $body !~ /\S/;
1667
1668	$body =~ tr/\r//d if $Global::Windows;
1669
1670	$MVSAFE::Safe = 1;
1671	if (
1672		$opt->{global}
1673			and
1674		$Global::AllowGlobal->{$Vend::Cat}
1675		)
1676	{
1677		$MVSAFE::Safe = 0 unless $MVSAFE::Unsafe;
1678	}
1679
1680	if(! $MVSAFE::Safe) {
1681		$result = eval($body);
1682	}
1683	else {
1684		$result = $ready_safe->reval($body);
1685	}
1686
1687	undef $MVSAFE::Safe;
1688
1689	if ($@) {
1690#::logDebug("tag_perl failed $@");
1691		my $msg = $@;
1692		if($Vend::Try) {
1693			$Vend::Session->{try}{$Vend::Try} .= "\n"
1694				if $Vend::Session->{try}{$Vend::Try};
1695			$Vend::Session->{try}{$Vend::Try} .= $@;
1696		}
1697        if($opt->{number_errors}) {
1698            my @lines = split("\n",$body);
1699            my $counter = 1;
1700            map { $_ = sprintf("% 4d %s",$counter++,$_); } @lines;
1701            $body = join("\n",@lines);
1702        }
1703        if($opt->{trim_errors}) {
1704            if($msg =~ /line (\d+)\.$/) {
1705                my @lines = split("\n",$body);
1706                my $start = $1 - $opt->{trim_errors} - 1;
1707                my $length = (2 * $opt->{trim_errors}) + 1;
1708                @lines = splice(@lines,$start,$length);
1709                $body = join("\n",@lines);
1710            }
1711        }
1712        if($opt->{eval_label}) {
1713            $msg =~ s/\(eval \d+\)/($opt->{eval_label})/g;
1714        }
1715        if($opt->{short_errors}) {
1716            chomp($msg);
1717            logError( "Safe: %s" , $msg );
1718            logGlobal({ level => 'debug' }, "Safe: %s" , $msg );
1719        } else {
1720            logError( "Safe: %s\n%s\n" , $msg, $body );
1721            logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body );
1722        }
1723		return $opt->{failure};
1724	}
1725#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
1726
1727	if ($opt->{no_return}) {
1728		$Vend::Session->{mv_perl_result} = $result;
1729		$result = join "", @Vend::Document::Out;
1730		@Vend::Document::Out = ();
1731	}
1732#::logDebug("tag_perl succeeded result=$result\nEND");
1733	return $result;
1734}
1735
1736sub ed {
1737	return $_[0] if ! $_[0] or $Safe_data or $::Pragma->{safe_data};
1738	$_[0] =~ s/\[/&#91;/g;
1739	return $_[0];
1740}
1741
1742sub show_tags {
1743	my($type, $opt, $text) = @_;
1744
1745	$type = 'html interchange' unless $type;
1746	$type =~ s/minivend/interchange/g;
1747
1748	if ($type =~ /interchange/i) {
1749		$text =~ s/\[/&#91;/g;
1750	}
1751	if($type =~ /html/i) {
1752		$text =~ s/\</&lt;/g;
1753	}
1754	return $text;
1755}
1756
1757sub pragma {
1758	my($pragma, $opt, $text) = @_;
1759	$pragma =~ s/\W+//g;
1760
1761	my $value = defined $opt->{value} ? $opt->{value} : 1;
1762	if(! defined $opt->{value} and $text =~ /\S/) {
1763		$value = $text;
1764	}
1765
1766	$::Pragma->{$pragma} = $value;
1767	return;
1768}
1769
1770sub flag {
1771	my($flag, $opt, $text) = @_;
1772	$flag = lc $flag;
1773
1774	if(! $text) {
1775		($flag, $text) = split /\s+/, $flag;
1776	}
1777	my $value = defined $opt->{value} ? $opt->{value} : 1;
1778	my $fmt = $opt->{status} || '';
1779	my @status;
1780
1781#::logDebug("tag flag=$flag text=$text value=$value opt=". uneval_it($opt));
1782	if($flag eq 'write' || $flag eq 'read') {
1783		my $arg = $opt->{table} || $text;
1784		$value = 0 if $flag eq 'read';
1785		my (@args) = Text::ParseWords::shellwords($arg);
1786		my $dbname;
1787		foreach $dbname (@args) {
1788			# Handle table:column:key
1789			$dbname =~ s/:.*//;
1790#::logDebug("tag flag write $dbname=$value");
1791			$Vend::WriteDatabase{$dbname} = $value;
1792		}
1793	}
1794	elsif($flag =~ /^transactions?/i) {
1795		my $arg = $opt->{table} || $text;
1796		my (@args) = Text::ParseWords::shellwords($arg);
1797		my $dbname;
1798		foreach $dbname (@args) {
1799			# Handle table:column:key
1800			$dbname =~ s/:.*//;
1801			$Vend::TransactionDatabase{$dbname} = $value;
1802			$Vend::WriteDatabase{$dbname} = $value;
1803
1804			# we can't do anything else if in Safe
1805			next if $MVSAFE::Safe;
1806
1807			# Now we close and reopen
1808			my $db = database_exists_ref($dbname)
1809				or next;
1810			if($db->isopen()) {
1811				# need to reopen in transactions mode.
1812				$db->close_table();
1813				$db->suicide();
1814				$db = database_exists_ref($dbname);
1815				$db = $db->ref();
1816			}
1817			$Db{$dbname} = $db;
1818			$Sql{$dbname} = $db->dbh()
1819				if $db->can('dbh');
1820		}
1821	}
1822	elsif($flag eq 'commit' || $flag eq 'rollback') {
1823		my $arg = $opt->{table} || $text;
1824		$value = 0 if $flag eq 'rollback';
1825		my $method = $value ? 'commit' : 'rollback';
1826		my (@args) = Text::ParseWords::shellwords($arg);
1827		my $dbname;
1828		foreach $dbname (@args) {
1829			# Handle table:column:key
1830			$dbname =~ s/:.*//;
1831#::logDebug("tag commit $dbname=$value");
1832			my $db = database_exists_ref($dbname);
1833			next unless $db->isopen();
1834			next unless $db->config('Transactions');
1835			if( ! $db ) {
1836				logError("attempt to $method on unknown database: %s", $dbname);
1837				return undef;
1838			}
1839			if( ! $db->$method() ) {
1840				logError("problem doing $method for table: %s", $dbname);
1841				return undef;
1842			}
1843		}
1844	}
1845	elsif($flag eq 'checkhtml') {
1846		$Vend::CheckHTML = $value;
1847		@status = ("Set CheckHTML flag: %s", $value);
1848	}
1849	else {
1850		@status = ("Unknown flag operation '%s', ignored.", $flag);
1851		$status[0] = $opt->{status} if $opt->{status};
1852		logError( @status );
1853	}
1854	return '' unless $opt->{show};
1855	$status[0] = $opt->{status} if $opt->{status};
1856	return errmsg(@status);
1857}
1858
1859sub tag_export {
1860	my ($args, $opt, $text) = @_;
1861	$opt->{base} = $opt->{table} || $opt->{database} || undef
1862		unless defined $opt->{base};
1863	unless (defined $opt->{base}) {
1864		@{$opt}{ qw/base file type/ } = split /\s+/, $args;
1865	}
1866	if($opt->{delete}) {
1867		undef $opt->{delete} unless $opt->{verify};
1868	}
1869#::logDebug("exporting " . join (",", @{$opt}{ qw/base file type field delete/ }));
1870	my $status = Vend::Data::export_database(
1871			@{$opt}{ qw/base file type/ }, $opt,
1872		);
1873	return $status unless $opt->{hide};
1874	return '';
1875}
1876
1877sub export {
1878	my ($table, $opt, $text) = @_;
1879	if($opt->{delete}) {
1880		undef $opt->{delete} unless $opt->{verify};
1881	}
1882#::logDebug("exporting " . join (",", @{$opt}{ qw/table file type field delete/ }));
1883	my $status = Vend::Data::export_database(
1884			@{$opt}{ qw/table file type/ }, $opt,
1885		);
1886	return $status unless $opt->{hide};
1887	return '';
1888}
1889
1890sub mime {
1891	my ($option, $opt, $text) = @_;
1892	my $id;
1893
1894	my $out;
1895
1896#::logDebug("mime call, opt=" . uneval($opt));
1897	$Vend::TIMESTAMP = POSIX::strftime("%y%m%d%H%M%S", localtime())
1898		unless defined $Vend::TIMESTAMP;
1899
1900	$::Instance->{MIME_BOUNDARY} =
1901							$::Instance->{MIME_TIMESTAMP} . '-' .
1902							$Vend::SessionID . '-' .
1903							$Vend::Session->{pageCount} .
1904							':=' . $$
1905		unless defined $::Instance->{MIME_BOUNDARY};
1906
1907	my $msg_type = $opt->{type} || "multipart/mixed";
1908	if($option eq 'reset') {
1909		undef $::Instance->{MIME_TIMESTAMP};
1910		undef $::Instance->{MIME_BOUNDARY};
1911		$out = '';
1912	}
1913	elsif($option eq 'boundary') {
1914		$out = "--$::Instance->{MIME_BOUNDARY}";
1915	}
1916	elsif($option eq 'id') {
1917		$::Instance->{MIME} = 1;
1918		$out =	_mime_id();
1919	}
1920	elsif($option eq 'header') {
1921		$id = _mime_id();
1922		$out = <<EndOFmiMe;
1923MIME-Version: 1.0
1924Content-Type: $msg_type; BOUNDARY="$::Instance->{MIME_BOUNDARY}"
1925Content-ID: $id
1926EndOFmiMe
1927	}
1928	elsif ( $text !~ /\S/) {
1929		$out = '';
1930	}
1931	else {
1932		$id = _mime_id();
1933		$::Instance->{MIME} = 1;
1934		my $desc = $opt->{description} || $option;
1935		my $type = $opt->{type} || 'text/plain; charset=US-ASCII';
1936		my $disposition = $opt->{attach_only}
1937						? qq{attachment; filename="$desc"}
1938						: "inline";
1939		my $encoding = $opt->{transfer_encoding};
1940		my @headers;
1941		push @headers, "Content-Type: $type";
1942		push @headers, "Content-ID: $id";
1943		push @headers, "Content-Disposition: $disposition";
1944		push @headers, "Content-Description: $desc";
1945		push @headers, "Content-Transfer-Encoding: $opt->{transfer_encoding}"
1946			if $opt->{transfer_encoding};
1947		my $head = join "\n", @headers;
1948		$out = <<EndOFmiMe;
1949--$::Instance->{MIME_BOUNDARY}
1950$head
1951
1952$text
1953EndOFmiMe
1954
1955	}
1956#::logDebug("tag mime returns:\n$out");
1957	return $out;
1958}
1959
1960sub log {
1961	my($file, $opt, $data) = @_;
1962	my(@lines);
1963	my(@fields);
1964
1965	my $status;
1966
1967	$file = $opt->{file} || $Vend::Cfg->{LogFile};
1968	if($file =~ s/^\s*>\s*//) {
1969		$opt->{create} = 1;
1970	}
1971
1972	$file = Vend::Util::escape_chars($file);
1973	unless(Vend::File::allowed_file($file)) {
1974		Vend::File::log_file_violation($file, 'log');
1975		return undef;
1976	}
1977
1978	$file = ">$file" if $opt->{create};
1979
1980	unless($opt->{process} and $opt->{process} =~ /\bnostrip\b/i) {
1981		$data =~ s/\r\n/\n/g;
1982		$data =~ s/^\s+//;
1983		$data =~ s/\s+$/\n/;
1984	}
1985
1986	my ($delim, $record_delim);
1987	for(qw/delim record_delim/) {
1988		next unless defined $opt->{$_};
1989		$opt->{$_} = $ready_safe->reval(qq{$opt->{$_}});
1990	}
1991
1992	if($opt->{type}) {
1993		if($opt->{type} =~ /^text/) {
1994			$status = Vend::Util::writefile($file, $data, $opt);
1995		}
1996		elsif($opt->{type} =~ /^\s*quot/) {
1997			$record_delim = $opt->{record_delim} || "\n";
1998			@lines = split /$record_delim/, $data;
1999			for(@lines) {
2000				@fields = Text::ParseWords::shellwords $_;
2001				$status = logData($file, @fields)
2002					or last;
2003			}
2004		}
2005		elsif($opt->{type} =~ /^(?:error|debug)/) {
2006			if ($opt->{file}) {
2007				$data = format_log_msg($data) unless $data =~ s/^\\//;;
2008				$status = Vend::Util::writefile($file, $data, $opt);
2009			}
2010			elsif ($opt->{type} =~ /^debug/) {
2011				$status = Vend::Util::logDebug($data);
2012			}
2013			else {
2014				$status = Vend::Util::logError($data);
2015			}
2016		}
2017	}
2018	else {
2019		$record_delim = $opt->{record_delim} || "\n";
2020		$delim = $opt->{delimiter} || "\t";
2021		@lines = split /$record_delim/, $data;
2022		for(@lines) {
2023			@fields = split /$delim/, $_;
2024			$status = logData($file, @fields)
2025				or last;
2026		}
2027	}
2028
2029	return $status unless $opt->{hide};
2030	return '';
2031}
2032
2033sub _mime_id {
2034	'<Interchange.' . $::VERSION . '.' .
2035	$Vend::TIMESTAMP . '.' .
2036	$Vend::SessionID . '.' .
2037	++$Vend::Session->{pageCount} . '@' .
2038	$Vend::Cfg->{VendURL} . '>';
2039}
2040
2041sub http_header {
2042	shift;
2043	my ($opt, $text) = @_;
2044	$text =~ s/^\s+//;
2045	if($opt->{name}) {
2046		my $name = lc $opt->{name};
2047		$name =~ s/-/_/g;
2048		$name =~ s/\W+//g;
2049		$name =~ tr/_/-/s;
2050		$name =~ s/(\w+)/\u$1/g;
2051		my $content = $opt->{content} || $text;
2052		$content =~ s/^\s+//;
2053		$content =~ s/\s+$//;
2054		$content =~ s/[\r\n]/; /g;
2055		$text = "$name: $content";
2056	}
2057	if($Vend::StatusLine and ! $opt->{replace}) {
2058		$Vend::StatusLine =~ s/\s*$/\r\n/;
2059		$Vend::StatusLine .= $text;
2060	}
2061	else {
2062		$Vend::StatusLine = $text;
2063	}
2064	return $text if $opt->{show};
2065	return '';
2066}
2067
2068sub mvtime {
2069	my ($locale, $opt, $fmt) = @_;
2070	my $current;
2071
2072	if($locale) {
2073		$current = POSIX::setlocale(&POSIX::LC_TIME);
2074		POSIX::setlocale(&POSIX::LC_TIME, $locale);
2075	}
2076
2077	local($ENV{TZ}) = $opt->{tz} if $opt->{tz};
2078
2079	my $now = $opt->{time} || time();
2080	$fmt = '%Y%m%d' if $opt->{sortable};
2081
2082	if($opt->{adjust}) {
2083		my $neg = $opt->{adjust} =~ s/^\s*-\s*//;
2084		my $diff;
2085		$opt->{adjust} =~ s/^\s*\+\s*//;
2086		if($opt->{hours}) {
2087			$diff = (60 * 60) * ($opt->{adjust} || $opt->{hours});
2088		}
2089		elsif($opt->{adjust} !~ /[A-Za-z]/) {
2090			$opt->{adjust} =~ s:(\d+)(\d[05])$:$1 + $2 / 60:e;
2091			$opt->{adjust} =~ s/00$//;
2092			$diff = (60 * 60) * $opt->{adjust};
2093		}
2094		else {
2095			$diff = Vend::Config::time_to_seconds($opt->{adjust});
2096		}
2097		$now = $neg ? $now - $diff : $now + $diff;
2098	}
2099
2100	$fmt ||= $opt->{format} || $opt->{fmt} || '%c';
2101    my $out = $opt->{gmt} ? ( POSIX::strftime($fmt, gmtime($now)    ))
2102                          : ( POSIX::strftime($fmt, localtime($now) ));
2103	$out =~ s/\b0(\d)\b/$1/g if $opt->{zerofix};
2104	POSIX::setlocale(&POSIX::LC_TIME, $current) if defined $current;
2105	return $out;
2106}
2107
2108use vars qw/ %Tag_op_map /;
2109%Tag_op_map = (
2110			PRAGMA	=> \&pragma,
2111			FLAG	=> \&flag,
2112			LOG		=> \&log,
2113			TIME	=> \&mvtime,
2114			HEADER	=> \&http_header,
2115			EXPORT	=> \&tag_export,
2116			TOUCH	=> sub {1},
2117			EACH	=> sub {
2118							my $table = shift;
2119							my $opt = shift;
2120							$opt->{search} = "ra=yes\nst=db\nml=100000\nfi=$table";
2121#::logDebug("tag each: table=$table opt=" . uneval($opt));
2122							return tag_loop_list('', $opt, shift);
2123						},
2124			MIME	=> \&mime,
2125			SHOW_TAGS	=> \&show_tags,
2126		);
2127
2128sub do_tag {
2129	my $op = uc $_[0];
2130#::logDebug("tag op: op=$op opt=" . uneval(\@_));
2131	return $_[3] if !  defined $Tag_op_map{$op};
2132	shift;
2133#::logDebug("tag args now: op=$op opt=" . uneval(\@_));
2134	return &{$Tag_op_map{$op}}(@_);
2135}
2136
2137sub tag_counter {
2138    my $file = shift || 'etc/counter';
2139	my $opt = shift;
2140#::logDebug("counter: file=$file start=$opt->{start} sql=$opt->{sql} routine=$opt->{inc_routine} caller=" . scalar(caller()) );
2141	if($opt->{sql}) {
2142		my ($tab, $seq) = split /:+/, $opt->{sql}, 2;
2143		my $db = database_exists_ref($tab);
2144		my $dbh;
2145		my $dsn;
2146		if($opt->{bypass}) {
2147			$dsn = $opt->{dsn} || $ENV{DBI_DSN};
2148			$dbh = DBI->connect(
2149						$dsn,
2150						$opt->{user},
2151						$opt->{pass},
2152						$opt->{attr},
2153					);
2154		}
2155		elsif($db) {
2156			$dbh = $db->dbh();
2157			$dsn = $db->config('DSN');
2158		}
2159
2160		my $val;
2161
2162		eval {
2163			my $diemsg = errmsg(
2164							"Counter sequence '%s' failed, using file.\n",
2165							$opt->{sql},
2166						);
2167			if(! $dbh) {
2168				die errmsg(
2169						"No database handle for counter sequence '%s', using file.",
2170						$opt->{sql},
2171					);
2172			}
2173			elsif($seq =~ /^\s*SELECT\W/i) {
2174#::logDebug("found custom SQL SELECT for sequence: $seq");
2175				my $sth = $dbh->prepare($seq) or die $diemsg;
2176				$sth->execute or die $diemsg;
2177				($val) = $sth->fetchrow_array;
2178			}
2179			elsif($dsn =~ /^dbi:mysql:/i) {
2180				$seq ||= $tab;
2181				$dbh->do("INSERT INTO $seq VALUES (0)")		or die $diemsg;
2182				my $sth = $dbh->prepare("select LAST_INSERT_ID()")
2183					or die $diemsg;
2184				$sth->execute()								or die $diemsg;
2185				($val) = $sth->fetchrow_array;
2186			}
2187			elsif($dsn =~ /^dbi:Pg:/i) {
2188				my $sth = $dbh->prepare("select nextval('$seq')")
2189					or die $diemsg;
2190				$sth->execute()
2191					or die $diemsg;
2192				($val) = $sth->fetchrow_array;
2193			}
2194			elsif($dsn =~ /^dbi:Oracle:/i) {
2195				my $sth = $dbh->prepare("select $seq.nextval from dual")
2196					or die $diemsg;
2197				$sth->execute()
2198					or die $diemsg;
2199				($val) = $sth->fetchrow_array;
2200			}
2201
2202		};
2203
2204		logOnce('error', $@) if $@;
2205
2206		return $val if defined $val;
2207	}
2208
2209	unless (allowed_file($file)) {
2210		log_file_violation ($file, 'counter');
2211		return undef;
2212	}
2213
2214    $file = $Vend::Cfg->{VendRoot} . "/$file"
2215        unless Vend::Util::file_name_is_absolute($file);
2216
2217	for(qw/inc_routine dec_routine/) {
2218		my $routine = $opt->{$_}
2219			or next;
2220
2221		if( ! ref($routine) ) {
2222			$opt->{$_}   = $Vend::Cfg->{Sub}{$routine};
2223			$opt->{$_} ||= $Global::GlobalSub->{$routine};
2224		}
2225	}
2226
2227    my $ctr = new Vend::CounterFile
2228					$file,
2229					$opt->{start} || undef,
2230					$opt->{date},
2231					$opt->{inc_routine},
2232					$opt->{dec_routine};
2233    return $ctr->value() if $opt->{value};
2234    return $ctr->dec() if $opt->{decrement};
2235    return $ctr->inc();
2236}
2237
2238# Returns the text of a user entered field named VAR.
2239sub tag_value_extended {
2240    my($var, $opt) = @_;
2241
2242	my $vspace = $opt->{values_space};
2243	my $vref;
2244	if (defined $vspace) {
2245		if ($vspace eq '') {
2246			$vref = $Vend::Session->{values};
2247		}
2248		else {
2249			$vref = $Vend::Session->{values_repository}{$vspace} ||= {};
2250		}
2251	}
2252	else {
2253		$vref = $::Values;
2254	}
2255
2256	my $yes = $opt->{yes} || 1;
2257	my $no = $opt->{'no'} || '';
2258
2259	if($opt->{test}) {
2260		$opt->{test} =~ /(?:is)?put/i
2261			and
2262			return defined $CGI::put_ref ? $yes : $no;
2263		$opt->{test} =~ /(?:is)?file/i
2264			and
2265			return defined $CGI::file{$var} ? $yes : $no;
2266		$opt->{test} =~ /defined/i
2267			and
2268			return defined $CGI::values{$var} ? $yes : $no;
2269		return length $CGI::values{$var}
2270			if $opt->{test} =~ /length|size/i;
2271		return '';
2272	}
2273
2274	if($opt->{put_contents}) {
2275		return undef if ! defined $CGI::put_ref;
2276		return $$CGI::put_ref;
2277	}
2278
2279	my $val = $CGI::values{$var} || $vref->{$var} || return undef;
2280	$val =~ s/</&lt;/g unless $opt->{enable_html};
2281	$val =~ s/\[/&#91;/g unless $opt->{enable_itl};
2282
2283	if($opt->{file_contents}) {
2284		return '' if ! defined $CGI::file{$var};
2285		return $CGI::file{$var};
2286	}
2287
2288	if($opt->{put_ref}) {
2289		return $CGI::put_ref;
2290	}
2291
2292	if($opt->{outfile}) {
2293		my $file = $opt->{outfile};
2294		$file =~ s/^\s+//;
2295		$file =~ s/\s+$//;
2296
2297		unless (Vend::File::allowed_file($file)) {
2298			Vend::File::log_file_violation($file, 'value-extended');
2299			return '';
2300		}
2301
2302		if($opt->{ascii}) {
2303			my $replace = $^O =~ /win32/i ? "\r\n" : "\n";
2304			if($CGI::file{$var} !~ /\n/) {
2305				# Must be a mac file.
2306				$CGI::file{$var} =~ s/\r/$replace/g;
2307			}
2308			elsif ( $CGI::file{$var} =~ /\r\n/) {
2309				# Probably a PC file
2310				$CGI::file{$var} =~ s/\r\n/$replace/g;
2311			}
2312			else {
2313				$CGI::file{$var} =~ s/\n/$replace/g;
2314			}
2315		}
2316		if($opt->{maxsize} and length($CGI::file{$var}) > $opt->{maxsize}) {
2317			logError(
2318				"Uploaded file write of %s bytes greater than maxsize %s. Aborted.",
2319				length($CGI::file{$var}),
2320				$opt->{maxsize},
2321			);
2322			return $no;
2323		}
2324#::logDebug(">$file \$CGI::file{$var}" . uneval($opt));
2325		Vend::Util::writefile(">$file", \$CGI::file{$var}, $opt)
2326			and return $yes;
2327		return $no;
2328	}
2329
2330	my $joiner;
2331	if (defined $opt->{joiner}) {
2332		$joiner = $opt->{joiner};
2333		if($joiner eq '\n') {
2334			$joiner = "\n";
2335		}
2336		elsif($joiner =~ m{\\}) {
2337			$joiner = $ready_safe->reval("qq{$joiner}");
2338		}
2339	}
2340	else {
2341		$joiner = ' ';
2342	}
2343
2344	my $index = defined $opt->{'index'} ? $opt->{'index'} : '*';
2345
2346	$index = '*' if $index =~ /^\s*\*?\s*$/;
2347
2348	my @ary;
2349	if (!ref $val) {
2350		@ary = split /\0/, $val;
2351	}
2352	elsif($val =~ /ARRAY/) {
2353		@ary = @$val;
2354	}
2355	else {
2356		logError( "value-extended %s: passed non-scalar, non-array object", $var);
2357	}
2358
2359	return join " ", 0 .. $#ary if $opt->{elements};
2360
2361	eval {
2362		@ary = @ary[$ready_safe->reval( $index eq '*' ? "0 .. $#ary" : $index )];
2363	};
2364	logError("value-extended $var: bad index") if $@;
2365
2366	if($opt->{filter}) {
2367		for(@ary) {
2368			$_ = filter_value($opt->{filter}, $_, $var);
2369		}
2370	}
2371	return join $joiner, @ary;
2372}
2373
2374sub format_auto_transmission {
2375	my $ref = shift;
2376
2377	## Auto-transmission from Vend::Data::update_data
2378	## Looking for structure like:
2379	##
2380	##	[ '### BEGIN submission from', 'ckirk' ],
2381	##	[ 'username', 'ckirk' ],
2382	##	[ 'field2', 'value2' ],
2383	##	[ 'field1', 'value1' ],
2384	##	[ '### END submission from', 'ckirk' ],
2385	##	[ 'mv_data_fields', [ username, field1, field2 ]],
2386	##
2387
2388	return $ref unless ref($ref);
2389
2390	my $body = '';
2391	my %message;
2392	my $header  = shift @$ref;
2393	my $fields  = pop   @$ref;
2394	my $trailer = pop   @$ref;
2395
2396	$body .= "$header->[0]: $header->[1]\n";
2397
2398	for my $line (@$ref) {
2399		$message{$line->[0]} = $line->[1];
2400	}
2401
2402	my @order;
2403	if(ref $fields->[1]) {
2404		@order = @{$fields->[1]};
2405	}
2406	else {
2407		@order = sort keys %message;
2408	}
2409
2410	for (@order) {
2411		$body .= "$_: ";
2412		if($message{$_} =~ s/\r?\n/\n/g) {
2413			$body .= "\n$message{$_}\n";
2414		}
2415		else {
2416			$body .= $message{$_};
2417		}
2418		$body .= "\n";
2419	}
2420
2421	$body .= "$trailer->[0]: $trailer->[1]\n";
2422	return $body;
2423}
2424
2425sub tag_mail {
2426    my($to, $opt, $body) = @_;
2427    my($ok);
2428
2429	my @todo = (
2430					qw/
2431						From
2432						To
2433						Subject
2434						Reply-To
2435						Errors-To
2436					/
2437	);
2438
2439	my $abort;
2440	my $check;
2441
2442	my $setsub = sub {
2443		my $k = shift;
2444		return if ! defined $CGI::values{"mv_email_$k"};
2445		$abort = 1 if ! $::Scratch->{mv_email_enable};
2446		$check = 1 if $::Scratch->{mv_email_enable};
2447		return $CGI::values{"mv_email_$k"};
2448	};
2449
2450	my @headers;
2451	my %found;
2452
2453	unless($opt->{raw}) {
2454		for my $header (@todo) {
2455			logError("invalid email header: %s", $header)
2456				if $header =~ /[^-\w]/;
2457			my $key = lc $header;
2458			$key =~ tr/-/_/;
2459			my $val = $opt->{$key} || $setsub->($key);
2460			if($key eq 'subject' and ! length($val) ) {
2461				$val = errmsg('<no subject>');
2462			}
2463			next unless length $val;
2464			$found{$key} = $val;
2465			$val =~ s/^\s+//;
2466			$val =~ s/\s+$//;
2467			$val =~ s/[\r\n]+\s*(\S)/\n\t$1/g;
2468			push @headers, "$header: $val";
2469		}
2470		unless($found{to} or $::Scratch->{mv_email_enable} =~ /\@/) {
2471			return
2472				error_opt($opt, "Refuse to send email message with no recipient.");
2473		}
2474		elsif (! $found{to}) {
2475			$::Scratch->{mv_email_enable} =~ s/\s+/ /g;
2476			$found{to} = $::Scratch->{mv_email_enable};
2477			push @headers, "To: $::Scratch->{mv_email_enable}";
2478		}
2479	}
2480
2481	if($opt->{extra}) {
2482		$opt->{extra} =~ s/^\s+//mg;
2483		$opt->{extra} =~ s/\s+$//mg;
2484		push @headers, grep /^\w[-\w]*:/, split /\n/, $opt->{extra};
2485	}
2486
2487	$body ||= $setsub->('body');
2488	unless($body) {
2489		return error_opt($opt, "Refuse to send email message with no body.");
2490	}
2491
2492	$body = format_auto_transmission($body) if ref $body;
2493
2494	push(@headers, '') if @headers;
2495
2496	return error_opt("mv_email_enable not set, required.") if $abort;
2497	if($check and $found{to} ne $Scratch->{mv_email_enable}) {
2498		return error_opt(
2499				"mv_email_enable to address (%s) doesn't match enable (%s)",
2500				$found{to},
2501				$Scratch->{mv_email_enable},
2502			);
2503	}
2504
2505    SEND: {
2506		$ok = send_mail(\@headers, $body);
2507    }
2508
2509    if (!$ok) {
2510		close MAIL;
2511		$body = substr($body, 0, 2000) if length($body) > 2000;
2512        return error_opt(
2513					"Unable to send mail using %s\n%s",
2514					$Vend::Cfg->{SendMailProgram},
2515					join("\n", @headers, $body),
2516				);
2517	}
2518
2519	delete $Scratch->{mv_email_enable} if $check;
2520	return if $opt->{hide};
2521	return join("\n", @headers, $body) if $opt->{show};
2522    return ($opt->{success} || $ok);
2523}
2524
2525# Returns the text of a user entered field named VAR.
2526sub tag_value {
2527    my($var,$opt) = @_;
2528#::logDebug("called value args=" . uneval(\@_));
2529	local($^W) = 0;
2530
2531	my $vspace = $opt->{values_space};
2532	my $vref;
2533	if (defined $vspace) {
2534		if ($vspace eq '') {
2535			$vref = $Vend::Session->{values};
2536		}
2537		else {
2538			$vref = $Vend::Session->{values_repository}{$vspace} ||= {};
2539		}
2540	}
2541	else {
2542		$vref = $::Values;
2543	}
2544
2545	$vref->{$var} = $opt->{set} if defined $opt->{set};
2546
2547	my $value = defined $vref->{$var} ? $vref->{$var} : '';
2548	$value =~ s/\[/&#91;/g unless $opt->{enable_itl};
2549	if($opt->{filter}) {
2550		$value = filter_value($opt->{filter}, $value, $var);
2551		$vref->{$var} = $value unless $opt->{keep};
2552	}
2553	$::Scratch->{$var} = $value if $opt->{scratch};
2554	return '' if $opt->{hide};
2555    return $opt->{default} if ! $value and defined $opt->{default};
2556	$value =~ s/</&lt;/g unless $opt->{enable_html};
2557    return $value;
2558}
2559
2560sub esc {
2561	my $string = shift;
2562	$string =~ s!(\W)!'%' . sprintf '%02x', ord($1)!eg;
2563	return $string;
2564}
2565
2566# Escapes a scan reliably in three different possible ways
2567sub escape_scan {
2568	my ($scan, $ref) = @_;
2569#::logDebug("escape_scan: scan=$scan");
2570	if (ref $scan) {
2571		for(@$scan) {
2572			my $add = '';
2573			$_ = "se=$_" unless /[=\n]/;
2574			$add .= "\nos=0"  unless m{^\s*os=}m;
2575			$add .= "\nne=0"  unless m{^\s*ne=}m;
2576			$add .= "\nop=rm" unless m{^\s*op=}m;
2577			$add .= "\nbs=0"  unless m{^\s*bs=}m;
2578			$add .= "\nsf=*"  unless m{^\s*sf=}m;
2579			$add .= "\ncs=0"  unless m{^\s*cs=}m;
2580			$add .= "\nsg=0"  unless m{^\s*sg=}m;
2581			$add .= "\nnu=0"  unless m{^\s*nu=}m;
2582			$_ .= $add;
2583		}
2584		$scan = join "\n", @$scan;
2585		$scan .= "\nco=yes" unless m{^\s*co=}m;
2586#::logDebug("escape_scan: scan=$scan");
2587	}
2588
2589	if($scan =~ /^\s*(?:sq\s*=\s*)?select\s+/im) {
2590		eval {
2591			$scan = Vend::Scan::sql_statement($scan, $ref || \%CGI::values)
2592		};
2593		if($@) {
2594			my $msg = errmsg("SQL query failed: %s\nquery was: %s", $@, $scan);
2595			logError($msg);
2596			$scan = 'se=BAD_SQL';
2597		}
2598	}
2599
2600	return join '/', 'scan', escape_mv('/', $scan);
2601}
2602
2603sub escape_form {
2604	my $val = shift;
2605
2606	$val =~ s/^\s+//mg;
2607	$val =~ s/\s+$//mg;
2608
2609	## Already escaped, return
2610	return $val if $val =~ /^\S+=\S+=\S*$/;
2611
2612	my @args = split /\n+/, $val;
2613
2614	for(@args) {
2615		s/^(.*?=)(.+)/$1 . Vend::Util::unhexify($2)/ge;
2616	}
2617
2618	for(@args) {
2619		next if /^[\w=]+$/;
2620		s!\0!-_NULL_-!g;
2621		s!([^=]+)=(.*)!esc($1) . '=' . esc($2)!eg
2622			or (undef $_, next);
2623	}
2624	return join $Global::UrlJoiner, grep length($_), @args;
2625}
2626
2627sub escape_mv {
2628	my ($joiner, $scan, $not_scan, $esc) = @_;
2629
2630	my @args;
2631
2632	if(index($scan, "\n") != -1) {
2633		$scan =~ s/^\s+//mg;
2634		$scan =~ s/\s+$//mg;
2635		@args = split /\n+/, $scan;
2636	}
2637	elsif($scan =~ /&\w\w=/) {
2638		@args = split /&/, $scan;
2639	}
2640	else {
2641		$scan =~ s!::!__SLASH__!g;
2642		@args  = split m:/:, $scan;
2643	}
2644	@args = grep $_, @args;
2645	for(@args) {
2646		s!/!__SLASH__!g unless defined $not_scan;
2647		s!\0!-_NULL_-!g;
2648		m!\w=!
2649		    or (undef $_, next);
2650		s!__SLASH__!::!g unless defined $not_scan;
2651	}
2652	return join $joiner, grep(defined $_, @args);
2653}
2654
2655PAGELINK: {
2656
2657my ($urlroutine, $page, $arg, $opt);
2658
2659sub tag_page {
2660    my ($page, $arg, $opt) = @_;
2661
2662	my $url = tag_area(@_);
2663
2664	my $extra;
2665	if($extra = ($opt ||= {})->{extra} || '') {
2666		$extra =~ s/^(\w+)$/class=$1/;
2667		$extra = " $extra";
2668	}
2669    return qq{<a href="$url"$extra>};
2670}
2671
2672# Returns an href which will call up the specified PAGE.
2673
2674sub tag_area {
2675    ($page, $arg, $opt) = @_;
2676
2677	$page = '' if ! defined $page;
2678
2679	if( $page and $opt->{alias}) {
2680		my $aloc = $opt->{once} ? 'one_time_path_alias' : 'path_alias';
2681		$Vend::Session->{$aloc}{$page} = {}
2682			if not defined $Vend::Session->{path_alias}{$page};
2683		$Vend::Session->{$aloc}{$page} = $opt->{alias};
2684	}
2685
2686	my $r;
2687
2688	if ($opt->{search}) {
2689		$page = escape_scan($opt->{search});
2690	}
2691	elsif ($page =~ /^[a-z][a-z]+:/) {
2692		### Javascript or absolute link
2693		return $page unless $opt->{form};
2694		$page =~ s{(\w+://[^/]+)/}{}
2695			or return $page;
2696		my $intro = $1;
2697		my @pieces = split m{/}, $page, 9999;
2698		$page = pop(@pieces);
2699		if(! length($page)) {
2700			$page = pop(@pieces);
2701			if(! length($page)) {
2702				$r = $intro;
2703				$r =~ s{/([^/]+)}{};
2704				$page = "$1/";
2705			}
2706			else {
2707				$page .= "/";
2708			}
2709		}
2710		$r = join "/", $intro, @pieces unless $r;
2711		$opt->{add_dot_html} = 0;
2712		$opt->{no_session} = 1;
2713		$opt->{secure} = 0;
2714		$opt->{no_count} = 1;
2715	}
2716	elsif ($page eq 'scan') {
2717		$page = escape_scan($arg);
2718		undef $arg;
2719	}
2720
2721	$urlroutine = $opt->{secure} ? \&secure_vendUrl : \&vendUrl;
2722
2723	return $urlroutine->($page, $arg, undef, $opt);
2724}
2725
2726}
2727
2728*form_link = \&tag_area;
2729
2730# Sets the default shopping cart for display
2731sub tag_cart {
2732	$Vend::CurrentCart = shift;
2733	return '';
2734}
2735
2736# Sets the discount namespace.
2737sub switch_discount_space {
2738	my $dspace = shift || 'main';
2739
2740	if (! $Vend::Cfg->{DiscountSpacesOn}) {
2741		$::Discounts
2742			= $Vend::Session->{discount}
2743			||= {};
2744		return $Vend::DiscountSpaceName = 'main';
2745	}
2746
2747	my $oldspace = $Vend::DiscountSpaceName || 'main';
2748#::logDebug("switch_discount_space: called for space '$dspace'; current space is $oldspace.");
2749	unless ($Vend::Session->{discount} and $Vend::Session->{discount_space}) {
2750		$::Discounts
2751			= $Vend::Session->{discount}
2752			= $Vend::Session->{discount_space}{main}
2753			||= ($Vend::Session->{discount} || {});
2754		$Vend::DiscountSpaceName = 'main';
2755#::logDebug('switch_discount_space: initialized discount space hash.');
2756	}
2757	if ($dspace ne $oldspace) {
2758		$::Discounts
2759			= $Vend::Session->{discount}
2760			= $Vend::Session->{discount_space}{$Vend::DiscountSpaceName = $dspace}
2761			||= {};
2762#::logDebug("switch_discount_space: changed discount space from '$oldspace' to '$Vend::DiscountSpaceName'");
2763	}
2764	else {
2765		# Make certain the hash is set, in case app programmer manipulated the session directly.
2766		$::Discounts
2767			= $Vend::Session->{discount}
2768			= $Vend::Session->{discount_space}{$Vend::DiscountSpaceName}
2769			unless ref $::Discounts eq 'HASH';
2770	}
2771	return $oldspace;
2772}
2773
2774sub tag_calc {
2775	my($body) = @_;
2776	my $result;
2777	if($Vend::NoInterpolate) {
2778		logGlobal({ level => 'alert' },
2779					"Attempt to interpolate perl/ITL from RPC, no permissions."
2780					);
2781	}
2782
2783	$Items = $Vend::Items;
2784
2785	if($MVSAFE::Safe) {
2786		$result = eval($body);
2787	}
2788	else {
2789		init_calc() if ! $Vend::Calc_initialized;
2790		$result = $ready_safe->reval($body);
2791	}
2792
2793	if ($@) {
2794		my $msg = $@;
2795		$Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
2796		logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
2797		logError("Safe: %s\n%s\n" , $msg, $body);
2798		return $MVSAFE::Safe ? '' : 0;
2799	}
2800	return $result;
2801}
2802
2803sub tag_unless {
2804	return tag_self_contained_if(@_, 1) if defined $_[4];
2805	return tag_if(@_, 1);
2806}
2807
2808sub tag_self_contained_if {
2809	my($base, $term, $operator, $comp, $body, $negate) = @_;
2810
2811	my ($else,$elsif,@addl);
2812
2813	local($^W) = 0;
2814#::logDebug("self_if: base=$base term=$term op=$operator comp=$comp");
2815	if ($body =~ s#$QR{condition_begin}##) {
2816		$comp = $1;
2817	}
2818#::logDebug("self_if: base=$base term=$term op=$operator comp=$comp");
2819
2820	if ( $body =~ /\[[EeTtAaOo][hHLlNnRr][SsEeDd\s]/ ) {
2821		($body, $elsif, $else, @addl) = split_if($body);
2822	}
2823
2824#::logDebug("Additional ops found:\n" . join("\n", @addl) ) if @addl;
2825
2826	unless(defined $operator || defined $comp) {
2827		$comp = '';
2828		undef $operator;
2829		undef $comp;
2830	}
2831
2832	($base =~ s/^\W+// or $base = "!$base") if $negate;
2833
2834	my $status = conditional ($base, $term, $operator, $comp, @addl);
2835
2836	my $out;
2837	if($status) {
2838		$out = $body;
2839	}
2840	elsif ($elsif) {
2841		$else = '[else]' . $else . '[/else]' if length $else;
2842		$elsif =~ s#(.*?)$QR{'/elsif'}(.*)#$1${2}[/elsif]#s;
2843		$out = '[if ' . $elsif . $else . '[/if]';
2844	}
2845	elsif (length $else) {
2846		$out = $else;
2847	}
2848	else {
2849		return '';
2850	}
2851
2852	return $out;
2853}
2854
2855sub pull_cond {
2856	my($string, $reverse, $cond, $lhs) = @_;
2857#::logDebug("pull_cond string='$string' rev='$reverse' cond='$cond' lhs='$lhs'");
2858	my ($op, $rhs) = split /\s+/, $cond, 2;
2859	$rhs =~ s/^(["'])(.*)\1$/$2/;
2860	if(! defined $cond_op{$op} ) {
2861		logError("bad conditional operator %s in if-PREFIX-data", $op);
2862		return pull_else($string, $reverse);
2863	}
2864	return 	$cond_op{$op}->($lhs, $rhs)
2865			? pull_if($string, $reverse)
2866			: pull_else($string, $reverse);
2867}
2868
2869sub pull_if {
2870	return pull_cond(@_) if $_[2];
2871	my($string, $reverse) = @_;
2872	return pull_else($string) if $reverse;
2873	find_matching_else(\$string) if $string =~ s:$QR{has_else}::;
2874	return $string;
2875}
2876
2877sub pull_else {
2878	return pull_cond(@_) if $_[2];
2879	my($string, $reverse) = @_;
2880	return pull_if($string) if $reverse;
2881	return find_matching_else(\$string) if $string =~ s:$QR{has_else}::;
2882	return;
2883}
2884
2885## ORDER PAGE
2886
2887my (@Opts);
2888my (@Flds);
2889my %Sort = (
2890
2891	''	=> sub { $_[0] cmp $_[1]				},
2892	none	=> sub { $_[0] cmp $_[1]				},
2893	f	=> sub { (lc $_[0]) cmp (lc $_[1])	},
2894	fr	=> sub { (lc $_[1]) cmp (lc $_[0])	},
2895    l  => sub {
2896            my ($a1,$a2) = split /[,.]/, $_[0], 2;
2897            my ($b1,$b2) = split /[,.]/, $_[1], 2;
2898            return $a1 <=> $b1 || $a2 <=> $b2;
2899    },
2900    lr  => sub {
2901            my ($a1,$a2) = split /[,.]/, $_[0], 2;
2902            my ($b1,$b2) = split /[,.]/, $_[1], 2;
2903            return $b1 <=> $a1 || $b2 <=> $a2;
2904    },
2905	n	=> sub { $_[0] <=> $_[1]				},
2906	nr	=> sub { $_[1] <=> $_[0]				},
2907	r	=> sub { $_[1] cmp $_[0]				},
2908);
2909
2910@Sort{qw/rf rl rn/} = @Sort{qw/fr lr nr/};
2911
2912use vars qw/%Sort_field/;
2913%Sort_field = %Sort;
2914
2915sub tag_sort_ary {
2916    my($opts, $list) = (@_);
2917    $opts =~ s/^\s+//;
2918    $opts =~ s/\s+$//;
2919#::logDebug("tag_sort_ary: opts=$opts list=" . uneval($list));
2920	my @codes;
2921	my $key = 0;
2922
2923	my ($start, $end, $num);
2924	my $glob_opt = 'none';
2925
2926    my @opts =  split /\s+/, $opts;
2927    my @option; my @bases; my @fields;
2928
2929    for(@opts) {
2930        my ($base, $fld, $opt) = split /:/, $_;
2931
2932		if($base =~ /^(\d+)$/) {
2933			$key = $1;
2934			$glob_opt = $fld || $opt || 'none';
2935			next;
2936		}
2937		if($base =~ /^([-=+])(\d+)-?(\d*)/) {
2938			my $op = $1;
2939			if    ($op eq '-') { $start = $2 }
2940			elsif ($op eq '+') { $num   = $2 }
2941			elsif ($op eq '=') {
2942				$start = $2;
2943				$end = ($3 || undef);
2944			}
2945			next;
2946		}
2947
2948        push @bases, $base;
2949        push @fields, $fld;
2950        push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none');
2951    }
2952
2953	if(defined $end) {
2954		$num = 1 + $end - $start;
2955		$num = undef if $num < 1;
2956 	}
2957
2958    my $i;
2959    my $routine = 'sub { ';
2960	for( $i = 0; $i < @bases; $i++) {
2961			$routine .= '&{$Vend::Interpolate::Sort_field{"' .
2962						$option[$i] .
2963						'"}}(' . "\n";
2964			$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->[$key]),\n";
2965			$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->[$key]) ) or ";
2966	}
2967	$routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!;
2968	$routine .= '($_[0]->[$key],$_[1]->[$key]); }';
2969#::logDebug("tag_sort_ary routine: $routine\n");
2970
2971    my $code = eval $routine;
2972    die "Bad sort routine\n" if $@;
2973
2974	#Prime the sort? Prevent variable suicide??
2975	#&{$Vend::Interpolate::Sort_field{'n'}}('31', '30');
2976
2977	use locale;
2978	if($::Scratch->{mv_locale}) {
2979		POSIX::setlocale(POSIX::LC_COLLATE(),
2980			$::Scratch->{mv_locale});
2981	}
2982
2983	@codes = sort {&$code($a, $b)} @$list;
2984
2985	if($start > 1) {
2986		splice(@codes, 0, $start - 1);
2987	}
2988
2989	if(defined $num) {
2990		splice(@codes, $num);
2991	}
2992#::logDebug("tag_sort_ary routine returns: " . uneval(\@codes));
2993	return \@codes;
2994}
2995
2996sub tag_sort_hash {
2997    my($opts, $list) = (@_);
2998    $opts =~ s/^\s+//;
2999    $opts =~ s/\s+$//;
3000#::logDebug("tag_sort_hash: opts=$opts list=" . uneval($list));
3001	my @codes;
3002	my $key = 'code';
3003
3004	my ($start, $end, $num);
3005	my $glob_opt = 'none';
3006
3007    my @opts =  split /\s+/, $opts;
3008    my @option; my @bases; my @fields;
3009
3010    for(@opts) {
3011
3012		if(/^(\w+)(:([flnr]+))?$/) {
3013			$key = $1;
3014			$glob_opt = $3 || 'none';
3015			next;
3016		}
3017		if(/^([-=+])(\d+)-?(\d*)/) {
3018			my $op = $1;
3019			if    ($op eq '-') { $start = $2 }
3020			elsif ($op eq '+') { $num   = $2 }
3021			elsif ($op eq '=') {
3022				$start = $2;
3023				$end = ($3 || undef);
3024			}
3025			next;
3026		}
3027        my ($base, $fld, $opt) = split /:/, $_;
3028
3029        push @bases, $base;
3030        push @fields, $fld;
3031        push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none');
3032    }
3033
3034	if(defined $end) {
3035		$num = 1 + $end - $start;
3036		$num = undef if $num < 1;
3037 	}
3038
3039	if (! defined $list->[0]->{$key}) {
3040		logError("sort key '$key' not defined in list. Skipping sort.");
3041		return $list;
3042	}
3043
3044    my $i;
3045    my $routine = 'sub { ';
3046	for( $i = 0; $i < @bases; $i++) {
3047			$routine .= '&{$Vend::Interpolate::Sort_field{"' .
3048						$option[$i] .
3049						'"}}(' . "\n";
3050			$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->{$key}),\n";
3051			$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->{$key}) ) or ";
3052	}
3053	$routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!;
3054	$routine .= '($a->{$key},$_[1]->{$key}); }';
3055
3056#::logDebug("tag_sort_hash routine: $routine\n");
3057    my $code = eval $routine;
3058    die "Bad sort routine\n" if $@;
3059
3060	#Prime the sort? Prevent variable suicide??
3061	#&{$Vend::Interpolate::Sort_field{'n'}}('31', '30');
3062
3063	use locale;
3064	if($::Scratch->{mv_locale}) {
3065		POSIX::setlocale(POSIX::LC_COLLATE(),
3066			$::Scratch->{mv_locale});
3067	}
3068
3069	@codes = sort {&$code($a,$b)} @$list;
3070
3071	if($start > 1) {
3072		splice(@codes, 0, $start - 1);
3073	}
3074
3075	if(defined $num) {
3076		splice(@codes, $num);
3077	}
3078#::logDebug("tag_sort_hash routine returns: " . uneval(\@codes));
3079	return \@codes;
3080}
3081
3082my %Prev;
3083
3084sub check_change {
3085	my($name, $value, $text, $substr) = @_;
3086	# $value is case-sensitive flag if passed text;
3087	if(defined $text) {
3088		$text =~ s:$QR{condition}::;
3089		$value = $value ? lc $1 : $1;
3090	}
3091	$value = substr($value, 0, $substr) if $substr;
3092	my $prev = $Prev{$name};
3093	$Prev{$name} = $value;
3094	if(defined $text) {
3095		return pull_if($text) if ! defined $prev or $value ne $prev;
3096		return pull_else($text);
3097	}
3098	return 1 unless defined $prev;
3099	return $value eq $prev ? 0 : 1;
3100}
3101
3102sub list_compat {
3103	my $prefix = shift;
3104	my $textref = shift;
3105
3106	$$textref =~ s:\[quantity[-_]name:[$prefix-quantity-name:gi;
3107	$$textref =~ s:\[modifier[-_]name\s:[$prefix-modifier-name :gi;
3108
3109	$$textref =~ s:\[if[-_]data\s:[if-$prefix-data :gi
3110		and $$textref =~ s:\[/if[-_]data\]:[/if-$prefix-data]:gi;
3111
3112	$$textref =~ s:\[if[-_]modifier\s:[if-$prefix-param :gi
3113		and $$textref =~ s:\[/if[-_]modifier\]:[/if-$prefix-param]:gi;
3114
3115	$$textref =~ s:\[if[-_]field\s:[if-$prefix-field :gi
3116		and $$textref =~ s:\[/if[-_]field\]:[/if-$prefix-field]:gi;
3117
3118	$$textref =~ s:\[on[-_]change\s:[$prefix-change :gi
3119		and $$textref =~ s:\[/on[-_]change\s:[/$prefix-change :gi;
3120
3121	return;
3122}
3123
3124sub tag_search_region {
3125	my($params, $opt, $text) = @_;
3126	$opt->{search} = $params if $params;
3127	$opt->{prefix}      ||= 'item';
3128	$opt->{list_prefix} ||= 'search[-_]list';
3129# LEGACY
3130	list_compat($opt->{prefix}, \$text) if $text;
3131# END LEGACY
3132	return region($opt, $text);
3133}
3134
3135sub find_sort {
3136	my($text) = @_;
3137	return undef unless defined $$text and $$text =~ s#\[sort(([\s\]])[\000-\377]+)#$1#io;
3138	my $options = find_close_square($$text);
3139	$$text = substr( $$text,length($options) + 1 )
3140				if defined $options;
3141	$options = interpolate_html($options) if index($options, '[') != -1;
3142	return $options || '';
3143}
3144
3145# Artificial for better variable passing
3146{
3147	my( $next_anchor,
3148		$prev_anchor,
3149		$page_anchor,
3150		$border,
3151		$border_selected,
3152		$opt,
3153		$r,
3154		$chunk,
3155		$perm,
3156		$total,
3157		$current,
3158		$page,
3159		$prefix,
3160		$more_id,
3161		$session,
3162		$link_template,
3163		);
3164
3165sub more_link_template {
3166	my ($anchor, $arg, $form_arg) = @_;
3167
3168	my $url = tag_area("scan/MM=$arg", '', {
3169	    form => $form_arg,
3170	    secure => $CGI::secure,
3171	});
3172
3173	my $lt = $link_template;
3174	$lt =~ s/\$URL\$/$url/g;
3175	$lt =~ s/\$ANCHOR\$/$anchor/g;
3176	return $lt;
3177}
3178
3179sub more_link {
3180	my($inc, $pa) = @_;
3181	my ($next, $last, $arg);
3182	my $list = '';
3183	$pa =~ s/__PAGE__/$inc/g;
3184	my $form_arg = "mv_more_ip=1\nmv_nextpage=$page";
3185	$form_arg .= "\npf=$prefix" if $prefix;
3186	$form_arg .= "\n$opt->{form}" if $opt->{form};
3187	$form_arg .= "\nmi=$more_id" if $more_id;
3188	$next = ($inc-1) * $chunk;
3189#::logDebug("more_link: inc=$inc current=$current");
3190	$last = $next + $chunk - 1;
3191	$last = ($last+1) < $total ? $last : ($total - 1);
3192	$pa =~ s/__PAGE__/$inc/g;
3193	$pa =~ s/__MINPAGE__/$next + 1/eg;
3194	$pa =~ s/__MAXPAGE__/$last + 1/eg;
3195	if($inc == $current) {
3196		$pa =~ s/__BORDER__/$border_selected || $border || ''/e;
3197		$list .= qq|<strong>$pa</strong> | ;
3198	}
3199	else {
3200		$pa =~ s/__BORDER__/$border/e;
3201		$arg = "$session:$next:$last:$chunk$perm";
3202		$list .= more_link_template($pa, $arg, $form_arg) . ' ';
3203	}
3204	return $list;
3205}
3206
3207sub tag_more_list {
3208	(
3209		$next_anchor,
3210		$prev_anchor,
3211		$page_anchor,
3212		$border,
3213		$border_selected,
3214		$opt,
3215		$r,
3216	) = @_;
3217
3218	if(my $name = $opt->{more_routine}) {
3219		my $sub = $Vend::Cfg->{Sub}{$name} || $Global::GlobalSub->{$name};
3220		return $sub->(@_) if $sub;
3221	}
3222#::logDebug("more_list: opt=$opt label=$opt->{label}");
3223	return undef if ! $opt;
3224	$q = $opt->{object} || $::Instance->{SearchObject}{$opt->{label}};
3225	return '' unless $q->{matches} > $q->{mv_matchlimit}
3226		and $q->{mv_matchlimit} > 0;
3227	my($arg,$inc,$last,$m);
3228	my($adder,$pages);
3229	my($first_anchor,$last_anchor);
3230	my %hash;
3231
3232
3233	$session = $q->{mv_cache_key};
3234	my $first = $q->{mv_first_match} || 0;
3235	$chunk = $q->{mv_matchlimit};
3236	$perm = $q->{mv_more_permanent} ? ':1' : '';
3237	$total = $q->{matches};
3238	my $next = defined $q->{mv_next_pointer}
3239				? $q->{mv_next_pointer}
3240				: $first + $chunk;
3241	$page = $q->{mv_search_page} || $Global::Variable->{MV_PAGE};
3242	$prefix = $q->{prefix} || '';
3243	my $form_arg = "mv_more_ip=1\nmv_nextpage=$page";
3244	$form_arg .= "\npf=$q->{prefix}" if $q->{prefix};
3245	$form_arg .= "\n$opt->{form}" if $opt->{form};
3246	if($q->{mv_more_id}) {
3247		$more_id = $q->{mv_more_id};
3248		$form_arg .= "\nmi=$more_id";
3249	}
3250	else {
3251		$more_id = undef;
3252	}
3253
3254	my $more_joiner = $opt->{more_link_joiner} || ' ';
3255
3256	if($r =~ s:\[border\]($All)\[/border\]::i) {
3257		$border = $1;
3258		$border =~ s/\D//g;
3259	}
3260	if($r =~ s:\[border[-_]selected\]($All)\[/border[-_]selected\]::i) {
3261		$border = $1;
3262		$border =~ s/\D//g;
3263	}
3264
3265	undef $link_template;
3266	$r =~ s:\[link[-_]template\]($All)\[/link[-_]template\]::i
3267		and $link_template = $1;
3268	$link_template ||= q{<a href="$URL$">$ANCHOR$</a>};
3269
3270	if(! $chunk or $chunk >= $total) {
3271		return '';
3272	}
3273
3274	$border = qq{ border="$border"} if defined $border;
3275	$border_selected = qq{ border="$border_selected"}
3276		if defined $border_selected;
3277
3278	$adder = ($total % $chunk) ? 1 : 0;
3279	$pages = int($total / $chunk) + $adder;
3280	$current = int($next / $chunk) || $pages;
3281
3282	if($first) {
3283		$first = 0 if $first < 0;
3284
3285		# First link may appear when prev link is valid
3286		if($r =~ s:\[first[-_]anchor\]($All)\[/first[-_]anchor\]::i) {
3287			$first_anchor = $1;
3288		}
3289		else {
3290			$first_anchor = errmsg('First');
3291		}
3292		unless ($first_anchor eq 'none') {
3293			$arg = $session;
3294			$arg .= ':0:';
3295			$arg .= $chunk - 1;
3296			$arg .= ":$chunk$perm";
3297			$hash{first_link} = more_link_template($first_anchor, $arg, $form_arg);
3298		}
3299
3300		unless ($prev_anchor) {
3301			if($r =~ s:\[prev[-_]anchor\]($All)\[/prev[-_]anchor\]::i) {
3302				$prev_anchor = $1;
3303			}
3304			else {
3305				$prev_anchor = errmsg('Previous');
3306			}
3307		}
3308		elsif ($prev_anchor ne 'none') {
3309			$prev_anchor = qq%<img src="$prev_anchor"$border>%;
3310		}
3311		unless ($prev_anchor eq 'none') {
3312			$arg = $session;
3313			$arg .= ':';
3314			$arg .= $first - $chunk;
3315			$arg .= ':';
3316			$arg .= $first - 1;
3317			$arg .= ":$chunk$perm";
3318			$hash{prev_link} = more_link_template($prev_anchor, $arg, $form_arg);
3319		}
3320
3321	}
3322	else {
3323		$r =~ s:\[(prev|first)[-_]anchor\]$All\[/\1[-_]anchor\]::ig;
3324	}
3325
3326	if($next) {
3327
3328		unless ($next_anchor) {
3329			if($r =~ s:\[next[-_]anchor\]($All)\[/next[-_]anchor\]::i) {
3330				$next_anchor = $1;
3331			}
3332			else {
3333				$next_anchor = errmsg('Next');
3334			}
3335		}
3336		else {
3337			$next_anchor = qq%<img src="$next_anchor"$border>%;
3338		}
3339		$last = $next + $chunk - 1;
3340		$last = $last > ($total - 1) ? $total - 1 : $last;
3341		$arg = "$session:$next:$last:$chunk$perm";
3342		$hash{next_link} = more_link_template($next_anchor, $arg, $form_arg);
3343
3344 		# Last link can appear when next link is valid
3345		if($r =~ s:\[last[-_]anchor\]($All)\[/last[-_]anchor\]::i) {
3346			$last_anchor = $1;
3347		}
3348		else {
3349			$last_anchor = errmsg('Last');
3350		}
3351		unless ($last_anchor eq 'none') {
3352			$last = $total - 1;
3353			my $last_beg_idx = $total - ($total % $chunk || $chunk);
3354			$arg = "$session:$last_beg_idx:$last:$chunk$perm";
3355			$hash{last_link} = more_link_template($last_anchor, $arg, $form_arg);
3356		}
3357	}
3358	else {
3359		$r =~ s:\[(last|next)[-_]anchor\]$All\[/\1[-_]anchor\]::gi;
3360	}
3361
3362	unless ($page_anchor) {
3363		if($r =~ s:\[page[-_]anchor\]($All)\[/page[-_]anchor\]::i) {
3364			$page_anchor = $1;
3365		}
3366		else {
3367			$page_anchor = '__PAGE__';
3368		}
3369	}
3370	elsif ($page_anchor ne 'none') {
3371		$page_anchor = qq%<img src="$page_anchor?__PAGE__"__BORDER__>%;
3372	}
3373
3374	$page_anchor =~ s/\$(MIN|MAX)?PAGE\$/__${1}PAGE__/g;
3375
3376	my $more_string = errmsg('more');
3377	my ($decade_next, $decade_prev, $decade_div);
3378	if( $q->{mv_more_decade} or $r =~ m:\[decade[-_]next\]:) {
3379		$r =~ s:\[decade[-_]next\]($All)\[/decade[-_]next\]::i
3380			and $decade_next = $1;
3381		$decade_next = "<small>&#91;$more_string&gt;&gt;&#93;</small>"
3382			if ! $decade_next;
3383		$r =~ s:\[decade[-_]prev\]($All)\[/decade[-_]prev\]::i
3384			and $decade_prev = $1;
3385		$decade_prev = "<small>&#91;&lt;&lt;$more_string&#93;</small>"
3386			if ! $decade_prev;
3387		$decade_div = $q->{mv_more_decade} > 1 ? $q->{mv_more_decade} : 10;
3388	}
3389
3390	my ($begin, $end);
3391	if(defined $decade_div and $pages > $decade_div) {
3392		if($current > $decade_div) {
3393			$begin = ( int ($current / $decade_div) * $decade_div ) + 1;
3394			$hash{decade_prev} = more_link($begin - $decade_div, $decade_prev);
3395		}
3396		else {
3397			$begin = 1;
3398		}
3399		if($begin + $decade_div <= $pages) {
3400			$end = $begin + $decade_div;
3401			$hash{decade_next} = more_link($end, $decade_next);
3402			$end--;
3403		}
3404		else {
3405			$end = $pages;
3406			delete $hash{$decade_next};
3407		}
3408#::logDebug("more_list: decade found pages=$pages current=$current begin=$begin end=$end next=$next last=$last decade_div=$decade_div");
3409	}
3410	else {
3411		($begin, $end) = (1, $pages);
3412		delete $hash{$decade_next};
3413	}
3414#::logDebug("more_list: pages=$pages current=$current begin=$begin end=$end next=$next last=$last decade_div=$decade_div page_anchor=$page_anchor");
3415
3416	my @more_links;
3417	if ($q->{mv_alpha_list}) {
3418		for my $record (@{$q->{mv_alpha_list}}) {
3419			$arg = "$session:$record->[2]:$record->[3]:" . ($record->[3] - $record->[2] + 1);
3420			my $letters = substr($record->[0], 0, $record->[1]);
3421			push @more_links, more_link_template($letters, $arg, $form_arg);
3422		}
3423		$hash{more_alpha} = join $more_joiner, @more_links;
3424	}
3425	else {
3426		foreach $inc ($begin .. $end) {
3427			last if $page_anchor eq 'none';
3428			push @more_links, more_link($inc, $page_anchor);
3429		}
3430		$hash{more_numeric} = join $more_joiner, @more_links;
3431	}
3432
3433	$hash{more_list} = join $more_joiner, @more_links;
3434
3435	$first = $first + 1;
3436	$last = $first + $chunk - 1;
3437	$last = $last > $total ? $total : $last;
3438	$m = $first . '-' . $last;
3439	$hash{matches} = $m;
3440	$hash{first_match} = $first;
3441	$hash{last_match} = $last;
3442	$hash{decade_first} = $begin;
3443	$hash{decade_last} = $end;
3444	$hash{last_page} = $hash{total_pages} = $pages;
3445	$hash{current_page} = $current;
3446	$hash{match_count} = $q->{matches};
3447
3448	if($r =~ /{[A-Z][A-Z_]+[A-Z]}/ and $r !~ $QR{more}) {
3449		return tag_attr_list($r, \%hash, 1);
3450	}
3451	else {
3452		my $tpl = qq({FIRST_LINK?}{FIRST_LINK} {/FIRST_LINK?}{PREV_LINK?}{PREV_LINK} {/PREV_LINK?}{DECADE_PREV?}{DECADE_PREV} {/DECADE_PREV?}{MORE_LIST}{DECADE_NEXT?} {DECADE_NEXT}{/DECADE_NEXT?}{NEXT_LINK?} {NEXT_LINK}{/NEXT_LINK?}{LAST_LINK?} {LAST_LINK}{/LAST_LINK?});
3453		$tpl =~ s/\s+$//;
3454		my $list = tag_attr_list($opt->{more_template} || $tpl, \%hash, 1);
3455		$r =~ s,$QR{more},$list,g;
3456		$r =~ s,$QR{matches},$m,g;
3457		$r =~ s,$QR{match_count},$q->{matches},g;
3458		return $r;
3459	}
3460
3461}
3462
3463}
3464
3465# Naming convention
3466# Ld  Label Data
3467# B   Begin
3468# E   End
3469# D   Data
3470# I   If
3471my $LdD = qr{\s+([-\w:#/.]+)\]};
3472my $LdI = qr{\s+([-\w:#/.]+)$Optr\]($Some)};
3473my $LdB;
3474my $LdIB;
3475my $LdIE;
3476my $LdExpr;
3477my $B;
3478my $E;
3479my $IB;
3480my $IE;
3481my $Prefix;
3482my $Orig_prefix;
3483
3484sub tag_labeled_data_row {
3485	my ($key, $text) = @_;
3486	my ($row, $table, $tabRE);
3487	my $done;
3488	my $prefix;
3489
3490	if(defined $Prefix) {
3491		$prefix = $Prefix;
3492		undef $Prefix;
3493		$LdB = qr(\[$prefix[-_]data$Spacef)i;
3494		$LdIB = qr(\[if[-_]$prefix[-_]data(\d*)$Spacef(!?)(?:%20|\s)*)i;
3495		$LdIE = qr(\[/if[-_]$prefix[-_]data)i;
3496		$LdExpr = qr{ \[(?:$prefix[-_]data|if[-_]$prefix[-_]data(\d*))
3497	                \s+ !?\s* ($Codere) \s
3498					(?!$All\[(?:$prefix[-_]data|if[-_]$prefix[-_]data\1))  }xi;
3499		%Data_cache = ();
3500	}
3501	# Want the last one
3502#::logDebug(<<EOF);
3503#tag_labeled_data_row:
3504#	prefix=$prefix
3505#	LdB   =$LdB
3506#	LdIB  =$LdIB
3507#	LdIE  =$LdIE
3508#	LdD   =$LdD
3509#	LdI   =$LdI
3510#	LdExpr=$LdExpr
3511#EOF
3512
3513    while($$text =~ $LdExpr) {
3514		$table = $2;
3515		$tabRE = qr/$table/;
3516		$row = $Data_cache{"$table.$key"}
3517				|| ( $Data_cache{"$table.$key"}
3518						= Vend::Data::database_row($table, $key)
3519					)
3520				|| {};
3521		$done = 1;
3522		$$text =~ s#$LdIB$tabRE$LdI$LdIE\1\]#
3523					$row->{$3}	? pull_if($5,$2,$4,$row->{$3})
3524								: pull_else($5,$2,$4,$row->{$3})#ge
3525			and undef $done;
3526#::logDebug("after if: table=$table 1=$1 2=$2 3=$3 $$text =~ s#$LdIB $tabRE $LdI $LdIE#");
3527
3528		$$text =~ s/$LdB$tabRE$LdD/ed($row->{$1})/eg
3529			and undef $done;
3530		last if $done;
3531	}
3532	return $_;
3533}
3534
3535sub random_elements {
3536	my($ary, $wanted) = @_;
3537	return (0 .. $#$ary) unless $wanted > 0;
3538	$wanted = 1 if $wanted =~ /\D/;
3539	return undef unless ref $ary;
3540
3541	my %seen;
3542	my ($j, @out);
3543	my $count = scalar @$ary;
3544	$wanted = $count if $wanted > $count;
3545	for($j = 0; $j < $wanted; $j++) {
3546		my $cand = int rand($count);
3547		redo if $seen{$cand}++;
3548		push(@out, $cand);
3549	}
3550	return (@out);
3551}
3552
3553my $opt_select;
3554my $opt_table;
3555my $opt_field;
3556my $opt_value;
3557
3558sub labeled_list {
3559    my($opt, $text, $obj) = @_;
3560	my($count);
3561	$obj = $opt->{object} if ! $obj;
3562	return '' if ! $obj;
3563
3564	my $ary = $obj->{mv_results};
3565	return '' if (! $ary or ! ref $ary or ! defined $ary->[0]);
3566
3567	my $save_unsafe = $MVSAFE::Unsafe || '';
3568	$MVSAFE::Unsafe = 1;
3569
3570	# This allows left brackets to be output by the data tags
3571	local($Safe_data);
3572	$Safe_data = 1 if $opt->{safe_data};
3573
3574#	if($opt->{prefix} eq 'item') {
3575#::logDebug("labeled list: opt:\n" . uneval($opt) . "\nobj:" . uneval($obj) . "text:" . substr($text,0,100));
3576#	}
3577	$Orig_prefix = $Prefix = $opt->{prefix} || 'item';
3578
3579	$B  = qr(\[$Prefix)i;
3580	$E  = qr(\[/$Prefix)i;
3581	$IB = qr(\[if[-_]$Prefix)i;
3582	$IE = qr(\[/if[-_]$Prefix)i;
3583
3584	my $end;
3585	# List more
3586	if (	defined $CGI::values{mv_more_matches}
3587			and     $CGI::values{mv_more_matches} eq 'loop'  )
3588	{
3589		undef $CGI::values{mv_more_matches};
3590		$opt->{fm}	= $CGI::values{mv_next_pointer} + 1;
3591		$end		= $CGI::values{mv_last_pointer}
3592			if defined $CGI::values{mv_last_pointer};
3593		$opt->{ml}	= $CGI::values{mv_matchlimit}
3594			if defined $CGI::values{mv_matchlimit};
3595	}
3596	# get the number to start the increment from
3597	my $i = 0;
3598	if (defined $obj->{more_in_progress} and $obj->{mv_first_match}) {
3599		$i = $obj->{mv_first_match};
3600	}
3601	elsif (defined $opt->{random} && !is_no($opt->{random})) {
3602		$opt->{random} = scalar(@$ary) if $opt->{random} =~ /^[yYtT]/;
3603		@$ary = @$ary[random_elements($ary, $opt->{random})];
3604		$i = 0; $end = $#$ary;
3605		undef $obj->{mv_matchlimit};
3606	}
3607	elsif (defined $opt->{fm}) {
3608		$i = $opt->{fm} - 1;
3609	}
3610
3611	$count = $obj->{mv_first_match} || $i;
3612	$count++;
3613	# Zero the on-change hash
3614	undef %Prev;
3615
3616	if(defined $opt->{option}) {
3617		$opt_value = $opt->{option};
3618		my $optref = $opt->{cgi} ? (\%CGI::values) : $::Values;
3619
3620		if($opt_value =~ s/\s*($Codere)::($Codere)\s*//) {
3621            $opt_table = $1;
3622            $opt_field = $2;
3623			$opt_value = lc($optref->{$opt_value}) || undef;
3624            $opt_select = sub {
3625                return lc(tag_data($opt_table, $opt_field, shift)) eq $opt_value;
3626            }
3627				if $opt_value;
3628        }
3629		elsif(defined $optref->{$opt_value} and length $optref->{$opt_value} ) {
3630			$opt_value = lc($optref->{$opt_value});
3631			$opt_select = ! $opt->{multiple}
3632						  ? sub { return "\L$_[0]" eq $opt_value }
3633						  : sub { $opt_value =~ /^$_[0](?:\0|$)/i or
3634						  		  $opt_value =~ /\0$_[0](?:\0|$)/i
3635								  };
3636		}
3637	}
3638	else {
3639		undef $opt_select;
3640	}
3641
3642	my $return;
3643	if($Vend::OnlyProducts) {
3644		$text =~ s#$B$QR{_field}#[$Prefix-data $Vend::OnlyProducts $1]#g
3645			and $text =~ s#$E$QR{'/_field'}#[/$Prefix-data]#g;
3646		$text =~ s,$IB$QR{_field_if_wo},[if-$Prefix-data $1$Vend::OnlyProducts $2],g
3647			and $text =~ s,$IE$QR{'/_field'},[/if-$Prefix-data],g;
3648	}
3649#::logDebug("Past only products.");
3650	$end =	($obj->{mv_matchlimit} and $obj->{mv_matchlimit} > 0)
3651			? $i + ($opt->{ml} || $obj->{mv_matchlimit}) - 1
3652			: $#$ary;
3653	$end = $#$ary if $#$ary < $end;
3654
3655# LEGACY
3656	$text =~ /^\s*\[sort\s+.*/si
3657		and $opt->{sort} = find_sort(\$text);
3658# END LEGACY
3659
3660	my $r;
3661	if($ary->[0] =~ /HASH/) {
3662		$ary = tag_sort_hash($opt->{sort}, $ary) if $opt->{sort};
3663		$r = iterate_hash_list($i, $end, $count, $text, $ary, $opt_select, $opt);
3664	}
3665	else {
3666		my $fa = $obj->{mv_return_fields} || undef;
3667		my $fh = $obj->{mv_field_hash}    || undef;
3668		my $fn = $obj->{mv_field_names}   || undef;
3669		my $row_fields = $fa;
3670		$ary = tag_sort_ary($opt->{sort}, $ary) if $opt->{sort};
3671		if ($fa and $fn) {
3672			my $idx = 0;
3673			$fh = {};
3674			$row_fields = [];
3675			@$row_fields = @{$fn}[@$fa];
3676			for(@$fa) {
3677				$fh->{$fn->[$_]} = $idx++;
3678			}
3679		}
3680		elsif (! $fh and $fn) {
3681			my $idx = 0;
3682			$fh = {};
3683			$row_fields = $fn;
3684			for(@$fn) {
3685				$fh->{$_} = $idx++;
3686			}
3687		}
3688		$opt->{mv_return_fields} = $fa;
3689#::logDebug("Missing mv_field_hash and/or mv_field_names in Vend::Interpolate::labeled_list") unless ref $fh eq 'HASH';
3690		# Pass the field arrayref ($row_fields) for support in iterate_array_list of new $Row object...
3691		$r = iterate_array_list($i, $end, $count, $text, $ary, $opt_select, $fh, $opt, $row_fields);
3692	}
3693	$MVSAFE::Unsafe = $save_unsafe;
3694	return $r;
3695}
3696
3697sub tag_attr_list {
3698	my ($body, $hash, $ucase) = @_;
3699
3700	if(! ref $hash) {
3701		$hash = string_to_ref($hash);
3702		if($@) {
3703			logDebug("eval error: $@");
3704		}
3705		return undef if ! ref $hash;
3706	}
3707	if($ucase) {
3708		my $Marker = '[A-Z_]\\w+';
3709		$body =~ s!\{($Marker)\}!$hash->{"\L$1"}!g;
3710		$body =~ s!\{($Marker)\?($Marker)\:($Marker)\}!
3711					length($hash->{lc $1}) ? $hash->{lc $2} : $hash->{lc $3}
3712				  !eg;
3713		$body =~ s!\{($Marker)\|($Some)\}!$hash->{lc $1} || $2!eg;
3714		$body =~ s!\{($Marker)\s+($Some)\}! $hash->{lc $1} ? $2 : ''!eg;
3715		1 while $body =~ s!\{($Marker)\?\}($Some){/\1\?\}! $hash->{lc $1} ? $2 : ''!eg;
3716		1 while $body =~ s!\{($Marker)\:\}($Some){/\1\:\}! $hash->{lc $1} ? '' : $2!eg;
3717		$body =~ s!\{(\w+)\:+(\w+)\:+(.*?)\}! tag_data($1, $2, $3) !eg;
3718	}
3719	else {
3720	$body =~ s!\{($Codere)\}!$hash->{$1}!g;
3721	$body =~ s!\{($Codere)\?($Codere)\:($Codere)\}!
3722				length($hash->{$1}) ? $hash->{$2} : $hash->{$3}
3723			  !eg;
3724	$body =~ s!\{($Codere)\|($Some)\}!$hash->{$1} || $2!eg;
3725	$body =~ s!\{($Codere)\s+($Some)\}! $hash->{$1} ? $2 : ''!eg;
3726	1 while $body =~ s!\{($Codere)\?\}($Some){/\1\?\}! $hash->{$1} ? $2 : ''!eg;
3727	1 while $body =~ s!\{($Codere)\:\}($Some){/\1\:\}! $hash->{$1} ? '' : $2!eg;
3728	$body =~ s!\{(\w+)\:+(\w+)\:+(.*?)\}! tag_data($1, $2, $3) !eg;
3729	}
3730	return $body;
3731}
3732
3733sub tag_address {
3734	my ($count, $item, $hash, $opt, $body) = @_;
3735#::logDebug("in ship_address");
3736	return pull_else($body) if defined $opt->{if} and ! $opt->{if};
3737	return pull_else($body) if ! $Vend::username || ! $Vend::Session->{logged_in};
3738#::logDebug("logged in with usernam=$Vend::username");
3739
3740	my $tag = 'address';
3741	my $attr = 'mv_ad';
3742	my $nattr = 'mv_an';
3743	my $pre = '';
3744	if($opt->{billing}) {
3745		$tag = 'b_address';
3746		$attr = 'mv_bd';
3747		$nattr = 'mv_bn';
3748		$pre = 'b_';
3749	}
3750
3751#	if($item->{$attr} and ! $opt->{set}) {
3752#		my $pre = $opt->{prefix};
3753#		$pre =~ s/[-_]/[-_]/g;
3754#		$body =~ s:\[$pre\]($Some)\[/$pre\]:$item->{$attr}:g;
3755#		return pull_if($body);
3756#	}
3757
3758	my $nick = $opt->{nick} || $opt->{nickname} || $item->{$nattr};
3759
3760#::logDebug("nick=$nick");
3761
3762	my $user;
3763	if(not $user = $Vend::user_object) {
3764		 $user = new Vend::UserDB username => ($opt->{username} || $Vend::username);
3765	}
3766#::logDebug("user=$user");
3767	! $user and return pull_else($body);
3768
3769	my $blob = $user->get_hash('SHIPPING')   or return pull_else($body);
3770#::logDebug("blob=$blob");
3771	my $addr = $blob->{$nick};
3772
3773	if (! $addr) {
3774		%$addr = %{ $::Values };
3775	}
3776
3777#::logDebug("addr=" . uneval($addr));
3778
3779	$addr->{mv_an} = $nick;
3780	my @nick = sort keys %$blob;
3781	my $label;
3782	if($label = $opt->{address_label}) {
3783		@nick = sort { $blob->{$a}{$label} cmp  $blob->{$a}{$label} } @nick;
3784		@nick = map { "$_=" . ($blob->{$_}{$label} || $_) } @nick;
3785		for(@nick) {
3786			s/,/&#44;/g;
3787		}
3788	}
3789	$opt->{blank} = '--select--' unless $opt->{blank};
3790	unshift(@nick, "=$opt->{blank}");
3791	$opt->{address_book} = join ",", @nick
3792		unless $opt->{address_book};
3793
3794	my $joiner = get_joiner($opt->{joiner}, "<br$Vend::Xtrailer>");
3795	if(! $opt->{no_address}) {
3796		my @vals = map { $addr->{$_} }
3797					grep /^address_?\d*$/ && length($addr->{$_}), keys %$addr;
3798		$addr->{address} = join $joiner, @vals;
3799	}
3800
3801	if($opt->{widget}) {
3802		$addr->{address_book} = tag_accessories(
3803									$item->{code},
3804									undef,
3805									{
3806										attribute => $nattr,
3807										type => $opt->{widget},
3808										passed => $opt->{address_book},
3809										form => $opt->{form},
3810									},
3811									$item
3812									);
3813	}
3814
3815	if($opt->{set} || ! $item->{$attr}) {
3816		my $template = '';
3817		if($::Variable->{MV_SHIP_ADDRESS_TEMPLATE}) {
3818			$template .= $::Variable->{MV_SHIP_ADDRESS_TEMPLATE};
3819		}
3820		else {
3821			$template .= "{company}\n" if $addr->{"${pre}company"};
3822			$template .= <<EOF;
3823{address}
3824{city}, {state} {zip}
3825{country} -- {phone_day}
3826EOF
3827		}
3828		$template =~ s/{(\w+.*?)}/{$pre$1}/g if $pre;
3829		$addr->{mv_ad} = $item->{$attr} = tag_attr_list($template, $addr);
3830	}
3831	else {
3832		$addr->{mv_ad} = $item->{$attr};
3833	}
3834
3835	if($opt->{textarea}) {
3836		$addr->{textarea} = tag_accessories(
3837									$item->{code},
3838									undef,
3839									{
3840										attribute => $attr,
3841										type => 'textarea',
3842										rows => $opt->{rows} || '4',
3843										cols => $opt->{cols} || '40',
3844									},
3845									$item
3846									);
3847	}
3848
3849	$body =~ s:\[$tag\]($Some)\[/$tag\]:tag_attr_list($1, $addr):eg;
3850	return pull_if($body);
3851}
3852
3853sub tag_object {
3854	my ($count, $item, $hash, $opt, $body) = @_;
3855	my $param = delete $hash->{param}
3856		or return undef;
3857	my $method;
3858	my $out = '';
3859	eval {
3860		if(not $method = delete $hash->{method}) {
3861			$out = $item->{$param}->();
3862		}
3863		else {
3864			$out = $item->{$param}->$method();
3865		}
3866	};
3867	return $out;
3868}
3869
3870my %Dispatch_hash = (
3871	address => \&tag_address,
3872	object  => \&tag_object,
3873);
3874
3875sub find_matching_else {
3876    my($buf) = @_;
3877    my $out;
3878	my $canon;
3879
3880    my $open  = '[else]';
3881    my $close = '[/else]';
3882    my $first;
3883	my $pos;
3884
3885  	$$buf =~ s{\[else\]}{[else]}igo;
3886    $first = index($$buf, $open);
3887#::logDebug("first=$first");
3888	return undef if $first < 0;
3889	my $int     = $first;
3890	my $begin   = $first;
3891	$$buf =~ s{\[/else\]}{[/else]}igo
3892		or $int = -1;
3893
3894	while($int > -1) {
3895		$pos   = $begin + 1;
3896		$begin = index($$buf, $open, $pos);
3897		$int   = index($$buf, $close, $int + 1);
3898		last if $int < 1;
3899		if($begin > $int) {
3900			$first = $int = $begin;
3901			$int = $begin;
3902		}
3903#::logDebug("pos=$pos int=$int first=$first begin=$begin");
3904    }
3905	$first = $begin if $begin > -1;
3906	substr($$buf, $first) =~ s/(.*)//s;
3907	$out = $1;
3908	substr($out, 0, 6) = '';
3909	return $out;
3910}
3911
3912sub tag_dispatch {
3913	my($tag, $count, $item, $hash, $chunk) = @_;
3914	$tag = lc $tag;
3915	$tag =~ tr/-/_/;
3916	my $full = lc "$Orig_prefix-tag-$tag";
3917	$full =~ tr/-/_/;
3918#::logDebug("tag_dispatch: tag=$tag count=$count chunk=$chunk");
3919	my $attrseq = [];
3920	my $attrhash = {};
3921	my $eaten;
3922	my $this_tag;
3923
3924	$eaten = Vend::Parse::_find_tag(\$chunk, $attrhash, $attrseq);
3925	substr($chunk, 0, 1) = '';
3926
3927	$this_tag = Vend::Parse::find_matching_end($full, \$chunk);
3928
3929	$attrhash->{prefix} = $tag unless $attrhash->{prefix};
3930
3931	my $out;
3932	if(defined $Dispatch_hash{$tag}) {
3933		$out = $Dispatch_hash{$tag}->($count, $item, $hash, $attrhash, $this_tag);
3934	}
3935	else {
3936		$attrhash->{body} = $this_tag unless defined $attrhash->{body};
3937#::logDebug("calling tag tag=$tag this_tag=$this_tag attrhash=" . uneval($attrhash));
3938		$Tag ||= new Vend::Tags;
3939		$out = $Tag->$tag($attrhash);
3940	}
3941	return $out . $chunk;
3942}
3943
3944my $rit = 1;
3945
3946sub resolve_nested_if {
3947	my ($where, $what) = @_;
3948	$where =~ s~\[$what\s+(?!.*\[$what\s)(.*?)\[/$what\]~
3949				'[' . $what . $rit . " $1" . '[/' . $what . $rit++ . ']'~seg;
3950#::logDebug("resolved?\n$where\n");
3951	return $where;
3952}
3953
3954use vars qw/%Ary_code/;
3955%Ary_code = (
3956	accessories => \&tag_accessories,
3957	common => \&Vend::Data::product_common,
3958	description => \&Vend::Data::product_description,
3959	field => \&Vend::Data::product_field,
3960	last => \&interpolate_html,
3961	next => \&interpolate_html,
3962	options => \&Vend::Options::tag_options,
3963);
3964
3965use vars qw/%Hash_code/;
3966%Hash_code = (
3967	accessories => \&tag_accessories,
3968	common => \&Vend::Data::item_common,
3969	description => \&Vend::Data::item_description,
3970	field => \&Vend::Data::item_field,
3971	last => \&interpolate_html,
3972	next => \&interpolate_html,
3973	options => \&tag_options,
3974);
3975
3976sub map_list_routines {
3977	my($type, $opt) = @_;
3978
3979	### This allows mapping of new routines to
3980	##    PREFIX-options
3981	##    PREFIX-accessories
3982	##    PREFIX-description
3983	##    PREFIX-common
3984	##    PREFIX-field
3985	##    PREFIX-price
3986	##    PREFIX-tag
3987	##    PREFIX-last
3988	##    PREFIX-next
3989
3990	my $nc;
3991
3992	my $ac;
3993	for $ac ($Global::CodeDef->{$type}, $Vend::Cfg->{CodeDef}{$type}) {
3994		next unless $ac and $ac->{Routine};
3995		$nc ||= {};
3996		for(keys %{$ac->{Routine}}) {
3997			$nc->{$_} = $ac->{Routine}{$_};
3998		}
3999	}
4000
4001	if($ac = $opt->{maproutine}) {
4002		$nc ||= {};
4003		if(! ref($ac) ) {
4004			$ac =~ s/[\s'",=>\0]+$//;
4005			$ac =~ s/^[\s'",=>\0]+//;
4006			$ac = { split /[\s'",=>\0]+/, $ac };
4007		}
4008		$ac = {} if ref($ac) ne 'HASH';
4009		while( my($k,$v) = each %$ac) {
4010			$nc->{$k} = $Vend::Cfg->{Sub}{$v} || $Global::GlobalSub->{$v}
4011			  or do {
4012				  logError("%s: non-existent mapped routine %s.", $type, $_);
4013					delete $nc->{$_};
4014			  };
4015		}
4016	}
4017	return $nc;
4018}
4019
4020sub alternate {
4021	my ($count, $inc, $end, $page_start, $array_last) = @_;
4022
4023	if(! length($inc)) {
4024		$inc ||= $::Values->{mv_item_alternate} || 2;
4025	}
4026
4027	return $count % $inc if $inc >= 1;
4028
4029	my $status;
4030	if($inc == -1 or $inc eq 'except_last') {
4031		$status = 1 unless $count - 1 == $end;
4032	}
4033	elsif($inc eq '0' or $inc eq 'first_only') {
4034		$status = 1 if $count == 1 || $count == ($page_start + 1);
4035	}
4036	elsif($inc eq 'except_first') {
4037		$status = 1 unless $count == 1 || $count == ($page_start + 1);
4038	}
4039	elsif($inc eq 'last_only') {
4040		$status = 1 if $count - 1 == $end;
4041	}
4042	elsif($inc eq 'absolute_last') {
4043		$status = 1 if $count == $array_last;
4044	}
4045	elsif($inc eq 'absolute_first') {
4046		$status = 1 if $count == 1;
4047	}
4048	return ! $status;
4049}
4050
4051sub iterate_array_list {
4052	my ($i, $end, $count, $text, $ary, $opt_select, $fh, $opt, $fa) = @_;
4053#::logDebug("passed opt=" . ::uneval($opt));
4054	my $page_start = $i;
4055	my $array_last = scalar @{$ary || []};
4056	my $r = '';
4057	$opt ||= {};
4058
4059	# The $Row object needs to be built per-row, so undef it initially.
4060	$fa ||= [];
4061	@$fa = sort { $fh->{$a} <=> $fh->{$b} } keys %$fh
4062		if ! @$fa and ref $fh eq 'HASH';
4063	undef $Row;
4064
4065	my $lim;
4066	if($lim = $::Limit->{list_text_size} and length($text) > $lim) {
4067		my $len = length($text);
4068		my $caller = join "|", caller();
4069		my $msg = "Large list text encountered,  length=$len, caller=$caller";
4070		logError($msg);
4071		return undef if $::Limit->{list_text_overflow} eq 'abort';
4072	}
4073
4074	# Optimize for no-match, on-match, etc
4075	if(! $opt->{iterator} and $text !~ /\[(?:if-)?$Prefix-/) {
4076		for(; $i <= $end; $i++) {
4077			$r .= $text;
4078		}
4079		return $r;
4080	}
4081
4082	my $nc = map_list_routines('ArrayCode', $opt);
4083
4084	$nc and local(@Ary_code{keys %$nc}) = values %$nc;
4085
4086	my ($run, $row, $code, $return);
4087my $once = 0;
4088#::logDebug("iterating array $i to $end. count=$count opt_select=$opt_select ary=" . uneval($ary));
4089
4090	$text =~ s{
4091		$B$QR{_include}
4092	}{
4093		my $filename = $1;
4094
4095		$Data_cache{"/$filename"} or do {
4096		    my $content = Vend::Util::readfile($filename);
4097		    vars_and_comments(\$content);
4098		    $Data_cache{"/$filename"} = $content;
4099		};
4100	}igex;
4101
4102	if($text =~ m/^$B$QR{_line}\s*$/is) {
4103		my $i = $1 || 0;
4104		my $fa = $opt->{mv_return_fields};
4105		$r .= join "\t", @$fa[$i .. $#$fa];
4106		$r .= "\n";
4107	}
4108	1 while $text =~ s#$IB$QR{_header_param_if}$IE[-_]header[-_]param\1\]#
4109			  (defined $opt->{$3} ? $opt->{$3} : '')
4110				  					?	pull_if($5,$2,$4,$opt->{$3})
4111									:	pull_else($5,$2,$4,$opt->{$3})#ige;
4112	$text =~ s#$B$QR{_header_param}#defined $opt->{$1} ? ed($opt->{$1}) : ''#ige;
4113	while($text =~ s#$B$QR{_sub}$E$QR{'/_sub'}##i) {
4114		my $name = $1;
4115		my $routine = $2;
4116		## Not necessary?
4117		## $Vend::Cfg->{Sub}{''} = sub { errmsg('undefined sub') }
4118		##	unless defined $Vend::Cfg->{Sub}{''};
4119		$routine = 'sub { ' . $routine . ' }' unless $routine =~ /^\s*sub\s*{/;
4120		my $sub;
4121		eval {
4122			$sub = $ready_safe->reval($routine);
4123		};
4124		if($@) {
4125			logError( errmsg("syntax error on %s-sub %s]: $@", $B, $name) );
4126			$sub = sub { errmsg('ERROR') };
4127		}
4128#::logDebug("sub $name: $sub --> $routine");
4129		$Vend::Cfg->{Sub}{$name} = $sub;
4130	}
4131
4132	my $oexec = { %$opt };
4133
4134	if($opt->{iterator}) {
4135		my $sub;
4136		$sub = $opt->{iterator}          if ref($opt->{iterator}) eq 'CODE';
4137		$sub ||= $Vend::Cfg->{Sub}{$opt->{iterator}}
4138				|| $Global::GlobalSub->{$opt->{iterator}};
4139		if(! $sub) {
4140			logError(
4141				"list iterator subroutine '%s' called but not defined. Skipping.",
4142				$opt->{iterator},
4143			);
4144			return '';
4145		}
4146		for( ; $i <= $end ; $i++ ) {
4147			$r .= $sub->($text, $ary->[$i], $oexec);
4148		}
4149		return $r;
4150	}
4151
4152	1 while $text =~ s{(\[(if[-_]$Prefix[-_][a-zA-Z]+)(?=.*\[\2)\s.*\[/\2\])}
4153					  {
4154					  	resolve_nested_if($1, $2)
4155					  }se;
4156
4157	# log helpful errors if any unknown field names are
4158	# used in if-prefix-param or prefix-param tags
4159	my @field_msg = ('error', "Unknown field name '%s' used in tag %s");
4160	$run = $text;
4161	if(! $opt->{ignore_undefined}) {
4162	$run =~ s#$B$QR{_param}# defined $fh->{$1} ||
4163		logOnce(@field_msg, $1, "$Orig_prefix-param") #ige;
4164	$run =~ s#$IB$QR{_param_if}# defined $fh->{$3} ||
4165		logOnce(@field_msg, $3, "if-$Orig_prefix-param") #ige;
4166	}
4167
4168	for( ; $i <= $end ; $i++, $count++ ) {
4169		$row = $ary->[$i];
4170		last unless defined $row;
4171		$code = $row->[0];
4172
4173#::logDebug("Doing $code substitution, count $count++");
4174#::logDebug("Doing '" . substr($code, 0, index($code, "\n") + 1) . "' substitution, count $count++");
4175
4176	    $run = $text;
4177		$run =~ s#$B$QR{_alternate}$E$QR{'/_alternate'}#
4178						  alternate($count, $1, $end, $page_start, $array_last)
4179				  							?	pull_else($2)
4180											:	pull_if($2)#ige;
4181		1 while $run =~ s#$IB$QR{_param_if}$IE[-_](?:param|modifier)\1\]#
4182				  (defined $fh->{$3} ? $row->[$fh->{$3}] : '')
4183				  					?	pull_if($5,$2,$4,$row->[$fh->{$3}])
4184									:	pull_else($5,$2,$4,$row->[$fh->{$3}])#ige;
4185	    $run =~ s#$B$QR{_param}#defined $fh->{$1} ? ed($row->[$fh->{$1}]) : ''#ige;
4186		1 while $run =~ s#$IB$QR{_pos_if}$IE[-_]pos\1\]#
4187				  $row->[$3]
4188						?	pull_if($5,$2,$4,$row->[$3])
4189						:	pull_else($5,$2,$4,$row->[$3])#ige;
4190	    $run =~ s#$B$QR{_pos}#ed($row->[$1])#ige;
4191#::logDebug("fh: " . uneval($fh) . uneval($row)) unless $once++;
4192		1 while $run =~ s#$IB$QR{_field_if}$IE[-_]field\1\]#
4193				  my $tmp = product_field($3, $code);
4194				  $tmp	?	pull_if($5,$2,$4,$tmp)
4195						:	pull_else($5,$2,$4,$tmp)#ige;
4196		$run =~ s:$B$QR{_line}:join "\t", @{$row}[ ($1 || 0) .. $#$row]:ige;
4197	    $run =~ s:$B$QR{_increment}:$count:ig;
4198		$run =~ s:$B$QR{_accessories}:
4199						$Ary_code{accessories}->($code,$1,{}):ige;
4200		$run =~ s:$B$QR{_options}:
4201						$Ary_code{options}->($code,$1):ige;
4202		$run =~ s:$B$QR{_code}:$code:ig;
4203		$run =~ s:$B$QR{_description}:ed($Ary_code{description}->($code)):ige;
4204		$run =~ s:$B$QR{_field}:ed($Ary_code{field}->($1, $code)):ige;
4205		$run =~ s:$B$QR{_common}:ed($Ary_code{common}->($1, $code)):ige;
4206		tag_labeled_data_row($code, \$run);
4207		$run =~ s!$B$QR{_price}!
4208					currency(product_price($code,$1), $2)!ige;
4209
4210		1 while $run =~ s!$B$QR{_change}$E$QR{'/_change'}\1\]!
4211							check_change($1,$3,undef,$2)
4212											?	pull_if($4)
4213											:	pull_else($4)!ige;
4214		$run =~ s#$B$QR{_tag}($Some$E[-_]tag[-_]\1\])#
4215						tag_dispatch($1,$count, $row, $ary, $2)#ige;
4216		$run =~ s#$B$QR{_calc}$E$QR{'/_calc'}#
4217			unless ($Row) {
4218				$Row = {};
4219				@{$Row}{@$fa} = @$row;
4220			}
4221			tag_calc($1)
4222			#ige;
4223		$run =~ s#$B$QR{_exec}$E$QR{'/_exec'}#
4224					init_calc() if ! $Vend::Calc_initialized;
4225					(
4226						$Vend::Cfg->{Sub}{$1} ||
4227						$Global::GlobalSub->{$1} ||
4228						sub { logOnce('error', "subroutine $1 missing for PREFIX-exec"); errmsg('ERROR') }
4229					)->($2,$row,$oexec)
4230				#ige;
4231		$run =~ s#$B$QR{_filter}$E$QR{'/_filter'}#filter_value($1,$2)#ige;
4232		$run =~ s#$B$QR{_last}$E$QR{'/_last'}#
4233                    my $tmp = $Ary_code{last}->($1);
4234					$tmp =~ s/^\s+//;
4235					$tmp =~ s/\s+$//;
4236                    if($tmp && $tmp < 0) {
4237                        last;
4238                    }
4239                    elsif($tmp) {
4240                        $return = 1;
4241                    }
4242                    '' #ixge;
4243		$run =~ s#$B$QR{_next}$E$QR{'/_next'}#
4244                    $Ary_code{next}->($1) != 0 ? (undef $Row, next) : '' #ixge;
4245		$run =~ s/<option\s*/<option SELECTED /i
4246			if $opt_select and $opt_select->($code);
4247		undef $Row;
4248		$r .= $run;
4249		last if $return;
4250    }
4251	return $r;
4252}
4253
4254sub iterate_hash_list {
4255	my($i, $end, $count, $text, $hash, $opt_select, $opt) = @_;
4256
4257	my $r = '';
4258	$opt ||= {};
4259
4260	# Optimize for no-match, on-match, etc
4261	if(! $opt->{iterator} and $text !~ /\[/) {
4262		for(; $i <= $end; $i++) {
4263			$r .= $text;
4264		}
4265		return $r;
4266	}
4267
4268	my $code_field = $opt->{code_field} || 'mv_sku';
4269	my ($run, $code, $return, $item);
4270
4271	my $nc = map_list_routines('HashCode', $opt);
4272
4273	$nc and local(@Hash_code{keys %$nc}) = values %$nc;
4274
4275#::logDebug("iterating hash $i to $end. count=$count opt_select=$opt_select hash=" . uneval($hash));
4276	1 while $text =~ s#$IB$QR{_header_param_if}$IE[-_]header[-_]param\1\]#
4277			  (defined $opt->{$3} ? $opt->{$3} : '')
4278				  					?	pull_if($5,$2,$4,$opt->{$3})
4279									:	pull_else($5,$2,$4,$opt->{$3})#ige;
4280	$text =~ s#$B$QR{_header_param}#defined $opt->{$1} ? ed($opt->{$1}) : ''#ige;
4281	while($text =~ s#$B$QR{_sub}$E$QR{'/_sub'}##i) {
4282		my $name = $1;
4283		my $routine = $2;
4284		## Not necessary?
4285		## $Vend::Cfg->{Sub}{''} = sub { errmsg('undefined sub') }
4286		##	unless defined $Vend::Cfg->{Sub}{''};
4287		$routine = 'sub { ' . $routine . ' }' unless $routine =~ /^\s*sub\s*{/;
4288		my $sub;
4289		eval {
4290			$sub = $ready_safe->reval($routine);
4291		};
4292		if($@) {
4293			logError( errmsg("syntax error on %s-sub %s]: $@", $B, $name) );
4294			$sub = sub { errmsg('ERROR') };
4295		}
4296		$Vend::Cfg->{Sub}{$name} = $sub;
4297	}
4298#::logDebug("subhidden: $opt->{subhidden}");
4299
4300	my $oexec = { %$opt };
4301
4302	if($opt->{iterator}) {
4303		my $sub;
4304		$sub   = $opt->{iterator}          if ref($opt->{iterator}) eq 'CODE';
4305		$sub ||= $Vend::Cfg->{Sub}{$opt->{iterator}}
4306				|| $Global::GlobalSub->{$opt->{iterator}};
4307		if(! $sub) {
4308			logError(
4309				"list iterator subroutine '%s' called but not defined. Skipping.",
4310				$opt->{iterator},
4311			);
4312			return '';
4313		}
4314
4315		for( ; $i <= $end ; $i++ ) {
4316			$r .= $sub->($text, $hash->[$i], $oexec);
4317		}
4318		return $r;
4319	}
4320
4321	1 while $text =~ s{(\[(if[-_]$Prefix[-_][a-zA-Z]+)(?=.*\[\2)\s.*\[/\2\])}
4322					  {
4323					  	resolve_nested_if($1, $2)
4324					  }se;
4325
4326	# undef the $Row object, as it should only be set as needed by [PREFIX-calc]
4327	undef $Row;
4328
4329	for ( ; $i <= $end; $i++, $count++) {
4330		$item = $hash->[$i];
4331		$item->{mv_ip} = $opt->{reverse} ? ($end - $i) : $i;
4332		if($opt->{modular}) {
4333			if($opt->{master}) {
4334				next unless $item->{mv_mi} eq $opt->{master};
4335			}
4336			if($item->{mv_mp} and $item->{mv_si} and ! $opt->{subitems}) {
4337#				$r .= <<EOF if $opt->{subhidden};
4338#<INPUT TYPE="hidden" NAME="quantity$item->{mv_ip}" VALUE="$item->{quantity}">
4339#EOF
4340				next;
4341			}
4342		}
4343		$item->{mv_cache_price} = undef;
4344		$code = $item->{$code_field} || $item->{code};
4345		$code = '' unless defined $code;
4346
4347#::logDebug("Doing $code (variant $item->{code}) substitution, count $count++");
4348
4349		$run = $text;
4350		$run =~ s#$B$QR{_alternate}$E$QR{'/_alternate'}#
4351						  alternate($i + 1, $1, $end)
4352				  							?	pull_else($2)
4353											:	pull_if($2)#ge;
4354		tag_labeled_data_row($code,\$run);
4355		$run =~ s:$B$QR{_line}:join "\t", @{$hash}:ge;
4356		1 while $run =~ s#$IB$QR{_param_if}$IE[-_](?:param|modifier)\1\]#
4357				  $item->{$3}	?	pull_if($5,$2,$4,$item->{$3})
4358								:	pull_else($5,$2,$4,$item->{$3})#ige;
4359		1 while $run =~ s#$IB$QR{_parent_if}$IE[-_]parent\1\]#
4360				  $item->{$3}	?	pull_if($5,$2,$4,$opt->{$3})
4361								:	pull_else($5,$2,$4,$opt->{$3})#ige;
4362		1 while $run =~ s#$IB$QR{_field_if}$IE[-_]field\1\]#
4363				  my $tmp = item_field($item, $3);
4364				  $tmp	?	pull_if($5,$2,$4,$tmp)
4365						:	pull_else($5,$2,$4,$tmp)#ge;
4366		$run =~ s:$B$QR{_increment}:$i + 1:ge;
4367
4368		$run =~ s:$B$QR{_accessories}:
4369						$Hash_code{accessories}->($code,$1,{},$item):ge;
4370		$run =~ s:$B$QR{_options}:
4371						$Hash_code{options}->($item,$1):ige;
4372		$run =~ s:$B$QR{_sku}:$code:ig;
4373		$run =~ s:$B$QR{_code}:$item->{code}:ig;
4374		$run =~ s:$B$QR{_quantity}:$item->{quantity}:g;
4375		$run =~ s:$B$QR{_param}:ed($item->{$1}):ge;
4376		$run =~ s:$B$QR{_parent}:ed($opt->{$1}):ge;
4377		$run =~ s:$B$QR{_quantity_name}:quantity$item->{mv_ip}:g;
4378		$run =~ s:$B$QR{_modifier_name}:$1$item->{mv_ip}:g;
4379		$run =~ s!$B$QR{_subtotal}!currency(item_subtotal($item),$1)!ge;
4380		$run =~ s!$B$QR{_discount_subtotal}!
4381						currency( discount_subtotal($item), $1 )!ge;
4382		$run =~ s:$B$QR{_code}:$code:g;
4383		$run =~ s:$B$QR{_field}:ed($Hash_code{field}->($item, $1) || $item->{$1}):ge;
4384		$run =~ s:$B$QR{_common}:ed($Hash_code{common}->($item, $1) || $item->{$1}):ge;
4385		$run =~ s:$B$QR{_description}:
4386							ed($Hash_code{description}->($item) || $item->{description})
4387							:ge;
4388		$run =~ s!$B$QR{_price}!currency(item_price($item,$1), $2)!ge;
4389		$run =~ s!$B$QR{_discount_price}!
4390					currency(
4391						discount_price($item, item_price($item,$1), $1 || 1)
4392						, $2
4393						)!ge
4394				or
4395				$run =~ s!$QR{discount_price}!
4396							currency(
4397								discount_price($item, item_price($item,$1), $1 || 1)
4398								, $2
4399								)!ge;
4400		$run =~ s!$B$QR{_difference}!
4401					currency(
4402							item_difference(
4403								$item->{code},
4404								item_price($item, $item->{quantity}),
4405								$item->{quantity},
4406								$item,
4407							),
4408							$2,
4409					)!ge;
4410		$run =~ s!$B$QR{_discount}!
4411					currency(
4412							item_discount(
4413								$item->{code},
4414								item_price($item, $item->{quantity}),
4415								$item->{quantity},
4416							),
4417							$2,
4418					)!ge;
4419		1 while $run =~ s!$B$QR{_change}$E$QR{'/_change'}\1\]!
4420							check_change($1,$3,undef,$2)
4421											?	pull_if($4)
4422											:	pull_else($4)!ige;
4423		$run =~ s#$B$QR{_tag}($All$E[-_]tag[-_]\1\])#
4424						tag_dispatch($1,$count, $item, $hash, $2)#ige;
4425		$Row = $item;
4426		$run =~ s#$B$QR{_calc}$E$QR{'/_calc'}#tag_calc($1)#ige;
4427		$run =~ s#$B$QR{_exec}$E$QR{'/_exec'}#
4428					init_calc() if ! $Vend::Calc_initialized;
4429					(
4430						$Vend::Cfg->{Sub}{$1} ||
4431						$Global::GlobalSub->{$1} ||
4432						sub { 'ERROR' }
4433					)->($2,$item,$oexec)
4434				#ige;
4435		$run =~ s#$B$QR{_filter}$E$QR{'/_filter'}#filter_value($1,$2)#ige;
4436		$run =~ s#$B$QR{_last}$E$QR{'/_last'}#
4437                    my $tmp = interpolate_html($1);
4438                    if($tmp && $tmp < 0) {
4439                        last;
4440                    }
4441                    elsif($tmp) {
4442                        $return = 1;
4443                    }
4444                    '' #xoge;
4445		$run =~ s#$B$QR{_next}$E$QR{'/_next'}#
4446                    interpolate_html($1) != 0 ? next : '' #oge;
4447		$run =~ s/<option\s*/<option SELECTED /i
4448			if $opt_select and $opt_select->($code);
4449
4450		$r .= $run;
4451		undef $Row;
4452#::logDebug("item $code mv_cache_price: $item->{mv_cache_price}");
4453		delete $item->{mv_cache_price};
4454		last if $return;
4455	}
4456
4457	return $r;
4458}
4459
4460sub error_opt {
4461	my ($opt, @args) = @_;
4462	return undef unless ref $opt;
4463	my $msg = errmsg(@args);
4464	$msg = "$opt->{error_id}: $msg" if $opt->{error_id};
4465	if($opt->{log_error}) {
4466		logError($msg);
4467	}
4468	return $msg if $opt->{show_error};
4469	return undef;
4470}
4471
4472sub query {
4473	if(ref $_[0]) {
4474		unshift @_, '';
4475	}
4476	my ($query, $opt, $text) = @_;
4477	$opt = {} if ! $opt;
4478	$opt->{prefix} = 'sql' unless $opt->{prefix};
4479	if($opt->{more} and $Vend::More_in_progress) {
4480		undef $Vend::More_in_progress;
4481		return region($opt, $text);
4482	}
4483	$opt->{table} = $Vend::Cfg->{ProductFiles}[0]
4484		unless $opt->{table};
4485	my $db = $Vend::Database{$opt->{table}} ;
4486	return $opt->{failure} if ! $db;
4487
4488	$opt->{query} = $query
4489		if $query;
4490
4491	$opt->{query} =~ s:
4492			\[\Q$opt->{prefix}\E[_-]quote\](.*?)\[/\Q$opt->{prefix}\E[_-]quote\]
4493		:
4494			$db->quote($1)
4495		:xisge;
4496
4497	if (! $opt->{wantarray} and ! defined $MVSAFE::Safe) {
4498		my $result = $db->query($opt, $text);
4499		return (ref $result) ? '' : $result;
4500	}
4501	$db->query($opt, $text);
4502}
4503
4504sub html_table {
4505    my($opt, $ary, $na) = @_;
4506
4507	if (!$na) {
4508		$na = [ split /\s+/, $opt->{columns} ];
4509	}
4510	if(! ref $ary) {
4511		$ary =~ s/^\s+//;
4512		$ary =~ s/\s+$//;
4513		my $delimiter = quotemeta $opt->{delimiter} || "\t";
4514		my $splittor = quotemeta $opt->{record_delim} || "\n";
4515		my (@rows) = split /$splittor/, $ary;
4516		$na = [ split /$delimiter/, shift @rows ] if $opt->{th};
4517		$ary = [];
4518		my $count = scalar @$na || -1;
4519		for (@rows) {
4520			push @$ary, [split /$delimiter/, $_, $count];
4521		}
4522	}
4523
4524	my ($tr, $td, $th, $fc, $fr) = @{$opt}{qw/tr td th fc fr/};
4525
4526	for($tr, $td, $th, $fc, $fr) {
4527		next unless defined $_;
4528		s/(.)/ $1/;
4529	}
4530
4531	my $r = '';
4532	$tr = '' if ! defined $tr;
4533	$td = '' if ! defined $td;
4534	if(! defined $th || $th and scalar @$na ) {
4535		$th = '' if ! defined $th;
4536		$r .= "<tr$tr>";
4537		for(@$na) {
4538			$r .= "<th$th><b>$_</b></th>";
4539		}
4540		$r .= "</tr>\n";
4541	}
4542	my $row;
4543	if($fr) {
4544		$r .= "<tr$fr>";
4545		my $val;
4546		$row = shift @$ary;
4547		if($fc) {
4548			$val = (shift @$row) || '&nbsp;';
4549			$r .= "<td$fc>$val</td>";
4550		}
4551		foreach (@$row) {
4552			$val = $_ || '&nbsp;';
4553			$r .= "<td$td>$val</td>";
4554		}
4555		$r .= "</tr>\n";
4556
4557	}
4558	foreach $row (@$ary) {
4559		$r .= "<tr$tr>";
4560		my $val;
4561		if($fc) {
4562			$val = (shift @$row) || '&nbsp;';
4563			$r .= "<td$fc>$val</td>";
4564		}
4565		foreach (@$row) {
4566			$val = $_ || '&nbsp;';
4567			$r .= "<td$td>$val</td>";
4568		}
4569		$r .= "</tr>\n";
4570	}
4571	return $r;
4572}
4573
4574#
4575# Tests of above routines
4576#
4577#print html_table( {
4578#					td => "BGCOLOR=#FFFFFF",
4579#					},
4580#[
4581#	[qw/ data1a	data2a	data3a/],
4582#	[qw/ data1b	data2b	data3b/],
4583#	[qw/ data1c	data2c	data3c/],
4584#],
4585#[ qw/cell1 cell2 cell3/ ],
4586#);
4587#
4588#print html_table( {
4589#					td => "BGCOLOR=#FFFFFF",
4590#					columns => "cell1 cell2 cell3",
4591#					}, <<EOF);
4592#data1a	data2a	data3a
4593#data1b	data2b	data3b
4594#data1c	data2c	data3c
4595#EOF
4596
4597
4598# SQL
4599sub tag_sql_list {
4600    my($text,$ary,$nh,$opt,$na) = @_;
4601	$opt = {} unless defined $opt;
4602	$opt->{prefix}      = 'sql' if ! defined $opt->{prefix};
4603	$opt->{list_prefix} = 'sql[-_]list' if ! defined $opt->{prefix};
4604
4605	my $object = {
4606					mv_results => $ary,
4607					mv_field_hash => $nh,
4608					mv_return_fields => $na,
4609					mv_more_id => $opt->{mv_more_id},
4610					matches => scalar @$ary,
4611				};
4612
4613	# Scans the option hash for more search settings if mv_more_alpha
4614	# is set in [query ...] tag....
4615	if($opt->{ma}) {
4616		# Find the sort field and alpha options....
4617		Vend::Scan::parse_profile_ref($object, $opt);
4618		# We need to turn the hash reference into a search object
4619		$object = new Vend::Search (%$object);
4620		# Delete this so it will meet conditions for creating a more
4621		delete $object->{mv_matchlimit};
4622	}
4623
4624	$opt->{object} = $object;
4625    return region($opt, $text);
4626}
4627# END SQL
4628
4629# Displays a search page with the special [search-list] tag evaluated.
4630
4631sub opt_region {
4632	my $opt = pop @_;
4633	my $new = { %$opt };
4634	my $out = iterate_hash_list(@_,[$new]);
4635	$Prefix = $Orig_prefix;
4636	return $out;
4637}
4638
4639sub region {
4640
4641	my($opt,$page) = @_;
4642
4643	my $obj;
4644
4645	if($opt->{object}) {
4646		### The caller supplies the object, no search to be done
4647		$obj = $opt->{object};
4648	}
4649	else {
4650		### We need to run a search to get an object
4651		my $c;
4652		if($CGI::values{mv_more_matches} || $CGI::values{MM}) {
4653
4654			### It is a more function, we need to get the parameters
4655			find_search_params(\%CGI::values);
4656			delete $CGI::values{mv_more_matches};
4657		}
4658		elsif ($opt->{search}) {
4659			### Explicit search in tag parameter, run just like any
4660			if($opt->{more} and $::Instance->{SearchObject}{''}) {
4661				$obj = $::Instance->{SearchObject}{''};
4662				#::logDebug("cached search");
4663			}
4664			else {
4665				$c = {	mv_search_immediate => 1,
4666							mv_search_label => $opt->{label} || 'current',
4667						};
4668				my $params = escape_scan($opt->{search});
4669				Vend::Scan::find_search_params($c, $params);
4670				$c->{mv_no_more} = ! $opt->{more};
4671				$obj = perform_search($c);
4672			}
4673		}
4674		else {
4675			### See if we have a search already done for this label
4676			$obj = $::Instance->{SearchObject}{$opt->{label}};
4677		}
4678
4679		# If none of the above happen, we need to perform a search
4680		# based on the passed CGI parameters
4681		if(! $obj) {
4682			$obj = perform_search();
4683			$obj = {
4684				matches => 0,
4685				mv_search_error => [ errmsg('No search was found') ],
4686			} if ! $obj;
4687		}
4688		finish_search($obj);
4689
4690		# Label it for future reference
4691		$::Instance->{SearchObject}{$opt->{label}} = $opt->{object} = $obj;
4692	}
4693
4694	my $lprefix;
4695	my $mprefix;
4696	if($opt->{list_prefix}) {
4697		$lprefix = $opt->{list_prefix};
4698		$mprefix = "(?:$opt->{list_prefix}-)?";
4699	}
4700	elsif ($opt->{prefix}) {
4701		$lprefix = "(?:$opt->{prefix}-)?list";
4702		$mprefix = "(?:$opt->{prefix}-)?";
4703	}
4704	else {
4705		$lprefix = "list";
4706		$mprefix = "";
4707	}
4708
4709#::logDebug("region: opt:\n" . uneval($opt) . "\npage:" . substr($page,0,100));
4710
4711	if($opt->{ml} and ! defined $obj->{mv_matchlimit} ) {
4712		$obj->{mv_matchlimit} = $opt->{ml};
4713		$obj->{mv_more_decade} = $opt->{md};
4714		$obj->{matches} = scalar @{$obj->{mv_results}};
4715		$obj->{mv_cache_key} = generate_key($opt->{query} || substr($page,0,100));
4716		$obj->{mv_more_permanent} = $opt->{pm};
4717		$obj->{mv_first_match} = $opt->{fm} if $opt->{fm};
4718		$obj->{mv_search_page} = $opt->{sp} if $opt->{sp};
4719		$obj->{prefix} = $opt->{prefix} if $opt->{prefix};
4720		my $out = delete $obj->{mv_results};
4721		Vend::Search::save_more($obj, $out);
4722		$obj->{mv_results} = $out;
4723	}
4724
4725	$opt->{prefix} = $obj->{prefix} if $obj->{prefix};
4726
4727	$Orig_prefix = $Prefix = $opt->{prefix} || 'item';
4728
4729	$B  = qr(\[$Prefix)i;
4730	$E  = qr(\[/$Prefix)i;
4731	$IB = qr(\[if[-_]$Prefix)i;
4732	$IE = qr(\[/if[-_]$Prefix)i;
4733
4734	my $new;
4735	$page =~   s!
4736					\[ ( $mprefix  more[-_]list )  $Optx$Optx$Optx$Optx$Optx \]
4737						($Some)
4738					\[/\1\]
4739				!
4740					tag_more_list($2,$3,$4,$5,$6,$opt,$7)
4741				!xige;
4742	$page =~   s!
4743					\[ ( $mprefix  on[-_]match )\]
4744						($Some)
4745					\[/\1\]
4746				!
4747					$obj->{matches} > 0 ? opt_region(0,0,1,$2,$opt) : ''
4748				!xige;
4749	$page =~   s!
4750					\[ ( $mprefix  no[-_]match )\]
4751						($Some)
4752					\[/\1\]
4753				!
4754					$obj->{matches} > 0 ? '' : opt_region(0,0,1,$2,$opt)
4755				!xige;
4756
4757	$page =~ s:\[($lprefix)\]($Some)\[/\1\]:labeled_list($opt,$2,$obj):ige
4758		or $page = labeled_list($opt,$page,$obj);
4759#::logDebug("past labeled_list");
4760
4761    return $page;
4762}
4763
4764sub tag_loop_list {
4765	my ($list, $opt, $text) = @_;
4766
4767	my $fn;
4768	my @rows;
4769
4770	$opt->{prefix} ||= 'loop';
4771	$opt->{label}  ||= "loop" . ++$::Instance->{List_it} . $Global::Variable->{MV_PAGE};
4772
4773#::logDebug("list is: " . uneval($list) );
4774
4775	## Thanks to Kaare Rasmussen for this suggestion
4776	## about passing embedded Perl objects to a list
4777
4778	# Can pass object.mv_results=$ary object.mv_field_names=$ary
4779	if ($opt->{object}) {
4780		my $obj = $opt->{object};
4781		# ensure that number of matches is always set
4782		# so [on-match] / [no-match] works
4783		$obj->{matches} = scalar(@{$obj->{mv_results}});
4784		return region($opt, $text);
4785	}
4786
4787	# Here we can take the direct results of an op like
4788	# @set = $db->query() && return \@set;
4789	# Called with
4790	#	[loop list=`$Scratch->{ary}`] [loop-code]
4791	#	[/loop]
4792	if (ref $list) {
4793#::logDebug("opt->list in: " . uneval($list) );
4794		unless (ref $list eq 'ARRAY' and ref $list->[0] eq 'ARRAY') {
4795			logError("loop was passed invalid list=`...` argument");
4796			return;
4797		}
4798		my ($ary, $fh, $fa) = @$list;
4799		my $obj = $opt->{object} ||= {};
4800		$obj->{mv_results} = $ary;
4801		$obj->{matches} = scalar @$ary;
4802		$obj->{mv_field_names} = $fa if $fa;
4803		$obj->{mv_field_hash} = $fh if $fh;
4804		if($opt->{ml}) {
4805			$obj->{mv_matchlimit} = $opt->{ml};
4806			$obj->{mv_no_more} = ! $opt->{more};
4807			$obj->{mv_first_match} = $opt->{mv_first_match} || 0;
4808			$obj->{mv_next_pointer} = $opt->{mv_first_match} + $opt->{ml};
4809		}
4810		return region($opt, $text);
4811	}
4812
4813	my $delim;
4814
4815	if($opt->{search}) {
4816#::logDebug("loop resolve search");
4817		if($opt->{more} and $Vend::More_in_progress) {
4818			undef $Vend::More_in_progress;
4819			return region($opt, $text);
4820		}
4821		else {
4822			return region($opt, $text);
4823		}
4824	}
4825	elsif ($opt->{file}) {
4826#::logDebug("loop resolve file");
4827		$list = Vend::Util::readfile($opt->{file});
4828		$opt->{lr} = 1 unless
4829						defined $opt->{lr}
4830						or $opt->{quoted};
4831	}
4832	elsif ($opt->{extended}) {
4833		###
4834		### This returns
4835		###
4836		my ($view, $tab, $key) = split /:+/, $opt->{extended}, 3;
4837		if(! $key) {
4838			$key = $tab;
4839			$tab = $view;
4840			undef $view;
4841		}
4842		my $id = $tab;
4843		$id .= "::$key" if $key;
4844		my $meta = Vend::Table::Editor::meta_record(
4845								$id,
4846								$view,
4847								$opt->{table},
4848								$opt->{extended_only},
4849								);
4850		if(! $meta) {
4851			$opt->{object} = {
4852					matches		=> 1,
4853					mv_results	=> [],
4854					mv_field_names => [],
4855			};
4856		}
4857		else {
4858			$opt->{object} = {
4859					matches		=> 1,
4860					mv_results	=> [ $meta ],
4861			};
4862		}
4863		return region($opt, $text);
4864	}
4865
4866	if ($fn = $opt->{fn} || $opt->{mv_field_names}) {
4867		$fn = [ grep /\S/, split /[\s,]+/, $fn ];
4868	}
4869
4870	if ($opt->{lr}) {
4871#::logDebug("loop resolve line");
4872		$list =~ s/^\s+//;
4873		$list =~ s/\s+$//;
4874		if ($list) {
4875			$delim = $opt->{delimiter} || "\t";
4876			my $splittor = $opt->{record_delim} || "\n";
4877			if ($splittor eq "\n") {
4878				$list =~ s/\r\n/\n/g;
4879			}
4880
4881			eval {
4882				@rows = map { [ split /\Q$delim/, $_ ] } split /\Q$splittor/, $list;
4883			};
4884		}
4885	}
4886	elsif($opt->{acclist}) {
4887#::logDebug("loop resolve acclist");
4888		$fn = [ qw/option label/ ] unless $fn;
4889		eval {
4890			my @items = split /\s*,\s*/, $list;
4891			for(@items) {
4892				my ($o, $l) = split /=/, $_;
4893				$l = $o unless $l;
4894				push @rows, [ $o, $l ];
4895			}
4896		};
4897#::logDebug("rows:" . uneval(\@rows));
4898	}
4899	elsif($opt->{quoted}) {
4900#::logDebug("loop resolve quoted");
4901		my @l = Text::ParseWords::shellwords($list);
4902		produce_range(\@l) if $opt->{ranges};
4903		eval {
4904			@rows = map { [$_] } @l;
4905		};
4906	}
4907	else {
4908#::logDebug("loop resolve default");
4909		$delim = $opt->{delimiter} || '[,\s]+';
4910		my @l =  split /$delim/, $list;
4911		produce_range(\@l) if $opt->{ranges};
4912		eval {
4913			@rows = map { [$_] } @l;
4914		};
4915	}
4916
4917	if($@) {
4918		logError("bad split delimiter in loop list: $@");
4919#::logDebug("loop resolve error $@");
4920	}
4921
4922	# head_skip pulls rows off the top, and uses the last row to
4923	# set the field names if mv_field_names/fn option was not set
4924	if ($opt->{head_skip}) {
4925		my $i = 0;
4926		my $last_row;
4927		$last_row = shift(@rows) while $i++ < $opt->{head_skip};
4928		$fn ||= $last_row;
4929	}
4930
4931	$opt->{object} = {
4932			matches		=> scalar(@rows),
4933			mv_results	=> \@rows,
4934			mv_field_names => $fn,
4935	};
4936
4937#::logDebug("loop object: " . uneval($opt));
4938	return region($opt, $text);
4939}
4940
4941# Tries to display the on-the-fly page if page is missing
4942sub fly_page {
4943	my($code, $opt, $page) = @_;
4944
4945	my ($selector, $subname, $base, $listref);
4946
4947	return $page if (! $code and $Vend::Flypart eq $Vend::FinalPath);
4948
4949	$code = $Vend::FinalPath
4950		unless $code;
4951
4952	$Vend::Flypart = $code;
4953
4954	if ($subname = $Vend::Cfg->{SpecialSub}{flypage}) {
4955		my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
4956		$listref = $sub->($code);
4957		$listref = { mv_results => [[$listref]] } unless ref($listref);
4958		$base = $listref;
4959	}
4960	else {
4961		$base = product_code_exists_ref($code);
4962		$listref = {mv_results => [[$code]]};
4963	}
4964
4965#::logDebug("fly_page: code=$code base=$base page=" . substr($page, 0, 100));
4966	return undef unless $base || $opt->{onfly};
4967
4968	$base = $Vend::Cfg->{ProductFiles}[0] unless $base;
4969
4970    if($page) {
4971		$selector = 'passed in tag';
4972	}
4973	elsif(	$Vend::ForceFlypage ) {
4974		$selector = $Vend::ForceFlypage;
4975		undef $Vend::ForceFlypage;
4976	}
4977	elsif(	$selector = $Vend::Cfg->{PageSelectField}
4978			and db_column_exists($base,$selector)
4979		)
4980	{
4981			$selector = database_field($base, $code, $selector)
4982	}
4983
4984	$selector = find_special_page('flypage')
4985		unless $selector;
4986#::logDebug("fly_page: selector=$selector");
4987
4988	unless (defined $page) {
4989		unless( allowed_file($selector) ) {
4990			log_file_violation($selector, 'fly_page');
4991			return undef;
4992		}
4993		$page = readin($selector);
4994		if (defined $page) {
4995			vars_and_comments(\$page);
4996		} else {
4997			logError("attempt to display code=$code with bad flypage '$selector'");
4998			return undef;
4999		}
5000	}
5001
5002	# This allows access from embedded Perl
5003	$Tmp->{flycode} = $code;
5004# TRACK
5005	$Vend::Track->view_product($code) if $Vend::Track;
5006# END TRACK
5007
5008	$opt->{prefix} ||= 'item';
5009# LEGACY
5010	list_compat($opt->{prefix}, \$page) if $page;
5011# END LEGACY
5012
5013	return labeled_list( $opt, $page, $listref);
5014}
5015
5016sub item_difference {
5017	my($code,$price,$q,$item) = @_;
5018	return $price - discount_price($item || $code,$price,$q);
5019}
5020
5021sub item_discount {
5022	my($code,$price,$q) = @_;
5023	return ($price * $q) - discount_price($code,$price,$q) * $q;
5024}
5025
5026sub discount_subtotal {
5027	my ($item, $price) = @_;
5028
5029	unless (ref $item) {
5030		::logError("Bad call to discount price, item is not reference: %s", $item);
5031		return 0;
5032	}
5033
5034	my $quantity = $item->{quantity} || 1;
5035
5036	$price ||= item_price($item);
5037	my $new_price = discount_price($item, $price);
5038
5039	return $new_price * $quantity;
5040}
5041
5042sub discount_price {
5043	my ($item, $price, $quantity) = @_;
5044	my $extra;
5045	my $code;
5046
5047	unless (ref $item) {
5048		$code = $item;
5049		$item = { code => $code, quantity => ($quantity || 1) };
5050	}
5051
5052
5053	($code, $extra) = ($item->{code}, $item->{mv_discount});
5054
5055	if ($extra and ! $::Discounts) {
5056		my $dspace = $Vend::DiscountSpaceName ||= 'main';
5057		$Vend::Session->{discount_space}{main}
5058			= $Vend::Session->{discount}
5059			||= {} unless $Vend::Session->{discount_space}{main};
5060		$::Discounts
5061			= $Vend::Session->{discount}
5062			= $Vend::Session->{discount_space}{$dspace}
5063			||= {} if $Vend::Cfg->{DiscountSpacesOn};
5064	}
5065
5066	return $price unless $extra or $::Discounts && %$::Discounts;
5067
5068	$quantity = $item->{quantity};
5069
5070	$Vend::Interpolate::item = $item;
5071	$Vend::Interpolate::q = $quantity || 1;
5072	$Vend::Interpolate::s = $price;
5073
5074	my $subtotal = $price * $quantity;
5075
5076#::logDebug("quantity=$q code=$item->{code} price=$s");
5077
5078	my ($discount, $return);
5079
5080	for($code, 'ALL_ITEMS') {
5081		next unless $discount = $::Discounts->{$_};
5082		$Vend::Interpolate::s = $return ||= $subtotal;
5083        $return = $ready_safe->reval($discount);
5084		if($@) {
5085			::logError("Bad discount code for %s: %s", $discount);
5086			$return = $subtotal;
5087			next;
5088		}
5089        $price = $return / $q;
5090    }
5091
5092	if($extra) {
5093		EXTRA: {
5094			$return = $ready_safe->reval($extra);
5095			last EXTRA if $@;
5096			$price = $return;
5097		}
5098	}
5099	return $price;
5100}
5101
5102sub apply_discount {
5103	my($item) = @_;
5104
5105	my($formula, $cost);
5106	my(@formulae);
5107
5108	# Check for individual item discount
5109	push(@formulae, $::Discounts->{$item->{code}})
5110		if defined $::Discounts->{$item->{code}};
5111	# Check for all item discount
5112	push(@formulae, $::Discounts->{ALL_ITEMS})
5113		if defined $::Discounts->{ALL_ITEMS};
5114	push(@formulae, $item->{mv_discount})
5115		if defined $item->{mv_discount};
5116
5117	my $subtotal = item_subtotal($item);
5118
5119	init_calc() unless $Vend::Calc_initialized;
5120	# Calculate any formalas found
5121	foreach $formula (@formulae) {
5122		next unless $formula;
5123		$Vend::Interpolate::q = $item->{quantity};
5124		$Vend::Interpolate::s = $subtotal;
5125		$Vend::Interpolate::item = $item;
5126#		$formula =~ s/\$q\b/$item->{quantity}/g;
5127#		$formula =~ s/\$s\b/$subtotal/g;
5128		$cost = $ready_safe->reval($formula);
5129		if($@) {
5130			logError
5131				"Discount for $item->{code} has bad formula. Not applied.\n$@";
5132			next;
5133		}
5134		$subtotal = $cost;
5135	}
5136	$subtotal;
5137}
5138
5139# Stubs for relocated shipping stuff in case of legacy code
5140*read_shipping = \&Vend::Ship::read_shipping;
5141*custom_shipping = \&Vend::Ship::shipping;
5142*tag_shipping_desc = \&Vend::Ship::tag_shipping_desc;
5143*shipping = \&Vend::Ship::shipping;
5144*tag_handling = \&Vend::Ship::tag_handling;
5145*tag_shipping = \&Vend::Ship::tag_shipping;
5146*tag_ups = \&Vend::Ship::tag_ups;
5147
5148# Sets the value of a scratchpad field
5149sub set_scratch {
5150	my($var,$val) = @_;
5151    $::Scratch->{$var} = $val;
5152	return '';
5153}
5154
5155# Sets the value of a temporary scratchpad field
5156sub set_tmp {
5157	my($var,$val) = @_;
5158	push @Vend::TmpScratch, $var;
5159    $::Scratch->{$var} = $val;
5160	return '';
5161}
5162
5163sub timed_build {
5164    my $file = shift;
5165    my $opt = shift;
5166	my $abort;
5167
5168	if ($Vend::LockedOut) {
5169		$abort = 1;
5170		delete $opt->{new};
5171	}
5172	elsif (defined $opt->{if}) {
5173		$abort = 1 if ! $opt->{if};
5174	}
5175
5176	my $saved_file;
5177	if($opt->{scan}) {
5178		$saved_file = $Vend::ScanPassed;
5179		$abort = 1 if ! $saved_file || $file =~ m:MM=:;
5180	}
5181
5182	$opt->{login} = 1 if $opt->{auto};
5183
5184	my $save_scratch;
5185	if($opt->{new} and $Vend::new_session and !$Vend::Session->{logged_in}) {
5186#::logDebug("we are new");
5187		$save_scratch = $::Scratch;
5188		$Vend::Cookie = 1;
5189		$Vend::Session->{scratch} = { %{$Vend::Cfg->{ScratchDefault}}, mv_no_session_id => 1, mv_no_count => 1, mv_force_cache => 1 };
5190
5191	}
5192	else {
5193		return Vend::Interpolate::interpolate_html($_[0])
5194			if $abort
5195			or ( ! $opt->{force}
5196					and
5197					(   ! $Vend::Cookie
5198						or ! $opt->{login} && $Vend::Session->{logged_in}
5199					)
5200				);
5201	}
5202
5203	local ($Scratch->{mv_no_session_id});
5204	$Scratch->{mv_no_session_id} = 1;
5205
5206	if($opt->{auto}) {
5207		$opt->{minutes} = 60 unless defined $opt->{minutes};
5208		my $dir = "$Vend::Cfg->{ScratchDir}/auto-timed";
5209		unless (allowed_file($dir)) {
5210			log_file_violation($dir, 'timed_build');
5211			return;
5212		}
5213		if(! -d $dir) {
5214			require File::Path;
5215			File::Path::mkpath($dir);
5216		}
5217		$file = "$dir/" . generate_key(@_);
5218	}
5219
5220	my $secs;
5221	CHECKDIR: {
5222		last CHECKDIR if Vend::File::file_name_is_absolute($file);
5223		last CHECKDIR if $file and $file !~ m:/:;
5224		my $dir;
5225		if ($file) {
5226			$dir = '.';
5227		}
5228		else {
5229			$dir = 'timed';
5230			$file = $saved_file || $Vend::Flypart || $Global::Variable->{MV_PAGE};
5231#::logDebug("static=$file");
5232			if($saved_file) {
5233				$file = $saved_file;
5234				$file =~ s:^scan/::;
5235				$file = generate_key($file);
5236				$file = "scan/$file";
5237			}
5238			else {
5239				$saved_file = $file = ($Vend::Flypart || $Global::Variable->{MV_PAGE});
5240			}
5241			$file .= $Vend::Cfg->{HTMLsuffix};
5242		}
5243		$dir .= "/$1"
5244			if $file =~ s:(.*)/::;
5245		unless (allowed_file($dir)) {
5246			log_file_violation($dir, 'timed_build');
5247			return;
5248		}
5249		if(! -d $dir) {
5250			require File::Path;
5251			File::Path::mkpath($dir);
5252		}
5253		$file = Vend::Util::catfile($dir, $file);
5254	}
5255
5256#::logDebug("saved=$saved_file");
5257#::logDebug("file=$file exists=" . -f $file);
5258	if($opt->{minutes}) {
5259        $secs = int($opt->{minutes} * 60);
5260    }
5261	elsif ($opt->{period}) {
5262		$secs = Vend::Config::time_to_seconds($opt->{period});
5263	}
5264
5265    $file = Vend::Util::escape_chars($file);
5266    if(! $opt->{auto} and ! allowed_file($file)) {
5267		log_file_violation($file, 'timed_build');
5268		return undef;
5269    }
5270
5271    if( ! -f $file or $secs && (stat(_))[9] < (time() - $secs) ) {
5272        my $out = Vend::Interpolate::interpolate_html(shift);
5273		$opt->{umask} = '22' unless defined $opt->{umask};
5274        Vend::Util::writefile(">$file", $out, $opt );
5275		$Vend::Session->{scratch} = $save_scratch if $save_scratch;
5276        return $out;
5277    }
5278	$Vend::Session->{scratch} = $save_scratch if $save_scratch;
5279	return Vend::Util::readfile($file);
5280}
5281
5282sub update {
5283	my ($func, $opt) = @_;
5284	if($func eq 'quantity') {
5285		Vend::Order::update_quantity();
5286	}
5287	elsif($func eq 'cart') {
5288		my $cart;
5289		if($opt->{name}) {
5290			$cart = $::Carts->{$opt->{name}};
5291		}
5292		else {
5293			$cart = $Vend::Items;
5294		}
5295		return if ! ref $cart;
5296		Vend::Cart::toss_cart($cart, $opt->{name});
5297	}
5298	elsif ($func eq 'process') {
5299		Vend::Dispatch::do_process();
5300	}
5301	elsif ($func eq 'values') {
5302		Vend::Dispatch::update_user();
5303	}
5304	elsif ($func eq 'data') {
5305		Vend::Data::update_data();
5306	}
5307	return;
5308}
5309
5310my $Ship_its = 0;
5311
5312sub push_warning {
5313	$Vend::Session->{warnings} = [$Vend::Session->{warnings}]
5314		if ! ref $Vend::Session->{warnings};
5315	push @{$Vend::Session->{warnings}}, errmsg(@_);
5316	return;
5317}
5318
5319
5320sub taxable_amount {
5321	my($cart, $dspace) = @_;
5322    my($taxable, $i, $code, $item, $tmp, $quantity);
5323
5324	return subtotal($cart || undef, $dspace || undef) unless $Vend::Cfg->{NonTaxableField};
5325
5326	my($save, $oldspace);
5327
5328    if ($cart) {
5329        $save = $Vend::Items;
5330        tag_cart($cart);
5331    }
5332
5333	# Support for discount namespaces.
5334	$oldspace = switch_discount_space($dspace) if $dspace;
5335
5336    $taxable = 0;
5337
5338    foreach $i (0 .. $#$Vend::Items) {
5339		$item =	$Vend::Items->[$i];
5340		next if is_yes( $item->{mv_nontaxable} );
5341		next if is_yes( item_field($item, $Vend::Cfg->{NonTaxableField}) );
5342		$tmp = item_subtotal($item);
5343		unless (%$::Discounts) {
5344			$taxable += $tmp;
5345		}
5346		else {
5347			$taxable += apply_discount($item);
5348		}
5349    }
5350
5351	if (defined $::Discounts->{ENTIRE_ORDER}) {
5352		$Vend::Interpolate::q = tag_nitems();
5353		$Vend::Interpolate::s = $taxable;
5354		my $cost = $Vend::Interpolate::ready_safe->reval(
5355							 $::Discounts->{ENTIRE_ORDER},
5356						);
5357		if($@) {
5358			logError
5359				"Discount ENTIRE_ORDER has bad formula. Returning normal subtotal.";
5360			$cost = $taxable;
5361		}
5362		$taxable = $cost;
5363	}
5364
5365	$Vend::Items = $save if defined $save;
5366
5367	# Restore initial discount namespace if appropriate.
5368	switch_discount_space($oldspace) if defined $oldspace;
5369
5370	return $taxable;
5371}
5372
5373
5374
5375sub fly_tax {
5376	my ($area, $opt) = @_;
5377
5378	if(my $country_check = $::Variable->{TAXCOUNTRY}) {
5379		$country_check =~ /\b$::Values->{country}\b/
5380			or return 0;
5381	}
5382
5383	if(! $area) {
5384		my $zone = $Vend::Cfg->{SalesTax};
5385		while($zone =~ m/(\w+)/g) {
5386			last if $area = $::Values->{$1};
5387		}
5388	}
5389#::logDebug("flytax area=$area");
5390	return 0 unless $area;
5391	my $rates = $::Variable->{TAXRATE};
5392	my $taxable_shipping = $::Variable->{TAXSHIPPING} || '';
5393	my $taxable_handling = $::Variable->{TAXHANDLING} || '';
5394	$rates =~ s/^\s+//;
5395	$rates =~ s/\s+$//;
5396	$area =~ s/^\s+//;
5397	$area =~ s/\s+$//;
5398	my (@rates) = split /\s*,\s*/, $rates;
5399	my $rate;
5400	for(@rates) {
5401		my ($k,$v) = split /\s*=\s*/, $_, 2;
5402		next unless "\U$k" eq "\U$area";
5403		$rate = $v;
5404		$rate = $rate / 100 if $rate > 1;
5405		last;
5406	}
5407#::logDebug("flytax rate=$rate");
5408	return 0 unless $rate;
5409
5410	my ($oldcart, $oldspace);
5411	if ($opt->{cart}) {
5412		$oldcart = $Vend::Items;
5413		tag_cart($opt->{cart});
5414	}
5415	if ($opt->{discount_space}) {
5416		$oldspace = switch_discount_space($opt->{discount_space});
5417	}
5418
5419	my $amount = taxable_amount();
5420#::logDebug("flytax before shipping amount=$amount");
5421	$amount   += tag_shipping()
5422		if $taxable_shipping =~ m{(^|[\s,])$area([\s,]|$)}i;
5423	$amount   += tag_handling()
5424		if $taxable_handling =~ m{(^|[\s,])$area([\s,]|$)}i;
5425
5426	$Vend::Items = $oldcart if defined $oldcart;
5427	switch_discount_space($oldspace) if defined $oldspace;
5428
5429#::logDebug("flytax amount=$amount return=" . $amount*$rate);
5430	return $amount * $rate;
5431}
5432
5433sub percent_rate {
5434	my $rate = shift;
5435	$rate =~ s/\s*%\s*$// and $rate /= 100;
5436	return $rate;
5437}
5438
5439sub tax_vat {
5440	my($type, $opt) = @_;
5441#::logDebug("entering VAT, opts=" . uneval($opt));
5442	my $cfield = $::Variable->{MV_COUNTRY_TAX_VAR} || 'country';
5443	my $country = $opt->{country} || $::Values->{$cfield};
5444
5445	return 0 if ! $country;
5446	my $ctable   = $opt->{country_table}
5447				|| $::Variable->{MV_COUNTRY_TABLE}
5448				|| 'country';
5449	my $c_taxfield   = $opt->{country_tax_field}
5450				|| $::Variable->{MV_COUNTRY_TAX_FIELD}
5451				|| 'tax';
5452#::logDebug("ctable=$ctable c_taxfield=$c_taxfield country=$country");
5453	$type ||= tag_data($ctable, $c_taxfield, $country)
5454		or return 0;
5455#::logDebug("tax type=$type");
5456	$type =~ s/^\s+//;
5457	$type =~ s/\s+$//;
5458
5459	my @taxes;
5460
5461	if($type =~ /^(\w+)$/) {
5462		my $sfield = $1;
5463		my $state  = $opt->{state} || $::Values->{$sfield};
5464		return 0 if ! $state;
5465		my $stable   = $opt->{state_table}
5466					|| $::Variable->{MV_STATE_TABLE}
5467					|| 'state';
5468		my $s_taxfield   = $opt->{state_tax_field}
5469					|| $::Variable->{MV_STATE_TAX_FIELD}
5470					|| 'tax';
5471		my $s_taxtype   = $opt->{tax_type_field}
5472					|| $::Variable->{MV_TAX_TYPE_FIELD}
5473					|| 'tax_name';
5474		my $db = database_exists_ref($stable)
5475			or return 0;
5476		my $addl = '';
5477		if($opt->{tax_type}) {
5478			$addl = " AND $s_taxtype = " .
5479					$db->quote($opt->{tax_type}, $s_taxtype);
5480		}
5481		my $q = qq{
5482						SELECT $s_taxfield FROM $stable
5483						WHERE  $cfield = '$country'
5484						AND    $sfield = '$state'
5485						$addl
5486					};
5487#::logDebug("tax state query=$q");
5488		my $ary;
5489		eval {
5490			$ary = $db->query($q);
5491		};
5492		if($@) {
5493			logError("error on state tax query %s", $q);
5494		}
5495#::logDebug("query returns " . uneval($ary));
5496		return 0 unless ref $ary;
5497		for(@$ary) {
5498			next unless $_->[0];
5499			push @taxes, $_->[0];
5500		}
5501	}
5502	else {
5503		@taxes = $type;
5504	}
5505
5506	my $total = 0;
5507	foreach my $t (@taxes) {
5508		$t =~ s/^\s+//;
5509		$t =~ s/\s+$//;
5510		if ($t =~ /simple:(.*)/) {
5511			$total += fly_tax($::Values->{$1});
5512			next;
5513		}
5514		elsif ($t =~ /handling:(.*)/) {
5515			my @modes = grep /\S/, split /[\s,]+/, $1;
5516
5517			my $cost = 0;
5518			$cost += tag_handling($_) for @modes;
5519			$total += $cost;
5520			next;
5521		}
5522		my $tax;
5523#::logDebug("tax type=$t");
5524		if($t =~ /^(\d+(?:\.\d+)?)\s*(\%)$/) {
5525			my $rate = $1;
5526			$rate /= 100 if $2;
5527            $rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive};
5528			my $amount = Vend::Interpolate::taxable_amount();
5529			$total += ($rate * $amount);
5530		}
5531		else {
5532			$tax = Vend::Util::get_option_hash($t);
5533		}
5534#::logDebug("tax hash=" . uneval($tax));
5535		my $pfield   = $opt->{tax_category_field}
5536					|| $::Variable->{MV_TAX_CATEGORY_FIELD}
5537					|| 'tax_category';
5538		my @pfield = split /:+/, $pfield;
5539
5540		for my $item (@$Vend::Items) {
5541			my $rhash = tag_data($item->{mv_ib}, undef, $item->{code}, { hash => 1});
5542			my $cat = join ":", @{$rhash}{@pfield};
5543			my $rate = defined $tax->{$cat} ? $tax->{$cat} : $tax->{default};
5544#::logDebug("item $item->{code} cat=$cat rate=$rate");
5545			$rate = percent_rate($rate);
5546			next if $rate <= 0;
5547			$rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive};
5548			my $sub = discount_subtotal($item);
5549#::logDebug("item $item->{code} subtotal=$sub");
5550			$total += $sub * $rate;
5551#::logDebug("tax total=$total");
5552		}
5553
5554		my $tax_shipping_rate = 0;
5555
5556		## Add some tax on shipping ONLY IF TAXABLE ITEMS
5557		## if rate for mv_shipping_when_taxable category is set
5558		if ($tax->{mv_shipping_when_taxable} and $total > 0) {
5559			$tax_shipping_rate += percent_rate($tax->{mv_shipping_when_taxable});
5560		}
5561
5562		## Add some tax on shipping if rate for mv_shipping category is set
5563		if ($tax->{mv_shipping} > 0) {
5564			$tax_shipping_rate += percent_rate($tax->{mv_shipping});
5565		}
5566
5567		if($tax_shipping_rate > 0) {
5568			my $rate = $tax_shipping_rate;
5569			$rate =~ s/\s*%\s*$// and $rate /= 100;
5570			my $sub = tag_shipping() * $rate;
5571#::logDebug("applying shipping tax rate of $rate, tax of $sub");
5572			$total += $sub;
5573		}
5574
5575		## Add some tax on handling if rate for mv_handling category is set
5576		if ($tax->{mv_handling} > 0) {
5577			my $rate = $tax->{mv_handling};
5578			$rate =~ s/\s*%\s*$// and $rate /= 100;
5579			$rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive};
5580			my $sub = tag_handling() * $rate;
5581#::logDebug("applying handling tax rate of $rate, tax of $sub");
5582			$total += $sub;
5583		}
5584
5585	}
5586
5587	return $total;
5588}
5589
5590# Calculate the sales tax
5591sub salestax {
5592	my($cart, $opt) = @_;
5593
5594	$opt ||= {};
5595
5596	my($save, $oldspace);
5597	### If the user has assigned to salestax,
5598	### we use their value come what may, no rounding
5599	if($Vend::Session->{assigned}) {
5600		return $Vend::Session->{assigned}{salestax}
5601			if defined $Vend::Session->{assigned}{salestax}
5602			&& length( $Vend::Session->{assigned}{salestax});
5603	}
5604
5605    if ($cart) {
5606        $save = $Vend::Items;
5607        tag_cart($cart);
5608    }
5609
5610	$oldspace = switch_discount_space( $opt->{discount_space} ) if $opt->{discount_space};
5611
5612#::logDebug("salestax entered, cart=$cart");
5613	my $tax_hash;
5614	my $cost;
5615	if($Vend::Cfg->{SalesTax} eq 'multi') {
5616		$cost = tax_vat($opt->{type}, $opt);
5617	}
5618	elsif($Vend::Cfg->{SalesTax} =~ /\[/) {
5619		$cost = interpolate_html($Vend::Cfg->{SalesTax});
5620	}
5621	elsif($Vend::Cfg->{SalesTaxFunction}) {
5622		$tax_hash = tag_calc($Vend::Cfg->{SalesTaxFunction});
5623#::logDebug("found custom tax function: " . uneval($tax_hash));
5624	}
5625	else {
5626		$tax_hash = $Vend::Cfg->{SalesTaxTable};
5627#::logDebug("looking for tax function: " . uneval($tax_hash));
5628	}
5629
5630# if we have a cost from previous routines, return it
5631	if(defined $cost) {
5632		$Vend::Items = $save if $save;
5633		switch_discount_space($oldspace) if defined $oldspace;
5634		if($cost < 0 and $::Pragma->{no_negative_tax}) {
5635			$cost = 0;
5636		}
5637		return Vend::Util::round_to_frac_digits($cost);
5638	}
5639
5640#::logDebug("got to tax function: " . uneval($tax_hash));
5641	my $amount = taxable_amount();
5642	# Restore the original discount namespace if appropriate; no other routines need the discount info.
5643	switch_discount_space($oldspace) if defined $oldspace;
5644
5645	my($r, $code);
5646	# Make it upper case for state and overseas postal
5647	# codes, zips don't matter
5648	my(@code) = map { (uc $::Values->{$_}) || '' }
5649					split /[,\s]+/, $Vend::Cfg->{SalesTax};
5650	push(@code, 'DEFAULT');
5651
5652	$tax_hash = { DEFAULT => } if ! ref($tax_hash) =~ /HASH/;
5653
5654	if(! defined $tax_hash->{DEFAULT}) {
5655#::logDebug("Sales tax failed, no tax source, returning 0");
5656		return 0;
5657	}
5658
5659	CHECKSHIPPING: {
5660		last CHECKSHIPPING unless $Vend::Cfg->{TaxShipping};
5661		foreach $code (@code) {
5662			next unless $Vend::Cfg->{TaxShipping} =~ /\b\Q$code\E\b/i;
5663			$amount += tag_shipping();
5664			last;
5665		}
5666	}
5667
5668	foreach $code (@code) {
5669		next unless $code;
5670		# Trim the zip+4
5671#::logDebug("salestax: check code '$code'");
5672		$code =~ s/(\d{5})-\d{4}/$1/;
5673		next unless defined $tax_hash->{$code};
5674		my $tax = $tax_hash->{$code};
5675#::logDebug("salestax: found tax='$tax' for code='$code'");
5676		if($tax =~ /^-?(?:\d+(?:\.\d*)?|\.\d+)$/) {
5677			$r = $amount * $tax;
5678		}
5679		else {
5680			$r = Vend::Data::chain_cost(
5681					{	mv_price	=> $amount,
5682						code		=> $code,
5683						quantity	=> $amount, }, $tax);
5684		}
5685#::logDebug("salestax: final tax='$r' for code='$code'");
5686		last;
5687	}
5688
5689	$Vend::Items = $save if defined $save;
5690
5691	if($r < 0 and ! $::Pragma->{no_negative_tax}) {
5692		$r = 0;
5693	}
5694
5695	return Vend::Util::round_to_frac_digits($r);
5696}
5697
5698# Returns just subtotal of items ordered, with discounts
5699# applied
5700sub subtotal {
5701	my($cart, $dspace) = @_;
5702
5703	### If the user has assigned to salestax,
5704	### we use their value come what may, no rounding
5705	if($Vend::Session->{assigned}) {
5706		return $Vend::Session->{assigned}{subtotal}
5707			if defined $Vend::Session->{assigned}{subtotal}
5708			&& length( $Vend::Session->{assigned}{subtotal});
5709	}
5710
5711    my ($save, $subtotal, $i, $item, $tmp, $cost, $formula, $oldspace);
5712	if ($cart) {
5713		$save = $Vend::Items;
5714		tag_cart($cart);
5715	}
5716
5717	levies() unless $Vend::Levying;
5718
5719	# Use switch_discount_space unconditionally to guarantee existance of proper discount structures.
5720	$oldspace = switch_discount_space($dspace || $Vend::DiscountSpaceName);
5721
5722	my $discount = (ref($::Discounts) eq 'HASH' and %$::Discounts);
5723
5724    $subtotal = 0;
5725	$tmp = 0;
5726
5727    foreach $i (0 .. $#$Vend::Items) {
5728        $item = $Vend::Items->[$i];
5729        $tmp = Vend::Data::item_subtotal($item);
5730        if($discount || $item->{mv_discount}) {
5731            $subtotal +=
5732                apply_discount($item, $tmp);
5733        }
5734        else { $subtotal += $tmp }
5735	}
5736
5737	if (defined $::Discounts->{ENTIRE_ORDER}) {
5738		$formula = $::Discounts->{ENTIRE_ORDER};
5739		$formula =~ s/\$q\b/tag_nitems()/eg;
5740		$formula =~ s/\$s\b/$subtotal/g;
5741		$cost = $Vend::Interpolate::ready_safe->reval($formula);
5742		if($@) {
5743			logError
5744				"Discount ENTIRE_ORDER has bad formula. Returning normal subtotal.\n$@";
5745			$cost = $subtotal;
5746		}
5747		$subtotal = $cost;
5748	}
5749	$Vend::Items = $save if defined $save;
5750	$Vend::Session->{latest_subtotal} = $subtotal;
5751
5752	# Switch to original discount space if an actual switch occured.
5753	switch_discount_space($oldspace) if $dspace and defined $oldspace;
5754
5755    return $subtotal;
5756}
5757
5758
5759
5760# Returns the total cost of items ordered.
5761
5762sub total_cost {
5763	my ($cart, $dspace) = @_;
5764    my ($total, $i, $save, $oldspace);
5765
5766	$oldspace = switch_discount_space($dspace) if $dspace;
5767
5768	if ($cart) {
5769		$save = $Vend::Items;
5770		tag_cart($cart);
5771	}
5772
5773	$total = 0;
5774
5775	if($Vend::Cfg->{Levies}) {
5776		$total = subtotal();
5777		$total += levies();
5778	}
5779	else {
5780		my $shipping = 0;
5781		$shipping += tag_shipping()
5782			if $::Values->{mv_shipmode};
5783		$shipping += tag_handling()
5784			if $::Values->{mv_handling};
5785		$total += subtotal();
5786		$total += $shipping;
5787		$total += salestax()
5788			unless $Vend::Cfg->{TaxInclusive};
5789	}
5790	$Vend::Items = $save if defined $save;
5791	$Vend::Session->{latest_total} = $total;
5792	switch_discount_space($oldspace) if defined $oldspace;
5793    return $total;
5794}
5795
5796
5797sub levy_sum {
5798	my ($set, $levies, $repos) = @_;
5799
5800	$set    ||= $Vend::CurrentCart || 'main';
5801	$levies ||= $Vend::Cfg->{Levies};
5802	$repos  ||= $Vend::Cfg->{Levy_repository};
5803
5804	my $icart = $Vend::Session->{carts}{$set} || [];
5805
5806	my @sums;
5807	for(@$icart) {
5808		push @sums, @{$_}{sort keys %$_};
5809	}
5810	my $items;
5811	for(@$levies) {
5812		next unless $items = $repos->{$_}{check_status};
5813		push @sums, @{$::Values}{ split /[\s,\0]/, $items };
5814	}
5815	return generate_key(@sums);
5816}
5817
5818sub levies {
5819	my($recalc, $set, $opt) = @_;
5820
5821	my $levies;
5822	return unless $levies = $Vend::Cfg->{Levies};
5823
5824
5825	$opt ||= {};
5826	my $repos = $Vend::Cfg->{Levy_repository};
5827#::logDebug("Calling levies, recalc=$recalc group=$opt->{group}");
5828
5829	if(! $repos) {
5830		logOnce('error', "Levies set but no levies defined! No tax or shipping.");
5831		return;
5832	}
5833	$Vend::Levying = 1;
5834	$set ||= $Vend::CurrentCart;
5835	$set ||= 'main';
5836
5837	$Vend::Session->{levies} ||= {};
5838
5839	my $lcheck = $Vend::Session->{latest_levy} ||= {};
5840	$lcheck = $lcheck->{$set} ||= {};
5841
5842	if($Vend::LeviedOnce and ! $recalc and ! $opt->{group} and $lcheck->{sum}) {
5843		my $newsum = levy_sum($set, $levies, $repos);
5844#::logDebug("did levy check, new=$newsum old=$lcheck->{sum}");
5845		if($newsum  eq $lcheck->{sum}) {
5846			undef $Vend::Levying;
5847#::logDebug("levy returning cached value");
5848			return $lcheck->{total};
5849		}
5850	}
5851
5852	my $lcart = $Vend::Session->{levies}{$set} = [];
5853
5854	my $run = 0;
5855	for my $name (@$levies) {
5856		my $l = $repos->{$name};
5857#::logDebug("Levying $name, repos => " . uneval($l));
5858		if(! $l) {
5859			logOnce('error', "Levy '%s' called but not defined. Skipping.", $name);
5860			next;
5861		}
5862		if(my $if = $l->{include_if}) {
5863			if($if =~ /^\w+$/) {
5864				next unless $::Values->{$if};
5865			}
5866			elsif($if =~ /__[A-Z]\w+__|[[a-zA-Z]/) {
5867				my $val = interpolate_html($if);
5868				$val =~ s/^\s+//;
5869				$val =~ s/^s+$//;
5870				next unless $val;
5871			}
5872			else {
5873				next unless tag_calc($if);
5874			}
5875		}
5876		if(my $if = $l->{exclude_if}) {
5877			if($if =~ /^\w+$/) {
5878				next if $::Values->{$if};
5879			}
5880			elsif($if =~ /__[A-Z]\w+__|[[a-zA-Z]/) {
5881				my $val = interpolate_html($if);
5882				$val =~ s/^\s+//;
5883				$val =~ s/^s+$//;
5884				next if $val;
5885			}
5886			else {
5887				next if tag_calc($if);
5888			}
5889		}
5890		my $type = $l->{type} || ($name eq 'salestax' ? 'salestax' : 'shipping');
5891		my $mode;
5892
5893		if($l->{mode_from_values}) {
5894			$mode = $::Values->{$l->{mode_from_values}};
5895		}
5896		elsif($l->{mode_from_scratch}) {
5897			$mode = $::Scratch->{$l->{mode_from_scratch}};
5898		}
5899
5900		$mode ||= ($l->{mode} || $name);
5901		my $group = $l->{group} || $type;
5902		my $cost = 0;
5903		my $sort;
5904		my $desc;
5905		my $lab_field = $l->{label_value};
5906		if($type eq 'salestax') {
5907			my $save;
5908			$sort = $l->{sort} || '010';
5909			$lab_field ||= $Vend::Cfg->{SalesTax};
5910			if($l->{tax_fields}) {
5911				$save = $Vend::Cfg->{SalesTax};
5912				$Vend::Cfg->{SalesTax} = $l->{tax_fields};
5913			}
5914			elsif ($l->{multi}) {
5915				$save = $Vend::Cfg->{SalesTax};
5916				$Vend::Cfg->{SalesTax} = 'multi';
5917			}
5918			$cost = salestax(undef, { tax_type => $l->{tax_type} } );
5919			$l->{description} ||= 'Sales Tax';
5920			$Vend::Cfg->{SalesTax} = $save if defined $save;
5921		}
5922		elsif ($type eq 'shipping' or $type eq 'handling') {
5923			if(not $sort = $l->{sort}) {
5924				$sort = $type eq 'handling' ? 100 : 500;
5925			}
5926
5927			my @modes = split /\0/, $mode;
5928			for my $m (@modes) {
5929				$cost += shipping($m);
5930				if($l->{description}) {
5931					if($l->{multi_description}) {
5932						$l->{description} = $l->{multi_description};
5933					}
5934					else {
5935						$l->{description} .= ', ' if $l->{description};
5936						$l->{description} .= tag_shipping_desc($m);
5937					}
5938				}
5939				else {
5940					$l->{description} = tag_shipping_desc($m);
5941				}
5942			}
5943		}
5944		elsif($type eq 'custom') {
5945			my $sub;
5946			SUBFIND: {
5947				$sub = $Vend::Cfg->{Sub}{$mode} || $Global::GlobalSub->{$mode}
5948					and last SUBFIND;
5949				eval {
5950					$sub = $Vend::Cfg->{UserTag}{Routine}{$mode};
5951				};
5952				last SUBFIND if ! $@ and $sub;
5953				eval {
5954					$sub = $Global::UserTag->{Routine}{$mode};
5955				};
5956			}
5957			if( ref($sub) eq 'CODE') {
5958				($cost, $desc, $sort) = $sub->($l);
5959			}
5960			else {
5961				logError("No subroutine found for custom levy '%s'", $name);
5962			}
5963		}
5964
5965		$desc = errmsg(
5966					$l->{description},
5967					$::Values->{$lab_field},
5968				);
5969
5970		my $cost_format;
5971
5972		my $item = {
5973							code			=> $name,
5974							mode			=> $mode,
5975							type			=> $type,
5976							sort			=> $sort || $l->{sort},
5977							cost			=> round_to_frac_digits($cost),
5978							currency		=> currency($cost),
5979							group			=> $group,
5980							inclusive		=> $l->{inclusive},
5981							label			=> $l->{label} || $desc,
5982							part_number		=> $l->{part_number},
5983							description		=> $desc,
5984						};
5985		if($cost == 0) {
5986			next unless $l->{keep_if_zero};
5987			$item->{free} = 1;
5988			$item->{free_message} = $l->{free_message} || $cost;
5989		}
5990
5991		if(my $target = $l->{add_to}) {
5992			my $found;
5993			foreach my $lev (@$lcart) {
5994				next unless $lev->{code} eq $target;
5995				$lev->{cost} += $item->{cost};
5996				$lev->{cost} = round_to_frac_digits($lev->{cost});
5997				$lev->{currency} = currency($lev->{cost});
5998				$found = 1;
5999				last;
6000			}
6001			unless($found) {
6002				push @$lcart, $item;
6003			}
6004        }
6005        else {
6006                push @$lcart, $item;
6007        }
6008	}
6009
6010	@$lcart = sort { $a->{sort} cmp $b->{sort} } @$lcart;
6011
6012	for(@$lcart) {
6013		next if $opt->{group} and $opt->{group} ne $_->{group};
6014		next if $_->{inclusive};
6015		next if $_->{type} eq 'salestax' and $Vend::Cfg->{TaxInclusive};
6016		$run += $_->{cost};
6017	}
6018
6019	$run = round_to_frac_digits($run);
6020	if(! $opt->{group}) {
6021		$lcheck = $Vend::Session->{latest_levy}{$set} = {};
6022		$lcheck->{sum}   = levy_sum($set, $levies, $repos);
6023		$lcheck->{total} = $run;
6024		$Vend::LeviedOnce = 1;
6025	}
6026
6027	undef $Vend::Levying;
6028	return $run;
6029}
6030
60311;
6032