Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

5956 lines (5267 sloc) 149.341 kb
# Vend::Interpolate - Interpret Interchange tags
#
# $Id: Interpolate.pm,v 2.261.2.9 2008-07-28 21:27:22 mheins Exp $
#
# Copyright (C) 2002-2005 Interchange Development Group
# Copyright (C) 1996-2002 Red Hat, Inc.
#
# This program was originally based on Vend 0.2 and 0.3
# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301 USA.
package Vend::Interpolate;
require Exporter;
@ISA = qw(Exporter);
$VERSION = substr(q$Revision: 2.261.2.9 $, 10);
@EXPORT = qw (
interpolate_html
subtotal
tag_data
tag_attr_list
$Tag
$CGI
$Session
$Values
$Discounts
$Sub
);
=head1 NAME
Vend::Interpolate -- Interchange tag interpolation routines
=head1 SYNOPSIS
(no external use)
=head1 DESCRIPTION
The Vend::Interpolate contains the majority of the Interchange Tag
Language implementation rouines. Historically, it contained the entire
tag language implementation for MiniVend, accounting for its name.
It contains most of the handler routines pointed to by Vend::Parse, which
accepts the parsing output of Vend::Parser. (Vend::Parser was originally based
on HTML::Parser 1.x).
There are two interpolative parsers in Vend::Interpolate,
iterate_array_list() and iterate_hash_list() -- these routines parse
the lists used in the widely employed [loop ..], [search-region ...],
[item-list], and [query ..] ITL tag constructs.
This module makes heavy use of precompiled regexes. You will notice variables
being used in the regular expression constructs. For example, C<$All> is a
a synonym for C<[\000-\377]*>, C<$Some> is equivalent to C<[\000-\377]*?>, etc.
This is not only for clarity of the regular expression, but for speed.
=cut
# SQL
push @EXPORT, 'tag_sql_list';
# END SQL
@EXPORT_OK = qw( sort_cart );
use Safe;
my $hole;
BEGIN {
eval {
require Safe::Hole;
$hole = new Safe::Hole;
};
}
# We generally know when we are testing these things, but be careful
no warnings qw(uninitialized numeric);
use strict;
use Vend::Util;
use Vend::File;
use Vend::Data;
use Vend::Form;
require Vend::Cart;
use HTML::Entities;
use Vend::Server;
use Vend::Scan;
use Vend::Tags;
use Vend::Subs;
use Vend::Document;
use Vend::Parse;
use POSIX qw(ceil strftime LC_CTYPE);
use vars qw(%Data_cache);
my $wantref = 1;
# MVASP
my @Share_vars;
my @Share_routines;
BEGIN {
@Share_vars = qw/
$s
$q
$item
$CGI_array
$CGI
$Discounts
$Document
%Db
$DbSearch
%Filter
$Search
$Carts
$Config
%Sql
$Items
$Row
$Scratch
$Shipping
$Session
$Tag
$Tmp
$TextSearch
$Values
$Variable
$Sub
/;
@Share_routines = qw/
&tag_data
&errmsg
&Log
&Debug
&uneval
&get_option_hash
&dotted_hash
&encode_entities
&HTML
&interpolate_html
/;
}
use vars @Share_vars, @Share_routines,
qw/$ready_safe $safe_safe/;
use vars qw/%Filter %Ship_handler $Safe_data/;
$ready_safe = new Safe;
$ready_safe->trap(qw/:base_io/);
$ready_safe->untrap(qw/sort ftfile/);
sub reset_calc {
#::logDebug("reset_state=$Vend::Calc_reset -- resetting calc from " . caller);
if(! $Global::Foreground and $Vend::Cfg->{ActionMap}{_mvsafe}) {
#::logDebug("already made");
$ready_safe = $Vend::Cfg->{ActionMap}{_mvsafe};
}
else {
my $pkg = 'MVSAFE' . int(rand(100000));
undef $MVSAFE::Safe;
$ready_safe = new Safe $pkg;
$ready_safe->share_from('MVSAFE', ['$safe']);
#::logDebug("new safe made=$ready_safe->{Root}");
$ready_safe->trap(@{$Global::SafeTrap});
$ready_safe->untrap(@{$Global::SafeUntrap});
no strict 'refs';
$Document = new Vend::Document;
*Log = \&Vend::Util::logError;
*Debug = \&Vend::Util::logDebug;
*uneval = \&Vend::Util::uneval_it;
*HTML = \&Vend::Document::HTML;
$ready_safe->share(@Share_vars, @Share_routines);
$DbSearch = new Vend::DbSearch;
$TextSearch = new Vend::TextSearch;
$Tag = new Vend::Tags;
$Sub = new Vend::Subs;
}
$Tmp = {};
undef $s;
undef $q;
undef $item;
%Db = ();
%Sql = ();
undef $Shipping;
$Vend::Calc_reset = 1;
undef $Vend::Calc_initialized;
return $ready_safe;
}
sub init_calc {
#::logDebug("reset_state=$Vend::Calc_reset init_state=$Vend::Calc_initialized -- initting calc from " . caller);
reset_calc() unless $Vend::Calc_reset;
$CGI_array = \%CGI::values_array;
$CGI = \%CGI::values;
$Carts = $::Carts;
$Discounts = $::Discounts;
$Items = $Vend::Items;
$Config = $Vend::Cfg;
$Scratch = $::Scratch;
$Values = $::Values;
$Session = $Vend::Session;
$Search = $::Instance->{SearchObject} ||= {};
$Variable = $::Variable;
$Vend::Calc_initialized = 1;
return;
}
# Define conditional ops
my %cond_op = (
eq => sub { $_[0] eq $_[1] },
ne => sub { $_[0] ne $_[1] },
gt => sub { $_[0] gt $_[1] },
ge => sub { $_[0] ge $_[1] },
le => sub { $_[0] le $_[1] },
lt => sub { $_[0] lt $_[1] },
'>' => sub { $_[0] > $_[1] },
'<' => sub { $_[0] < $_[1] },
'>=' => sub { $_[0] >= $_[1] },
'<=' => sub { $_[0] <= $_[1] },
'==' => sub { $_[0] == $_[1] },
'!=' => sub { $_[0] != $_[1] },
'=~' => sub {
my $re;
$_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:;
$2 and substr($_[1], 0, 0) = "(?$2)";
eval { $re = qr/$_[1]/ };
if($@) {
logError("bad regex %s in if-PREFIX-data", $_[1]);
return undef;
}
return $_[0] =~ $re;
},
'!~' => sub {
my $re;
$_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:;
$2 and substr($_[1], 0, 0) = "(?$2)";
eval { $re = qr/$_[1]/ };
if($@) {
logError("bad regex %s in if-PREFIX-data", $_[1]);
return undef;
}
return $_[0] !~ $re;
},
'filter' => sub {
my ($string, $filter) = @_;
my $newval = filter_value($filter, $string);
return $string eq $newval ? 1 : 0;
},
'length' => sub {
my ($string, $lenspec) = @_;
my ($min,$max) = split /-/, $lenspec;
if($min and length($string) < $min) {
return 0;
}
elsif($max and length($string) > $max) {
return 0;
}
else {
return 0 unless length($string) > 0;
}
return 1;
},
);
my %file_op = (
A => sub { -A $_[0] },
B => sub { -B $_[0] },
d => sub { -d $_[0] },
e => sub { -e $_[0] },
f => sub { -f $_[0] },
g => sub { -g $_[0] },
l => sub { -l $_[0] },
M => sub { -M $_[0] },
r => sub { -r $_[0] },
s => sub { -s $_[0] },
T => sub { -T $_[0] },
u => sub { -u $_[0] },
w => sub { -w $_[0] },
x => sub { -x $_[0] },
);
$cond_op{len} = $cond_op{length};
# Regular expression pre-compilation
my %T;
my %QR;
my $All = '[\000-\377]*';
my $Some = '[\000-\377]*?';
my $Codere = '[-\w#/.]+';
my $Coderex = '[-\w:#=/.%]+';
my $Mandx = '\s+([-\w:#=/.%]+)';
my $Mandf = '(?:%20|\s)+([-\w#/.]+)';
my $Spacef = '(?:%20|\s)+';
my $Spaceo = '(?:%20|\s)*';
my $Optx = '\s*([-\w:#=/.%]+)?';
my $Optr = '(?:\s+([^]]+))?';
my $Mand = '\s+([-\w#/.]+)';
my $Opt = '\s*([-\w#/.]+)?';
my $T = '\]';
my $D = '[-_]';
my $XAll = qr{[\000-\377]*};
my $XSome = qr{[\000-\377]*?};
my $XCodere = qr{[-\w#/.]+};
my $XCoderex = qr{[-\w:#=/.%]+};
my $XMandx = qr{\s+([-\w:#=/.%]+)};
my $XMandf = qr{(?:%20|\s)+([-\w#/.]+)};
my $XSpacef = qr{(?:%20|\s)+};
my $XSpaceo = qr{(?:%20|\s)*};
my $XOptx = qr{\s*([-\w:#=/.%]+)?};
my $XMand = qr{\s+([-\w#/.]+)};
my $XOpt = qr{\s*([-\w#/.]+)?};
my $XD = qr{[-_]};
my $Gvar = qr{\@\@([A-Za-z0-9]\w+[A-Za-z0-9])\@\@};
my $Evar = qr{\@_([A-Za-z0-9]\w+[A-Za-z0-9])_\@};
my $Cvar = qr{__([A-Za-z0-9]\w*?[A-Za-z0-9])__};
my @th = (qw!
/_alternate
/_calc
/_change
/_exec
/_filter
/_header_param
/_last
/_modifier
/_next
/_param
/_pos
/_sub
/col
/comment
/condition
/else
/elsif
/more_list
/no_match
/on_match
/sort
/then
_accessories
_alternate
_calc
_change
_code
_common
_data
_description
_discount
_exec
_field
_filter
_header_param
_increment
_last
_line
_match
_modifier
_next
_options
_param
_parent
_pos
_price
_quantity
_sku
_subtotal
_sub
col
comment
condition
discount_price
_discount_price
_discount_subtotal
_difference
else
elsif
matches
match_count
_modifier_name
more
more_list
no_match
on_match
_quantity_name
sort
then
! );
my $shown = 0;
my $tag;
for (@th) {
$tag = $_;
s/([A-Za-z0-9])/[\u$1\l$1]/g;
s/[-_]/[-_]/g;
$T{$tag} = $_;
next if $tag =~ m{^_};
$T{$tag} = "\\[$T{$tag}";
next unless $tag =~ m{^/};
$T{$tag} = "$T{$tag}\]";
}
%QR = (
'/_alternate' => qr($T{_alternate}\]),
'/_calc' => qr($T{_calc}\]),
'/_change' => qr([-_]change\s+)i,
'/_data' => qr($T{_data}\]),
'/_exec' => qr($T{_exec}\]),
'/_field' => qr($T{_field}\]),
'/_filter' => qr($T{_filter}\]),
'/_last' => qr($T{_last}\]),
'/_modifier' => qr($T{_modifier}\]),
'/_next' => qr($T{_next}\]),
'/_pos' => qr($T{_pos}\]),
'/_sub' => qr($T{_sub}\]),
'/order' => qr(\[/order\])i,
'/page' => qr(\[/page(?:target)?\])i,
'_accessories' => qr($T{_accessories}($Spacef[^\]]+)?\]),
'_alternate' => qr($T{_alternate}$Opt\]($Some)),
'_calc' => qr($T{_calc}\]($Some)),
'_exec' => qr($T{_exec}$Mand\]($Some)),
'_filter' => qr($T{_filter}\s+($Some)\]($Some)),
'_sub' => qr($T{_sub}$Mand\]($Some)),
'_change' => qr($T{_change}$Mand$Opt\] \s*
$T{condition}\]
($Some)
$T{'/condition'}
($Some))xi,
'_code' => qr($T{_code}\]),
'_sku' => qr($T{_sku}\]),
'col' => qr(\[col(?:umn)?\s+
([^\]]+)
\]
($Some)
\[/col(?:umn)?\] )ix,
'comment' => qr($T{comment}(?:\s+$Some)?\]
(?!$All$T{comment}\])
$Some
$T{'/comment'})x,
'_description' => qr($T{_description}\]),
'_difference' => qr($T{_difference}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]),
'_discount' => qr($T{_discount}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]),
'_field_if' => qr($T{_field}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
'_field_if_wo' => qr($T{_field}$Spacef(!?)\s*($Codere$Optr)\]),
'_field' => qr($T{_field}$Mandf\]),
'_common' => qr($T{_common}$Mandf\]),
'_increment' => qr($T{_increment}\]),
'_last' => qr($T{_last}\]\s*($Some)\s*),
'_line' => qr($T{_line}$Opt\]),
'_next' => qr($T{_next}\]\s*($Some)\s*),
'_options' => qr($T{_options}($Spacef[^\]]+)?\]),
'_header_param' => qr($T{_header_param}$Mandf$Optr\]),
'_header_param_if' => qr($T{_header_param}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
'_param_if' => qr((?:$T{_param}|$T{_modifier})(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
'_param' => qr((?:$T{_param}|$T{_modifier})$Mandf\]),
'_parent_if' => qr($T{_parent}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)),
'_parent' => qr($T{_parent}$Mandf\]),
'_pos_if' => qr($T{_pos}(\d*)$Spacef(!?)\s*(\d+)$Optr\]($Some)),
'_pos' => qr($T{_pos}$Spacef(\d+)\]),
'_price' => qr!$T{_price}(?:\s+(\d+))?$Optx\]!,
'_quantity' => qr($T{_quantity}\]),
'_subtotal' => qr($T{_subtotal}$Optx\]),
'_tag' => qr([-_] tag [-_] ([-\w]+) \s+)x,
'condition' => qr($T{condition}$T($Some)$T{'/condition'}),
'condition_begin' => qr(^\s*$T{condition}\]($Some)$T{'/condition'}),
'_discount_price' => qr($T{_discount_price}(?:\s+(\d+))?$Optx\]),
'discount_price' => qr($T{discount_price}(?:\s+(\d+))?$Optx\]),
'_discount_subtotal' => qr($T{_discount_subtotal}$Optx\]),
'has_else' => qr($T{'/else'}\s*$),
'else_end' => qr($T{else}\]($All)$T{'/else'}\s*$),
'elsif_end' => qr($T{elsif}\s+($All)$T{'/elsif'}\s*$),
'matches' => qr($T{matches}\]),
'match_count' => qr($T{match_count}\]),
'more' => qr($T{more}\]),
'more_list' => qr($T{more_list}$Optx$Optx$Optx$Optx$Optx\]($Some)$T{'/more_list'}),
'no_match' => qr($T{no_match}\]($Some)$T{'/no_match'}),
'on_match' => qr($T{on_match}\]($Some)$T{'/on_match'}),
'_quantity_name' => qr($T{_quantity_name}\]),
'_modifier_name' => qr($T{_modifier_name}$Spacef(\w+)\]),
'then' => qr(^\s*$T{then}$T($Some)$T{'/then'}),
);
FINTAG: {
for(keys %T) {
$QR{$_} = qr($T{$_})
if ! defined $QR{$_};
}
}
undef @th;
undef %T;
sub get_joiner {
my ($joiner, $default) = @_;
return $default unless defined $joiner and length $joiner;
if($joiner eq '\n') {
$joiner = "\n";
}
elsif($joiner =~ m{\\}) {
$joiner = $safe_safe->reval("qq{$joiner}");
}
return length($joiner) ? $joiner : $default;
}
sub substitute_image {
my ($text) = @_;
## Allow no substitution of downloads
return if $::Pragma->{download};
## If post_page routine processor returns true, return. Otherwise,
## continue image rewrite
if($::Pragma->{post_page}) {
Vend::Dispatch::run_macro($::Pragma->{post_page}, $text)
and return;
}
unless ( $::Pragma->{no_image_rewrite} ) {
my $dir = $CGI::secure ?
($Vend::Cfg->{ImageDirSecure} || $Vend::Cfg->{ImageDir}) :
$Vend::Cfg->{ImageDir};
if ($dir) {
$$text =~ s#(<i\w+\s+[^>]*?src=")(?!\w+:)([^/'][^"]+)#
$1 . $dir . $2#ige;
$$text =~ s#(<body\s+[^>]*?background=")(?!\w+:)([^/'][^"]+)#
$1 . $dir . $2#ige;
$$text =~ s#(<t(?:[dhr]|able)\s+[^>]*?background=")(?!\w+:)([^/'][^"]+)#
$1 . $dir . $2#ige;
}
}
if($Vend::Cfg->{ImageAlias}) {
for (keys %{$Vend::Cfg->{ImageAlias}} ) {
$$text =~ s#(<i\w+\s+[^>]*?src=")($_)#
$1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige;
$$text =~ s#(<body\s+[^>]*?background=")($_)#
$1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige;
$$text =~ s#(<t(?:[dhr]|able)\s+[^>]*?background=")($_)#
$1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige;
}
}
}
sub dynamic_var {
my $varname = shift;
return readfile($Vend::Cfg->{DirConfig}{Variable}{$varname})
if $Vend::Cfg->{DirConfig}
and defined $Vend::Cfg->{DirConfig}{Variable}{$varname};
VARDB: {
last VARDB if $::Pragma->{dynamic_variables_file_only};
last VARDB unless $Vend::Cfg->{VariableDatabase};
if($Vend::VarDatabase) {
last VARDB unless $Vend::VarDatabase->record_exists($varname);
return $Vend::VarDatabase->field($varname, 'Variable');
}
else {
$Vend::VarDatabase = database_exists_ref($Vend::Cfg->{VariableDatabase})
or undef $Vend::Cfg->{VariableDatabase};
redo VARDB;
}
}
return $::Variable->{$varname};
}
sub vars_and_comments {
my $html = shift;
## We never want to interpolate vars if in restricted mode
return if $Vend::restricted;
local($^W) = 0;
# Set whole-page pragmas from [pragma] tags
1 while $$html =~ s/\[pragma\s+(\w+)(?:\s+(\w+))?\]/
$::Pragma->{$1} = (length($2) ? $2 : 1), ''/ige;
undef $Vend::PageInit unless $::Pragma->{init_page};
if(defined $Vend::PageInit and ! $Vend::PageInit++) {
Vend::Dispatch::run_macro($::Pragma->{init_page}, $html);
}
# Substitute in Variable values
$$html =~ s/$Gvar/$Global::Variable->{$1}/g;
if($::Pragma->{dynamic_variables}) {
$$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge
and
$$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge;
$$html =~ s/$Cvar/dynamic_var($1)/ge;
}
else {
$$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge
and
$$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge;
$$html =~ s/$Cvar/$::Variable->{$1}/g;
}
if($::Pragma->{pre_page}) {
Vend::Dispatch::run_macro($::Pragma->{pre_page}, $html);
}
# Strip out [comment] [/comment] blocks
1 while $$html =~ s%$QR{comment}%%go;
# Translate legacy atomic [/page] and [/order] tags
$$html =~ s,\[/page(?:target)?\],</a>,ig;
$$html =~ s,\[/order\],</a>,ig;
# Translate Interchange tags embedded in HTML comments like <!--[tag ...]-->
! $::Pragma->{no_html_comment_embed}
and
$$html =~ s/<!--+\[/[/g
and $$html =~ s/\]--+>/]/g;
}
sub interpolate_html {
my ($html, $wantref, $opt) = @_;
return undef if $Vend::NoInterpolate;
my ($name, @post);
my ($bit, %post);
local($^W);
my $toplevel;
if(defined $Vend::PageInit and ! $Vend::PageInit) {
defined $::Variable->{MV_AUTOLOAD}
and $html =~ s/^/$::Variable->{MV_AUTOLOAD}/;
$toplevel = 1;
}
#::logDebug("opt=" . uneval($opt));
vars_and_comments(\$html)
unless $opt and $opt->{onfly};
$^W = 1 if $::Pragma->{perl_warnings_in_page};
# Returns, could be recursive
my $parse = new Vend::Parse $wantref;
$parse->parse($html);
while($parse->{_buf}) {
if($toplevel and $parse->{SEND}) {
delete $parse->{SEND};
::response();
$parse->destination($parse->{_current_output});
}
$parse->parse('');
}
return $parse->{OUT} if defined $wantref;
return ${$parse->{OUT}};
}
sub filter_value {
my($filter, $value, $tag, @passed_args) = @_;
#::logDebug("filter_value: filter='$filter' value='$value' tag='$tag'");
my @filters = Text::ParseWords::shellwords($filter);
my @args;
if(! $Vend::Filters_initted++ and my $ref = $Vend::Cfg->{CodeDef}{Filter}) {
while (my($k, $v) = each %{$ref->{Routine}}) {
$Filter{$k} = $v;
}
}
for (@filters) {
next unless length($_);
@args = @passed_args;
if(/^[^.]*%/) {
$value = sprintf($_, $value);
next;
}
if (/^(\d+)([\.\$]?)$/) {
my $len;
return $value unless ($len = length($value)) > $1;
my ($limit, $mod) = ($1, $2);
unless($mod) {
substr($value, $limit) = '';
}
elsif($mod eq '.') {
substr($value, $1) = '...';
}
elsif($mod eq '$') {
substr($value, 0, $len - $limit) = '...';
}
return $value;
next;
}
while( s/\.([^.]+)$//) {
unshift @args, $1;
}
if(/^\d+$/) {
substr($value , $_) = ''
if length($value) > $_;
next;
}
if ( /^words(\d+)(\.?)$/ ) {
my @str = (split /\s+/, $value);
if (scalar @str > $1) {
my $num = $1;
$value = join(' ', @str[0..--$num]);
$value .= $2 ? '...' : '';
}
next;
}
my $sub;
unless ($sub = $Filter{$_} || Vend::Util::codedef_routine('Filter', $_) ) {
logError ("Unknown filter '%s'", $_);
next;
}
unshift @args, $value, $tag;
$value = $sub->(@args);
}
#::logDebug("filter_value returns: value='$value'");
return $value;
}
sub try {
my ($label, $opt, $body) = @_;
$label = 'default' unless $label;
$Vend::Session->{try}{$label} = '';
my $out;
my $save;
$save = delete $SIG{__DIE__} if defined $SIG{__DIE__};
$Vend::Try = $label;
eval {
$out = interpolate_html($body);
};
undef $Vend::Try;
$SIG{__DIE__} = $save if defined $save;
if($@) {
$Vend::Session->{try}{$label} .= "\n"
if $Vend::Session->{try}{$label};
$Vend::Session->{try}{$label} .= $@;
}
if ($opt->{status}) {
return ($Vend::Session->{try}{$label}) ? 0 : 1;
}
elsif ($opt->{hide}) {
return '';
}
elsif ($opt->{clean}) {
return ($Vend::Session->{try}{$label}) ? '' : $out;
}
return $out;
}
# Returns the text of a configurable database field or a
# session variable
sub tag_data {
my($selector,$field,$key,$opt,$flag) = @_;
local($Safe_data);
$Safe_data = 1 if $opt->{safe_data};
my $db;
if ( not $db = database_exists_ref($selector) ) {
if($selector eq 'session') {
if(defined $opt->{value}) {
$opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
if $opt->{filter};
if ($opt->{increment}) {
$Vend::Session->{$field} += (+ $opt->{value} || 1);
}
elsif ($opt->{append}) {
$Vend::Session->{$field} .= $opt->{value};
}
else {
$Vend::Session->{$field} = $opt->{value};
}
return '';
}
else {
my $value = $Vend::Session->{$field} || '';
$value = filter_value($opt->{filter}, $value, $field)
if $opt->{filter};
return $value;
}
}
else {
logError( "Bad data selector='%s' field='%s' key='%s'",
$selector,
$field,
$key,
);
return '';
}
}
elsif($opt->{increment}) {
#::logDebug("increment_field: key=$key field=$field value=$opt->{value}");
return increment_field($Vend::Database{$selector},$key,$field,$opt->{value} || 1);
}
elsif (defined $opt->{value}) {
#::logDebug("alter table: table=$selector alter=$opt->{alter} field=$field value=$opt->{value}");
if ($opt->{alter}) {
$opt->{alter} =~ s/\W+//g;
$opt->{alter} = lc($opt->{alter});
if ($opt->{alter} eq 'change') {
return $db->change_column($field, $opt->{value});
}
elsif($opt->{alter} eq 'add') {
return $db->add_column($field, $opt->{value});
}
elsif ($opt->{alter} eq 'delete') {
return $db->delete_column($field, $opt->{value});
}
else {
logError("alter function '%s' not found", $opt->{alter});
return undef;
}
}
else {
$opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
if $opt->{filter};
#::logDebug("set_field: table=$selector key=$key field=$field foreign=$opt->{foreign} value=$opt->{value}");
my $orig = $opt->{value};
if($opt->{serial}) {
$field =~ s/\.(.*)//;
my $hk = $1;
my $current = database_field($selector,$key,$field,$opt->{foreign});
$opt->{value} = dotted_hash($current, $hk, $orig);
}
my $result = set_field(
$selector,
$key,
$field,
$opt->{value},
$opt->{append},
$opt->{foreign},
);
return $orig if $opt->{serial};
return $result
}
}
elsif ($opt->{serial}) {
$field =~ s/\.(.*)//;
my $hk = $1;
return ed(
dotted_hash(
database_field($selector,$key,$field,$opt->{foreign}),
$hk,
)
);
}
elsif ($opt->{hash}) {
return undef unless $db->record_exists($key);
return $db->row_hash($key);
}
elsif ($opt->{filter}) {
return filter_value(
$opt->{filter},
ed(database_field($selector,$key,$field,$opt->{foreign})),
$field,
);
}
#The most common , don't enter a block, no accoutrements
return ed(database_field($selector,$key,$field,$opt->{foreign}));
}
sub input_filter_do {
my($varname, $opt, $routine) = @_;
#::logDebug("filter var=$varname opt=" . uneval_it($opt));
return undef unless defined $CGI::values{$varname};
#::logDebug("before filter=$CGI::values{$varname}");
$routine = $opt->{routine} || ''
if ! $routine;
if($routine =~ /\S/) {
$routine = interpolate_html($routine);
$CGI::values{$varname} = tag_calc($routine);
}
if ($opt->{op}) {
$CGI::values{$varname} = filter_value($opt->{op}, $CGI::values{$varname}, $varname);
}
#::logDebug("after filter=$CGI::values{$varname}");
return;
}
sub input_filter {
my ($varname, $opt, $routine) = @_;
if($opt->{remove}) {
return if ! ref $Vend::Session->{Filter};
delete $Vend::Session->{Filter}{$_};
return;
}
$opt->{routine} = $routine if $routine =~ /\S/;
$Vend::Session->{Filter} = {} if ! $Vend::Session->{Filter};
$Vend::Session->{Filter}{$varname} = $opt->{op} if $opt->{op};
return;
}
sub conditional {
my($base,$term,$operator,$comp, @addl) = @_;
my $reverse;
# Only lowercase the first word-characters part of the conditional so that
# file-T doesn't turn into file-t (which is something different).
$base =~ s/(\w+)/\L$1/;
$base =~ s/^!// and $reverse = 1;
my ($op, $status);
my $noop;
$noop = 1, $operator = '' unless defined $operator;
my $sub;
my $newcomp;
if($operator =~ /^([^\s.]+)\.(.+)/) {
$operator = $1;
my $tag = $2;
my $arg;
if($comp =~ /^\w[-\w]+=/) {
$arg = get_option_hash($comp);
}
else {
$arg = $comp;
}
$Tag ||= new Vend::Tags;
#::logDebug("ready to call tag=$tag with arg=$arg");
$comp = $Tag->$tag($arg);
}
if($sub = $cond_op{$operator}) {
$noop = 1;
$newcomp = $comp;
undef $comp;
$newcomp =~ s/^(["'])(.*)\1$/$2/s or
$newcomp =~ s/^qq?([{(])(.*)[})]$/$2/s or
$newcomp =~ s/^qq?(\S)(.*)\1$/$2/s;
}
local($^W) = 0;
undef $@;
#::logDebug("cond: base=$base term=$term op=$operator comp=$comp newcomp=$newcomp nooop=$noop\n");
#::logDebug (($reverse ? '!' : '') . "cond: base=$base term=$term op=$operator comp=$comp");
#::logDebug ("cond: base=$base term=$term op=$operator comp=$comp\n");
my $total;
if($base eq 'total') {
$base = $term;
$total = 1;
}
if($base eq 'session') {
$op = qq%$Vend::Session->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'scratch') {
$op = qq%$::Scratch->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base =~ /^value/) {
$op = qq%$::Values->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'cgi') {
$op = qq%$CGI::values{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'pragma') {
$op = qq%$::Pragma->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'explicit') {
undef $noop;
$status = $ready_safe->reval($comp);
}
elsif($base eq 'variable') {
$op = qq%$::Variable->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'global') {
$op = qq%$Global::Variable->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'items') {
my $cart;
if($term) {
$cart = $::Carts->{$term} || undef;
}
else {
$cart = $Vend::Items;
}
$op = defined $cart ? scalar @{$cart} : 0;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'data') {
my($d,$f,$k) = split /::/, $term, 3;
$op = database_field($d,$k,$f);
#::logDebug ("tag_if db=$d fld=$f key=$k\n");
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'field') {
my($f,$k) = split /::/, $term;
$op = product_field($f,$k);
#::logDebug("tag_if field fld=$f key=$k\n");
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'discount') {
# Use switch_discount_space to ensure that the hash is set properly.
switch_discount_space($Vend::DiscountSpaceName)
unless ref $::Discounts eq 'HASH';
$op = qq%$::Discounts->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base eq 'ordered') {
$operator = 'main' unless $operator;
my ($attrib, $i);
$op = '';
unless ($comp) {
$attrib = 'quantity';
}
else {
($attrib,$comp) = split /\s+/, $comp;
}
foreach $i (@{$::Carts->{$operator}}) {
next unless $i->{code} eq $term;
($op++, next) if $attrib eq 'lines';
$op = $i->{$attrib};
last;
}
$op = "q{$op}" unless defined $noop;
$op .= qq% $comp% if $comp;
}
elsif($base =~ /^file(-([A-Za-z]))?$/) {
#$op =~ s/[^rwxezfdTsB]//g;
#$op = substr($op,0,1) || 'f';
my $fop = $2 || 'f';
if(! $file_op{$fop}) {
logError("Unrecognized file test '%s'. Returning false.", $fop);
$status = 0;
}
else {
$op = $file_op{$fop}->($term);
}
}
elsif($base =~ /^errors?$/) {
my $err;
if(! $term or $total) {
$err = is_hash($Vend::Session->{errors})
? scalar (keys %{$Vend::Session->{errors}})
: 0;
}
else {
$err = is_hash($Vend::Session->{errors})
? $Vend::Session->{errors}{$term}
: 0;
}
$op = $err;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base =~ /^warnings?$/) {
my $warn = 0;
if(my $ary = $Vend::Session->{warnings}) {
ref($ary) eq 'ARRAY' and $warn = scalar(@$ary);
}
$op = $warn;
}
elsif($base eq 'validcc') {
no strict 'refs';
$status = Vend::Order::validate_whole_cc($term, $operator, $comp);
}
elsif($base eq 'config') {
$op = qq%$Vend::Cfg->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
elsif($base =~ /^module.version/) {
eval {
no strict 'refs';
$op = ${"${term}::VERSION"};
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
};
}
elsif($base =~ /^accessor/) {
if ($comp) {
$op = qq%$Vend::Cfg->{Accessories}->{$term}%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%;
}
else {
for(@{$Vend::Cfg->{UseModifier}}) {
next unless product_field($_,$term);
$status = 1;
last;
}
}
}
elsif($base eq 'control') {
$op = 0;
if (defined $::Scratch->{control_index}
and defined $::Control->[$Scratch->{control_index}]) {
$op = qq%$::Control->[$::Scratch->{control_index}]{$term}%;
$op = "q{$op}"
unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
}
else {
$op = qq%$term%;
$op = "q{$op}" unless defined $noop;
$op .= qq% $operator $comp%
if defined $comp;
}
#::logDebug("noop='$noop' op='$op'");
RUNSAFE: {
last RUNSAFE if defined $status;
if($sub) {
$status = $sub->($op, $newcomp);
last RUNSAFE;
}
elsif ($noop) {
$status = $op ? 1 : 0;
last RUNSAFE;
}
$ready_safe->trap(@{$Global::SafeTrap});
$ready_safe->untrap(@{$Global::SafeUntrap});
$status = $ready_safe->reval($op) ? 1 : 0;
if ($@) {
logError "Bad if '@_': $@";
$status = 0;
}
}
$status = $reverse ? ! $status : $status;
for(@addl) {
my $chain = /^\[[Aa]/;
last if ($chain ^ $status);
$status = ${(new Vend::Parse)->parse($_)->{OUT}} ? 1 : 0;
}
#::logDebug("if status=$status");
return $status;
}
sub find_close_square {
my $chunk = shift;
my $first = index($chunk, ']');
return undef if $first < 0;
my $int = index($chunk, '[');
my $pos = 0;
while( $int > -1 and $int < $first) {
$pos = $int + 1;
$first = index($chunk, ']', $first + 1);
$int = index($chunk, '[', $pos);
}
return substr($chunk, 0, $first);
}
sub find_andor {
my($text) = @_;
return undef
unless $$text =~ s# \s* \[
( (?:[Aa][Nn][Dd]|[Oo][Rr]) \s+
$All)
#$1#x;
my $expr = find_close_square($$text);
return undef unless defined $expr;
$$text = substr( $$text,length($expr) + 1 );
return "[$expr]";
}
sub split_if {
my ($body) = @_;
my ($then, $else, $elsif, $andor, @addl);
$else = $elsif = '';
push (@addl, $andor) while $andor = find_andor(\$body);
$body =~ s#$QR{then}##o
and $then = $1;
$body =~ s#$QR{has_else}##o
and $else = find_matching_else(\$body);
$body =~ s#$QR{elsif_end}##o
and $elsif = $1;
$body = $then if defined $then;
return($body, $elsif, $else, @addl);
}
sub tag_if {
my ($cond,$body,$negate) = @_;
#::logDebug("Called tag_if: $cond\n$body\n");
my ($base, $term, $op, $operator, $comp);
my ($else, $elsif, $else_present, @addl);
($base, $term, $operator, $comp) = split /\s+/, $cond, 4;
if ($base eq 'explicit') {
$body =~ s#$QR{condition_begin}##o
and ($comp = $1, $operator = '');
}
#::logDebug("tag_if: base=$base term=$term op=$operator comp=$comp");
#Handle unless
($base =~ s/^\W+// or $base = "!$base") if $negate;
$else_present = 1 if
$body =~ /\[[EeTtAaOo][hHLlNnRr][SsEeDd\s]/;
($body, $elsif, $else, @addl) = split_if($body)
if $else_present;
#::logDebug("Additional ops found:\n" . join("\n", @addl) ) if @addl;
unless(defined $operator) {
undef $operator;
undef $comp;
}
my $status = conditional ($base, $term, $operator, $comp, @addl);
#::logDebug("Result of if: $status\n");
my $out;
if($status) {
$out = $body;
}
elsif ($elsif) {
$else = '[else]' . $else . '[/else]' if length $else;
my $pertinent = Vend::Parse::find_matching_end('elsif', \$elsif);
unless(defined $pertinent) {
$pertinent = $elsif;
$elsif = '';
}
$elsif .= '[/elsif]' if $elsif =~ /\S/;
$out = '[if ' . $pertinent . $elsif . $else . '[/if]';
}
elsif (length $else) {
$out = $else;
}
return $out;
}
# This generates a *session-based* Autoload routine based
# on the contents of a preset Profile (see the Profile directive).
#
# Normally used for setting pricing profiles with CommonAdjust,
# ProductFiles, etc.
#
sub restore_profile {
my $save;
return unless $save = $Vend::Session->{Profile_save};
for(keys %$save) {
$Vend::Cfg->{$_} = $save->{$_};
}
return;
}
sub tag_profile {
my($profile, $opt) = @_;
#::logDebug("in tag_profile=$profile opt=" . uneval_it($opt));
$opt = {} if ! $opt;
my $tag = $opt->{tag} || 'default';
if(! $profile) {
if($opt->{restore}) {
restore_profile();
if(ref $Vend::Session->{Autoload}) {
@{$Vend::Session->{Autoload}} =
grep $_ !~ /^$tag-/, @{$Vend::Session->{Autoload}};
}
}
return if ! ref $Vend::Session->{Autoload};
$opt->{joiner} = ' ' unless defined $opt->{joiner};
return join $opt->{joiner},
grep /^\w+-\w+$/, @{ $Vend::Session->{Autoload} };
}
if($profile =~ s/(\w+)-//) {
$opt->{tag} = $1;
$opt->{run} = 1;
}
elsif (! $opt->{set} and ! $opt->{run}) {
$opt->{set} = $opt->{run} = 1;
}
if( "$profile$tag" =~ /\W/ ) {
logError(
"profile: invalid characters (tag=%s profile=%s), must be [A-Za-z_]+",
$tag,
$profile,
);
return $opt->{failure};
}
if($opt->{run}) {
#::logDebug("running profile=$profile tag=$tag");
my $prof = $Vend::Cfg->{Profile_repository}{$profile};
if (not $prof) {
logError( "profile %s (%s) non-existant.", $profile, $tag );
return $opt->{failure};
}
#::logDebug("found profile=$profile");
$Vend::Cfg->{Profile} = $prof;
restore_profile();
#::logDebug("restored profile");
PROFSET:
for my $one (keys %$prof) {
#::logDebug("doing profile $one");
next unless defined $Vend::Cfg->{$one};
my $string;
my $val = $prof->{$one};
if( ! ref $Vend::Cfg->{$one} ) {
# Do nothing
}
elsif( ref($Vend::Cfg->{$one}) eq 'HASH') {
if( ref($val) ne 'HASH') {
$string = '{' . $prof->{$one} . '}'
unless $prof->{$one} =~ /^{/
and $prof->{$one} =~ /}\s*$/;
}
}
elsif( ref($Vend::Cfg->{$one}) eq 'ARRAY') {
if( ref($val) ne 'ARRAY') {
$string = '[' . $prof->{$one} . ']'
unless $prof->{$one} =~ /^\[/
and $prof->{$one} =~ /]\s*$/;
}
}
else {
logError( "profile: cannot handle object of type %s.",
$Vend::Cfg->{$one},
);
logError("profile: profile for $one not changed.");
next;
}
#::logDebug("profile value=$val, string=$string");
undef $@;
$val = $ready_safe->reval($string) if $string;
if($@) {
logError( "profile: bad object %s: %s", $one, $string );
next;
}
$Vend::Session->{Profile_save}{$one} = $Vend::Cfg->{$one}
unless defined $Vend::Session->{Profile_save}{$one};
#::logDebug("set $one to value=$val, string=$string");
$Vend::Cfg->{$one} = $val;
}
return $opt->{success}
unless $opt->{set};
}
#::logDebug("setting profile=$profile tag=$tag");
my $al;
if(! $Vend::Session->{Autoload}) {
# Do nothing....
}
elsif(ref $Vend::Session->{Autoload}) {
$al = $Vend::Session->{Autoload};
}
else {
$al = [ $Vend::Session->{Autoload} ];
}
if($al) {
@$al = grep $_ !~ m{^$tag-\w+$}, @$al;
}
$al = [] if ! $al;
push @$al, "$tag-$profile";
#::logDebug("profile=$profile Autoload=" . uneval_it($al));
$Vend::Session->{Autoload} = $al;
return $opt->{success};
}
*tag_options = \&Vend::Options::tag_options;
sub produce_range {
my ($ary, $max) = @_;
$max = $Vend::Cfg->{Limit}{option_list} if ! $max;
my @do;
for (my $i = 0; $i < scalar(@$ary); $i++) {
$ary->[$i] =~ /^\s* ([a-zA-Z0-9]+) \s* \.\.+ \s* ([a-zA-Z0-9]+) \s* $/x
or next;
my @new = $1 .. $2;
if(@new > $max) {
logError(
"Refuse to add %d options to option list via range, max %d.",
scalar(@new),
$max,
);
next;
}
push @do, $i, \@new;
}
my $idx;
my $new;
while($new = pop(@do)) {
my $idx = pop(@do);
splice @$ary, $idx, 1, @$new;
}
return;
}
sub tag_accessories {
my($code,$extra,$opt,$item) = @_;
my $ishash;
if(ref $item) {
#::logDebug("tag_accessories: item is a hash");
$ishash = 1;
}
# Had extra if got here
#::logDebug("tag_accessories: code=$code opt=" . uneval_it($opt) . " item=" . uneval_it($item) . " extra=$extra");
my($attribute, $type, $field, $db, $name, $outboard, $passed);
$opt = {} if ! $opt;
if($extra) {
$extra =~ s/^\s+//;
$extra =~ s/\s+$//;
@{$opt}{qw/attribute type column table name outboard passed/} =
split /\s*,\s*/, $extra;
}
($attribute, $type, $field, $db, $name, $outboard, $passed) =
@{$opt}{qw/attribute type column table name outboard passed/};
## Code only passed when we are a product
if($code) {
GETACC: {
my $col = $opt->{column} || $opt->{attribute};
my $key = $opt->{outboard} || $code;
last GETACC if ! $col;
if($opt->{table}) {
$opt->{passed} ||= tag_data($opt->{table}, $col, $key);
}
else {
$opt->{passed} ||= product_field($col, $key);
}
}
return unless $opt->{passed} || $opt->{type};
$opt->{type} ||= 'select';
return unless
$opt->{passed}
or
$opt->{type} =~ /^(text|password|hidden)/i;
}
return Vend::Form::display($opt, $item);
}
# MVASP
sub mvasp {
my ($tables, $opt, $text) = @_;
my @code;
$opt->{no_return} = 1 unless defined $opt->{no_return};
while ( $text =~ s/(.*?)<%//s || $text =~ s/(.+)//s ) {
push @code, <<EOF;
; my \$html = <<'_MV_ASP_EOF$^T';
$1
_MV_ASP_EOF$^T
chop(\$html);
HTML( \$html );
EOF
$text =~ s/(.*?)%>//s
or last;;
my $bit = $1;
if ($bit =~ s/^\s*=\s*//) {
$bit =~ s/;\s*$//;
push @code, "; HTML( $bit );"
}
else {
push @code, $bit, ";\n";
}
}
my $asp = join "", @code;
#::logDebug("ASP CALL:\n$asp\n");
return tag_perl ($tables, $opt, $asp);
}
# END MVASP
$safe_safe = new Safe;
sub tag_perl {
my ($tables, $opt,$body) = @_;
my ($result,@share);
#::logDebug("tag_perl MVSAFE=$MVSAFE::Safe opts=" . uneval($opt));
if($Vend::NoInterpolate) {
logGlobal({ level => 'alert' },
"Attempt to interpolate perl/ITL from RPC, no permissions."
);
return undef;
}
if ($MVSAFE::Safe) {
#::logDebug("tag_perl: Attempt to call perl from within Safe.");
return undef;
}
#::logDebug("tag_perl: tables=$tables opt=" . uneval($opt) . " body=$body");
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
if($opt->{subs} or $opt->{arg} =~ /\bsub\b/) {
no strict 'refs';
for(keys %{$Global::GlobalSub}) {
#::logDebug("tag_perl share subs: GlobalSub=$_");
next if defined $Global::AdminSub->{$_}
and ! $Global::AllowGlobal->{$Vend::Cat};
*$_ = \&{$Global::GlobalSub->{$_}};
push @share, "&$_";
}
for(keys %{$Vend::Cfg->{Sub} || {}}) {
#::logDebug("tag_perl share subs: Sub=$_");
*$_ = \&{$Vend::Cfg->{Sub}->{$_}};
push @share, "&$_";
}
}
if($tables) {
my (@tab) = grep /\S/, split /\s+/, $tables;
foreach my $tab (@tab) {
next if $Db{$tab};
my $db = database_exists_ref($tab);
next unless $db;
my $dbh;
$db = $db->ref();
if($db->config('type') == 10) {
my @extra_tabs = $db->_shared_databases();
push (@tab, @extra_tabs);
$dbh = $db->dbh();
} elsif ($db->can('dbh')) {
$dbh = $db->dbh();
}
if($hole) {
if ($dbh) {
$Sql{$tab} = $hole->wrap($dbh);
}
$Db{$tab} = $hole->wrap($db);
if($db->config('name') ne $tab) {
$Db{$db->config('name')} = $Db{$tab};
}
}
else {
$Sql{$tab} = $db->[$Vend::Table::DBI::DBI]
if $db =~ /::DBI/;
$Db{$tab} = $db;
}
}
}
$Tag = $hole->wrap($Tag) if $hole and ! $Vend::TagWrapped++;
init_calc() if ! $Vend::Calc_initialized;
$ready_safe->share(@share) if @share;
if($Vend::Cfg->{Tie_Watch}) {
eval {
for(@{$Vend::Cfg->{Tie_Watch}}) {
logGlobal("touching $_");
my $junk = $Config->{$_};
}
};
}
#$hole->wrap($Tag);
$MVSAFE::Safe = 1;
if (
$opt->{global}
and
$Global::AllowGlobal->{$Vend::Cat}
)
{
$MVSAFE::Safe = 0 unless $MVSAFE::Unsafe;
}
$body = readfile($opt->{file}) . $body
if $opt->{file};
$body =~ tr/\r//d if $Global::Windows;
$Items = $Vend::Items;
if(! $MVSAFE::Safe) {
$result = eval($body);
}
else {
$result = $ready_safe->reval($body);
}
undef $MVSAFE::Safe;
if ($@) {
#::logDebug("tag_perl failed $@");
my $msg = $@;
if($Vend::Try) {
$Vend::Session->{try}{$Vend::Try} .= "\n"
if $Vend::Session->{try}{$Vend::Try};
$Vend::Session->{try}{$Vend::Try} .= $@;
}
if($opt->{number_errors}) {
my @lines = split("\n",$body);
my $counter = 1;
map { $_ = sprintf("% 4d %s",$counter++,$_); } @lines;
$body = join("\n",@lines);
}
if($opt->{trim_errors}) {
if($msg =~ /line (\d+)\.$/) {
my @lines = split("\n",$body);
my $start = $1 - $opt->{trim_errors} - 1;
my $length = (2 * $opt->{trim_errors}) + 1;
@lines = splice(@lines,$start,$length);
$body = join("\n",@lines);
}
}
if($opt->{eval_label}) {
$msg =~ s/\(eval \d+\)/($opt->{eval_label})/g;
}
if($opt->{short_errors}) {
chomp($msg);
logError( "Safe: %s" , $msg );
logGlobal({ level => 'debug' }, "Safe: %s" , $msg );
} else {
logError( "Safe: %s\n%s\n" , $msg, $body );
logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body );
}
return $opt->{failure};
}
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
if ($opt->{no_return}) {
$Vend::Session->{mv_perl_result} = $result;
$result = join "", @Vend::Document::Out;
@Vend::Document::Out = ();
}
#::logDebug("tag_perl succeeded result=$result\nEND");
return $result;
}
sub ed {
return $_[0] if ! $_[0] or $Safe_data or $::Pragma->{safe_data};
$_[0] =~ s/\[/&#91;/g;
return $_[0];
}
sub show_tags {
my($type, $opt, $text) = @_;
$type = 'html interchange' unless $type;
$type =~ s/minivend/interchange/g;
if ($type =~ /interchange/i) {
$text =~ s/\[/&#91;/g;
}
if($type =~ /html/i) {
$text =~ s/\</&lt;/g;
}
return $text;
}
sub pragma {
my($pragma, $opt, $text) = @_;
$pragma =~ s/\W+//g;
my $value = defined $opt->{value} ? $opt->{value} : 1;
if(! defined $opt->{value} and $text =~ /\S/) {
$value = $text;
}
$::Pragma->{$pragma} = $value;
return;
}
sub flag {
my($flag, $opt, $text) = @_;
$flag = lc $flag;
if(! $text) {
($flag, $text) = split /\s+/, $flag;
}
my $value = defined $opt->{value} ? $opt->{value} : 1;
my $fmt = $opt->{status} || '';
my @status;
#::logDebug("tag flag=$flag text=$text value=$value opt=". uneval_it($opt));
if($flag eq 'write' || $flag eq 'read') {
my $arg = $opt->{table} || $text;
$value = 0 if $flag eq 'read';
my (@args) = Text::ParseWords::shellwords($arg);
my $dbname;
foreach $dbname (@args) {
# Handle table:column:key
$dbname =~ s/:.*//;
#::logDebug("tag flag write $dbname=$value");
$Vend::WriteDatabase{$dbname} = $value;
}
}
elsif($flag =~ /^transactions?/i) {
my $arg = $opt->{table} || $text;
my (@args) = Text::ParseWords::shellwords($arg);
my $dbname;
foreach $dbname (@args) {
# Handle table:column:key
$dbname =~ s/:.*//;
$Vend::TransactionDatabase{$dbname} = $value;
$Vend::WriteDatabase{$dbname} = $value;
# we can't do anything else if in Safe
next if $MVSAFE::Safe;
# Now we close and reopen
my $db = database_exists_ref($dbname)
or next;
if($db->isopen()) {
# need to reopen in transactions mode.
$db->close_table();
$db->suicide();
$db = database_exists_ref($dbname);
$db = $db->ref();
}
$Db{$dbname} = $db;
$Sql{$dbname} = $db->dbh()
if $db->can('dbh');
}
}
elsif($flag eq 'commit' || $flag eq 'rollback') {
my $arg = $opt->{table} || $text;
$value = 0 if $flag eq 'rollback';
my $method = $value ? 'commit' : 'rollback';
my (@args) = Text::ParseWords::shellwords($arg);
my $dbname;
foreach $dbname (@args) {
# Handle table:column:key
$dbname =~ s/:.*//;
#::logDebug("tag commit $dbname=$value");
my $db = database_exists_ref($dbname);
next unless $db->isopen();
next unless $db->config('Transactions');
if( ! $db ) {
logError("attempt to $method on unknown database: %s", $dbname);
return undef;
}
if( ! $db->$method() ) {
logError("problem doing $method for table: %s", $dbname);
return undef;
}
}
}
elsif($flag eq 'checkhtml') {
$Vend::CheckHTML = $value;
@status = ("Set CheckHTML flag: %s", $value);
}
else {
@status = ("Unknown flag operation '%s', ignored.", $flag);
$status[0] = $opt->{status} if $opt->{status};
logError( @status );
}
return '' unless $opt->{show};
$status[0] = $opt->{status} if $opt->{status};
return errmsg(@status);
}
sub tag_export {
my ($args, $opt, $text) = @_;
$opt->{base} = $opt->{table} || $opt->{database} || undef
unless defined $opt->{base};
unless (defined $opt->{base}) {
@{$opt}{ qw/base file type/ } = split /\s+/, $args;
}
if($opt->{delete}) {
undef $opt->{delete} unless $opt->{verify};
}
#::logDebug("exporting " . join (",", @{$opt}{ qw/base file type field delete/ }));
my $status = Vend::Data::export_database(
@{$opt}{ qw/base file type/ }, $opt,
);
return $status unless $opt->{hide};
return '';
}
sub export {
my ($table, $opt, $text) = @_;
if($opt->{delete}) {
undef $opt->{delete} unless $opt->{verify};
}
#::logDebug("exporting " . join (",", @{$opt}{ qw/table file type field delete/ }));
my $status = Vend::Data::export_database(
@{$opt}{ qw/table file type/ }, $opt,
);
return $status unless $opt->{hide};
return '';
}
sub mime {
my ($option, $opt, $text) = @_;
my $id;
my $out;
#::logDebug("mime call, opt=" . uneval($opt));
$Vend::TIMESTAMP = POSIX::strftime("%y%m%d%H%M%S", localtime())
unless defined $Vend::TIMESTAMP;
$::Instance->{MIME_BOUNDARY} =
$::Instance->{MIME_TIMESTAMP} . '-' .
$Vend::SessionID . '-' .
$Vend::Session->{pageCount} .
':=' . $$
unless defined $::Instance->{MIME_BOUNDARY};
my $msg_type = $opt->{type} || "multipart/mixed";
if($option eq 'reset') {
undef $::Instance->{MIME_TIMESTAMP};
undef $::Instance->{MIME_BOUNDARY};
$out = '';
}
elsif($option eq 'boundary') {
$out = "--$::Instance->{MIME_BOUNDARY}";
}
elsif($option eq 'id') {
$::Instance->{MIME} = 1;
$out = _mime_id();
}
elsif($option eq 'header') {
$id = _mime_id();
$out = <<EndOFmiMe;
MIME-Version: 1.0
Content-Type: $msg_type; BOUNDARY="$::Instance->{MIME_BOUNDARY}"
Content-ID: $id
EndOFmiMe
}
elsif ( $text !~ /\S/) {
$out = '';
}
else {
$id = _mime_id();
$::Instance->{MIME} = 1;
my $desc = $opt->{description} || $option;
my $type = $opt->{type} || 'text/plain; charset=US-ASCII';
my $disposition = $opt->{attach_only}
? qq{attachment; filename="$desc"}
: "inline";
my $encoding = $opt->{transfer_encoding};
my @headers;
push @headers, "Content-Type: $type";
push @headers, "Content-ID: $id";
push @headers, "Content-Disposition: $disposition";
push @headers, "Content-Description: $desc";
push @headers, "Content-Transfer-Encoding: $opt->{transfer_encoding}"
if $opt->{transfer_encoding};
my $head = join "\n", @headers;
$out = <<EndOFmiMe;
--$::Instance->{MIME_BOUNDARY}
$head
$text
EndOFmiMe
}
#::logDebug("tag mime returns:\n$out");
return $out;
}
sub log {
my($file, $opt, $data) = @_;
my(@lines);
my(@fields);
my $status;
$file = $opt->{file} || $Vend::Cfg->{LogFile};
if($file =~ s/^\s*>\s*//) {
$opt->{create} = 1;
}
$file = Vend::Util::escape_chars($file);
unless(Vend::File::allowed_file($file)) {
Vend::File::log_file_violation($file, 'log');
return undef;
}
$file = ">$file" if $opt->{create};
unless($opt->{process} and $opt->{process} =~ /\bnostrip\b/i) {
$data =~ s/\r\n/\n/g;
$data =~ s/^\s+//;
$data =~ s/\s+$/\n/;
}
my ($delim, $record_delim);
for(qw/delim record_delim/) {
next unless defined $opt->{$_};
$opt->{$_} = $ready_safe->reval(qq{$opt->{$_}});
}
if($opt->{type}) {
if($opt->{type} =~ /^text/) {
$status = Vend::Util::writefile($file, $data, $opt);
}
elsif($opt->{type} =~ /^\s*quot/) {
$record_delim = $opt->{record_delim} || "\n";
@lines = split /$record_delim/, $data;
for(@lines) {
@fields = Text::ParseWords::shellwords $_;
$status = logData($file, @fields)
or last;
}
}
elsif($opt->{type} =~ /^(?:error|debug)/) {
if ($opt->{file}) {
$data = format_log_msg($data) unless $data =~ s/^\\//;;
$status = Vend::Util::writefile($file, $data, $opt);
}
elsif ($opt->{type} =~ /^debug/) {
$status = Vend::Util::logDebug($data);
}
else {
$status = Vend::Util::logError($data);
}
}
}
else {
$record_delim = $opt->{record_delim} || "\n";
$delim = $opt->{delimiter} || "\t";
@lines = split /$record_delim/, $data;
for(@lines) {
@fields = split /$delim/, $_;
$status = logData($file, @fields)
or last;
}
}
return $status unless $opt->{hide};
return '';
}
sub _mime_id {
'<Interchange.' . $::VERSION . '.' .
$Vend::TIMESTAMP . '.' .
$Vend::SessionID . '.' .
++$Vend::Session->{pageCount} . '@' .
$Vend::Cfg->{VendURL} . '>';
}
sub http_header {
shift;
my ($opt, $text) = @_;
$text =~ s/^\s+//;
if($opt->{name}) {
my $name = lc $opt->{name};
$name =~ s/-/_/g;
$name =~ s/\W+//g;
$name =~ tr/_/-/s;
$name =~ s/(\w+)/\u$1/g;
my $content = $opt->{content} || $text;
$content =~ s/^\s+//;
$content =~ s/\s+$//;
$content =~ s/[\r\n]/; /g;
$text = "$name: $content";
}
if($Vend::StatusLine and ! $opt->{replace}) {
$Vend::StatusLine =~ s/\s*$/\r\n/;
$Vend::StatusLine .= $text;
}
else {
$Vend::StatusLine = $text;
}
return $text if $opt->{show};
return '';
}
sub mvtime {
my ($locale, $opt, $fmt) = @_;
my $current;
if($locale) {
$current = POSIX::setlocale(&POSIX::LC_TIME);
POSIX::setlocale(&POSIX::LC_TIME, $locale);
}
local($ENV{TZ}) = $opt->{tz} if $opt->{tz};
my $now = $opt->{time} || time();
$fmt = '%Y%m%d' if $opt->{sortable};
if($opt->{adjust}) {
my $neg = $opt->{adjust} =~ s/^\s*-\s*//;
my $diff;
$opt->{adjust} =~ s/^\s*\+\s*//;
if($opt->{hours}) {
$diff = (60 * 60) * ($opt->{adjust} || $opt->{hours});
}
elsif($opt->{adjust} !~ /[A-Za-z]/) {
$opt->{adjust} =~ s:(\d+)(\d[05])$:$1 + $2 / 60:e;
$opt->{adjust} =~ s/00$//;
$diff = (60 * 60) * $opt->{adjust};
}
else {
$diff = Vend::Config::time_to_seconds($opt->{adjust});
}
$now = $neg ? $now - $diff : $now + $diff;
}
$fmt ||= $opt->{format} || $opt->{fmt} || '%c';
my $out = $opt->{gmt} ? ( POSIX::strftime($fmt, gmtime($now) ))
: ( POSIX::strftime($fmt, localtime($now) ));
$out =~ s/\b0(\d)\b/$1/g if $opt->{zerofix};
POSIX::setlocale(&POSIX::LC_TIME, $current) if defined $current;
return $out;
}
use vars qw/ %Tag_op_map /;
%Tag_op_map = (
PRAGMA => \&pragma,
FLAG => \&flag,
LOG => \&log,
TIME => \&mvtime,
HEADER => \&http_header,
EXPORT => \&tag_export,
TOUCH => sub {1},
EACH => sub {
my $table = shift;
my $opt = shift;
$opt->{search} = "ra=yes\nst=db\nml=100000\nfi=$table";
#::logDebug("tag each: table=$table opt=" . uneval($opt));
return tag_loop_list('', $opt, shift);
},
MIME => \&mime,
SHOW_TAGS => \&show_tags,
);
sub do_tag {
my $op = uc $_[0];
#::logDebug("tag op: op=$op opt=" . uneval(\@_));
return $_[3] if ! defined $Tag_op_map{$op};
shift;
#::logDebug("tag args now: op=$op opt=" . uneval(\@_));
return &{$Tag_op_map{$op}}(@_);
}
sub tag_counter {
my $file = shift || 'etc/counter';
my $opt = shift;
#::logDebug("counter: file=$file start=$opt->{start} sql=$opt->{sql} routine=$opt->{inc_routine} caller=" . scalar(caller()) );
if($opt->{sql}) {
my ($tab, $seq) = split /:+/, $opt->{sql}, 2;
my $db = database_exists_ref($tab);
my $dbh;
my $dsn;
if($opt->{bypass}) {
$dsn = $opt->{dsn} || $ENV{DBI_DSN};
$dbh = DBI->connect(
$dsn,
$opt->{user},
$opt->{pass},
$opt->{attr},
);
}
elsif($db) {
$dbh = $db->dbh();
$dsn = $db->config('DSN');
}
my $val;
eval {
my $diemsg = errmsg(
"Counter sequence '%s' failed, using file.\n",
$opt->{sql},
);
if(! $dbh) {
die errmsg(
"No database handle for counter sequence '%s', using file.",
$opt->{sql},
);
}
elsif($dsn =~ /^dbi:mysql:/i) {
$seq ||= $tab;
$dbh->do("INSERT INTO $seq VALUES (0)") or die $diemsg;
my $sth = $dbh->prepare("select LAST_INSERT_ID()")
or die $diemsg;
$sth->execute() or die $diemsg;
($val) = $sth->fetchrow_array;
}
elsif($dsn =~ /^dbi:Pg:/i) {
my $sth = $dbh->prepare("select nextval('$seq')")
or die $diemsg;
$sth->execute()
or die $diemsg;
($val) = $sth->fetchrow_array;
}
elsif($dsn =~ /^dbi:Oracle:/i) {
my $sth = $dbh->prepare("select $seq.nextval from dual")
or die $diemsg;
$sth->execute()
or die $diemsg;
($val) = $sth->fetchrow_array;
}
};
logOnce('error', $@) if $@;
return $val if defined $val;
}
unless (allowed_file($file)) {
log_file_violation ($file, 'counter');
return undef;
}
$file = $Vend::Cfg->{VendRoot} . "/$file"
unless Vend::Util::file_name_is_absolute($file);
for(qw/inc_routine dec_routine/) {
my $routine = $opt->{$_}
or next;
if( ! ref($routine) ) {
$opt->{$_} = $Vend::Cfg->{Sub}{$routine};
$opt->{$_} ||= $Global::GlobalSub->{$routine};
}
}
my $ctr = new Vend::CounterFile
$file,
$opt->{start} || undef,
$opt->{date},
$opt->{inc_routine},
$opt->{dec_routine};
return $ctr->value() if $opt->{value};
return $ctr->dec() if $opt->{decrement};
return $ctr->inc();
}
# Returns the text of a user entered field named VAR.
sub tag_value_extended {
my($var, $opt) = @_;
my $vspace = $opt->{values_space};
my $vref;
if (defined $vspace) {
if ($vspace eq '') {
$vref = $Vend::Session->{values};
}
else {
$vref = $Vend::Session->{values_repository}{$vspace} ||= {};
}
}
else {
$vref = $::Values;
}
my $yes = $opt->{yes} || 1;
my $no = $opt->{'no'} || '';
if($opt->{test}) {
$opt->{test} =~ /(?:is)?put/i
and
return defined $CGI::put_ref ? $yes : $no;
$opt->{test} =~ /(?:is)?file/i
and
return defined $CGI::file{$var} ? $yes : $no;
$opt->{test} =~ /defined/i
and
return defined $CGI::values{$var} ? $yes : $no;
return length $CGI::values{$var}
if $opt->{test} =~ /length|size/i;
return '';
}
if($opt->{put_contents}) {
return undef if ! defined $CGI::put_ref;
return $$CGI::put_ref;
}
my $val = $CGI::values{$var} || $vref->{$var} || return undef;
$val =~ s/</&lt;/g unless $opt->{enable_html};
$val =~ s/\[/&#91;/g unless $opt->{enable_itl};
if($opt->{file_contents}) {
return '' if ! defined $CGI::file{$var};
return $CGI::file{$var};
}
if($opt->{put_ref}) {
return $CGI::put_ref;
}
if($opt->{outfile}) {
my $file = $opt->{outfile};
$file =~ s/^\s+//;
$file =~ s/\s+$//;
if($file =~ m{^([A-Za-z]:)?[\\/.]}) {
logError("attempt to write absolute file $file");
return '';
}
if($opt->{ascii}) {
my $replace = $^O =~ /win32/i ? "\r\n" : "\n";
if($CGI::file{$var} !~ /\n/) {
# Must be a mac file.
$CGI::file{$var} =~ s/\r/$replace/g;
}
elsif ( $CGI::file{$var} =~ /\r\n/) {
# Probably a PC file
$CGI::file{$var} =~ s/\r\n/$replace/g;
}
else {
$CGI::file{$var} =~ s/\n/$replace/g;
}
}
if($opt->{maxsize} and length($CGI::file{$var}) > $opt->{maxsize}) {
logError(
"Uploaded file write of %s bytes greater than maxsize %s. Aborted.",
length($CGI::file{$var}),
$opt->{maxsize},
);
return $opt->{no} || '';
}
#::logDebug(">$file \$CGI::file{$var}" . uneval($opt));
Vend::Util::writefile(">$file", \$CGI::file{$var}, $opt)
and return $opt->{yes} || '';
return $opt->{'no'} || '';
}
my $joiner;
if (defined $opt->{joiner}) {
$joiner = $opt->{joiner};
if($joiner eq '\n') {
$joiner = "\n";
}
elsif($joiner =~ m{\\}) {
$joiner = $ready_safe->reval("qq{$joiner}");
}
}
else {
$joiner = ' ';
}
my $index = defined $opt->{'index'} ? $opt->{'index'} : '*';
$index = '*' if $index =~ /^\s*\*?\s*$/;
my @ary;
if (!ref $val) {
@ary = split /\0/, $val;
}
elsif($val =~ /ARRAY/) {
@ary = @$val;
}
else {
logError( "value-extended %s: passed non-scalar, non-array object", $var);
}
return join " ", 0 .. $#ary if $opt->{elements};
eval {
@ary = @ary[$ready_safe->reval( $index eq '*' ? "0 .. $#ary" : $index )];
};
logError("value-extended $var: bad index") if $@;
if($opt->{filter}) {
for(@ary) {
$_ = filter_value($opt->{filter}, $_, $var);
}
}
return join $joiner, @ary;
}
sub format_auto_transmission {
my $ref = shift;
## Auto-transmission from Vend::Data::update_data
## Looking for structure like:
##
## [ '### BEGIN submission from', 'ckirk' ],
## [ 'username', 'ckirk' ],
## [ 'field2', 'value2' ],
## [ 'field1', 'value1' ],
## [ '### END submission from', 'ckirk' ],
## [ 'mv_data_fields', [ username, field1, field2 ]],
##
return $ref unless ref($ref);
my $body = '';
my %message;
my $header = shift @$ref;
my $fields = pop @$ref;
my $trailer = pop @$ref;
$body .= "$header->[0]: $header->[1]\n";
for my $line (@$ref) {
$message{$line->[0]} = $line->[1];
}
my @order;
if(ref $fields->[1]) {
@order = @{$fields->[1]};
}
else {
@order = sort keys %message;
}
for (@order) {
$body .= "$_: ";
if($message{$_} =~ s/\r?\n/\n/g) {
$body .= "\n$message{$_}\n";
}
else {
$body .= $message{$_};
}
$body .= "\n";
}
$body .= "$trailer->[0]: $trailer->[1]\n";
return $body;
}
sub tag_mail {
my($to, $opt, $body) = @_;
my($ok);
my @todo = (
qw/
From
To
Subject
Reply-To
Errors-To
/
);
my $abort;
my $check;
my $setsub = sub {
my $k = shift;
return if ! defined $CGI::values{"mv_email_$k"};
$abort = 1 if ! $::Scratch->{mv_email_enable};
$check = 1 if $::Scratch->{mv_email_enable};
return $CGI::values{"mv_email_$k"};
};
my @headers;
my %found;
unless($opt->{raw}) {
for my $header (@todo) {
logError("invalid email header: %s", $header)
if $header =~ /[^-\w]/;
my $key = lc $header;
$key =~ tr/-/_/;
my $val = $opt->{$key} || $setsub->($key);
if($key eq 'subject' and ! length($val) ) {
$val = errmsg('<no subject>');
}
next unless length $val;
$found{$key} = $val;
$val =~ s/^\s+//;
$val =~ s/\s+$//;
$val =~ s/[\r\n]+\s*(\S)/\n\t$1/g;
push @headers, "$header: $val";
}
unless($found{to} or $::Scratch->{mv_email_enable} =~ /\@/) {
return
error_opt($opt, "Refuse to send email message with no recipient.");
}
elsif (! $found{to}) {
$::Scratch->{mv_email_enable} =~ s/\s+/ /g;
$found{to} = $::Scratch->{mv_email_enable};
push @headers, "To: $::Scratch->{mv_email_enable}";
}
}
if($opt->{extra}) {
$opt->{extra} =~ s/^\s+//mg;
$opt->{extra} =~ s/\s+$//mg;
push @headers, grep /^\w[-\w]*:/, split /\n/, $opt->{extra};
}
$body ||= $setsub->('body');
unless($body) {
return error_opt($opt, "Refuse to send email message with no body.");
}
$body = format_auto_transmission($body) if ref $body;
push(@headers, '') if @headers;
return error_opt("mv_email_enable not set, required.") if $abort;
if($check and $found{to} ne $Scratch->{mv_email_enable}) {
return error_opt(
"mv_email_enable to address (%s) doesn't match enable (%s)",
$found{to},
$Scratch->{mv_email_enable},
);
}
SEND: {
$ok = send_mail(\@headers, $body);
}
if (!$ok) {
close MAIL;
$body = substr($body, 0, 2000) if length($body) > 2000;
return error_opt(
"Unable to send mail using %s\n%s",
$Vend::Cfg->{SendMailProgram},
join("\n", @headers, $body),
);
}
delete $Scratch->{mv_email_enable} if $check;
return if $opt->{hide};
return join("\n", @headers, $body) if $opt->{show};
return ($opt->{success} || $ok);
}
# Returns the text of a user entered field named VAR.
sub tag_value {
my($var,$opt) = @_;
#::logDebug("called value args=" . uneval(\@_));
local($^W) = 0;
my $vspace = $opt->{values_space};
my $vref;
if (defined $vspace) {
if ($vspace eq '') {
$vref = $Vend::Session->{values};
}
else {
$vref = $Vend::Session->{values_repository}{$vspace} ||= {};
}
}
else {
$vref = $::Values;
}
$vref->{$var} = $opt->{set} if defined $opt->{set};
my $value = defined $vref->{$var} ? $vref->{$var} : '';
$value =~ s/\[/&#91;/g unless $opt->{enable_itl};
if($opt->{filter}) {
$value = filter_value($opt->{filter}, $value, $var);
$vref->{$var} = $value unless $opt->{keep};
}
$::Scratch->{$var} = $value if $opt->{scratch};
return '' if $opt->{hide};
return $opt->{default} if ! $value and defined $opt->{default};
$value =~ s/</&lt;/g unless $opt->{enable_html};
return $value;
}
sub esc {
my $string = shift;
$string =~ s!(\W)!'%' . sprintf '%02x', ord($1)!eg;
return $string;
}
# Escapes a scan reliably in three different possible ways
sub escape_scan {
my ($scan, $ref) = @_;
#::logDebug("escape_scan: scan=$scan");
if (ref $scan) {
for(@$scan) {
my $add = '';
$_ = "se=$_" unless /[=\n]/;
$add .= "\nos=0" unless m{^\s*os=}m;
$add .= "\nne=0" unless m{^\s*ne=}m;
$add .= "\nop=rm" unless m{^\s*op=}m;
$add .= "\nbs=0" unless m{^\s*bs=}m;
$add .= "\nsf=*" unless m{^\s*sf=}m;
$add .= "\ncs=0" unless m{^\s*cs=}m;
$add .= "\nsg=0" unless m{^\s*sg=}m;
$add .= "\nnu=0" unless m{^\s*nu=}m;
$_ .= $add;
}
$scan = join "\n", @$scan;
$scan .= "\nco=yes" unless m{^\s*co=}m;
#::logDebug("escape_scan: scan=$scan");
}
if($scan =~ /^\s*(?:sq\s*=\s*)?select\s+/im) {
eval {
$scan = Vend::Scan::sql_statement($scan, $ref || \%CGI::values)
};
if($@) {
my $msg = errmsg("SQL query failed: %s\nquery was: %s", $@, $scan);
logError($msg);
$scan = 'se=BAD_SQL';
}
}
return join '/', 'scan', escape_mv('/', $scan);
}
sub escape_form {
my $val = shift;
$val =~ s/^\s+//mg;
$val =~ s/\s+$//mg;
## Already escaped, return
return $val if $val =~ /^\S+=\S+=\S*$/;
my @args = split /\n+/, $val;
for(@args) {
s/^(.*?=)(.+)/$1 . Vend::Util::unhexify($2)/ge;
}
for(@args) {
next if /^[\w=]+$/;
s!\0!-_NULL_-!g;
s!([^=]+)=(.*)!esc($1) . '=' . esc($2)!eg
or (undef $_, next);
}
return join $Global::UrlJoiner, grep length($_), @args;
}
sub escape_mv {
my ($joiner, $scan, $not_scan, $esc) = @_;
my @args;
if(index($scan, "\n") != -1) {
$scan =~ s/^\s+//mg;
$scan =~ s/\s+$//mg;
@args = split /\n+/, $scan;
}
elsif($scan =~ /&\w\w=/) {
@args = split /&/, $scan;
}
else {
$scan =~ s!::!__ESLASH__!g;
@args = split m:/:, $scan;
}
@args = grep $_, @args;
for(@args) {
s!/!__SLASH__!g unless defined $not_scan;
s!\0!-_NULL_-!g;
m!\w=!
or (undef $_, next);
s!__SLASH__!::!g unless defined $not_scan;
}
return join $joiner, grep(defined $_, @args);
}
PAGELINK: {
my ($urlroutine, $page, $arg, $opt);
sub tag_page {
my ($page, $arg, $opt) = @_;
my $url = tag_area(@_);
my $extra;
if($extra = ($opt ||= {})->{extra} || '') {
$extra =~ s/^(\w+)$/class=$1/;
$extra = " $extra";
}
return qq{<a href="$url"$extra>};
}
# Returns an href which will call up the specified PAGE.
sub tag_area {
($page, $arg, $opt) = @_;
$page = '' if ! defined $page;
if( $page and $opt->{alias}) {
my $aloc = $opt->{once} ? 'one_time_path_alias' : 'path_alias';
$Vend::Session->{$aloc}{$page} = {}
if not defined $Vend::Session->{path_alias}{$page};
$Vend::Session->{$aloc}{$page} = $opt->{alias};
}
my $r;
if ($opt->{search}) {
$page = escape_scan($opt->{search});
}
elsif ($page =~ /^[a-z][a-z]+:/) {
### Javascript or absolute link
return $page unless $opt->{form};
$page =~ s{(\w+://[^/]+)/}{}
or return $page;
my $intro = $1;
my @pieces = split m{/}, $page, 9999;
$page = pop(@pieces);
if(! length($page)) {
$page = pop(@pieces);
if(! length($page)) {
$r = $intro;
$r =~ s{/([^/]+)}{};
$page = "$1/";
}
else {
$page .= "/";
}
}
$r = join "/", $intro, @pieces unless $r;
$opt->{add_dot_html} = 0;
$opt->{no_session} = 1;
$opt->{secure} = 0;
$opt->{no_count} = 1;
}
elsif ($page eq 'scan') {
$page = escape_scan($arg);
undef $arg;
}
$urlroutine = $opt->{secure} ? \&secure_vendUrl : \&vendUrl;
return $urlroutine->($page, $arg, undef, $opt);
}
}
*form_link = \&tag_area;
# Sets the default shopping cart for display
sub tag_cart {
$Vend::CurrentCart = shift;
return '';
}
# Sets the discount namespace.
sub switch_discount_space {
my $dspace = shift || 'main';
if (! $Vend::Cfg->{DiscountSpacesOn}) {
$::Discounts
= $Vend::Session->{discount}
||= {};
return $Vend::DiscountSpaceName = 'main';
}
my $oldspace = $Vend::DiscountSpaceName || 'main';
#::logDebug("switch_discount_space: called for space '$dspace'; current space is $oldspace.");
unless ($Vend::Session->{discount} and $Vend::Session->{discount_space}) {
$::Discounts
= $Vend::Session->{discount}
= $Vend::Session->{discount_space}{main}
||= ($Vend::Session->{discount} || {});
$Vend::DiscountSpaceName = 'main';
#::logDebug('switch_discount_space: initialized discount space hash.');
}
if ($dspace ne $oldspace) {
$::Discounts
= $Vend::Session->{discount}
= $Vend::Session->{discount_space}{$Vend::DiscountSpaceName = $dspace}
||= {};
#::logDebug("switch_discount_space: changed discount space from '$oldspace' to '$Vend::DiscountSpaceName'");
}
else {
# Make certain the hash is set, in case app programmer manipulated the session directly.
$::Discounts
= $Vend::Session->{discount}
= $Vend::Session->{discount_space}{$Vend::DiscountSpaceName}
unless ref $::Discounts eq 'HASH';
}
return $oldspace;
}
sub tag_calc {
my($body) = @_;
my $result;
if($Vend::NoInterpolate) {
logGlobal({ level => 'alert' },
"Attempt to interpolate perl/ITL from RPC, no permissions."
);
}
$Items = $Vend::Items;
if($MVSAFE::Safe) {
$result = eval($body);
}
else {
init_calc() if ! $Vend::Calc_initialized;
$result = $ready_safe->reval($body);
}
if ($@) {
my $msg = $@;
$Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
logError("Safe: %s\n%s\n" , $msg, $body);
return $MVSAFE::Safe ? '' : 0;
}
return $result;
}
sub tag_unless {
return tag_self_contained_if(@_, 1) if defined $_[4];
return tag_if(@_, 1);
}
sub tag_self_contained_if {
my($base, $term, $operator, $comp, $body, $negate) = @_;
my ($else,$elsif,@addl);
local($^W) = 0;
#::logDebug("self_if: base=$base term=$term op=$operator comp=$comp");
if ($body =~ s#$QR{condition_begin}##) {
$comp = $1;
}
#::logDebug("self_if: base=$base term=$term op=$operator comp=$comp");
if ( $body =~ /\[[EeTtAaOo][hHLlNnRr][SsEeDd\s]/ ) {
($body, $elsif, $else, @addl) = split_if($body);
}
#::logDebug("Additional ops found:\n" . join("\n", @addl) ) if @addl;
unless(defined $operator || defined $comp) {
$comp = '';
undef $operator;
undef $comp;
}
($base =~ s/^\W+// or $base = "!$base") if $negate;
my $status = conditional ($base, $term, $operator, $comp, @addl);
my $out;
if($status) {
$out = $body;
}
elsif ($elsif) {
$else = '[else]' . $else . '[/else]' if length $else;
$elsif =~ s#(.*?)$QR{'/elsif'}(.*)#$1${2}[/elsif]#s;
$out = '[if ' . $elsif . $else . '[/if]';
}
elsif (length $else) {
$out = $else;
}
else {
return '';
}
return $out;
}
sub pull_cond {
my($string, $reverse, $cond, $lhs) = @_;
#::logDebug("pull_cond string='$string' rev='$reverse' cond='$cond' lhs='$lhs'");
my ($op, $rhs) = split /\s+/, $cond, 2;
$rhs =~ s/^(["'])(.*)\1$/$2/;
if(! defined $cond_op{$op} ) {
logError("bad conditional operator %s in if-PREFIX-data", $op);
return pull_else($string, $reverse);
}
return $cond_op{$op}->($lhs, $rhs)
? pull_if($string, $reverse)
: pull_else($string, $reverse);
}
sub pull_if {
return pull_cond(@_) if $_[2];
my($string, $reverse) = @_;
return pull_else($string) if $reverse;
find_matching_else(\$string) if $string =~ s:$QR{has_else}::;
return $string;
}
sub pull_else {
return pull_cond(@_) if $_[2];
my($string, $reverse) = @_;
return pull_if($string) if $reverse;
return find_matching_else(\$string) if $string =~ s:$QR{has_else}::;
return;
}
## ORDER PAGE
my (@Opts);
my (@Flds);
my %Sort = (
'' => sub { $_[0] cmp $_[1] },
none => sub { $_[0] cmp $_[1] },
f => sub { (lc $_[0]) cmp (lc $_[1]) },
fr => sub { (lc $_[1]) cmp (lc $_[0]) },
l => sub {
my ($a1,$a2) = split /[,.]/, $_[0], 2;
my ($b1,$b2) = split /[,.]/, $_[1], 2;
return $a1 <=> $b1 || $a2 <=> $b2;
},
lr => sub {
my ($a1,$a2) = split /[,.]/, $_[0], 2;
my ($b1,$b2) = split /[,.]/, $_[1], 2;
return $b1 <=> $a1 || $b2 <=> $a2;
},
n => sub { $_[0] <=> $_[1] },
nr => sub { $_[1] <=> $_[0] },
r => sub { $_[1] cmp $_[0] },
);
@Sort{qw/rf rl rn/} = @Sort{qw/fr lr nr/};
use vars qw/%Sort_field/;
%Sort_field = %Sort;
sub tag_sort_ary {
my($opts, $list) = (@_);
$opts =~ s/^\s+//;
$opts =~ s/\s+$//;
#::logDebug("tag_sort_ary: opts=$opts list=" . uneval($list));
my @codes;
my $key = 0;
my ($start, $end, $num);
my $glob_opt = 'none';
my @opts = split /\s+/, $opts;
my @option; my @bases; my @fields;
for(@opts) {
my ($base, $fld, $opt) = split /:/, $_;
if($base =~ /^(\d+)$/) {
$key = $1;
$glob_opt = $fld || $opt || 'none';
next;
}
if($base =~ /^([-=+])(\d+)-?(\d*)/) {
my $op = $1;
if ($op eq '-') { $start = $2 }
elsif ($op eq '+') { $num = $2 }
elsif ($op eq '=') {
$start = $2;
$end = ($3 || undef);
}
next;
}
push @bases, $base;
push @fields, $fld;
push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none');
}
if(defined $end) {
$num = 1 + $end - $start;
$num = undef if $num < 1;
}
my $i;
my $routine = 'sub { ';
for( $i = 0; $i < @bases; $i++) {
$routine .= '&{$Vend::Interpolate::Sort_field{"' .
$option[$i] .
'"}}(' . "\n";
$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->[$key]),\n";
$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->[$key]) ) or ";
}
$routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!;
$routine .= '($_[0]->[$key],$_[1]->[$key]); }';
#::logDebug("tag_sort_ary routine: $routine\n");
my $code = eval $routine;
die "Bad sort routine\n" if $@;
#Prime the sort? Prevent variable suicide??
#&{$Vend::Interpolate::Sort_field{'n'}}('31', '30');
use locale;
if($::Scratch->{mv_locale}) {
POSIX::setlocale(POSIX::LC_COLLATE(),
$::Scratch->{mv_locale});
}
@codes = sort {&$code($a, $b)} @$list;
if($start > 1) {
splice(@codes, 0, $start - 1);
}
if(defined $num) {
splice(@codes, $num);
}
#::logDebug("tag_sort_ary routine returns: " . uneval(\@codes));
return \@codes;
}
sub tag_sort_hash {
my($opts, $list) = (@_);
$opts =~ s/^\s+//;
$opts =~ s/\s+$//;
#::logDebug("tag_sort_hash: opts=$opts list=" . uneval($list));
my @codes;
my $key = 'code';
my ($start, $end, $num);
my $glob_opt = 'none';
my @opts = split /\s+/, $opts;
my @option; my @bases; my @fields;
for(@opts) {
if(/^(\w+)(:([flnr]+))?$/) {
$key = $1;
$glob_opt = $3 || 'none';
next;
}
if(/^([-=+])(\d+)-?(\d*)/) {
my $op = $1;
if ($op eq '-') { $start = $2 }
elsif ($op eq '+') { $num = $2 }
elsif ($op eq '=') {
$start = $2;
$end = ($3 || undef);
}
next;
}
my ($base, $fld, $opt) = split /:/, $_;
push @bases, $base;
push @fields, $fld;
push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none');
}
if(defined $end) {
$num = 1 + $end - $start;
$num = undef if $num < 1;
}
if (! defined $list->[0]->{$key}) {
logError("sort key '$key' not defined in list. Skipping sort.");
return $list;
}
my $i;
my $routine = 'sub { ';
for( $i = 0; $i < @bases; $i++) {
$routine .= '&{$Vend::Interpolate::Sort_field{"' .
$option[$i] .
'"}}(' . "\n";
$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->{$key}),\n";
$routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->{$key}) ) or ";
}
$routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!;
$routine .= '($a->{$key},$_[1]->{$key}); }';
#::logDebug("tag_sort_hash routine: $routine\n");
my $code = eval $routine;
die "Bad sort routine\n" if $@;
#Prime the sort? Prevent variable suicide??
#&{$Vend::Interpolate::Sort_field{'n'}}('31', '30');
use locale;
if($::Scratch->{mv_locale}) {
POSIX::setlocale(POSIX::LC_COLLATE(),
$::Scratch->{mv_locale});
}
@codes = sort {&$code($a,$b)} @$list;
if($start > 1) {
splice(@codes, 0, $start - 1);
}
if(defined $num) {
splice(@codes, $num);
}
#::logDebug("tag_sort_hash routine returns: " . uneval(\@codes));
return \@codes;
}
my %Prev;
sub check_change {
my($name, $value, $text, $substr) = @_;
# $value is case-sensitive flag if passed text;
if(defined $text) {
$text =~ s:$QR{condition}::;
$value = $value ? lc $1 : $1;
}
$value = substr($value, 0, $substr) if $substr;
my $prev = $Prev{$name};
$Prev{$name} = $value;
if(defined $text) {
return pull_if($text) if ! defined $prev or $value ne $prev;
return pull_else($text);
}
return 1 unless defined $prev;
return $value eq $prev ? 0 : 1;
}
sub list_compat {
my $prefix = shift;
my $textref = shift;
$$textref =~ s:\[quantity[-_]name:[$prefix-quantity-name:gi;
$$textref =~ s:\[modifier[-_]name\s:[$prefix-modifier-name :gi;
$$textref =~ s:\[if[-_]data\s:[if-$prefix-data :gi
and $$textref =~ s:\[/if[-_]data\]:[/if-$prefix-data]:gi;
$$textref =~ s:\[if[-_]modifier\s:[if-$prefix-param :gi
and $$textref =~ s:\[/if[-_]modifier\]:[/if-$prefix-param]:gi;
$$textref =~ s:\[if[-_]field\s:[if-$prefix-field :gi
and $$textref =~ s:\[/if[-_]field\]:[/if-$prefix-field]:gi;
$$textref =~ s:\[on[-_]change\s:[$prefix-change :gi
and $$textref =~ s:\[/on[-_]change\s:[/$prefix-change :gi;
return;
}
sub tag_search_region {
my($params, $opt, $text) = @_;
$opt->{search} = $params if $params;
$opt->{prefix} ||= 'item';
$opt->{list_prefix} ||= 'search[-_]list';
# LEGACY
list_compat($opt->{prefix}, \$text) if $text;
# END LEGACY
return region($opt, $text);
}
sub find_sort {
my($text) = @_;
return undef unless defined $$text and $$text =~ s#\[sort(([\s\]])[\000-\377]+)#$1#io;
my $options = find_close_square($$text);
$$text = substr( $$text,length($options) + 1 )
if defined $options;
$options = interpolate_html($options) if index($options, '[') != -1;
return $options || '';
}
# Artificial for better variable passing
{
my( $next_anchor,
$prev_anchor,
$page_anchor,
$border,
$border_selected,
$opt,
$r,
$chunk,
$perm,
$total,
$current,
$page,
$prefix,
$more_id,
$session,
$link_template,
);
sub more_link_template {
my ($anchor, $arg, $form_arg) = @_;
my $url = tag_area("scan/MM=$arg", '', {
form => $form_arg,
secure => $CGI::secure,
});
my $lt = $link_template;
$lt =~ s/\$URL\$/$url/g;
$lt =~ s/\$ANCHOR\$/$anchor/g;
return $lt;
}
sub more_link {
my($inc, $pa) = @_;
my ($next, $last, $arg);
my $list = '';
$pa =~ s/__PAGE__/$inc/g;
my $form_arg = "mv_more_ip=1\nmv_nextpage=$page";
$form_arg .= "\npf=$prefix" if $prefix;
$form_arg .= "\n$opt->{form}" if $opt->{form};
$form_arg .= "\nmi=$more_id" if $more_id;
$next = ($inc-1) * $chunk;
#::logDebug("more_link: inc=$inc current=$current");
$last = $next + $chunk - 1;
$last = ($last+1) < $total ? $last : ($total - 1);
$pa =~ s/__PAGE__/$inc/g;
$pa =~ s/__MINPAGE__/$next + 1/eg;
$pa =~ s/__MAXPAGE__/$last + 1/eg;
if($inc == $current) {
$pa =~ s/__BORDER__/$border_selected || $border || ''/e;
$list .= qq|<strong>$pa</strong> | ;
}
else {
$pa =~ s/__BORDER__/$border/e;
$arg = "$session:$next:$last:$chunk$perm";
$list .= more_link_template($pa, $arg, $form_arg) . ' ';
}
return $list;
}
sub tag_more_list {
(
$next_anchor,
$prev_anchor,
$page_anchor,
$border,
$border_selected,
$opt,
$r,
) = @_;
#::logDebug("more_list: opt=$opt label=$opt->{label}");
return undef if ! $opt;
$q = $opt->{object} || $::Instance->{SearchObject}{$opt->{label}};
return '' unless $q->{matches} > $q->{mv_matchlimit}
and $q->{mv_matchlimit} > 0;
my($arg,$inc,$last,$m);
my($adder,$pages);
my($first_anchor,$last_anchor);
my $next_tag = '';
my $list = '';
$session = $q->{mv_cache_key};
my $first = $q->{mv_first_match} || 0;
$chunk = $q->{mv_matchlimit};
$perm = $q->{mv_more_permanent} ? ':1' : '';
$total = $q->{matches};
my $next = defined $q->{mv_next_pointer}
? $q->{mv_next_pointer}
: $first + $chunk;
$page = $q->{mv_search_page} || $Global::Variable->{MV_PAGE};
$prefix = $q->{prefix} || '';
my $form_arg = "mv_more_ip=1\nmv_nextpage=$page";
$form_arg .= "\npf=$q->{prefix}" if $q->{prefix};
$form_arg .= "\n$opt->{form}" if $opt->{form};
if($q->{mv_more_id}) {
$more_id = $q->{mv_more_id};
$form_arg .= "\nmi=$more_id";
}
else {
$more_id = undef;
}
if($r =~ s:\[border\]($All)\[/border\]::i) {
$border = $1;
$border =~ s/\D//g;
}
if($r =~ s:\[border[-_]selected\]($All)\[/border[-_]selected\]::i) {
$border = $1;
$border =~ s/\D//g;
}
undef $link_template;
$r =~ s:\[link[-_]template\]($All)\[/link[-_]template\]::i
and $link_template = $1;
$link_template ||= q{<a href="$URL$">$ANCHOR$</a>};
if(! $chunk or $chunk >= $total) {
return '';
}
$border = qq{ border="$border"} if defined $border;
$border_selected = qq{ border="$border_selected"}
if defined $border_selected;
$adder = ($total % $chunk) ? 1 : 0;
$pages = int($total / $chunk) + $adder;
$current = int($next / $chunk) || $pages;
if($first) {
$first = 0 if $first < 0;
# First link may appear when prev link is valid
if($r =~ s:\[first[-_]anchor\]($All)\[/first[-_]anchor\]::i) {
$first_anchor = $1;
}
else {
$first_anchor = errmsg('First');
}
unless ($first_anchor eq 'none') {
$arg = $session;
$arg .= ':0:';
$arg .= $chunk - 1;
$arg .= ":$chunk$perm";
$list .= more_link_template($first_anchor, $arg, $form_arg) . ' ';
}
unless ($prev_anchor) {
if($r =~ s:\[prev[-_]anchor\]($All)\[/prev[-_]anchor\]::i) {
$prev_anchor = $1;
}
else {