lib/Vend/Interpolate.pm

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