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)) {