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