[interchange-cvs] interchange - heins modified 182 files
interchange-core@interchange.redhat.com
interchange-core@interchange.redhat.com
Tue Jan 29 08:54:01 2002
User: heins
Date: 2002-01-29 05:52:43 GMT
Modified: lib/Vend Config.pm Interpolate.pm Order.pm Parse.pm Util.pm
Added: code/ActionMap foo.am
Added: code/Filter lc.filter
Added: code/SystemTag accessories.coretag area.coretag
Added: assign.coretag attr_list.coretag banner.coretag
Added: calc.coretag cart.coretag catch.coretag cgi.coretag
Added: charge.coretag checked.coretag control.coretag
Added: control_set.coretag counter.coretag
Added: currency.coretag data.coretag default.coretag
Added: description.coretag discount.coretag dump.coretag
Added: ecml.coretag either.coretag error.coretag
Added: export.coretag field.coretag file.coretag
Added: filter.coretag flag.coretag fly_list.coretag
Added: fly_tax.coretag handling.coretag harness.coretag
Added: html_table.coretag import.coretag include.coretag
Added: index.coretag input_filter.coretag
Added: item_list.coretag log.coretag loop.coretag
Added: mail.coretag msg.coretag mvasp.coretag
Added: nitems.coretag onfly.coretag options.coretag
Added: order.coretag page.coretag perl.coretag
Added: price.coretag process.coretag profile.coretag
Added: query.coretag read_cookie.coretag record.coretag
Added: region.coretag row.coretag salestax.coretag
Added: scratch.coretag scratchd.coretag
Added: search_region.coretag selected.coretag set.coretag
Added: set_cookie.coretag seti.coretag setlocale.coretag
Added: shipping.coretag shipping_desc.coretag soap.coretag
Added: sql.coretag strip.coretag subtotal.coretag
Added: tag.coretag time.coretag timed_build.coretag
Added: tmp.coretag total_cost.coretag tree.coretag
Added: try.coretag update.coretag userdb.coretag
Added: value.coretag value_extended.coretag
Added: warnings.coretag
Added: code/UI_Tag add_gpg_key.coretag
Added: available_ups_internal.coretag
Added: available_www_shipping.coretag
Added: backup_database.coretag backup_file.coretag
Added: base_url.coretag check_upload.coretag
Added: component_editor.coretag cp.coretag crypt.coretag
Added: db_columns.coretag db_hash.coretag dbinfo.coretag
Added: diff.coretag diffmerge.coretag
Added: directive_value.coretag display.coretag
Added: dump_session.coretag e.coretag
Added: export_database.coretag file_info.coretag
Added: file_navigator.coretag filters.coretag
Added: get_gpg_keys.coretag global_value.coretag
Added: grep_mm.coretag if_key_exists.coretag if_mm.coretag
Added: if_sql.coretag image_collate.coretag
Added: import_fields.coretag list_databases.coretag
Added: list_glob.coretag list_keys.coretag
Added: list_pages.coretag load_templates.coretag
Added: meta_record.coretag mm_locale.coretag
Added: mm_value.coretag newer.coretag quick_table.coretag
Added: read_page.coretag read_shipping.coretag
Added: read_ui_page.coretag read_ui_template.coretag
Added: reconfig.coretag reconfig_time.coretag
Added: reconfig_wait.coretag regenerate.coretag
Added: return_to.coretag rotate_file.coretag
Added: rotate_table.coretag row_edit.coretag
Added: run_profile.coretag set_alias.coretag
Added: substitute_file.coretag table_editor.coretag
Added: uneval.coretag unlink_file.coretag version.coretag
Added: widget.coretag with.coretag write_page.coretag
Added: write_relative_file.coretag write_shipping.coretag
Added: code/UserTag bar_button.tag button.tag convert_date.tag
Added: db_date.tag delete_cart.tag email.tag email_raw.tag
Added: env.tag fcounter.tag fedex_query.tag formel.tag
Added: fortune.tag get_url.tag history_scan.tag image.tag
Added: load_cart.tag loc.tag rand.tag save_cart.tag
Added: summary.tag table_organize.tag title_bar.tag
Added: ups_query.tag usertrack.tag var.tag
Added: xml_generator.tag
Log:
* The great tag breakout!
* Almost all tags are now UserTag definitions. The only exceptions
are:
and bounce goto if label or unless
* New TagDir directive (default is VENDROOT/code) sets the
directory (or directories) which are searched for code definitions
set by UserTag and CodeDef.
* New TagGroup directive establishes groups of ITL tags which can
be included.
TagGroup :crufty "banner default ecml html_table onfly sql"
The default groups include :core, which contains all of the
ITL tags defined in 4.8/early 4.9. The groups are defined
in $Vend::Cfg::StdTags and can be undefined if desired
with "TagGroup :group".
* New TagInclude directive allows inclusion of tags (or groups
of tags). If a tag is defined as a core tag (with a .coretag
or .tag or .ct extension) and is not included, it will not
be compiled and placed in the tag map. This is for all catalogs,
so if *any* catalog uses a tag it must be included.
Examples:
# Include the base tags
TagInclude :core
# Not the commerce tags
TagInclude !:commerce
# But make sure item-list is included even though
# it is in :commerce
TagInclude item-list
## Double negatives are honored
TagGroup :foo "bar !baz buz"
## With the group above, the below is equivalent
## to TagInclude !bar baz !buz
TagInclude !:foo
* New CodeDef directive allows the setting of filters,
order checks, FormAction, ActionMap, ItemAction,
and LocaleChange.
## filters
CodeDef mixedcase Filter
CodeDef mixedcase Routine <<EOR
sub {
my $val = shift;
## [filter mixedcase]mixed case[/filter]
## outputs "MiXeD CaSe"
$val =~ s/(.)(.)/\u$1\l$2/g;
return $val;
}
EOR
## order checks
CodeDef mixedcase OrderCheck
CodeDef foo Routine <<EOR
sub {
my ($ref, $var, $val) = @_;
return (1,$var) if $val eq 'bar';
return (0,$var, "foo must be bar");
}
EOR
All work in catalog.cfg; LocaleChange and ItemAction are not
global. FormAction, ActionMap, and ItemAction directives
are equivalent to their CodeDef equivalents.
Revision Changes Path
1.1 interchange/code/ActionMap/foo.am
rev 1.1, prev_rev 1.0
Index: foo.am
===================================================================
CodeDef foo ActionMap
CodeDef foo Routine <<EOR
sub {
$CGI->{mv_nextpage} = 'aboutus';
}
EOR
1.1 interchange/code/Filter/lc.filter
rev 1.1, prev_rev 1.0
Index: lc.filter
===================================================================
CodeDef lc Filter
CodeDef lc Routine <<EOR
sub {
use locale;
return lc(shift);
}
EOR
1.1 interchange/code/SystemTag/accessories.coretag
rev 1.1, prev_rev 1.0
Index: accessories.coretag
===================================================================
UserTag accessories Order code arg
UserTag accessories addAttr
UserTag accessories attrAlias db table
UserTag accessories attrAlias base table
UserTag accessories attrAlias database table
UserTag accessories attrAlias col column
UserTag accessories attrAlias row code
UserTag accessories attrAlias field column
UserTag accessories attrAlias key code
UserTag accessories PosNumber 2
UserTag accessories MapRoutine Vend::Interpolate::tag_accessories
1.1 interchange/code/SystemTag/area.coretag
rev 1.1, prev_rev 1.0
Index: area.coretag
===================================================================
UserTag area Order href arg
UserTag area addAttr
UserTag area Implicit secure secure
UserTag area PosNumber 2
UserTag area replaceAttr form action
UserTag area replaceAttr a href
UserTag area MapRoutine Vend::Interpolate::tag_area
1.1 interchange/code/SystemTag/assign.coretag
rev 1.1, prev_rev 1.0
Index: assign.coretag
===================================================================
UserTag assign addAttr
UserTag assign PosNumber 0
UserTag assign Routine <<EOR
my %_assignable = (qw/
salestax 1
shipping 1
handling 1
subtotal 1
/);
sub {
my ($opt) = @_;
if($opt->{clear}) {
delete $Vend::Session->{assigned};
return;
}
$Vend::Session->{assigned} ||= {};
for(keys %$opt) {
next unless $_assignable{$_};
my $value = $opt->{$_};
$value =~ s/^\s+//;
$value =~ s/\s+$//;
if($value =~ /^-?\d+\.?\d*$/) {
$Vend::Session->{assigned}{$_} = $value;
}
else {
logError(
"Attempted assign of non-numeric '%s' to %s. Deleted.",
$value,
$_,
);
delete $Vend::Session->{assigned}{$_};
}
}
return;
}
EOR
1.1 interchange/code/SystemTag/attr_list.coretag
rev 1.1, prev_rev 1.0
Index: attr_list.coretag
===================================================================
UserTag attr-list Order hash
UserTag attr-list hasEndTag
UserTag attr-list PosNumber 1
UserTag attr-list MapRoutine Vend::Interpolate::tag_attr_list
1.1 interchange/code/SystemTag/banner.coretag
rev 1.1, prev_rev 1.0
Index: banner.coretag
===================================================================
UserTag banner Order category
UserTag banner addAttr
UserTag banner PosNumber 1
UserTag banner Routine <<EOR
sub {
my ($place, $opt) = @_;
sub tag_weighted_banner {
my ($category, $opt) = @_;
my $dir = catfile($Vend::Cfg->{ScratchDir}, 'Banners');
mkdir $dir, 0777 if ! -d $dir;
if($category) {
my $c = $category;
$c =~ s/\W//g;
$dir .= "/$c";
}
my $statfile = $Vend::Cfg->{ConfDir};
$statfile .= "/status.$Vend::Cat";
my $start_time;
if($opt->{once}) {
$start_time = 0;
}
elsif(! -f $statfile) {
Vend::Util::writefile( $statfile, "banners initialized " . time() . "\n");
$start_time = time();
}
else {
$start_time = (stat(_))[9];
}
my $weight_file = "$dir/total_weight";
initialize_banner_directory($dir, $category, $opt)
if (
! -f $weight_file
or
(stat(_))[9] < $start_time
);
my $n = int( rand( readfile($weight_file) ) );
return Vend::Util::readfile("$dir/$n");
}
return tag_weighted_banner($place, $opt) if $opt->{weighted};
my $table = $opt->{table} || 'banner';
my $r_field = $opt->{r_field} || 'rotate';
my $b_field = $opt->{b_field} || 'banner';
my $sep = $opt->{separator} || ':';
my $delim = $opt->{delimiter} || "{or}";
$place = 'default' if ! $place;
my $totrot;
do {
my $banner_data;
$totrot = tag_data($table, $r_field, $place);
if(! length $totrot) {
# No banner present
unless ($place =~ /$sep/ or $place eq 'default') {
$place = 'default';
redo;
}
}
elsif ($totrot) {
my $current = $::Scratch->{"rotate_$place"}++ || 0;
my $data = tag_data($table, $b_field, $place);
my(@banners) = split /\Q$delim/, $data;
return '' unless @banners;
return $banners[$current % scalar(@banners)];
}
else {
return tag_data($table, $b_field, $place);
}
} while $place =~ s/(.*)$sep.*/$1/;
return;
}
EOR
1.1 interchange/code/SystemTag/calc.coretag
rev 1.1, prev_rev 1.0
Index: calc.coretag
===================================================================
UserTag calc hasEndTag
UserTag calc Interpolate
UserTag calc MapRoutine Vend::Interpolate::tag_calc
1.1 interchange/code/SystemTag/cart.coretag
rev 1.1, prev_rev 1.0
Index: cart.coretag
===================================================================
UserTag cart Order name
UserTag cart InvalidateCache
UserTag cart PosNumber 1
UserTag cart MapRoutine Vend::Interpolate::tag_cart
1.1 interchange/code/SystemTag/catch.coretag
rev 1.1, prev_rev 1.0
Index: catch.coretag
===================================================================
UserTag catch Order label
UserTag catch addAttr
UserTag catch hasEndTag
#UserTag catch Test <<EOT
#EOT
UserTag catch Routine <<EOR
sub {
my ($label, $opt, $body) = @_;
$label = 'default' unless $label;
my $patt;
return pull_else($body)
unless $patt = $Vend::Session->{try}{$label};
$body = pull_if($body);
if ( $opt->{exact} ) {
#----------------------------------------------------------------
# Convert multiple errors to 'or' list and compile it.
# Note also the " at (eval ...)" kludge to strip the line numbers
$patt =~ s/(?: +at +\(eval .+\).+)?\n\s*/|/g;
$patt =~ s/^\s*//;
$patt =~ s/\|$//;
$patt = qr($patt);
#----------------------------------------------------------------
}
my $found;
while ($body =~ s{
\[/
(.+?)
/\]
(.*?)
\[/
(?:\1)?/?
\]}{}sx ) {
my $re;
my $error = $2;
eval {
$re = qr{$1}
};
next if $@;
next unless $patt =~ $re;
$found = $error;
last;
}
$body = $found if $found;
$body =~ s/\s+$//;
$body =~ s/^\s+//;
return $body;
}
EOR
1.1 interchange/code/SystemTag/cgi.coretag
rev 1.1, prev_rev 1.0
Index: cgi.coretag
===================================================================
UserTag cgi Order name
UserTag cgi addAttr
UserTag cgi InvalidateCache
UserTag cgi PosNumber 1
UserTag cgi Routine <<EOR
sub {
my($var, $opt) = @_;
my($value);
local($^W) = 0;
$CGI::values{$var} = $opt->{set} if defined $opt->{set};
$value = defined $CGI::values{$var} ? ($CGI::values{$var}) : '';
if ($value) {
# Eliminate any Interchange tags
$value =~ s~<([A-Za-z]*[^>]*\s+[Mm][Vv]\s*=\s*)~<$1~g;
$value =~ s/\[/[/g;
}
if($opt->{filter}) {
$value = filter_value($opt->{filter}, $value, $var);
$CGI::values{$var} = $value unless $opt->{keep};
}
return '' if $opt->{hide};
$value =~ s/</</g
unless $opt->{enable_html};
return $value;
}
EOR
1.1 interchange/code/SystemTag/charge.coretag
rev 1.1, prev_rev 1.0
Index: charge.coretag
===================================================================
UserTag charge Order route
UserTag charge addAttr
UserTag charge InvalidateCache
UserTag charge PosNumber 1
UserTag charge MapRoutine Vend::Payment::charge
1.1 interchange/code/SystemTag/checked.coretag
rev 1.1, prev_rev 1.0
Index: checked.coretag
===================================================================
UserTag checked Order name value
UserTag checked addAttr
UserTag checked Implicit multiple multiple
UserTag checked Implicit default default
UserTag checked InvalidateCache
UserTag checked PosNumber 2
UserTag checked replaceAttr input checked
UserTag checked Routine <<EOR
sub {
my ($field,$value,$opt) = @_;
$value = 'on' unless defined $value;
my $ref = $opt->{cgi} ? $CGI::values{$field} : $::Values->{$field};
return 'CHECKED' if ! length($ref) and $opt->{default};
if(! $opt->{case}) {
$ref = lc($ref);
$value = lc($value);
}
return 'CHECKED' if $ref eq $value;
if ($opt->{multiple}) {
my $regex = quotemeta $value;
return 'CHECKED' if $ref =~ /(?:^|\0)$regex(?:$|\0)/i;
}
return '';
}
EOR
1.1 interchange/code/SystemTag/control.coretag
rev 1.1, prev_rev 1.0
Index: control.coretag
===================================================================
UserTag control Order name default
UserTag control addAttr
UserTag control PosNumber 2
UserTag control Routine <<EOR
sub {
my ($name, $default, $opt) = @_;
use vars qw/$Tmp/;
if(! $name) {
# Here we either reset the index or increment it
# Done this way for speed, no blocks to enter other than top one
if($opt->{space}) {
$::Control = $Tmp->{$opt->{space}} ||= [];
return set_tmp('control_index', 0);
}
else {
($::Scratch->{control_index} = 0, return) if $opt->{reset};
return set_tmp('control_index', ++$::Scratch->{control_index});
}
}
$name = lc $name;
$name =~ s/-/_/g;
$opt ||= {};
if (! defined $default and $opt->{set}) {
$::Control->[$::Scratch->{control_index}]{$name} = $::Scratch->{$name};
return;
}
return defined $::Control->[$::Scratch->{control_index}]{$name}
? ( $::Control->[$::Scratch->{control_index}]{$name} || $default )
: ( length($::Scratch->{$name}) ? ($::Scratch->{$name}) : $default )
}
EOR
1.1 interchange/code/SystemTag/control_set.coretag
rev 1.1, prev_rev 1.0
Index: control_set.coretag
===================================================================
UserTag control-set Order index
UserTag control-set addAttr
UserTag control-set hasEndTag
UserTag control-set PosNumber 1
UserTag control-set Routine <<EOR
# Batch sets a set of controls without affecting Scratch
# Increments the index afterwards unless index is defined
sub {
my ($index, $opt, $body) = @_;
my $inc;
unless($index) {
$index = $::Scratch->{control_index} || 0;
$inc = 1;
}
while($body =~ m{\[([-\w]+)\](.*)\[/\1\]}sg) {
my $name = lc $1;
my $val = $2;
$name =~ s/-/_/g;
$::Control->[$index]{$name} = $val;
}
$::Scratch->{control_index}++;
return;
}
EOR
1.1 interchange/code/SystemTag/counter.coretag
rev 1.1, prev_rev 1.0
Index: counter.coretag
===================================================================
UserTag counter Order file
UserTag counter addAttr
UserTag counter attrAlias name file
UserTag counter InvalidateCache
UserTag counter PosNumber 1
UserTag counter MapRoutine Vend::Interpolate::tag_counter
1.1 interchange/code/SystemTag/currency.coretag
rev 1.1, prev_rev 1.0
Index: currency.coretag
===================================================================
UserTag currency Order convert noformat
UserTag currency hasEndTag
UserTag currency Interpolate
UserTag currency PosNumber 2
UserTag currency Routine <<EOR
sub {
my($convert,$noformat,$amount) = @_;
return Vend::Util::currency($amount, $noformat, $convert);
}
EOR
1.1 interchange/code/SystemTag/data.coretag
rev 1.1, prev_rev 1.0
Index: data.coretag
===================================================================
UserTag data Order table field key
UserTag data addAttr
UserTag data attrAlias column field
UserTag data attrAlias code key
UserTag data attrAlias base table
UserTag data attrAlias database table
UserTag data attrAlias col field
UserTag data attrAlias row key
UserTag data attrAlias name field
UserTag data Implicit increment increment
UserTag data PosNumber 3
UserTag data MapRoutine Vend::Interpolate::tag_data
1.1 interchange/code/SystemTag/default.coretag
rev 1.1, prev_rev 1.0
Index: default.coretag
===================================================================
UserTag default Order name default
UserTag default addAttr
UserTag default InvalidateCache
UserTag default PosNumber 2
UserTag default Routine <<EOR
# Returns the text of a user entered field named VAR.
# Same as tag [value name=name default="string"] except
# returns 'default' if not present
sub {
my($var, $default, $opt) = @_;
$opt->{default} = !(length $default) ? 'default' : $default;
return tag_value($var, $opt);
}
EOR
1.1 interchange/code/SystemTag/description.coretag
rev 1.1, prev_rev 1.0
Index: description.coretag
===================================================================
UserTag description Order code base
UserTag description PosNumber 2
UserTag description MapRoutine Vend::Data::product_description
1.1 interchange/code/SystemTag/discount.coretag
rev 1.1, prev_rev 1.0
Index: discount.coretag
===================================================================
UserTag discount Order code
UserTag discount hasEndTag
UserTag discount InvalidateCache
UserTag discount PosNumber 1
UserTag discount Routine <<EOR
# Sets the value of a discount field
sub {
my($code, $opt, $value) = @_;
# API compatibility
if(! ref $opt) {
$value = $opt;
$opt = {};
}
if($opt->{subtract}) {
$value = <<EOF;
my \$tmp = \$s - $opt->{subtract};
\$tmp = 0 if \$tmp < 0;
return \$tmp;
EOF
}
elsif ($opt->{level}) {
$value = <<EOF;
return (\$s * \$q) if \$q < $opt->{level};
my \$tmp = \$s / \$q;
return \$s - \$tmp;
EOF
}
$Vend::Session->{discount}{$code} = $value;
delete $Vend::Session->{discount}->{$code}
unless (defined $value and $value);
return '';
}
EOR
1.1 interchange/code/SystemTag/dump.coretag
rev 1.1, prev_rev 1.0
Index: dump.coretag
===================================================================
UserTag dump Order key
UserTag dump PosNumber 1
UserTag dump MapRoutine ::full_dump
1.1 interchange/code/SystemTag/ecml.coretag
rev 1.1, prev_rev 1.0
Index: ecml.coretag
===================================================================
UserTag ecml Order name function
UserTag ecml addAttr
UserTag ecml PosNumber 2
UserTag ecml Routine <<EOR
sub {
require Vend::ECML;
return Vend::ECML::ecml(@_);
}
EOR
1.1 interchange/code/SystemTag/either.coretag
rev 1.1, prev_rev 1.0
Index: either.coretag
===================================================================
UserTag either hasEndTag
UserTag either PosNumber 0
UserTag either Routine <<EOR
sub {
my @ary = split /\[or\]/, shift;
my $result;
while(@ary) {
$result = interpolate_html(shift @ary);
$result =~ s/^\s+//;
$result =~ s/\s+$//;
return $result if $result;
}
return;
}
EOR
1.1 interchange/code/SystemTag/error.coretag
rev 1.1, prev_rev 1.0
Index: error.coretag
===================================================================
### This is in package Vend::Interpolate, and may make reference
### to variables in that module
UserTag error Order name
UserTag error addAttr
UserTag error PosNumber 1
UserTag error Routine <<EOR
sub set_error {
my ($error, $var, $opt) = @_;
$var = 'default' unless $var;
$opt = { keep => 1 } if ! $opt;
my $ref = $Vend::Session->{errors};
if($ref->{$var} and ! $opt->{overwrite}) {
$ref->{$var} .= errmsg(" AND ");
}
else {
$ref->{$var} = '';
}
$ref->{$var} .= $error;
return tag_error($var, $opt);
}
sub tag_error {
my($var, $opt) = @_;
$Vend::Session->{errors} = {}
unless defined $Vend::Session->{errors};
if($opt->{set}) {
$opt->{keep} = 1 unless defined $opt->{keep};
my $error = delete $opt->{set};
return set_error($error, $var, $opt);
}
my $err_ref = $Vend::Session->{errors};
my $text;
$text = $opt->{text} if $opt->{text};
my @errors;
my $found_error = '';
#::logDebug("tag_error: var=$var text=$text opt=" . ::uneval($opt));
#::logDebug("tag_error: var=$var text=$text");
if($opt->{all}) {
$opt->{joiner} = "\n" unless defined $opt->{joiner};
for(sort keys %$err_ref) {
my $err = $err_ref->{$_};
delete $err_ref->{$_} unless $opt->{keep};
next unless $err;
$found_error++;
my $string = '';
if ($opt->{show_label}) {
if ($string = $Vend::Session->{errorlabels}{$_}) {
$string =~ s/[:\s]+$//;
$string .= " ($_)" if $opt->{show_var};
$string .= ": ";
} else {
$string .= "($_): ";
}
} else {
$string .= "$_: " if $opt->{show_var};
}
$string .= $err;
push @errors, $string;
}
#::logDebug("error all=1 found=$found_error contents='@errors'");
return $found_error unless $text || $opt->{show_error};
$text .= "%s" if $text !~ /\%s/;
$text = pull_else($text, $found_error);
return sprintf $text, join($opt->{joiner}, @errors);
}
$found_error = ! (not $err_ref->{$var});
my $err = $err_ref->{$var} || '';
delete $err_ref->{$var} unless $opt->{keep};
#::logDebug("error found=$found_error contents='$err'");
return !(not $found_error)
unless $opt->{std_label} || $text || $opt->{show_error};
if($opt->{std_label}) {
# store the error label in user's session for later
# possible use in [error show_label=1] calls
$Vend::Session->{errorlabels}{$var} = $opt->{std_label};
if($text) {
}
elsif(defined $::Variable->{MV_ERROR_STD_LABEL}) {
$text = $::Variable->{MV_ERROR_STD_LABEL};
}
else {
$text = <<EOF;
<FONT COLOR=RED>{LABEL} <SMALL><I>(%s)</I></SMALL></FONT>
[else]{REQUIRED <B>}{LABEL}{REQUIRED </B>}[/else]
EOF
}
$text =~ s/{LABEL}/$opt->{std_label}/g;
$text =~ s/{REQUIRED\s+([^}]*)}/$opt->{required} ? $1 : ''/ge;
$err =~ s/\s+$//;
}
$text = '' unless defined $text;
$text .= '%s' unless $text =~ /\%s/;
$text = pull_else($text, $found_error);
return sprintf($text, $err);
}
sub {
return tag_error(@_);
}
EOR
1.1 interchange/code/SystemTag/export.coretag
rev 1.1, prev_rev 1.0
Index: export.coretag
===================================================================
UserTag export Order table
UserTag export addAttr
UserTag export attrAlias base table
UserTag export attrAlias database table
UserTag export InvalidateCache
UserTag export PosNumber 1
UserTag export MapRoutine Vend::Interpolate::export
1.1 interchange/code/SystemTag/field.coretag
rev 1.1, prev_rev 1.0
Index: field.coretag
===================================================================
UserTag field Order name code
UserTag field attrAlias column name
UserTag field attrAlias col name
UserTag field attrAlias row code
UserTag field attrAlias field name
UserTag field attrAlias key code
UserTag field PosNumber 2
UserTag field MapRoutine Vend::Data::product_field
1.1 interchange/code/SystemTag/file.coretag
rev 1.1, prev_rev 1.0
Index: file.coretag
===================================================================
UserTag file Order name type
UserTag file PosNumber 2
UserTag file Routine <<EOR
# Returns the contents of a file. Won't allow any arbitrary file unless
# NoAbsolute is not set.
sub {
my ($file, $type) = @_;
return readfile($file, $Global::NoAbsolute)
unless $type;
return readfile($file, $Global::NoAbsolute, 0)
if $type eq 'raw';
my $text = readfile($file, $Global::NoAbsolute);
if($type =~ /mac/i) {
$text =~ tr/\n/\r/;
}
elsif($type =~ /dos|window/i) {
$text =~ s/\n/\r\n/g;
}
elsif($type =~ /unix/i) {
if($text=~ /\n/) {
$text =~ tr/\r/\n/;
}
else {
$text =~ s/\r\n/\n/g;
}
}
return $text;
}
EOR
1.1 interchange/code/SystemTag/filter.coretag
rev 1.1, prev_rev 1.0
Index: filter.coretag
===================================================================
UserTag filter Order op
UserTag filter hasEndTag
UserTag filter PosNumber 1
UserTag filter MapRoutine Vend::Interpolate::filter_value
1.1 interchange/code/SystemTag/flag.coretag
rev 1.1, prev_rev 1.0
Index: flag.coretag
===================================================================
UserTag flag Order type
UserTag flag addAttr
UserTag flag attrAlias tables table
UserTag flag attrAlias flag type
UserTag flag attrAlias name type
UserTag flag InvalidateCache
UserTag flag PosNumber 1
UserTag flag MapRoutine Vend::Interpolate::flag
1.1 interchange/code/SystemTag/fly_list.coretag
rev 1.1, prev_rev 1.0
Index: fly_list.coretag
===================================================================
UserTag fly-list Order code
UserTag fly-list addAttr
UserTag fly-list hasEndTag
UserTag fly-list PosNumber 2
UserTag fly-list MapRoutine Vend::Interpolate::fly_page
1.1 interchange/code/SystemTag/fly_tax.coretag
rev 1.1, prev_rev 1.0
Index: fly_tax.coretag
===================================================================
UserTag fly-tax Order area
UserTag fly-tax PosNumber 1
UserTag fly-tax MapRoutine Vend::Interpolate::fly_tax
1.1 interchange/code/SystemTag/handling.coretag
rev 1.1, prev_rev 1.0
Index: handling.coretag
===================================================================
UserTag handling Order mode
UserTag handling addAttr
UserTag handling attrAlias tables table
UserTag handling attrAlias carts cart
UserTag handling attrAlias modes mode
UserTag handling attrAlias name mode
UserTag handling InvalidateCache
UserTag handling PosNumber 1
UserTag handling MapRoutine Vend::Interpolate::tag_handling
1.1 interchange/code/SystemTag/harness.coretag
rev 1.1, prev_rev 1.0
Index: harness.coretag
===================================================================
UserTag harness addAttr
UserTag harness hasEndTag
UserTag harness PosNumber 0
UserTag harness Routine <<EOR
my $Test = 'test001';
sub {
my ($opt, $input) = @_;
my $not;
my $expected = $opt->{expected} || 'OK';
$input =~ s:^\s+::;
$input =~ s:\s+$::;
$input =~ s:\s*\[expected\](.*)\[/expected\]\s*::s
and $expected = $1;
$input =~ s:\[not\](.*)\[/not\]::s
and $not = $1;
my $name = $Test++;
$name = $opt->{name}
if defined $opt->{name};
my $result;
eval {
$result = Vend::Interpolate::interpolate_html($input);
};
if($@) {
my $msg = "DIED in test $name. \$\@: $@";
#::logDebug($msg);
return $msg;
}
if($expected) {
return "NOT OK $name: $result!=$expected" unless $result =~ /$expected/;
}
if($not) {
return "NOT OK $name: $result==$not" unless $result !~ /$not/;
}
return "OK $name";
}
EOR
1.1 interchange/code/SystemTag/html_table.coretag
rev 1.1, prev_rev 1.0
Index: html_table.coretag
===================================================================
UserTag html-table addAttr
UserTag html-table hasEndTag
UserTag html-table PosNumber 0
UserTag html-table MapRoutine Vend::Interpolate::html_table
1.1 interchange/code/SystemTag/import.coretag
rev 1.1, prev_rev 1.0
Index: import.coretag
===================================================================
UserTag import Order table type
UserTag import addAttr
UserTag import attrAlias base table
UserTag import attrAlias database table
UserTag import hasEndTag
UserTag import Interpolate
UserTag import InvalidateCache
UserTag import PosNumber 2
UserTag import MapRoutine Vend::Data::import_text
1.1 interchange/code/SystemTag/include.coretag
rev 1.1, prev_rev 1.0
Index: include.coretag
===================================================================
UserTag include Order file locale
UserTag include PosNumber 2
UserTag include Routine <<EOR
sub {
Vend::Interpolate::interpolate_html(
Vend::Util::readfile
($_[0], $Global::NoAbsolute, $_[1])
);
}
EOR
1.1 interchange/code/SystemTag/index.coretag
rev 1.1, prev_rev 1.0
Index: index.coretag
===================================================================
UserTag index Order table
UserTag index addAttr
UserTag index attrAlias base table
UserTag index attrAlias database table
UserTag index InvalidateCache
UserTag index PosNumber 1
UserTag index MapRoutine Vend::Data::index_database
1.1 interchange/code/SystemTag/input_filter.coretag
rev 1.1, prev_rev 1.0
Index: input_filter.coretag
===================================================================
UserTag input-filter Order name
UserTag input-filter addAttr
UserTag input-filter attrAlias var name
UserTag input-filter attrAlias variable name
UserTag input-filter attrAlias ops op
UserTag input-filter hasEndTag
UserTag input-filter InvalidateCache
UserTag input-filter PosNumber 1
UserTag input-filter MapRoutine Vend::Interpolate::input_filter
1.1 interchange/code/SystemTag/item_list.coretag
rev 1.1, prev_rev 1.0
Index: item_list.coretag
===================================================================
UserTag item-list Order name
UserTag item-list addAttr
UserTag item-list attrAlias cart name
UserTag item-list hasEndTag
UserTag item-list InvalidateCache
UserTag item-list Routine <<EOR
sub {
my($cart,$opt,$text) = @_;
my $obj = {
mv_results => $cart ? ($::Carts->{$cart} ||= [] ) : $Vend::Items,
};
return if ! $text;
$opt->{prefix} = 'item' unless defined $opt->{prefix};
# LEGACY
list_compat($opt->{prefix}, \$text);
# END LEGACY
return labeled_list($opt, $text, $obj);
}
EOR
1.1 interchange/code/SystemTag/log.coretag
rev 1.1, prev_rev 1.0
Index: log.coretag
===================================================================
UserTag log Order file
UserTag log addAttr
UserTag log attrAlias arg file
UserTag log hasEndTag
UserTag log PosNumber 1
UserTag log MapRoutine Vend::Interpolate::log
1.1 interchange/code/SystemTag/loop.coretag
rev 1.1, prev_rev 1.0
Index: loop.coretag
===================================================================
UserTag loop Order list
UserTag loop addAttr
UserTag loop attrAlias args list
UserTag loop attrAlias arg list
UserTag loop hasEndTag
UserTag loop PosNumber 1
UserTag loop MapRoutine Vend::Interpolate::tag_loop_list
1.1 interchange/code/SystemTag/mail.coretag
rev 1.1, prev_rev 1.0
Index: mail.coretag
===================================================================
UserTag mail Order to
UserTag mail addAttr
UserTag mail hasEndTag
UserTag mail InvalidateCache
UserTag mail PosNumber 1
UserTag mail MapRoutine Vend::Interpolate::tag_mail
1.1 interchange/code/SystemTag/msg.coretag
rev 1.1, prev_rev 1.0
Index: msg.coretag
===================================================================
UserTag msg Order key
UserTag msg addAttr
UserTag msg attrAlias lc inline
UserTag msg hasEndTag
UserTag msg Interpolate
UserTag msg PosNumber 1
UserTag msg Routine <<EOR
sub {
my ($key, $opt, $body) = @_;
my (@args, $message, $out, $startlocale);
unless ($opt->{raw}) {
if (ref $opt->{arg} eq 'ARRAY') {
@args = @{ $opt->{arg} };
} elsif (ref $opt->{arg} eq 'HASH') {
@args = map { $opt->{arg}->{$_} } sort keys %{ $opt->{arg} };
} elsif (! ref $opt->{arg}) {
@args = $opt->{arg};
}
}
if ($opt->{locale}) {
# we only mess with scratch mv_locale because
# Vend::Util::find_locale_bit uses it to determine current locale
$startlocale = $::Scratch->{mv_locale};
Vend::Util::setlocale($opt->{locale}, undef, { persist => 1 });
}
if ($opt->{inline}) {
$message = Vend::Util::find_locale_bit($body);
} else {
$message = $body;
}
if ($key) {
if ($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$key}) {
$message = $Vend::Cfg->{Locale}{$key};
} elsif ($Global::Locale and defined $Global::Locale->{$key}) {
$message = $Global::Locale->{$key};
}
}
if ($opt->{raw}) {
$out = $message;
} else {
$out = errmsg($message, @args);
}
if ($opt->{locale}) {
$::Scratch->{mv_locale} = $startlocale;
Vend::Util::setlocale();
}
return $out;
}
EOR
1.1 interchange/code/SystemTag/mvasp.coretag
rev 1.1, prev_rev 1.0
Index: mvasp.coretag
===================================================================
UserTag mvasp Order tables
UserTag mvasp addAttr
UserTag mvasp attrAlias table tables
UserTag mvasp Gobble
UserTag mvasp hasEndTag
UserTag mvasp InvalidateCache
UserTag mvasp PosNumber 1
UserTag mvasp NoReparse
UserTag mvasp MapRoutine Vend::Interpolate::mvasp
1.1 interchange/code/SystemTag/nitems.coretag
rev 1.1, prev_rev 1.0
Index: nitems.coretag
===================================================================
UserTag nitems Order name
UserTag nitems addAttr
UserTag nitems InvalidateCache
UserTag nitems PosNumber 1
UserTag nitems MapRoutine Vend::Util::tag_nitems
1.1 interchange/code/SystemTag/onfly.coretag
rev 1.1, prev_rev 1.0
Index: onfly.coretag
===================================================================
UserTag onfly Order code quantity
UserTag onfly addAttr
UserTag onfly PosNumber 2
UserTag onfly MapRoutine Vend::Order::onfly
1.1 interchange/code/SystemTag/options.coretag
rev 1.1, prev_rev 1.0
Index: options.coretag
===================================================================
UserTag options Order code
UserTag options addAttr
UserTag options PosNumber 1
UserTag options MapRoutine Vend::Interpolate::tag_options
1.1 interchange/code/SystemTag/order.coretag
rev 1.1, prev_rev 1.0
Index: order.coretag
===================================================================
UserTag order Order code quantity
UserTag order addAttr
UserTag order PosNumber 2
UserTag order Routine <<EOR
# Returns an href to place an order for the product PRODUCT_CODE.
# If AlwaysSecure is set, goes by the page accessed, otherwise
# if a secure order has been started (with a call to at least
# one secure_vendUrl), then it will be given the secure URL
sub {
my($code,$quantity,$opt) = @_;
$opt = {} unless $opt;
my($r);
my @parms = (
"mv_action=refresh",
);
push(@parms, "mv_order_item=$code");
push(@parms, "mv_order_mv_ib=$opt->{base}")
if($opt->{base});
push(@parms, "mv_cartname=$opt->{cart}")
if($opt->{cart});
push(@parms, "mv_order_quantity=$quantity")
if($quantity);
$opt->{form} = join "\n", @parms;
$opt->{page} = find_special_page('order')
unless $opt->{page};
return form_link($opt->{area}, $opt->{arg}, $opt)
if $opt->{area};
return tag_page($opt->{page}, $opt->{arg}, $opt);
}
EOR
1.1 interchange/code/SystemTag/page.coretag
rev 1.1, prev_rev 1.0
Index: page.coretag
===================================================================
UserTag page Order href arg
UserTag page addAttr
UserTag page attrAlias base arg
UserTag page Implicit secure secure
UserTag page PosNumber 2
UserTag page MapRoutine Vend::Interpolate::tag_page
1.1 interchange/code/SystemTag/perl.coretag
rev 1.1, prev_rev 1.0
Index: perl.coretag
===================================================================
UserTag perl Order tables
UserTag perl addAttr
UserTag perl attrAlias table tables
UserTag perl hasEndTag
UserTag perl InvalidateCache
UserTag perl PosNumber 1
UserTag perl MapRoutine Vend::Interpolate::tag_perl
1.1 interchange/code/SystemTag/price.coretag
rev 1.1, prev_rev 1.0
Index: price.coretag
===================================================================
UserTag price Order code
UserTag price addAttr
UserTag price attrAlias base mv_ib
UserTag price PosNumber 1
UserTag price Routine <<EOR
sub {
my($code,$ref) = @_;
my $amount = Vend::Data::item_price($ref,$ref->{quantity} || 1);
$amount = discount_price($ref,$amount, $ref->{quantity})
if $ref->{discount};
return currency( $amount, $ref->{noformat} );
}
EOR
1.1 interchange/code/SystemTag/process.coretag
rev 1.1, prev_rev 1.0
Index: process.coretag
===================================================================
UserTag process Order target secure
UserTag process addAttr
UserTag process replaceAttr form action
UserTag process Routine <<EOR
# Returns the href to process the completed order form or do the search.
sub {
my($target,$secure,$opt) = @_;
$secure = defined $secure ? $secure : $CGI::secure;
my $url = $secure ? secure_vendUrl('process') : vendUrl('process');
return $url unless $target;
return qq{$url" TARGET="$target};
}
EOR
1.1 interchange/code/SystemTag/profile.coretag
rev 1.1, prev_rev 1.0
Index: profile.coretag
===================================================================
UserTag profile Order name
UserTag profile addAttr
UserTag profile InvalidateCache
UserTag profile PosNumber 1
UserTag profile MapRoutine Vend::Interpolate::tag_profile
1.1 interchange/code/SystemTag/query.coretag
rev 1.1, prev_rev 1.0
Index: query.coretag
===================================================================
UserTag query Order sql
UserTag query addAttr
UserTag query attrAlias base table
UserTag query hasEndTag
UserTag query PosNumber 1
UserTag query MapRoutine Vend::Interpolate::query
1.1 interchange/code/SystemTag/read_cookie.coretag
rev 1.1, prev_rev 1.0
Index: read_cookie.coretag
===================================================================
UserTag read-cookie Order name
UserTag read-cookie InvalidateCache
UserTag read-cookie MapRoutine Vend::Util::read_cookie
1.1 interchange/code/SystemTag/record.coretag
rev 1.1, prev_rev 1.0
Index: record.coretag
===================================================================
UserTag record addAttr
UserTag record attrAlias column col
UserTag record attrAlias code key
UserTag record attrAlias field col
UserTag record PosNumber 0
UserTag record Routine <<EOR
sub {
my ($opt) = @_;
my $db = $Vend::Database{$opt->{table}};
return undef if ! $db;
$db = $db->ref();
# This can be called from Perl
my (@cols, @vals);
my $hash = $opt->{col};
my $filter = $opt->{filter};
return undef unless defined $opt->{key};
my $key = $opt->{key};
return undef unless ref $hash;
undef $filter unless ref $filter;
@cols = keys %$hash;
@vals = values %$hash;
RESOLVE: {
my $i = -1;
for(@cols) {
$i++;
if(! defined $db->test_column($_) ) {
splice (@cols, $i, 1);
my $tmp = splice (@vals, $i, 1);
::logError("bad field %s in record update, value=%s", $_, $tmp);
redo RESOLVE;
}
next unless defined $filter->{$_};
$vals[$i] = filter_value($filter->{$_}, $vals[$i], $_);
}
}
my $status;
eval {
my $status = $db->set_slice($key, \@cols, \@vals);
};
if($@) {
return $@ if $opt->{show_error};
}
return $status;
}
EOR
1.1 interchange/code/SystemTag/region.coretag
rev 1.1, prev_rev 1.0
Index: region.coretag
===================================================================
UserTag region addAttr
UserTag region attrAlias args arg
UserTag region attrAlias params arg
UserTag region attrAlias search arg
UserTag region hasEndTag
UserTag region PosNumber 0
UserTag region MapRoutine Vend::Interpolate::region
1.1 interchange/code/SystemTag/row.coretag
rev 1.1, prev_rev 1.0
Index: row.coretag
===================================================================
UserTag row Order width
UserTag row hasEndTag
UserTag row Interpolate
UserTag row PosNumber 1
UserTag row Routine <<EOR
sub tag_column {
my($spec,$text) = @_;
my($append,$f,$i,$line,$usable);
my(%def) = qw(
width 0
spacing 1
gutter 2
wrap 1
html 0
align left
);
my(%spec) = ();
my(@out) = ();
my(@lines) = ();
$spec =~ s/\n/ /g;
$spec =~ s/^\s+//;
$spec =~ s/\s+$//;
$spec = lc $spec;
$spec =~ s/\s*=\s*/=/;
$spec =~ s/^(\d+)/width=$1/;
%spec = split /[\s=]+/, $spec;
for(keys %def) {
$spec{$_} = $def{$_} unless defined $spec{$_};
}
if($spec{'html'} && $spec{'wrap'}) {
::logError("tag_column: can't have 'wrap' and 'html' specified at same time.");
$spec{wrap} = 0;
}
if(! $spec{align} or $spec{align} !~ /^n/i) {
$text =~ s/\s+/ /g;
}
my $len = sub {
my($txt) = @_;
if (1 or $spec{html}) {
$txt =~
s{ <
(
[^>'"] +
|
".*?"
|
'.*?'
) +
>
}{}gsx;
}
return length($txt);
};
$usable = $spec{'width'} - $spec{'gutter'};
return "BAD_WIDTH" if $usable < 1;
if($spec{'align'} =~ /^[ln]/i) {
$f = sub {
$_[0] .
' ' x ($usable - $len->($_[0])) .
' ' x $spec{'gutter'};
};
}
elsif($spec{'align'} =~ /^r/i) {
$f = sub {
' ' x ($usable - $len->($_[0])) .
$_[0] .
' ' x $spec{'gutter'};
};
}
elsif($spec{'align'} =~ /^i/i) {
$spec{'wrap'} = 0;
$usable = 9999;
$f = sub { @_ };
}
else {
return "BAD JUSTIFICATION SPECIFICATION: $spec{'align'}";
}
$append = '';
if($spec{'spacing'} > 1) {
$append .= "\n" x ($spec{'spacing'} - 1);
}
if($spec{'align'} =~ /^n/i) {
@lines = split(/\r?\n/, $text);
}
elsif(is_yes($spec{'wrap'}) and length($text) > $usable) {
@lines = wrap($text,$usable);
}
elsif($spec{'align'} =~ /^i/i) {
$lines[0] = ' ' x $spec{'width'};
$lines[1] = $text . ' ' x $spec{'gutter'};
}
elsif (! $spec{'html'}) {
$lines[0] = substr($text,0,$usable);
}
foreach $line (@lines) {
push @out , &{$f}($line);
for($i = 1; $i < $spec{'spacing'}; $i++) {
push @out, '';
}
}
@out;
}
sub wrap {
my ($str, $width) = @_;
my @a = ();
my ($l, $b);
for (;;) {
$str =~ s/^ +//;
$l = length($str);
last if $l == 0;
if ($l <= $width) {
push @a, $str;
last;
}
$b = rindex($str, " ", $width - 1);
if ($b == -1) {
push @a, substr($str, 0, $width);
$str = substr($str, $width);
}
else {
push @a, substr($str, 0, $b);
$str = substr($str, $b + 1);
}
}
return @a;
}
sub {
my($width,$text) = @_;
my($col,$spec);
my(@lines);
my(@len);
my(@out);
my($i,$j,$k);
my($x,$y,$line);
$i = 0;
while( $text =~ s!\[col(?:umn)?\s+
([^\]]+)
\]
([\000-\377]*?)
\[/col(?:umn)?\] !!ix ) {
$spec = $1;
$col = $2;
$lines[$i] = [];
@{$lines[$i]} = tag_column($spec,$col);
# Discover X dimension
$len[$i] = length(${$lines[$i]}[0]);
if(defined ${$lines[$i]}[1] and ${$lines[$i]}[1] =~ /^<\s*input\s+/i) {
shift @{$lines[$i]};
}
$i++;
}
my $totlen = 0;
for(@len) { $totlen += $_ }
if ($totlen > $width) {
return " B A D R O W S P E C I F I C A T I O N - columns too wide.\n"
}
# Discover y dimension
$j = $#{$lines[0]};
for ($k = 1; $k < $i; $k++) {
$j = $#{$lines[$k]} > $j ? $#{$lines[$k]} : $j;
}
for($y = 0; $y <= $j; $y++) {
$line = '';
for($x = 0; $x < $i; $x++) {
if(defined ${$lines[$x]}[$y]) {
$line .= ${$lines[$x]}[$y];
$line =~ s/\s+$//
if ($i - $x) == 1;
}
elsif (($i - $x) > 1) {
$line .= ' ' x $len[$x];
}
else {
$line =~ s/\s+$//;
}
}
push @out, $line;
}
join "\n", @out;
}
EOR
1.1 interchange/code/SystemTag/salestax.coretag
rev 1.1, prev_rev 1.0
Index: salestax.coretag
===================================================================
UserTag salestax Order name noformat
UserTag salestax attrAlias cart name
UserTag salestax InvalidateCache
UserTag salestax PosNumber 2
UserTag salestax Routine <<EOR
sub {
my($cart, $noformat) = @_;
return currency( salestax($cart), $noformat);
}
EOR
1.1 interchange/code/SystemTag/scratch.coretag
rev 1.1, prev_rev 1.0
Index: scratch.coretag
===================================================================
UserTag scratch Order name
UserTag scratch InvalidateCache
UserTag scratch PosNumber 1
UserTag scratch Routine <<EOR
sub {
my $var = shift;
return $::Scratch->{$var};
}
EOR
1.1 interchange/code/SystemTag/scratchd.coretag
rev 1.1, prev_rev 1.0
Index: scratchd.coretag
===================================================================
UserTag scratchd Order name
UserTag scratchd InvalidateCache
UserTag scratchd PosNumber 1
UserTag scratchd Routine <<EOR
sub {
my $var = shift;
return delete $::Scratch->{$var};
}
EOR
1.1 interchange/code/SystemTag/search_region.coretag
rev 1.1, prev_rev 1.0
Index: search_region.coretag
===================================================================
UserTag search-region Order arg
UserTag search-region addAttr
UserTag search-region attrAlias args arg
UserTag search-region attrAlias params arg
UserTag search-region attrAlias search arg
UserTag search-region hasEndTag
UserTag search-region PosNumber 0
UserTag search-region MapRoutine Vend::Interpolate::tag_search_region
1.1 interchange/code/SystemTag/selected.coretag
rev 1.1, prev_rev 1.0
Index: selected.coretag
===================================================================
UserTag selected Order name value
UserTag selected addAttr
UserTag selected InvalidateCache
UserTag selected PosNumber 2
UserTag selected replaceAttr option selected
UserTag selected Routine <<EOR
# Returns 'SELECTED' when a value is present on the form
# Must match exactly, but NOT case-sensitive
sub {
my ($field,$value,$opt) = @_;
$value = '' unless defined $value;
my $ref = $opt->{cgi} ? $CGI::values{$field} : $::Values->{$field};
return ' SELECTED' if ! length($ref) and $opt->{default};
if(! $opt->{case}) {
$ref = lc($ref);
$value = lc($value);
}
my $r = '';
return ' SELECTED' if $ref eq $value;
if ($opt->{multiple}) {
my $regex = quotemeta $value;
return ' SELECTED' if $ref =~ /(?:^|\0)$regex(?:$|\0)/i;
}
return '';
}
EOR
1.1 interchange/code/SystemTag/set.coretag
rev 1.1, prev_rev 1.0
Index: set.coretag
===================================================================
UserTag set Order name
UserTag set hasEndTag
UserTag set InvalidateCache
UserTag set PosNumber 1
UserTag set MapRoutine Vend::Interpolate::set_scratch
1.1 interchange/code/SystemTag/set_cookie.coretag
rev 1.1, prev_rev 1.0
Index: set_cookie.coretag
===================================================================
UserTag set-cookie Order name value expire domain path
UserTag set-cookie InvalidateCache
UserTag set-cookie MapRoutine Vend::Util::set_cookie
1.1 interchange/code/SystemTag/seti.coretag
rev 1.1, prev_rev 1.0
Index: seti.coretag
===================================================================
UserTag seti Order name
UserTag seti hasEndTag
UserTag seti Interpolate
UserTag seti InvalidateCache
UserTag seti PosNumber 1
UserTag seti MapRoutine Vend::Interpolate::set_scratch
1.1 interchange/code/SystemTag/setlocale.coretag
rev 1.1, prev_rev 1.0
Index: setlocale.coretag
===================================================================
UserTag setlocale Order locale currency
UserTag setlocale addAttr
UserTag setlocale PosNumber 2
UserTag setlocale MapRoutine Vend::Util::setlocale
1.1 interchange/code/SystemTag/shipping.coretag
rev 1.1, prev_rev 1.0
Index: shipping.coretag
===================================================================
UserTag shipping Order mode
UserTag shipping addAttr
UserTag shipping attrAlias tables table
UserTag shipping attrAlias carts cart
UserTag shipping attrAlias modes mode
UserTag shipping attrAlias name mode
UserTag shipping InvalidateCache
UserTag shipping PosNumber 1
UserTag shipping MapRoutine Vend::Interpolate::tag_shipping
1.1 interchange/code/SystemTag/shipping_desc.coretag
rev 1.1, prev_rev 1.0
Index: shipping_desc.coretag
===================================================================
UserTag shipping-desc Order mode
UserTag shipping-desc PosNumber 1
UserTag shipping-desc MapRoutine Vend::Interpolate::tag_shipping_desc
1.1 interchange/code/SystemTag/soap.coretag
rev 1.1, prev_rev 1.0
Index: soap.coretag
===================================================================
UserTag soap Order call uri proxy
UserTag soap addAttr
UserTag soap InvalidateCache
UserTag soap PosNumber 3
UserTag soap MapRoutine Vend::SOAP::tag_soap
1.1 interchange/code/SystemTag/sql.coretag
rev 1.1, prev_rev 1.0
Index: sql.coretag
===================================================================
UserTag sql Order type query
UserTag sql addAttr
UserTag sql hasEndTag
UserTag sql InvalidateCache
UserTag sql PosNumber 2
UserTag sql MapRoutine Vend::Data::sql_query
1.1 interchange/code/SystemTag/strip.coretag
rev 1.1, prev_rev 1.0
Index: strip.coretag
===================================================================
UserTag strip hasEndTag
UserTag strip PosNumber 0
UserTag strip Routine <<EOR
sub {
local($_) = shift;
s/^\s+//;
s/\s+$//;
return $_;
}
EOR
1.1 interchange/code/SystemTag/subtotal.coretag
rev 1.1, prev_rev 1.0
Index: subtotal.coretag
===================================================================
UserTag subtotal Order name noformat
UserTag subtotal attrAlias cart name
UserTag subtotal InvalidateCache
UserTag subtotal PosNumber 2
UserTag subtotal Routine <<EOR
sub {
my($cart, $noformat) = @_;
return currency( subtotal($cart), $noformat);
}
EOR
1.1 interchange/code/SystemTag/tag.coretag
rev 1.1, prev_rev 1.0
Index: tag.coretag
===================================================================
UserTag tag Order op arg
UserTag tag addAttr
UserTag tag attrAlias description arg
UserTag tag hasEndTag
UserTag tag PosNumber 2
UserTag tag MapRoutine Vend::Interpolate::do_tag
1.1 interchange/code/SystemTag/time.coretag
rev 1.1, prev_rev 1.0
Index: time.coretag
===================================================================
UserTag time Order locale
UserTag time addAttr
UserTag time hasEndTag
UserTag time PosNumber 1
UserTag time MapRoutine Vend::Interpolate::mvtime
1.1 interchange/code/SystemTag/timed_build.coretag
rev 1.1, prev_rev 1.0
Index: timed_build.coretag
===================================================================
UserTag timed-build Order file
UserTag timed-build addAttr
UserTag timed-build Gobble
UserTag timed-build hasEndTag
UserTag timed-build PosNumber 1
UserTag timed-build MapRoutine Vend::Interpolate::timed_build
1.1 interchange/code/SystemTag/tmp.coretag
rev 1.1, prev_rev 1.0
Index: tmp.coretag
===================================================================
UserTag tmp Order name
UserTag tmp hasEndTag
UserTag tmp Interpolate
UserTag tmp InvalidateCache
UserTag tmp PosNumber 1
UserTag tmp MapRoutine Vend::Interpolate::set_tmp
1.1 interchange/code/SystemTag/total_cost.coretag
rev 1.1, prev_rev 1.0
Index: total_cost.coretag
===================================================================
UserTag total-cost Order name noformat
UserTag total-cost attrAlias cart name
UserTag total-cost InvalidateCache
UserTag total-cost PosNumber 2
UserTag total-cost Routine <<EOR
sub {
my($cart, $noformat) = @_;
return currency( total_cost($cart), $noformat);
}
EOR
1.1 interchange/code/SystemTag/tree.coretag
rev 1.1, prev_rev 1.0
Index: tree.coretag
===================================================================
UserTag tree Order table master subordinate start
UserTag tree addAttr
UserTag tree attrAlias sub subordinate
UserTag tree hasEndTag
UserTag tree Routine <<EOR
sub {
my($table, $parent, $sub, $start_item, $opt, $text) = @_;
#::logDebug("tree-list: received parent=$parent sub=$sub start=$start_item");
my $db = ::database_exists_ref($table)
or return error_opt($opt, "Database %s doesn't exist", $table);
$db->column_exists($parent)
or return error_opt($opt, "Parent column %s doesn't exist", $parent);
$db->column_exists($sub)
or return error_opt($opt, "Subordinate column %s doesn't exist", $sub);
my $qkey = $db->quote($start_item, $parent);
my @outline = (1);
if(defined $opt->{outline}) {
$opt->{outline} =~ s/[^a-zA-Z0-9]+//g;
@outline = split //, $opt->{outline};
@outline = (qw/1 A 1 a 1 a/) if scalar @outline < 2;
}
my $mult = ( int($opt->{spacing}) || 10 );
my $keyfield = $db->config('KEY');
$opt->{code_field} = $keyfield if ! $opt->{code_field};
my $sort = '';
if($opt->{sort}) {
$sort .= ' ORDER BY ';
my @sort;
@sort = ref $opt->{sort}
? @{$opt->{sort}}
: ( $opt->{sort} );
for(@sort) {
s/\s*[=:]\s*([rnxf]).*//;
$_ .= " DESC" if $1 eq 'r';
}
$sort .= join ", ", @sort;
undef $opt->{sort};
}
my $qb = "select * from $table where $parent = $qkey$sort";
my $ary = $db->query( {
hashref => 1,
sql => $qb,
});
my $memo;
if( $opt->{memo} ) {
$memo = ($::Scratch->{$opt->{memo}} ||= {});
my $toggle;
if($opt->{toggle} and $toggle = $CGI::values{$opt->{toggle}}) {
$memo->{$toggle} = ! $memo->{$toggle};
}
}
if($opt->{collapse} and $CGI::values{$opt->{collapse}}) {
$memo = {};
delete $::Scratch->{$opt->{memo}} if $opt->{memo};
}
my $explode;
if($opt->{full} or $opt->{explode} and $CGI::values{$opt->{explode}}) {
$explode = 1;
}
my $enable;
$memo = {} if ! $memo;
my $stop_sub;
#::logDebug("tree-list: valid parent=$parent sub=$sub start=$start_item mult=$mult");
my @ary_stack = ( $ary ); # Stacks the rows
my @above_stack = { $start_item => 1 }; # Holds the previous levels
my @inc_stack = ($outline[0]); # Holds the increment characters
my @rows;
my $row;
ARY: for (;;) {
#::logDebug("next ary");
my $ary = pop(@ary_stack)
or last ARY;
my $above = pop(@above_stack);
my $level = scalar(@ary_stack);
my $increment = pop(@inc_stack);
ROW: for(;;) {
#::logDebug("next row level=$level increment=$increment");
my $prev = $row;
$row = shift @$ary
or ($prev and $prev->{mv_last} = 1), last ROW;
$row->{mv_level} = $level;
$row->{mv_spacing} = $level * $mult;
$row->{mv_spacer} = $opt->{spacer} x $row->{mv_spacing}
if $opt->{spacer};
$row->{mv_increment} = $increment++;
push(@rows, $row);
my $code = $row->{$keyfield};
$row->{mv_toggled} = 1 if $memo->{$code};
#::logDebug("next row sub=$sub=$row->{$sub}");
my $next = $row->{$sub}
or next ROW;
my $stop;
$row->{mv_children} = 1
if ($opt->{stop} and ! $row->{ $opt->{stop} } )
or ($opt->{continue} and $row->{ $opt->{continue} })
or ($opt->{autodetect});
$stop = 1 if ! $explode and ! $memo->{$code};
#::logDebug("next row sub=$sub=$next stop=$stop explode=$explode memo=$memo->{$code}");
if($above->{$next} and ($opt->{autodetect} or ! $stop) ) {
my $fmt = <<EOF;
Endless tree detected at key %s in table %s.
Parent %s, would traverse to %s.
EOF
my $msg = ::errmsg($fmt, $code, $table, $row->{$parent}, $next);
if(! $opt->{pedantic}) {
error_opt($opt, $msg);
next ROW;
}
else {
$opt->{log_error} = 1 unless $opt->{show_error};
return error_opt($opt, $msg);
}
}
my $a;
if ($opt->{autodetect} or ! $stop) {
my $key = $db->quote($next, $parent);
my $q = "SELECT * FROM $table WHERE $parent = $key$sort";
#::logDebug("next row query=$q");
$a = $db->query(
{
hashref => 1,
sql => $q,
}
);
$above->{$next} = 1 if $a and scalar @{$a};
}
if($opt->{autodetect}) {
$row->{mv_children} = $a ? scalar(@$a) : 0;
}
if (! $stop) {
push(@ary_stack, $ary);
push(@above_stack, $above);
push(@inc_stack, $increment);
$level++;
$increment = defined $outline[$level] ? $outline[$level] : 1;
$ary = $a;
}
} # END ROW
#::logDebug("last row");
} # END ARY
#::logDebug("last ary, results =" . ::uneval(\@rows));
return labeled_list($opt, $text, {mv_results => \@rows});
}
EOR
1.1 interchange/code/SystemTag/try.coretag
rev 1.1, prev_rev 1.0
Index: try.coretag
===================================================================
UserTag try Order label
UserTag try addAttr
UserTag try hasEndTag
UserTag try PosNumber 1
UserTag try MapRoutine Vend::Interpolate::try
1.1 interchange/code/SystemTag/update.coretag
rev 1.1, prev_rev 1.0
Index: update.coretag
===================================================================
UserTag update Order function
UserTag update addAttr
UserTag update InvalidateCache
UserTag update MapRoutine Vend::Interpolate::update
1.1 interchange/code/SystemTag/userdb.coretag
rev 1.1, prev_rev 1.0
Index: userdb.coretag
===================================================================
UserTag userdb Order function
UserTag userdb addAttr
UserTag userdb attrAlias table db
UserTag userdb attrAlias name nickname
UserTag userdb InvalidateCache
UserTag userdb PosNumber 1
UserTag userdb MapRoutine Vend::UserDB::userdb
1.1 interchange/code/SystemTag/value.coretag
rev 1.1, prev_rev 1.0
Index: value.coretag
===================================================================
UserTag value Order name
UserTag value addAttr
UserTag value InvalidateCache
UserTag value PosNumber 1
UserTag value MapRoutine Vend::Interpolate::tag_value
1.1 interchange/code/SystemTag/value_extended.coretag
rev 1.1, prev_rev 1.0
Index: value_extended.coretag
===================================================================
UserTag value-extended Order name
UserTag value-extended addAttr
UserTag value-extended InvalidateCache
UserTag value-extended PosNumber 1
UserTag value-extended MapRoutine Vend::Interpolate::tag_value_extended
1.1 interchange/code/SystemTag/warnings.coretag
rev 1.1, prev_rev 1.0
Index: warnings.coretag
===================================================================
UserTag warnings Order message
UserTag warnings addAttr
UserTag warnings PosNumber 1
UserTag warnings Routine <<EOR
sub {
my($message, $opt) = @_;
if($message) {
my $param = ref $opt->{param} ? $opt->{param} : [$opt->{param}];
push_warning($opt->{message}, @$param);
return unless $opt->{show};
}
return unless $Vend::Session->{warnings};
my $out = $opt->{header} || "";
$out .= '<ul><li>' if $opt->{auto};
if(! length($opt->{joiner})) {
$opt->{joiner} = $opt->{auto} ? '<li>' : "\n";
}
$out .= join $opt->{joiner}, @{$Vend::Session->{warnings}};
$out .= '</ul>' if $opt->{auto};
$out .= $opt->{footer} if length($opt->{footer});
delete $Vend::Session->{warnings} unless $opt->{keep};
return $out;
}
EOR
1.1 interchange/code/UI_Tag/add_gpg_key.coretag
rev 1.1, prev_rev 1.0
Index: add_gpg_key.coretag
===================================================================
UserTag add-gpg-key Order name
UserTag add-gpg-key addAttr
UserTag add-gpg-key Routine <<EOR
sub {
my ($name, $opt) = @_;
my $gpgexe = $Global::Variable->{GPG_PATH} || 'gpg';
my $outfile = "$Vend::Cfg->{ScratchDir}/$Vend::Session->{id}.gpg_results";
my $flags = "--import --batch 2> $outfile";
#::logDebug("gpg_add flags=$flags");
my $keytext = $opt->{text} || $CGI::values{$name};
$keytext =~ s/^\s+//;
$keytext =~ s/\s+$//;
open(GPGIMP, "| $gpgexe $flags")
or die "Can't fork!";
print GPGIMP $keytext;
close GPGIMP;
if($?) {
$::Scratch->{ui_failure} = ::errmsg("Failed GPG key import.");
return defined $opt->{failure} ? $opt->{failure} : undef;
}
else {
my $keylist = `$gpgexe --list-keys`;
$::Scratch->{ui_message} =
::errmsg(
"GPG key imported successfully.<PRE>\n%s\n</PRE>",
$keylist,
);
}
if($opt->{return_id}) {
open(GETGPGID, "< $outfile")
or do {
::logGlobal("GPG key ID read -- can't read %s: %s", $outfile, $!);
return undef;
};
my $id;
while(<GETGPGID>) {
next unless /\bkey (\w+): public key imported/;
$id = $1;
last;
}
close GETGPGID;
return $id || 'Failed ID get?';
}
elsif (defined $opt->{success}) {
return $opt->{success};
}
else {
return 1;
}
}
EOR
1.1 interchange/code/UI_Tag/available_ups_internal.coretag
rev 1.1, prev_rev 1.0
Index: available_ups_internal.coretag
===================================================================
UserTag available_ups_internal Routine <<EOR
sub {
my (@files) = glob('products/[0-9][0-9][0-9].csv');
return '' unless @files;
my $out = '';
for(@files) {
s:/(\d+)::
or next;
$out .= "$1\t$1\n";
}
return $out;
}
EOR
1.1 interchange/code/UI_Tag/available_www_shipping.coretag
rev 1.1, prev_rev 1.0
Index: available_www_shipping.coretag
===================================================================
UserTag available_www_shipping Order only
UserTag available_www_shipping Routine <<EOR
sub {
my ($only) = @_;
my $ups;
my $fedex;
my $other;
if(! $only or $only =~ /ups/i) {
eval {
require Business::UPS;
};
$ups = $@ ? 0 : 1;
}
if(! $only or $only =~ /fed/i) {
eval {
require Business::Fedex;
};
$fedex = $@ ? 0 : 1;
}
my @ups_modes;
my @fed_modes;
if($ups) {
push @ups_modes,
'1DM' => {type => 'UPS', description => 'Next Day Air Early AM'},
'1DML' => {type => 'UPS', description => 'Next Day Air Early AM Letter'},
'1DA' => {type => 'UPS', description => 'Next Day Air'},
'1DAL' => {type => 'UPS', description => 'Next Day Air Letter'},
'1DP' => {type => 'UPS', description => 'Next Day Air Saver'},
'1DPL' => {type => 'UPS', description => 'Next Day Air Saver Letter'},
'2DM' => {type => 'UPS', description => '2nd Day Air A.M.'},
'2DA' => {type => 'UPS', description => '2nd Day Air'},
'2DML' => {type => 'UPS', description => '2nd Day Air A.M. Letter'},
'2DAL' => {type => 'UPS', description => '2nd Day Air Letter'},
'3DS' => {type => 'UPS', description => '3 Day Select'},
'GNDCOM' => {type => 'UPS', description => 'Ground Commercial'},
'GNDRES' => {type => 'UPS', description => 'Ground Residential'},
'XPR' => {type => 'UPS', description => 'Worldwide Express'},
'XDM' => {type => 'UPS', description => 'Worldwide Express Plus'},
'XPRL' => {type => 'UPS', description => 'Worldwide Express Letter'},
'XDML' => {type => 'UPS', description => 'Worldwide Express Plus Letter'},
'XPD' => {type => 'UPS', description => 'Worldwide Expedited'},
;
}
if($fedex) {
push @fed_modes,
'FEG' => {type => 'FED', description => 'FedEx Ground'},
'FEH' => {type => 'FED', description => 'FedEx Home Delivery'},
'FPO' => {type => 'FED', description => 'FedEx Priority Overnight'},
'FSO' => {type => 'FED', description => 'FedEx Standard Overnight'},
'F2D' => {type => 'FED', description => 'FedEx 2-Day'},
'FES' => {type => 'FED', description => 'FedEx Express Saver'},
'FIP' => {type => 'FED', description => 'FedEx International Priority'},
'FIE' => {type => 'FED', description => 'FedEx International Economy'},
;
}
if (wantarray) {
return @ups_modes, @fed_modes;
}
else {
my $out = '';
my $i;
for ($i = 0; $i < @ups_modes; $i += 2) {
my $ref = $ups_modes[$i + 1];
$out .= qq{UPSE:$ups_modes[$i]\t$ref->{type}: $ref->{description}\n};
}
for ($i = 0; $i < @fed_modes; $i += 2) {
my $ref = $fed_modes[$i + 1];
$out .= qq{FEDE:$fed_modes[$i]\t$ref->{type}: $ref->{description}\n};
}
return $out;
}
}
EOR
1.1 interchange/code/UI_Tag/backup_database.coretag
rev 1.1, prev_rev 1.0
Index: backup_database.coretag
===================================================================
UserTag backup-database Order tables
UserTag backup-database AddAttr
UserTag backup-database Routine <<EOR
sub {
my ($tables, $opt) = @_;
my (@tables) = grep /\S/, split /['\s\0]+/, $tables;
my $backup_dir = $opt->{dir}
|| $::Variable->{BACKUP_DIRECTORY}
|| "$Vend::Cfg->{VendRoot}/backup";
my $gnum = $opt->{gnumeric};
my $agg = "$backup_dir/DBDOWNLOAD.all";
my $Max_xls_string = 255;
eval {
require Compress::Zlib;
} if $opt ->{compress};
eval {
require Spreadsheet::WriteExcel;
import Spreadsheet::WriteExcel;
} if $opt ->{xls};
undef $opt->{xls} if $@;
my $xls;
if($opt->{xls}) {
$xls = Spreadsheet::WriteExcel->new("$backup_dir/DBDOWNLOAD.xls");
if($opt->{max_xls_string}) {
$Max_xls_string = int($opt->{max_xls_string}) || 255;
$xls->{_xls_strmax} = $Max_xls_string;
}
}
my $gz;
my @errors;
if($gnum) {
open (AGG, ">$agg")
or die "Cannot write aggregate file $agg; $!\n";
}
my $done = 0;
for my $table (@tables) {
my $unlink;
my $db = Vend::Data::database_exists_ref($table);
my $file = "$backup_dir/" . $db->config('file');
my $status;
eval {
$status = export(
$table,
{
table => $table,
file => $file,
type => 'TAB',
},
);
};
if(! $status) {
push @errors,
errmsg(
"Error exporting %s to %s: %s",
$table,
$file,
$@ || 'unspecified',
);
next;
}
if($opt->{compress}) {
my $new = "$file.gz";
my $gz;
eval {
$gz = Compress::Zlib::gzopen($new, "wb")
or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
open(ZIN, $file)
or die errmsg("error opening %s: %s", $file, $!);
while(<ZIN>) {
$gz->gzwrite($_)
or die
errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
}
$gz->gzclose();
close ZIN;
};
if($@) {
push @errors, $@;
next;
}
$unlink = 1;
}
if($gnum) {
print AGG "\f" if $done;
print AGG "$table\n";
open(RECENT, $file)
or do {
push @errors,
errmsg("Can't read written file %s: %s", $file, $!);
next;
};
while(<RECENT>) {
/\t/ and s/^/'/ and
(
s/\t(0\d+)/\t'$1/g,
s/\t\+/\t'+/g,
s/\t( *\d[^\t]*[-A-Za-z ])/\t'$1/g
);
print AGG;
}
close RECENT;
}
if($xls) {
my $sheet = $xls->addworksheet($table);
$sheet->{_xls_strmax} = $Max_xls_string
if defined $opt->{max_xls_string};
$sheet->activate($table) if $table eq $Vend::Cfg->{ProductFiles}[0];
open(RECENT, $file)
or do {
push @errors,
errmsg("Can't read written file %s: %s", $file, $!);
next;
};
my $fstring = <RECENT>;
chomp $fstring;
my @fields = split /\t/, $fstring;
my $maxcol = scalar @fields - 1;
my $j;
for($j = 0; $j <= $maxcol; $j++) {
$sheet->write_string(0, $j, $fields[$j]);
}
my $i = 1;
while(<RECENT>) {
chomp;
my @extra;
my @overflow;
@fields = split /\t/, $_;
for($j = 0; $j <= $maxcol; $j++) {
my $l = 0;
my $ptr;
if ( length($fields[$j]) > $Max_xls_string) {
$overflow[$j] = $fields[$j];
$extra[$j] = [];
while ( length($overflow[$j]) > $Max_xls_string) {
for( ' ', "\n", " " ) {
$ptr = rindex $overflow[$j], $_, $Max_xls_string;
#::logDebug("char='$_' ptr=$ptr length=" . length($overflow[$j]) ) if $l < 10;
last if $ptr != -1;
}
#::logDebug("char='$_' ptr=$ptr\nstring=$overflow[$j]") if $l++ < 10;
$ptr = 254 if $ptr < 0;
$ptr++;
my $string = substr $overflow[$j], 0, $ptr;
$overflow[$j] = substr $overflow[$j], $ptr;
push @{$extra[$j]}, $string;
}
push @{$extra[$j]}, $overflow[$j];
$fields[$j] = shift @{$extra[$j]};
}
$sheet->write_string($i, $j, $fields[$j]);
}
if(@extra) {
my $max = 0;
for(@extra) {
next unless $_;
my $current = scalar @$_;
$max = $current if $max < $current;
}
for (my $k = 0; $k < $max; $k++) {
$i++;
for( $j = 0; $j < scalar @extra; $j++) {
next unless $_;
$sheet->write_string($i, $j, $extra[$j][$k]);
}
}
}
$i++;
}
close RECENT;
}
unlink($file) if $unlink;
undef $unlink;
$done++;
}
close AGG if $opt->{compress};
if($opt->{compress} and $gnum and $gnum =~ /^compress/i) {
my $file = $agg;
my $new = "$file.gz";
eval {
my $gz = Compress::Zlib::gzopen($new, "wb")
or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
open(ZIN, $file)
or die errmsg("error opening %s: %s", $file, $!);
while(<ZIN>) {
$gz->gzwrite($_)
or die
errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
}
$gz->gzclose();
close ZIN;
};
if($@) {
push @errors, $@;
}
else {
unlink($file);
}
}
if(@errors) {
$::Scratch->{ui_error} = '<UL><LI>';
$::Scratch->{ui_error} .= join "<LI>", @errors;
$::Scratch->{ui_error} .= '</UL>';
}
return $done;
}
EOR
1.1 interchange/code/UI_Tag/backup_file.coretag
rev 1.1, prev_rev 1.0
Index: backup_file.coretag
===================================================================
UserTag backup-file Order file
UserTag backup-file AddAttr
UserTag backup-file Routine <<EOR
sub {
my ($file, $opt) = @_;
require File::Copy;
require File::Path;
my $bu_file = "backup/$file";
$bu_file =~ s://+:/:g ;
$bu_file =~ m:(.*)/: ;
my $bu_dir = $1;
eval {
die ::errmsg("Cannot figure out backup directory from %s", $bu_file)
if ! $bu_dir;
if (! -d $bu_dir) {
File::Path::mkpath($bu_dir)
or die ::errmsg("Cannot make backup directory %s: %s", $bu_dir, $!);
}
if (-f $bu_file) {
my $fn = $bu_file;
$fn =~ s:.*/::;
UI::Primitive::rotate($fn, { Directory => $bu_dir } )
or die ::errmsg("Cannot make backup of %s: %s", $bu_file, $!);
}
#::logDebug("ready to copy $file to $bu_file");
File::Copy::copy($file, $bu_file)
or die ::errmsg("Copy %s to %s: %s", $file, $bu_file, $!);
};
if ($@) {
$::Scratch->{ui_error} = $@;
::logError($::Scratch->{ui_error});
return undef;
}
return 1;
}
EOR
1.1 interchange/code/UI_Tag/base_url.coretag
rev 1.1, prev_rev 1.0
Index: base_url.coretag
===================================================================
UserTag base-url Routine sub { return $Vend::Cfg->{VendURL} }
1.1 interchange/code/UI_Tag/check_upload.coretag
rev 1.1, prev_rev 1.0
Index: check_upload.coretag
===================================================================
UserTag check-upload Order file same
UserTag check-upload PosNumber 2
UserTag check-upload Routine <<EOR
sub {
use File::Copy;
my $file = shift;
my $same = shift;
my $dir = $Vend::Cfg->{ProductDir};
$same = $same ? '' : '+';
if (-s "upload/$file") {
File::Copy::copy "upload/$file", "$dir/$file$same"
or return "Couldn't copy uploaded file!";
unlink "upload/$file";
}
return '';
}
EOR
1.1 interchange/code/UI_Tag/component_editor.coretag
rev 1.1, prev_rev 1.0
Index: component_editor.coretag
===================================================================
UserTag component-editor Order item
UserTag component-editor addAttr
UserTag component-editor hasEndTag
UserTag component-editor Routine <<EOR
sub ce_read_components {
my ($spec, $opt) = @_;
$opt ||= {};
$opt->{components} = 1;
return ce_read_template($spec, $opt);
}
sub ce_read_template {
my ($spec, $opt) = @_;
$opt ||= {};
my $table = $opt->{table} || $::Variable->{UI_COMPONENT_TABLE};
my $tdir = $opt->{template_dir}
|| $::Variable->{UI_TEMPLATE_DIR} || 'templates';
my $cdir = $opt->{component_dir}
|| $::Variable->{UI_COMPONENT_DIR} || "$tdir/components";
my $group = $opt->{group};
my $tmpdir = $Vend::Cfg->{ScratchDir} || 'tmp';
for(\$tmpdir, \$tdir, \$cdir) {
$$_ =~ s!^$Vend::Cfg->{VendRoot}/!!;
}
$tmpdir .= "/components/$Vend::Session->{id}";
my $data;
my %out;
my @out;
my $db;
$db = database_exists_ref($table) if $table;
my @data;
if($opt->{components}) {
if(! $db) {
my @files = glob("$tdir/components/*");
for(@files) {
push @data,
Vend::Util::readfile($_, $Global::NoAbsolute, 0);
}
}
else {
my @atoms;
push @atoms, "select * from $table";
push @atoms, "where comp_type = '$opt->{type}'" if $opt->{type};
push @atoms, "where comp_group = '$opt->{group}'" if $opt->{group};
my $q = join " ", @atoms;
my $ary = $db->query({ sql => $q, hashref => 1 });
for(@$ary) {
push @data, $_->{comp_text};
}
}
}
elsif($spec) {
if(! $db) {
my @files = grep -f $_, glob("$tdir/*");
for(@files) {
push @data,
Vend::Util::readfile($_, $Global::NoAbsolute, 0);
}
}
else {
my @atoms;
push @atoms, "select * from $table";
push @atoms, "where code = '$spec'";
my $q = join " ", @atoms;
my $ary = $db->query({ sql => $q, hashref => 1 });
for(@$ary) {
push @data, $_->{comp_text};
}
}
}
my $might_be_single;
if(scalar @data == 1) {
$might_be_single = 1;
}
foreach my $data (@data) {
next unless length($data);
my $ref = {};
$data =~ m{\[comment\]\s*(ui_.*?)\[/comment\]\s*(.*)}s;
my $structure = $1 || '';
$ref->{ui_current_content} = $2 if $opt->{content};
next unless $structure;
my @lines = split /\n/, $structure;
my $found;
for(;;) {
my $i = -1;
for(@lines) {
$i++;
next unless s/\\$//;
$found = $i;
last;
}
last unless defined $found;
if (defined $found) {
my $add = splice @lines, $found + 1, 1;
#::logDebug("Add is '$add', found index=$found");
$lines[$found] .= $add;
#::logDebug("Complete line now is '$lines[$found]'");
undef $found;
}
}
$ref->{ui_definition} = join "\n", @lines;
my $current;
for(@lines) {
if(/^\s*ui_/) {
my ($el, $el_item, $el_data) = split /\s*:\s*/, $_;
#::logDebug("found el=$el el_item=$el_item el_data=$el_data");
if(defined $el_data) {
$ref->{$el} = { } if ! ref($ref->{$el});
$ref->{$el}{$el_item} = $el_data;
}
else {
$ref->{$el} = $el_item;
}
}
elsif ( /^(\w+)\s*:\s*(.*)$/) {
$current = $1;
$ref->{element}{$current} = $2;
$ref->{ui_display_order} = [] if ! $ref->{ui_display_order};
push @{$ref->{ui_display_order}}, $current;
}
elsif( /^\s+(\w+)\s*:\s*(.*)/ ) {
my ($fn, $fv) = ( lc($1), $2 );
$ref->{$fn}{$current} = $fv;
}
}
push @out, $ref;
}
if(wantarray) {
return @out;
}
elsif($opt->{single} or $might_be_single) {
return $out[0];
}
else {
return \@out;
}
}
sub {
my ($item, $opt, $template) = @_;
my %opt = ( junk => 1);
return ::uneval(ce_read_template('*', \%opt));
# package Vend::Interpolate;
# use vars qw/$Values $Scratch $Db $Tag $Config $CGI $Variable $safe_safe/;
# init_calc() if ! $Vend::Calc_initialized;
my @messages;
my @errors;
my $tref;
my $template_dir = $opt->{template_dir}
|| $::Variable->{UI_TEMPLATE_DIR}
|| 'templates';
if($opt->{template}) {
$tref;
}
my $rowcount = 0;
my $rowdiv = $opt->{across} || 1;
my $span = $rowdiv * 2;
my $oddspan = $span - 1;
$opt->{table_width} = '90%' if ! $opt->{table_width};
$opt->{left_width} = '30%' if ! $opt->{left_width};
if (! $opt->{inner_table_width}) {
if($opt->{table_width} =~ /%/) {
$opt->{inner_table_width} = '100%';
}
elsif ($opt->{table_width} =~ /^\d+$/) {
$opt->{inner_table_width} = $opt->{table_width} - 2;
}
else {
$opt->{inner_table_width} = $opt->{table_width};
}
}
}
EOR
1.1 interchange/code/UI_Tag/cp.coretag
rev 1.1, prev_rev 1.0
Index: cp.coretag
===================================================================
UserTag cp Order from to
UserTag cp addAttr
UserTag cp Routine <<EOR
sub {
my ($from, $to, $opt) = @_;
require File::Copy;
#Debug("cp from=$from to=$to umask=$opt->{umask}");
my $save_mask;
if($opt->{umask}) {
$opt->{umask} = oct($opt->{umask});
$save_mask = umask($opt->{umask});
}
my $status = File::Copy::copy($from, $to);
umask($save_mask) if defined $save_mask;
return '' if $opt->{hide};
return $status;
}
EOR
1.1 interchange/code/UI_Tag/crypt.coretag
rev 1.1, prev_rev 1.0
Index: crypt.coretag
===================================================================
UserTag crypt Order value
UserTag crypt Routine <<EOR
sub {
return crypt(shift, Vend::Util::random_string(2))
}
EOR
1.1 interchange/code/UI_Tag/db_columns.coretag
rev 1.1, prev_rev 1.0
Index: db_columns.coretag
===================================================================
UserTag db_columns Order name columns joiner passed_order
UserTag db_columns AttrAlias table name
UserTag db_columns AttrAlias fields columns
UserTag db_columns Routine <<EOR
sub {
my ($table,$columns, $joiner, $passed_order) = @_;
$table = $Values->{mv_data_table}
unless $table;
my $db = Vend::Data::database_exists_ref($table)
or return undef;
my $acl = UI::Primitive::get_ui_table_acl($table);
$db = $db->ref() unless $Vend::Interpolate::Db{$table};
my $key = $db->config('KEY');
$joiner = "\n" unless defined $joiner;
my @cols;
if(! $columns || $columns =~ /^[\s,\0]*$/) {
@cols = $db->columns();
}
else {
@cols = grep /\S/, split /[\s,\0]+/, $columns;
my (@allcols) = $db->columns();
my %col;
if($passed_order) {
@col{@allcols} = @allcols;
@allcols = @cols;
my $found;
for(@cols) {
next unless $_ eq $key;
$found = 1;
last;
}
unshift (@allcols, $key) if ! $found;
}
else {
@col{@cols} = @cols;
}
$col{$key} = $key if ! defined $col{$key};
@cols = grep defined $col{$_}, @cols;
}
if($acl) {
@cols = UI::Primitive::ui_acl_grep( $acl, 'fields', @cols);
}
return join $joiner, @cols;
}
EOR
1.1 interchange/code/UI_Tag/db_hash.coretag
rev 1.1, prev_rev 1.0
Index: db_hash.coretag
===================================================================
UserTag db-hash Order table column key
UserTag db-hash PosNumber 3
UserTag db-hash addAttr
UserTag db-hash Routine <<EOR
sub {
my($table, $col, $key, $opt) = @_;
$col =~ s/:+(.*)//s;
my $out;
#$out .= ::uneval(\@_);
my $rest = $1;
my $val = ::tag_data($table,$col,$key);
#$out .= "val=$val";
my $ref;
if ($val !~ /\S/) {
$ref = {};
}
else {
$ref = $Vend::Interpolate::ready_safe->reval($val);
if (! ref $ref) {
$ref = {};
}
}
if (! $rest) {
return $val unless defined $opt->{value};
}
my @extra;
@extra = split /:+/, $rest;
my $final = pop @extra;
my $curr = $ref;
$out .= "Original key request: $rest\n";
#$out .= ::uneval($ref);
$out .= "\nFinal key: $final\n";
for(@extra) {
$out .= "key --> $_\n";
$curr = $curr->{$_};
if (! ref $curr) {
return "BAD HASH: $out" if $opt->{show_error};
return;
}
}
if($opt->{keys}) {
return join get_joiner($opt->{joiner}), sort keys %$curr;
}
elsif(! defined $opt->{value}) {
return $curr->{$final};
}
else {
$curr->{$final} = $opt->{value};
tag_data($table, $col, $key, { value => ::uneval_it($ref) });
return $curr->{$final};
}
}
EOR
1.1 interchange/code/UI_Tag/dbinfo.coretag
rev 1.1, prev_rev 1.0
Index: dbinfo.coretag
===================================================================
# Return some info about a database
# Goes in minivend.cfg, not catalog.cfg
#
# THIS REQUIRES 3.12beta4 or higher!
#
# Examples:
#
# <PRE>
# columns: [dbinfo table=products columns=1 joiner="|"]
# file: [dbinfo table=products attribute=file]
# dir: [dbinfo table=products attribute=dir]
# storage: [dbinfo table=products storage=1]
# INDEX: [dbinfo table=products attrib=INDEX]
# CONTINUE: [dbinfo table=products attrib=CONTINUE]
# path to db: [dbinfo db=products attr=dir]/[dbinfo db=products attr=file]
# exists category: [dbinfo db=products column_exists=category]
# exists nevairbe: [dbinfo db=products column_exists=nevairbe No="Nope."]
# exists 00-0011: [dbinfo
# db=products
# record_exists="00-0011"
# YES="Yup."
# No="Nope."]
# exists 00-0000: [dbinfo
# db=products
# record_exists="00-0000"
# YES="Yup."
# No="Nope."]
#
# </PRE>
#
UserTag dbinfo Order table
UserTag dbinfo addAttr
UserTag dbinfo attrAlias base table
UserTag dbinfo attrAlias db table
UserTag dbinfo Routine <<EOR
sub {
my ($table, $opt) = @_;
sub _die {
$Vend::Session->{failure} .= shift;
return;
}
my $db_obj = $Vend::Cfg->{Database}{$table}
|| return _die("Table '$table' does not exist\n");
# attributes are: (case matters)
#
# CONTINUE
# dir
# EXCEL
# file
# INDEX
# MEMORY
# type
if($opt->{attribute} or $opt->{attribute} = $opt->{attrib} || $opt->{attr}) {
return $db_obj->{$opt->{attribute}};
}
# COLUMN_DEF, NUMERIC, NAME
if($opt->{attribute_ref}) {
return Vend::Util::uneval($db_obj->{$opt->{attribute_ref}});
}
my $db = Vend::Data::database_exists_ref($table)
|| return _die("Table '$table' does not exist\n");
$db = $db->ref() unless $Vend::Interpolate::Db{$table};
if($opt->{storage}) {
my $string = $db;
$string =~ /.*::(\w+).*/;
return $1;
}
# doesn't include first column!
return join (($opt->{joiner} || "\n"), $db->columns())
if($opt->{columns});
if($opt->{column_exists}) {
return defined $db->test_column($opt->{column_exists})
? ($opt->{yes} || 1)
: ($opt->{'no'} || '');
}
if($opt->{record_exists}) {
return $db->record_exists($opt->{record_exists})
? ($opt->{yes} || 1)
: ($opt->{'no'} || '');
}
return;
}
EOR
1.1 interchange/code/UI_Tag/diff.coretag
rev 1.1, prev_rev 1.0
Index: diff.coretag
===================================================================
UserTag diff Order current previous
UserTag diff attrAlias curr current prev previous
UserTag diff addAttr
UserTag diff Routine <<EOR
sub {
my ($curr, $prev, $opt) = @_;
$opt->{flags} .= ' -c' if $opt->{context};
$opt->{flags} .= ' -u' if $opt->{unified};
my $data_opt = {};
$data_opt->{safe_data} = 1 if $opt->{safe_data};
unless($opt->{flags} =~ /^[-\s\w.]*$/) {
Log("diff tag: Security violation with flags: $opt->{flags}");
return "Security violation with flags: $opt->{flags}. Logged.";
}
my ($currfn, $prevfn);
if($curr =~ /^(\w+)::(.*?)::(.*)/) {
my ($table, $col, $key) = ($1, $2, $3);
$currfn = "tmp/$Vend::SessionName.current";
my $data = tag_data($table, $col, $key, $data_opt);
if ($opt->{ascii}) {
$data =~ s/\r\n?/\n/g;
$data .= "\n" unless substr($data, -1, 1) eq "\n";
}
Vend::Util::writefile(">$currfn", $data);
}
else {
$currfn = $curr;
}
if($prev =~ /^(\w+)::(.*?)::(.*)/) {
my ($table, $col, $key) = ($1, $2, $3);
$prevfn = "tmp/$Vend::SessionName.previous";
my $data = tag_data($table, $col, $key, $data_opt);
if ($opt->{ascii}) {
$data =~ s/\r\n?/\n/g;
$data .= "\n" unless substr($data, -1, 1) eq "\n";
}
Vend::Util::writefile(">$prevfn", $data);
}
else {
$prevfn = $prev;
}
#Debug("diff command: 'diff $opt->{flags} $prevfn $currfn'");
return `diff $opt->{flags} $prevfn $currfn`;
}
EOR
1.1 interchange/code/UI_Tag/diffmerge.coretag
rev 1.1, prev_rev 1.0
Index: diffmerge.coretag
===================================================================
# This tag uses GNU diff3 to merge two texts blocks that were
# modified from the same ancestral text together, and marks
# conflicts that may appear. This is similar to CVS's merging
# and conflict marking. The names the diff3 manpage uses are:
#
# older
# / \
# / \
# / \
# mine yours
#
# You supply pointers to three text blocks, either as file names or
# database fields in the form Table::Column::Key. 'mine' can instead
# be provided in the body, between the opening and closing tags.
#
# The tag returns the merged text. You can find out whether a
# conflict was detected by providing the name of a scratch variable
# in the 'result' option where the return code from diff3 will be placed.
#
# Set the 'ascii' option to allow for different newline types and
# ignore whether the last line of the file has a newline.
#
# Set the 'safe_data' option to allow raw data to be pulled from the
# database without escaping left brackets (turning [ into [).
#
# Examples:
#
# [diffmerge /tmp/abcd2 /tmp/abcd1 /tmp/abcd3]
#
# [diffmerge
# yours="content::pagebody::00001"
# older="backup::pagebody::00001"
# ascii=1
# result=diff_result
# safe_data=1
# ][scratch new_pagebody][/diffmerge]
UserTag diffmerge Interpolate 1
UserTag diffmerge hasEndTag
UserTag diffmerge addAttr
# These designations come from the diff3 manpage.
# It seemed easier to use their names than to make up new ones.
UserTag diffmerge Order yours older mine
# But here I try to make up new ones anyway. :)
UserTag diffmerge attrAlias <<EOA
current mine
curr mine
previous yours
prev yours
old older
EOA
UserTag diffmerge Routine <<EOR
sub {
my ($yours, $older, $mine, $opt, $body) = @_;
unless ($opt->{flags} =~ /^[-\s\w.]*$/) {
Log("diffmerge tag: Security violation with flags: $opt->{flags}");
return "Security violation with flags: $opt->{flags}. Logged.";
}
my ($minefn, $yoursfn, $olderfn, $cmd, $merge);
my $tmpbasename = "tmp/$Vend::SessionName";
my $data_opt = {};
$data_opt->{safe_data} = 1 if $opt->{safe_data};
my $asciifix = sub {
local $_ = shift;
if ($opt->{ascii}) {
s/\r\n?/\n/g;
$_ .= "\n" unless substr($_, -1, 1) eq "\n";
}
return $_;
};
my $putfile = sub {
my ($name, $passed, $fn) = @_;
if ($$passed =~ /^(\w+)::(.*?)::(.*)/) {
my ($table, $col, $key) = ($1, $2, $3);
my $data = $asciifix->( tag_data($table, $col, $key, $data_opt) );
$$fn = "$tmpbasename.$name";
Vend::Util::writefile(">$$fn", $data);
}
else {
$$fn = $$passed;
}
};
if ($body) {
$body = $asciifix->($body);
$minefn = "tmp/$Vend::SessionName.mine";
Vend::Util::writefile(">$minefn", $body);
}
elsif ($mine) {
$putfile->('mine', \$mine, \$minefn);
}
$putfile->('yours', \$yours, \$yoursfn);
$putfile->('older', \$older, \$olderfn);
$cmd = "diff3 -m $opt->{flags} $minefn $olderfn $yoursfn";
#Debug("diffmerge command: '$cmd'");
$merge = `$cmd`;
if (defined $opt->{result}) {
unless ($opt->{result} =~ /\W/) {
$Scratch->{$opt->{result}} = $? >> 8;
#Debug("diffmerge put $Scratch->{$opt->{result}} into scratch $opt->{result}");
}
else {
Log("diffmerge tag: Invalid 'result' option given; must be a valid name for a scratch variable");
}
}
return $merge;
}
EOR
1.1 interchange/code/UI_Tag/directive_value.coretag
rev 1.1, prev_rev 1.0
Index: directive_value.coretag
===================================================================
UserTag directive_value order name unparse
UserTag directive_value PosNumber 2
UserTag directive_value Routine <<EOR
sub {
my($name,$unparse) = @_;
my ($value, $parsed) = UI::Primitive::read_directive($name);
if($unparse) {
$parsed =~ s/\@\@([A-Z]\w+?)\@\@/$Global::Variable->{$1}/g;
$parsed =~ s/__([A-Z]\w+?)__/$Vend::Cfg->{Variable}{$1}/g;
}
return ($parsed || $value);
}
EOR
1.1 interchange/code/UI_Tag/display.coretag
rev 1.1, prev_rev 1.0
Index: display.coretag
===================================================================
UserTag display Order table column key
UserTag display addAttr 1
UserTag display Interpolate 1
UserTag display posNumber 3
UserTag display Routine <<EOR
sub {
my ($table,$column,$key,$opt) = @_;
my $text;
my $size;
my $widget;
my $label;
my $help;
my $help_url;
my $template = $opt->{type} eq 'hidden' ? '' : $opt->{template};
if($template and $template !~ /\s/) {
$template = <<'EOF';
<TR>
<TD>
<B>$LABEL$</B>
</TD>
<TD VALIGN=TOP>
<TABLE CELLSPACING=0 CELLMARGIN=0><TR><TD>$WIDGET$</TD><TD><I>$HELP$</I>{HELP_URL}<BR><A HREF="$HELP_URL$">help</A>{/HELP_URL}</TD></TR></TABLE>
</TD>
</TR>
EOF
$opt->{template} = 1;
}
#::logDebug("meta call: table=$table col=$column key=$key text=$text");
$text = tag_data($table, $column, $key) if $table and $column and $key;
if($opt->{override}) {
$text = $opt->{default};
}
elsif (not defined $text) {
$text = length($opt->{default}) ? $opt->{default} : $CGI::values{$column};
}
#::logDebug("data call failed: $@") if $@;
if(! $CGI::values{ui_no_meta_display}) {
#::logDebug("meta call: table=$table col=$column key='$key' text=$text");
($widget, $label, $help, $help_url) = UI::Primitive::meta_display($table,$column,$key,$text,undef,undef,$opt);
#::logDebug("past meta_display, help=$help url=$help_url label=$label");
$widget =~ s/<(input|select)\s+/<$1 $opt->{js} /i
if $opt->{js};
}
if(! $widget and $opt->{type} ne 'value') {
my $iname = $opt->{name} || $column;
my $DECODE_CHARS = qq{[<"\000-\037\177-\377};
# Count lines for textarea
my $count;
$count = $text =~ s/(\r\n|\r|\n)/$1/g;
HTML::Entities::encode($text, '&');
HTML::Entities::encode($text, $DECODE_CHARS);
if ($count) {
$count++;
$count = 20 if $count > 20;
$widget = <<EOF;
<TEXTAREA NAME="$iname" COLS=60 ROWS=$count>$text</TEXTAREA>
EOF
}
elsif ($text =~ /^\d+$/) {
$size = 8;
}
else {
$size = 60;
}
$widget = <<EOF;
<INPUT NAME="$iname" SIZE=$size VALUE="$text">
EOF
}
return $widget unless $template;
$label = $column if ! $label;
my %sub = (
WIDGET => $widget,
HELP => $opt->{applylocale} ? errmsg($help) : $help,
HELP_URL => $help_url,
LABEL => $opt->{applylocale} ? errmsg($label) : $label,
);
# Strip the {TAG} {/TAG} pairs if nothing there
$template =~ s#{([A-Z_]+)}(.*?){/\1}#$sub{$1} ? $2: '' #ges;
# Insert the TAG
$template =~ s/\$([A-Z_]+)\$/$sub{$1}/g;
return $template;
}
EOR
1.1 interchange/code/UI_Tag/dump_session.coretag
rev 1.1, prev_rev 1.0
Index: dump_session.coretag
===================================================================
UserTag dump_session Order name
UserTag dump_session AddAttr
UserTag dump_session Routine <<EOR
sub {
my ($name, $opt) = @_;
my $joiner = $opt->{joiner} || ' ';
return "Cannot dump or find sessions with session type $Vend::Cfg->{SessionType}."
if $Vend::Cfg->{SessionType} ne 'File';
if($opt->{find}) {
require File::Find;
my $expire = $Vend::Cfg->{SessionExpire};
if( int($::Variable->{ACTIVE_SESSION_MINUTES}) ) {
$expire = $::Variable->{ACTIVE_SESSION_MINUTES} * 60;
}
my $now = time();
$expire = $now - $expire;
my @files;
my $wanted = sub {
return unless -f $_;
return if (stat(_))[9] < $expire;
return if /\.lock$/;
push @files, $_;
};
File::Find::find($wanted, $Vend::Cfg->{SessionDatabase});
return join $joiner, @files;
}
elsif (! $name) {
return "dump-session: Nothing to do.";
}
else {
my $fn = Vend::Util::get_filename($name, 2, 1, $Vend::Cfg->{SessionDatabase});
return '' unless -f $fn;
return ::uneval(Vend::Util::eval_file($fn));
}
}
EOR
1.1 interchange/code/UI_Tag/e.coretag
rev 1.1, prev_rev 1.0
Index: e.coretag
===================================================================
UserTag e HasEndTag
UserTag e Routine <<EOR
sub {
my $text = shift;
HTML::Entities::encode($text);
}
EOR
1.1 interchange/code/UI_Tag/export_database.coretag
rev 1.1, prev_rev 1.0
Index: export_database.coretag
===================================================================
UserTag export-database Order table file type
UserTag export-database addAttr
UserTag export-database Routine <<EOR
sub {
my($table, $file, $type, $opt) = @_;
delete $::Values->{ui_export_database}
or return undef;
if($opt->{delete} and ! $opt->{verify}) {
::logError("attempt to delete field without verify, abort");
return undef;
}
if(!$file and $type) {
#::logError("exporting as default type, no file specified");
undef $type;
}
$Vend::WriteDatabase{$table} = 1;
if(! $opt->{field}) {
#::logError("exporting:\ntable=$table\nfile=$file\ntype=$type\nsort=$opt->{sort}");
}
elsif($opt->{field} and $opt->{delete}) {
::logError("delete field:\ntable=$table\nfield=$opt->{field}\nsort=$opt->{sort}\n");
}
elsif($opt->{field}) {
::logError("add field:\ntable=$table\nfield=$opt->{field}\nsort=$opt->{sort}\n");
}
return Vend::Data::export_database(
$table,
$file,
$type,
$opt,
);
}
EOR
1.1 interchange/code/UI_Tag/file_info.coretag
rev 1.1, prev_rev 1.0
Index: file_info.coretag
===================================================================
UserTag file-info Order name
UserTag file-info attrAlias file name
UserTag file-info addAttr
UserTag file-info Routine <<EOR
sub {
my ($fn, $opt) = @_;
if($opt->{server}) {
$fn = "$Global::VendRoot/$fn"
}
elsif($opt->{conf}) {
$fn = "$Global::ConfDir/$fn"
}
elsif($opt->{run}) {
$fn = "$Global::RunDir/$fn"
}
my @stat = stat($fn);
my %info;
my @ary;
my $size = $stat[7] < 1024
? $stat[7]
: ( $stat[7] < 1024 * 1024
? sprintf ("%.2fK", $stat[7] / 1024)
: sprintf ("%.2fM", $stat[7] / 1024 / 1024)
);
if($opt->{flags}) {
$opt->{flags} =~ s/\W//g;
my @flags = split //, $opt->{flags};
for(@flags) {
s/(.)/"-$1 _"/ee;
}
return join "\t", @flags;
}
if($opt->{size}) {
return $stat[7];
}
if($opt->{time}) {
return $stat[9];
}
if($opt->{date}) {
return $Tag->time($Scratch->{mv_locale},{time => $stat[9], gmt => $opt->{gmt}},'%c');
}
$opt->{fmt} = '%f bytes, last modified %Y-%m-%d %H:%M:%S'
if ! $opt->{fmt};
$opt->{fmt} =~ s/%f/$size/g;
$Tag->time($Scratch->{mv_locale},{time => $stat[9], gmt => $opt->{gmt}},$opt->{fmt});
}
EOR
1.1 interchange/code/UI_Tag/file_navigator.coretag
rev 1.1, prev_rev 1.0
Index: file_navigator.coretag
===================================================================
UserTag file-navigator Order mask
UserTag file-navigator addAttr
UserTag file-navigator Routine <<EOR
use vars qw/$CGI $Session $Tag $Scratch/;
eval {
require Fcntl;
import Fcntl qw/:mode/;
};
if ($@) {
sub S_ISUID { return 2048 }
sub S_ISGID {return 1024}
sub S_ISVTX {return 512}
}
sub {
my ($dir_mask, $opt) = @_;
#::logDebug("file-nav dir_mask: $dir_mask opt: " . ::uneval($opt));
$dir_mask = '*';
my $base_admin = ( $::Variable->{UI_BASE} || 'admin');
my $base_url = $Vend::Cfg->{VendURL}
. '/'
. $base_admin;
my $full_path;
my $action = $CGI::values{action} || '';
my $already_found;
my $edit_page = $opt->{edit_page} || 'page_edit';
my $edit_var = $opt->{edit_var} || 'ui_page';
my @errors;
my @messages;
$Vend::Session->{ui_cwd} = $opt->{initial_dir}
if $opt->{initial_dir};
if($action eq 'chdir') {
my $newdir = $CGI::values{dir} || '.';
if(
Vend::Util::file_name_is_absolute($newdir)
or
$newdir =~ m{^\.\.|\.\./}
)
{
$Scratch->{ui_error} = ::errmsg('Security violation');
return interpolate_html("[bounce page='$base_admin/error']");
}
if(! -d $newdir) {
$Scratch->{ui_error} = ::errmsg("%s not a directory", $newdir);
return interpolate_html("[bounce page='$base_admin/error']");
}
$Vend::Session->{ui_cwd} = $newdir || '.';
}
my $curdir = $Vend::Session->{ui_cwd} || '.';
$curdir =~ s:/+$::;
my @files;
FINDNAV: {
if($action eq 'find') {
my $regex;
my $string = $CGI::values{find};
if($string !~ /\S/) {
push @errors, ::errmsg("Refuse to find a blank or whitespace.");
last FINDNAV;
}
elsif( $string =~ /\(\s*\?\s*\{/) {
$Scratch->{ui_error} = ::errmsg('Security violation');
return interpolate_html("[bounce page='$base_admin/error']");
}
else {
eval {
if($string =~ /\*/ and $string !~ /\.\*/) {
$regex =~ s/\*/.*/g;
}
$regex = qr{$string};
};
}
if($@ or ! $regex) {
push @errors, ::errmsg("%s is not a good search.", $regex);
last FINDNAV;
}
$full_path = 1;
require File::Find;
my $wanted;
local($SIG{__WARN__}) = sub { push @errors, $_ };
my %exclude;
if($CGI::values{find_action} =~ /\bfilename\b/) {
$wanted = sub {
push @files, $File::Find::name
if $_ =~ $regex;
};
}
else {
if($curdir eq '.' and ! $CGI::values{find_session}) {
%exclude = (qw! ./session 1 session 1 tmp 1 ./tmp 1!);
}
$wanted = sub {
local ($/) = undef;
if( -d $_ and $exclude{$File::Find::dir}) {
$File::Find::prune = 1;
return;
}
return unless -f _;
-s _ > 1_000_000
and do {
push(@errors,
errmsg("%s: refuse to find in megabyte-sized files",
$File::Find::name)
);
return;
};
open(TMPFINDNAV, "< $_")
or do {
push(@errors,
errmsg("%s: permission denied", $File::Find::name)
);
return;
};
my $str = <TMPFINDNAV>;
$str =~ $regex
and push (@files, $File::Find::name);
return;
};
}
File::Find::find($wanted, $curdir);
s:^./:: for @files;
if(@files) {
push @messages, errmsg("Found %s files.", scalar @files);
$already_found = 1;
}
else {
undef $full_path;
push @errors, errmsg("No files found.");
}
}
}
if($already_found) {
# do nothing
}
elsif($curdir eq '.') {
if($dir_mask eq '*') {
@files = grep $_ ne 'CVS', glob('*');
}
else {
@files = split /\s+/, $dir_mask;
}
}
else {
@files = grep $_ !~ m{/CVS$}, glob("$curdir/*");
}
my $this_page = $Global::Variable->{MV_PAGE};
my $this = Vend::Interpolate::tag_area($this_page);
$this =~ s/\?(.*)//;
my $up_img = qq{<img src="up.gif" align=center border=0 height=22 width=20 title="upload ~FN~">};
my $dn_img = qq{<img src="down.gif" align=center border=0 height=22 width=20 title="download ~FN~">};
my $vw_img = qq{<img src="index.gif" align=center border=0 height=22 width=20 title="view ~FN~">};
my $ed_img = qq{<img src="layout.gif" align=center border=0 height=22 width=20 title="edit ~FN~">};
my $dir_img = qq{<img src="folder.gif" align=center border=0 height=22 width=20 title="change directory to ~FN~">};
my $del_img = qq{<img src="delete.gif" align=center border=0 height=20 width=20 title="DELETE ~FN~">};
my $sp_img = qq{<img src="bg.gif" align=center border=0 height=20 width=20>};
if(defined $CGI->{details}) {
$Session->{ui_file_details} = $CGI->{details};
}
my $do_perms = $Session->{ui_file_details};
my $del_string = '';
$Tag->if_mm('advanced', 'delete_files')
and do {
$del_string = qq{<A onClick="return confirm('Are you sure you want to delete the file ~FN~?')" HREF="$Vend::Cfg->{VendURL}/$this_page?~ID~&mv_click=file_maintenance&ui_delete_file=~FN~&mv_action=back">$del_img</A>};
};
my $ftmpl = <<EOF;
<A HREF="$Vend::Cfg->{VendURL}/ui_download/~FN~?~ID~">$dn_img</A>$del_string<A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~&ui_return_to=$this_page">$up_img</A><A HREF="$base_url/do_view?~ID~&mv_arg=~FN~">$vw_img</A> %s <A HREF="$base_url/do_view?~ID~&mv_arg=~FN~">%s</A><BR>
EOF
my $utmpl = <<EOF;
<A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~&ui_return_to=$this_page">$up_img</A> %s <A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~&ui_return_to=$this_page">%s</A><BR>
EOF
my $ftmpl_ed;
if(! $do_perms and $opt->{edit_only}) {
$ftmpl_ed = <<EOF;
<A HREF="$base_url/$edit_page?~ID~&$edit_var=~FN~&ui_return_to=$this_page">$ed_img</A> %s <A HREF="$base_url/$edit_page?~ID~&$edit_var=~FN~&ui_return_to=$this_page">%s</A><BR>
EOF
}
else {
$ftmpl_ed = <<EOF;
<A HREF="$Vend::Cfg->{VendURL}/ui_download/~FN~?~ID~">$dn_img</A>$del_string<A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~&ui_return_to=$this_page">$up_img</A><A HREF="$base_url/$edit_page?~ID~&$edit_var=~FN~&ui_return_to=$this_page">$ed_img</A> %s <A HREF="$base_url/$edit_page?~ID~&$edit_var=~FN~&ui_return_to=$this_page">%s</A><BR>
EOF
}
my $dtmpl = <<EOF;
<A HREF="$Vend::Cfg->{VendURL}/$this_page?~ID~&action=chdir&dir=~FN~">$dir_img</A> %s <A HREF="$Vend::Cfg->{VendURL}/$this_page?~ID~&action=chdir&dir=~FN~">%s</A><BR>
EOF
$dtmpl = "$sp_img$sp_img$sp_img$dtmpl" if $do_perms;
my @out;
my $out;
my @dir;
my @plain;
sub perm_line {
my $fn = shift;
my @perm = qw/
---
--x
-w-
-wx
r--
r-x
rw-
rwx
/;
my @det;
if (-l $fn) {
@det = lstat($fn);
}
else {
@det = stat(_);
}
my $time = POSIX::strftime("%d-%b-%Y %H:%M:%S", localtime($det[9]));
my $permstring = sprintf('%04o', $det[2]);
#push @messages, "$_ perms=$permstring\n";
$permstring = substr($permstring, -3, 3);
my $top;
my (@ugo) = split //, $permstring;
@ugo = map { $_ = $perm[$_] } @ugo;
if (-l _) { $top = 'l' }
elsif (-d _) { $top = 'd' }
elsif (-f _) { $top = '-' }
else { $top = '?' }
$ugo[0] =~ s/.$/s/ if $det[2] & S_ISUID;
$ugo[1] =~ s/.$/s/ if $det[2] & S_ISGID;
$ugo[2] =~ s/.$/t/ if $det[2] & S_ISVTX;
my $user = getpwuid($det[4]);
my $grp = getgrgid($det[5]);
$grp = substr($grp, 0, 8) if length($grp) > 8;
$user = substr($grp, 0, 8) if length($user) > 8;
my $perm = join "", $top, @ugo;
my $ret = sprintf(" <TT><SMALL>%s %-8s %-8s %s</SMALL></TT>", $perm, $user, $grp, $time);
$ret =~ s/ / /g;
return $ret;
}
my $perms = '';
for(@files) {
my $fn = $_;
$fn =~ s:.*/::
unless $full_path;
my $fe = $_;
$fe =~ s!([^-\w./:,])!sprintf('%%%02x', ord($1) )!eg;
my $perms;
$perms = perm_line($_) if($do_perms);
if(-d $_) {
push @dir, [$fe, $fn, $dtmpl, $perms];
}
elsif ($opt->{edit_all} || /\.html?$/) {
push @plain, [$fe, $fn, $ftmpl_ed, $perms];
}
else {
push @plain, [$fe, $fn, $ftmpl, $perms];
}
}
my $nd = $curdir;
if($nd ne '.') {
$nd =~ s:/[^/]*$::
or $nd = '.';
my $msg = $nd eq '.'
? "<large><b>..</b></large>"
: "<large><b>..</b></large>";
unshift @dir, [ $nd, $msg, $dtmpl ];
}
unshift @dir, [ "$curdir/", errmsg('(new file)'), $utmpl ];
@dir = () if $opt->{no_dirs};
for(@errors) {
$out .= "<span class=cerror>$_</span><br>";
}
for(@messages) {
$out .= "<span class=cmessage>$_</span><br>";
}
for (@dir, @plain) {
$_->[2] = sprintf($_->[2], $_->[3], $_->[1]);
$_->[2] =~ s/~FN~/$_->[0]/g;
$_->[2] =~ s/~ID~/mv_session_id=$Session->{id}/g;
$out .= $_->[2];
}
return $out;
}
EOR
1.1 interchange/code/UI_Tag/filters.coretag
rev 1.1, prev_rev 1.0
Index: filters.coretag
===================================================================
UserTag filters Order exclude
UserTag filters Routine <<EOR
use vars '%Filter_desc';
%Vend::Interpolate::Filter_desc = (
filesafe => 'Safe for filename',
currency => 'Currency',
mailto => 'mailto: link',
commify => 'Commify',
lookup => 'DB lookup',
uc => 'Upper case',
date_change => 'Date widget',
null_to_space => 'NULL to SPACE',
null_to_comma => 'NULL to COMMA',
null_to_colons => 'NULL to ::',
space_to_null => 'SPACE to NULL',
colons_to_null => ':: to NULL',
last_non_null => 'Reverse combo',
nullselect => 'Combo box',
tabbed => 'Newline to TAB',
lc => 'Lower case',
digits_dot => 'Digits-dots',
backslash => 'Strip backslash',
option_format => 'Option format',
crypt => 'Crypt',
namecase => 'Name case',
name => 'Last,First to First Last',
digits => 'Digits only',
word => 'A-Za-z_0-9',
unix => 'DOS to UNIX CR',
dos => 'UNIX to DOS CR',
mac => 'LF/CR to CR',
no_white => 'No whitespace',
strip => 'Trim whitespace',
sql => 'SQL quoting',
textarea_put => 'Textarea PUT',
textarea_get => 'Textarea GET',
text2html => 'Simple text2html',
urlencode => 'URL encode',
entities => 'HTML entitiies',
);
my $fdesc_sort = sub {
return 1 if $a and ! $b;
return -1 if ! $a and $b;
return lc($Filter_desc{$a}) cmp lc($Filter_desc{$b});
};
sub {
my ($exclude) = @_;
my @out = map
{ $_ . ($Filter_desc{$_} ? "=$Filter_desc{$_}" : '') }
sort $fdesc_sort keys %Vend::Interpolate::Filter;
if($exclude == 1) {
@out = grep /=/, @out;
}
unshift @out, "=--add--";
return join ",\n", @out;
}
EOR
1.1 interchange/code/UI_Tag/get_gpg_keys.coretag
rev 1.1, prev_rev 1.0
Index: get_gpg_keys.coretag
===================================================================
UserTag get-gpg-keys Order dir
UserTag get-gpg-keys addAttr
UserTag get-gpg-keys Routine <<EOR
sub {
my ($dir, $opt) = @_;
my $gpgexe = $Global::Variable->{GPG_PATH} || 'gpg';
my $flags = "--list-keys";
if($dir) {
$dir = filter_value('filesafe', $dir);
$flags .= "--homedir $dir";
}
#::logDebug("gpg_get_keys flags=$flags");
open(GPGIMP, "$gpgexe $flags |")
or die "Can't fork!";
my $fmt = $opt->{long} ? "%s=%s (date %s, id %s)" : "%s=%s";
my @out;
while(<GPGIMP>) {
next unless s/^pub\s+//;
my ($id, $date, $text) = split /\s+/, $_, 3;
$id =~ s:.*?/::;
$text = ::errmsg( $fmt, $id, $text, $date, $id );
$text =~ s/</</g;
$text =~ s/>/>/g;
$text =~ s/,/,/g;
push @out, $text;
}
close GPGIMP;
my $joiner = $opt->{joiner} || ",\n";
unshift @out, "=none" if $opt->{none};
return join($joiner, @out);
}
EOR
1.1 interchange/code/UI_Tag/global_value.coretag
rev 1.1, prev_rev 1.0
Index: global_value.coretag
===================================================================
UserTag global-value Order name
UserTag global-value Routine <<EOR
sub {
no strict 'refs';
defined ${$_[0]} and return ${$_[0]};
return '';
}
EOR
1.1 interchange/code/UI_Tag/grep_mm.coretag
rev 1.1, prev_rev 1.0
Index: grep_mm.coretag
===================================================================
UserTag grep-mm Order function
UserTag grep-mm addAttr
UserTag grep-mm Interpolate
UserTag grep-mm hasEndTag
UserTag grep-mm Routine <<EOR
sub {
my($func, $opt, $text) = @_;
#::logDebug("grep-mm record: " . Vend::Util::uneval_it(\@_));
my $table = $opt->{table} || $::Values->{mv_data_table};
my $acl = UI::Primitive::get_ui_table_acl($table);
return $text unless $acl;
my @items = grep /\S/, Text::ParseWords::shellwords($text);
return join "\n", UI::Primitive::ui_acl_grep($acl, $func, @items);
}
EOR
1.1 interchange/code/UI_Tag/if_key_exists.coretag
rev 1.1, prev_rev 1.0
Index: if_key_exists.coretag
===================================================================
UserTag if-key-exists Routine <<EOR
sub {
my($table,$key,$text) = @_;
$text =~ s:\[else\](.*)\[/else\]::si;
my $else = $1 || '';
my $db = $Vend::Database{$table} || do { logError "Bad database $table"; return $else; };
$db = $db->ref() unless $Vend::Interpolate::Db{$table};
my $status;
eval {
$status = $db->record_exists($key);
};
return $else if $@;
return $else unless $status;
return $text;
}
EOR
UserTag if-key-exists Order table key
UserTag if-key-exists hasEndTag
1.1 interchange/code/UI_Tag/if_mm.coretag
rev 1.1, prev_rev 1.0
Index: if_mm.coretag
===================================================================
UserTag if-mm Order function name
UserTag if-mm addAttr
UserTag if-mm attrAlias key name
UserTag if-mm hasEndTag
UserTag if-mm Routine <<EOR
sub {
my($func, $field, $opt, $text) = @_;
my $record;
my $status;
my $reverse;
$reverse = $func =~ s/^\s*!\s*//;
my $extended = '';
$extended = $1 if $field =~ s/(=.*)//;
my ($group, @groups);
$text = 1 if ! $text;
CHECKIT: {
if ($group or ! ($record = $Vend::UI_entry) ) {
$record = ui_acl_enabled($group);
if ( ! ref $record) {
$status = $record;
last CHECKIT;
}
}
($status = 0, last CHECKIT) if ! UI::Primitive::is_logged();
($status = 1, last CHECKIT) if $record->{super};
$func = lc $func;
($status = 1, last CHECKIT) if $func eq 'logged_in';
my %acl_func = qw/
fields fields
field fields
columns fields
column fields
col fields
row keys
rows keys
key keys
keys keys
owner_field owner_field
owner owner_field
/;
my %file_func = qw/
page pages
file files
pages pages
files files
/;
my %bool_func = qw/
config 1
reconfig 1
/;
my %paranoid = qw/
mml 1
sql 1
report 1
add_delete 1
add_field 1
journal_update 1
/;
my %yesno_func = qw/
functions functions
advanced functions
tables tables
table tables
/;
my $table = $CGI::values{mv_data_table} || $::Values->{mv_data_table};
if($yesno_func{$func} eq 'tables') {
$opt->{table} = $field if ! $opt->{table};
$opt->{table} =~ s/^=/$table/;
}
elsif($yesno_func{$func} eq 'functions') {
$opt->{table} = $field;
}
$table = $opt->{table} || $table;
my $acl;
my $check;
$status = 0, last CHECKIT if $func eq 'super';
if($check = $file_func{$func}) {
$status = 1, last CHECKIT unless $record->{$check};
my $file = $field || $Global::Variable->{MV_PAGE};
# strip trailing slashes for checks on directories
$file =~ s%/+$%%;
my @files = UI::Primitive::list_glob($record->{$check}, $opt->{prefix});
if(! @files) {
$status = '';
last CHECKIT;
}
$status = ui_check_acl("$file$extended", join(" ", @files));
last CHECKIT;
}
if($bool_func{$func} ) {
$status = $record->{$func};
last CHECKIT;
}
if($check = $yesno_func{$func} ) {
my $v;
if($v = $record->{"yes_$check"}) {
$status = ui_check_acl("$table$extended", $v);
}
else {
$status = 1;
}
if($v = $record->{"no_$check"}) {
$status &&= ! ui_check_acl("$table$extended", $v);
}
last CHECKIT;
}
if(! ($check = $acl_func{$func}) ) {
my $default = $func =~ /^no_/ ? 0 : 1;
$status = $default, last CHECKIT unless $record->{$func};
$status = ui_check_acl("$table$extended", $record->{$func});
last CHECKIT;
}
# Now it is definitely a job for table_control;
$acl = UI::Primitive::get_ui_table_acl($table);
$status = 1, last CHECKIT unless $acl;
my $val;
if($acl->{owner_field} and $check eq 'keys') {
$status = ::tag_data($table, $acl->{owner_field}, $field)
eq $Vend::username;
last CHECKIT;
}
elsif ($check eq 'owner_field') {
$status = length $acl->{owner_field};
last CHECKIT;
}
$status = UI::Primitive::ui_acl_atom($acl, $check, $field);
}
if(! $status and $record and (@groups or $record->{groups}) ) {
goto CHECKIT if $group = shift @groups;
(@groups) = grep /\S/, split /\0,\s]+/, $record->{groups};
($group, @groups) = map { s/^/:/; $_ } @groups;
goto CHECKIT;
}
return $status
? (
Vend::Interpolate::pull_if($text, $reverse)
)
: Vend::Interpolate::pull_else($text, $reverse);
}
EOR
1.1 interchange/code/UI_Tag/if_sql.coretag
rev 1.1, prev_rev 1.0
Index: if_sql.coretag
===================================================================
UserTag if-sql Routine <<EOR
sub {
my($table,$text) = @_;
$text =~ s:\[else\](.*)\[/else\]::si;
my $else = $1 || '';
my $db = $Vend::Cfg->{Database}{$table} || return $else;
return $else unless $db->{'type'} eq '8';
return $text;
}
EOR
UserTag if-sql Order table
UserTag if-sql hasEndTag
1.1 interchange/code/UI_Tag/image_collate.coretag
rev 1.1, prev_rev 1.0
Index: image_collate.coretag
===================================================================
UserTag image-collate Order archive
UserTag image-collate addAttr
UserTag image-collate Routine <<EOR
sub {
my ($archive, $opt) = @_;
#Debug("Image collate called with archive=$archive" . ::uneval(\@_));
my $thumb = $opt->{thumb};
require File::Path;
require File::Copy;
sub tmp_die {
my (@args) = @_;
$args[0] = "image_collate: " . $args[0];
my $msg = ::errmsg(@args);
$Vend::Session->{ui_failure} = $msg;
#Debug($msg);
chdir($Vend::Cfg->{VendRoot});
return undef;
}
my $Exec;
if($archive =~ /\.zip$/i) {
$Exec = 'unzip -q -j';
}
elsif ($archive =~ /\.(tar\.|t)gz$/) {
$Exec = 'tar -x -z -f';
}
elsif ($archive =~ /\.bz2?$/) {
$Exec = 'tar -x -j -f';
}
elsif ($archive =~ /\.tar$/) {
$Exec = 'tar -x -f';
}
else {
my $tmp = $archive;
$tmp =~ s/.*\.//;
return tmp_die("unrecognized archive extension: %s", $tmp);
}
$archive =~ s:^upload/::;
$archive = "upload/$archive";
return undef unless -f $archive;
my $tmpdir = "$Vend::Cfg->{ScratchDir}/img/$Vend::Session->{id}";
File::Path::rmtree($tmpdir) if -d $tmpdir;
File::Path::mkpath($tmpdir)
or return tmp_die("cannot make directory %s: %s", $tmpdir, $!);
File::Copy::copy($archive, $tmpdir)
or return tmp_die("cannot copy archive %s to %s: %s", $archive, $tmpdir, $!);
chdir $tmpdir
or return tmp_die("cannot chdir to directory %s: %s", $tmpdir, $!);
my $afile = $archive;
$afile =~ s:.*/::;
system("$Exec $afile");
if($?) {
my $status = $? >> 8;
return tmp_die("error %s unarchiving %s: %s", $status, $afile, $!);
}
unlink $afile
or return tmp_die("cannot unlink archive %s: %s", $afile, $!);
sleep 1;
opendir(IMGDIR, '.')
or return tmp_die("couldn't open image directory?");
my @ifiles = grep -f $_, readdir(IMGDIR);
closedir(IMGDIR)
or return tmp_die("couldn't close image directory?");
#Debug("image files: " . join ", ", @ifiles);
my @unfound;
my @did;
my @do;
my $i_f = $opt->{image_field} || 'image';
my $t_f = $opt->{thumb_field} || 'thumb';
my $s_f = $opt->{sku_field} || 'sku';
my $table = $opt->{table} || 'products';
$Vend::WriteDatabase{$table} = 1;
my $db = ::database_exists_ref($table)
or return tmp_die("products table %s not found.", $table);
my $fields = "$s_f, $i_f";
$fields .= ", $t_f" if $thumb;
for(@ifiles) {
my (@parts) = split /\./, $_;
my ($base, $ext);
if(@parts < 2) {
$base = $parts[0];
$ext = '';
}
if(@parts == 2) {
$base = $parts[0];
$ext = ".$parts[1]";
}
else {
$ext = "." . pop @parts;
$base = join ".", @parts;
}
my $ary = $db->query("select $fields FROM $table WHERE $i_f = '$base$ext'");
if($ary and @$ary) {
for(@$ary) {
my ($sku, $i_d, $t_d) = @$_;
$t_d = $thumb ? "$base$ext" : $t_d;
push @do, [$sku, "$base$ext", $t_d];
}
}
else {
$ary = $db->query("select $s_f FROM $table WHERE $s_f = '$base'");
if($ary) {
for(@$ary) {
my ($sku, $i_d, $t_d) = @$_;
$t_d = $thumb ? "$base$ext" : $t_d;
push @do, [$sku, "$base$ext", $t_d];
}
}
}
if(! $ary or !@$ary) {
push @unfound, "$base$ext";
}
}
mkdir 'items', 0777;
mkdir 'thumb', 0777;
for(@do) {
my $sku = shift @$_;
push (@did, $sku);
$db->set_slice($sku, [$i_f, $t_f], $_)
or return tmp_error("unable to set table=%s for sku=%s.", $table, $sku);
File::Copy::copy($_->[0], 'items');
File::Copy::copy($_->[1], 'thumb') if $thumb;
}
my @errors;
if($thumb) {
my $size = $opt->{thumb_size} || '60x60';
chdir('thumb')
or return tmp_die("cannot chdir to directory %s: %s", "$tmpdir/thumb", $!);
system("/usr/X11R6/bin/mogrify -geometry $size *");
if($?) {
my $status = $? >> 8;
undef $thumb;
push @errors, errmsg("error %s creating thumbs: %s", $status, $!);
}
chdir '..';
}
my $save_mask = umask(2);
foreach my $base (qw/ items thumb /) {
my $imgbase = "$Vend::Cfg->{VendRoot}/images/$base";
if(! -d $imgbase) {
push @errors,
::errmsg("No image directory for %s. Skipping image copy.", $base);
}
else {
#my $curr = `pwd`;
#chop $curr;
#Debug("found dir $imgbase, curr=$curr, globbing $base/$_");
for( glob("$base/*") ) {
#Debug("copy $_ to $imgbase");
chmod 0664, $_;
File::Copy::copy($_, $imgbase)
or push @errors,
::errmsg("failed to copy %s to %s: %s", $_, $imgbase, $!);
}
}
}
umask $save_mask;
chdir($Vend::Cfg->{VendRoot});
return 1 if $opt->{return_status};
return '' if $opt->{hide};
my $out = '';
if($opt->{verbose}) {
$out .= "Files: <br><blockquote>" . join("<br>", @ifiles) . "</blockquote>\n";
$out .= "Files found:<br><blockquote>";
$out .= join("<BR>", @did);
$out .= "</blockquote>\n";
}
if(@unfound) {
$out .= "No item found for image file:<br><blockquote>";
$out .= join("<BR>", @unfound);
$out .= "</blockquote>Not copied.\n";
}
if(@errors) {
$out .= "Errors:<br><blockquote>";
$out .= join("<BR>", @errors);
$out .= "</blockquote>\n";
}
return $out;
}
EOR
1.1 interchange/code/UI_Tag/import_fields.coretag
rev 1.1, prev_rev 1.0
Index: import_fields.coretag
===================================================================
UserTag import_fields Order table
UserTag import_fields addAttr
UserTag import_fields Routine <<EOR
sub {
my($table, $opt) = @_;
use strict;
my $out;
#::logDebug("options for import_fields: " . ::uneval(\@_) );
local($SIG{__DIE__});
$SIG{"__DIE__"} = sub {
my $msg = shift;
::response(<<EOF);
<HTML><HEAD><TITLE>Fatal Administration Error</TITLE></HEAD><BODY>
<H1>FATAL error</H1>
<P>
<PRE>$msg</PRE>
Progress to date:
<P>
$out
</BODY></HTML>
EOF
exit 0;
};
my $file = $opt->{'file'} || $Vend::Cfg->{ProductDir} . "/$table.update";
my $currdb;
my $tmsg = '';
my $db;
CONVERT: {
last CONVERT if ! $opt->{convert};
if ($opt->{convert} eq 'auto') {
if($file =~ /\.(txt|all)$/i) {
last CONVERT;
}
elsif($file =~ /\.xls$/i) {
$opt->{convert} = 'xls';
redo CONVERT;
}
else {
$file =~ s:.*\.::
or $file = 'none';
return "Failed: unknown file extension ''";
}
}
elsif ($opt->{convert} eq 'xls') {
#::logDebug("doing XLS for file=$file");
eval {
require Spreadsheet::ParseExcel;
import Spreadsheet::ParseExcel;
my $oExcel = new Spreadsheet::ParseExcel;
my $oBook = $oExcel->Parse($file);
#::logDebug("oBook is $oBook");
if(! $oBook) {
die errmsg("Failed to parse XLS file %s: %s\n", $file, $!);
}
my($iR, $iC, $oWkS, $oWkC);
my $sheets = {};
for(my $iSheet=0; $iSheet < $oBook->{SheetCount} ; $iSheet++) {
my $oWkS = $oBook->{Worksheet}[$iSheet]
or next;
for(qw/MaxCol MaxRow MinCol MinRow/) {
die "No $_!" if ! defined $oWkS->{$_};
}
my $sname = $oWkS->{Name} or die "no sheet name.";
#::logDebug("doing sheet $sname");
$sheets->{$sname} = "$sname\n";
my $maxcol;
my $mincol;
my $iC;
my $iR = $oWkS->{MinRow};
for($iC = $oWkS->{MinCol} ; $iC <= $oWkS->{MaxCol} ; $iC++) {
$oWkC = $oWkS->{Cells}[$iR][$iC];
if(! $oWkC or ! $oWkC->Value) {
$maxcol = $iC;
$maxcol--;
last;
}
$maxcol = $iC;
}
$mincol = $oWkS->{MinCol};
my @out;
for( ; $iR <= $oWkS->{MaxRow}; $iR++) {
my $row = $oWkS->{Cells}[$iR];
@out = ();
for($iC = $mincol; $iC <= $maxcol; $iC++) {
if(! defined $row->[$iC]) {
push @out, "";
next;
}
push @out, $row->[$iC]->Value;
}
$sheets->{$sname} .= join "\t", @out;
$sheets->{$sname} .= "\n";
}
}
my @print;
for(sort keys %$sheets) {
push @print, $sheets->{$_};
}
$file =~ s/(\.xls)?$/.txt/i;
open OUT, ">$file"
or die "Cannot write $file: $!\n";
print OUT join "\cL", @print;
close OUT;
};
die "Excel conversion failed: $@\n" if $@;
}
else {
# other types, or assume gnumeric simple text
}
} # end CONVERT
my $change_sub;
if($opt->{multiple}) {
undef $table;
$change_sub = sub {
my $table = shift;
$Vend::WriteDatabase{$table} = 1;
#::logDebug("changing table to $table");
$db = Vend::Data::database_exists_ref($table);
#::logDebug("db now=$db");
die "Non-existent table '$table'\n" unless $db;
$db = $db->ref();
#::logDebug("db now=$db");
if($opt->{autonumber} and ! $db->config('_Auto_number') ) {
$db->config('AUTO_NUMBER', '1000');
}
#::logDebug("db now=$db");
$tmsg = "table $table: ";
return;
};
}
else {
$Vend::WriteDatabase{$table} = 1;
$db = Vend::Data::database_exists_ref($table);
die "Non-existent table '$table'\n" unless $db;
$db = $db->ref() unless $Vend::Interpolate::Db{$table};
if($opt->{autonumber} and ! $db->config('_Auto_number') ) {
$db->config('AUTO_NUMBER', '1000');
}
}
$out = '<PRE>';
my $delimiter = quotemeta $opt->{delimiter} || "\t";
open(UPDATE, $file)
or die "read $file: $!\n";
my $fields;
if($opt->{multiple}) {
# will get fields later
undef $opt->{fields};
}
elsif($opt->{'fields'}) {
$fields = $opt->{'fields'};
$out .= "Using fields from parameter: '$fields'\n";
}
my $verbose;
my $quiet;
$verbose = 1 if ! $opt->{quiet};
$quiet = 1 if $opt->{quiet} > 1;
TABLE: {
if(! $table) {
$table = <UPDATE>;
chomp $table;
$change_sub->($table);
}
#::logDebug("db now=$db");
if(! $opt->{fields}) {
$fields = <UPDATE>;
chomp $fields;
$fields =~ s/$delimiter/ /g;
$out .= "${tmsg}Using fields from file: '$fields'\n";
}
die "No field names." if ! $fields;
my @names;
my $k;
my @f;
@names = split /\s+/, $fields;
shift @names;
my @set;
my $i = 0;
my $idx = 0;
for(@names) {
$db->column_index($_);
$set[$idx++] = $db->field_settor($_);
}
my $count = 0;
my $totcount = 0;
my $delcount = 0;
my $addcount = 0;
while(<UPDATE>) {
chomp;
$totcount++;
($k, @f) = split /$delimiter/o, $_;
if(/^\f(\w+)$/) {
$out .= "${tmsg}$count records processed of $totcount input lines.\n";
$out .= "${tmsg}$delcount records deleted.\n" if $delcount;
$out .= "${tmsg}$addcount records added.\n" if $addcount;
$delcount = $totcount = $addcount = 0;
$change_sub->($1);
redo TABLE;
}
if(! $k and ! length($k)) {
if ($f[0] eq 'DELETE') {
next if ! $opt->{delete};
$out .= "${tmsg}Deleting record '$f[1]'.\n" if $verbose;
$db->delete_record($f[1]);
$count++;
$delcount++;
next;
}
}
$out .= "${tmsg}Record '$k' had too many fields, ignored.\n"
if @f > $idx;
if ( ! length($k) or ! $db->record_exists($k)) {
if ($opt->{add}) {
if( ! length($k) and ! $opt->{autonumber}) {
$out .= "${tmsg}Blank key, no autonumber option, skipping.\n";
next;
}
$k = $db->set_row($k);
$out .= "${tmsg}Adding record '$k'.\n" if $verbose;
$addcount++;
}
else {
$out .= "${tmsg}Non-existent record '$k', skipping.\n";
next;
}
}
for ($i = 0; $i < $idx; $i++) {
$set[$i]->($k, $f[$i]);
}
$count++;
}
$out .= "${tmsg}$count records processed of $totcount input lines.\n";
$out .= "${tmsg}$delcount records deleted.\n" if $delcount;
$out .= "${tmsg}$addcount records added.\n" if $addcount;
}
$out .= "</PRE>";
close UPDATE;
if($opt->{'move'}) {
my $ext = POSIX::strftime("%Y%m%d%H%M%S", localtime());
rename $file, "$file.$ext"
or die "rename $file --> $file.$ext: $!\n";
if( $opt->{dir}
and (-d $opt->{dir} or File::Path::mkpath($opt->{dir}))
and -w $opt->{dir}
)
{
File::Copy::move("$file.$ext", $opt->{dir})
or die "move $file.$ext --> $opt->{dir}: $!\n";
}
}
return $out unless $quiet;
return;
}
EOR
1.1 interchange/code/UI_Tag/list_databases.coretag
rev 1.1, prev_rev 1.0
Index: list_databases.coretag
===================================================================
UserTag list-databases Order nohide extended
UserTag list-databases routine <<EOR
sub {
my $nohide = shift;
my $extended = shift || '';
$extended = "=$extended" if $extended;
my @dbs;
my $d = $Vend::Cfg->{Database};
@dbs = sort keys %$d;
GENDBLIST: {
last GENDBLIST if $nohide;
my @outdb;
my $record = ui_acl_enabled();
last GENDBLIST if $record and $record->{super};
undef $record
unless ref($record)
and $record->{yes_tables} || $record->{no_tables};
for(@dbs) {
if($record) {
next if $record->{no_tables}
and ui_check_acl($_, $record->{no_tables});
my $check = "$_$extended";
next if $record->{yes_tables}
and ! ui_check_acl($check, $record->{yes_tables});
}
push @outdb, $_;
}
@dbs = $nohide ? (@dbs) : (@outdb);
}
my $string = join " ", grep /\S/, @dbs;
return $string;
}
EOR
1.1 interchange/code/UI_Tag/list_glob.coretag
rev 1.1, prev_rev 1.0
Index: list_glob.coretag
===================================================================
UserTag list_glob Order spec prefix
UserTag list_glob PosNumber 2
UserTag list_glob Routine <<EOR
sub {
my @files = UI::Primitive::list_glob(@_);
return (wantarray ? @files : join "\n", @files);
}
EOR
1.1 interchange/code/UI_Tag/list_keys.coretag
rev 1.1, prev_rev 1.0
Index: list_keys.coretag
===================================================================
UserTag list-keys Order table
UserTag list-keys addAttr
UserTag list-keys Routine <<EOR
sub {
my $table = shift;
#::logDebug("list-keys $table");
$table = $::Values->{mv_data_table}
unless $table;
#::logDebug("list-keys $table");
my @keys;
my $record;
if(! ($record = $Vend::UI_entry) ) {
$record = ui_acl_enabled();
}
my $acl;
my $keys;
if($record) {
#::logDebug("list_keys: record=$record");
$acl = get_ui_table_acl($table);
#::logDebug("list_keys table=$table: acl=$acl");
if($acl and $acl->{yes_keys}) {
#::logDebug("list_keys table=$table: yes.keys enabled");
@keys = grep /\S/, split /\s+/, $acl->{yes_keys};
}
}
unless (@keys) {
my $db = Vend::Data::database_exists_ref($table);
return '' unless $db;
$db = $db->ref() unless $Vend::Interpolate::Db{$table};
my $keyname = $db->config('KEY');
if($db->config('LARGE')) {
return ::errmsg('--not listed, too large--');
}
my $query = "select $keyname from $table order by $keyname";
#::logDebug("list_keys: query=$query");
$keys = $db->query(
{
query => $query,
ml => $::Variable->{UI_ACCESS_KEY_LIMIT} || 500,
st => 'db',
}
);
if(defined $keys) {
@keys = map {$_->[0]} @$keys;
}
else {
my $k;
while (($k) = $db->each_record()) {
push(@keys, $k);
}
if( $db->numeric($db->config('KEY')) ) {
@keys = sort { $a <=> $b } @keys;
}
else {
@keys = sort @keys;
}
}
#::logDebug("list_keys: query=returned " . ::uneval(\@keys));
}
if($acl) {
#::logDebug("list_keys acl: ". ::uneval($acl));
@keys = UI::Primitive::ui_acl_grep( $acl, 'keys', @keys);
}
return join("\n", @keys);
}
EOR
1.1 interchange/code/UI_Tag/list_pages.coretag
rev 1.1, prev_rev 1.0
Index: list_pages.coretag
===================================================================
UserTag list_pages Order options
UserTag list_pages addAttr
UserTag list_pages Routine <<EOR
sub {
my ($return_options, $opt) = @_;
my $out;
my @pages = UI::Primitive::list_pages($opt->{keep},$opt->{ext},$opt->{base});
if($return_options) {
$out = "<OPTION> " . (join "<OPTION> ", @pages);
}
elsif ($opt->{arrayref}) {
return \@pages;
}
else {
$out = join " ", @pages;
}
}
EOR
1.1 interchange/code/UI_Tag/load_templates.coretag
rev 1.1, prev_rev 1.0
Index: load_templates.coretag
===================================================================
UserTag load-templates Order dir
UserTag load-templates Routine <<EOR
sub {
my ($dir) = @_;
$dir ||= 'templates';
my ($templates) = $Tag->read_ui_template("$dir/*");
my ($components) = $Tag->read_ui_template("$dir/components/*");
my $db = database_exists_ref($::Variable->{UI_COMPONENT_TABLE} || 'component');
die "no db?!!?" if ! $db;
#
# Table "component"
# Attribute | Type | Modifier
#-----------------+------------------------+----------
# code | character varying(128) | not null
# base_code | text |
# mod_user | character varying(64) |
# comp_group | text |
# watchers | text |
# hostname | text |
# mod_time | integer |
# extension | character varying(16) |
# comp_type | character varying(16) |
# expiration_date | character varying(32) |
# note | character varying(255) |
# came_from | character varying(255) |
# show_date | character varying(32) |
# comp_text | text |
# cache_interval | text |
# cache_options | text |
# name | character varying(255) |
#Indices: component_code,
# component_expiration_date,
# component_show_date
my $template_cnt = 0;
my $component_cnt = 0;
for my $ref (@$templates) {
my $code = $ref->{ui_template}
or do {
Debug("template has no name");
next;
};
$code = "templates/$code";
my %record = (
comp_type => $ref->{ui_template_type} || 'template',
name => $ref->{ui_template_description},
comp_group => 'template',
comp_type => 'template',
hostname => 'localhost',
base_code => $code,
mod_user => $Vend::Session->{username},
mod_time => time(),
comp_text => $ref->{ui_definition},
);
$db->set_slice($code, \%record)
and $template_cnt++;
}
for my $ref (@$components) {
my $code = $ref->{ui_component}
or do {
Debug("component has no name");
next;
};
my $time = $Tag->time({ body => '%Y%m%d%H%M' });
my $text = join "\n", $ref->{ui_definition}, $ref->{ui_current_content};
my %record = (
comp_type => $ref->{ui_template_type} || 'template',
name => $ref->{ui_template_description},
comp_type => $ref->{ui_component_type},
comp_group => $ref->{ui_component_group},
hostname => 'localhost',
base_code => $code,
mod_user => $Vend::Session->{username},
mod_time => time(),
comp_text => $text,
);
$db->set_slice($code, \%record)
and $component_cnt++;
}
return "loaded $template_cnt templates, $component_cnt components";
}
EOR
1.1 interchange/code/UI_Tag/meta_record.coretag
rev 1.1, prev_rev 1.0
Index: meta_record.coretag
===================================================================
UserTag meta-record Order item view source
UserTag meta-record attrAlias table item
UserTag meta-record MapRoutine UI::Primitive::meta_record
1.1 interchange/code/UI_Tag/mm_locale.coretag
rev 1.1, prev_rev 1.0
Index: mm_locale.coretag
===================================================================
UserTag mm_locale Routine <<EOR
sub {
my $locale = $Values->{ui_locale} || $Tag->var('UI_LOCALE', 2);
my $lref;
# first delete locale settings from catalog
$Vend::Cfg->{Locale_repository} = {};
if ($locale && exists $Global::Locale_repository->{$locale}) {
$lref = $Vend::Cfg->{Locale_repository}{"$locale"}
= $Global::Locale_repository->{$locale};
$Tag->setlocale("$locale");
$Tag->tmp({name => 'mv_locale'}, $locale);
if ($lref->{MV_LANG_DIRECTION}) {
$Tag->tmp({name => 'ui_language_direction'}, qq{ dir="$lref->{MV_LANG_DIRECTION}"});
}
}
1;
}
EOR
1.1 interchange/code/UI_Tag/mm_value.coretag
rev 1.1, prev_rev 1.0
Index: mm_value.coretag
===================================================================
UserTag mm-value Order field table
UserTag mm-value addAttr
UserTag mm-value Routine <<EOR
sub {
my($field, $table, $opt, $text) = @_;
my $record;
my $status;
my $reverse;
my $uid = $opt->{user};
unless ($record = $Vend::UI_entry) {
return '' unless ref($record = ui_acl_enabled());
}
#::logDebug("mm-value record: " . ::uneval($record));
$table = $opt->{table} || $::Scratch->{ui_data_table};
if($field eq 'user') {
return $Vend::Session->{ui_username} || $Vend::Session->{username} || $CGI::user;
}
my %hash_field = qw/
acl_keys 1
no_fields 1
yes_fields 1
no_keys 1
yes_keys 1
owner_field 1
/;
my $acl;
my $check;
if($check = $hash_field{$field}) {
if ($field eq 'acl_keys') {
return join "\n", get_ui_table_acl($table, $uid, 1);
}
else {
$acl = get_ui_table_acl($table, $uid);
return $acl->{$field};
}
}
else {
return $record->{$field};
}
}
EOR
1.1 interchange/code/UI_Tag/newer.coretag
rev 1.1, prev_rev 1.0
Index: newer.coretag
===================================================================
UserTag newer Order source target
UserTag newer Routine <<EOR
sub {
my ($source, $file2) = @_;
my $file1 = $source;
if(! $file2 and $source !~ /\./) {
if($Global::GDBM) {
$file1 .= '.gdbm';
}
elsif($Global::DB_File) {
$file1 .= '.db';
}
else {
return undef;
}
$file2 = $Vend::Cfg->{Database}{$source}{'file'}
or return undef;
$file1 = $Vend::Cfg->{ProductDir} . '/' . $file1
unless $file1 =~ m:/:;
$file2 = $Vend::Cfg->{ProductDir} . '/' . $file2
unless $file2 =~ m:/:;
}
my $time1 = (stat($file1))[9]
or return undef;
my $time2 = (stat($file2))[9];
return 1 if $time1 > $time2;
return 0;
}
EOR
1.1 interchange/code/UI_Tag/quick_table.coretag
rev 1.1, prev_rev 1.0
Index: quick_table.coretag
===================================================================
UserTag quick_table HasEndTag
UserTag quick_table Interpolate
UserTag quick_table Order border
UserTag quick_table Routine <<EOR
sub {
my ($border,$input) = @_;
$border = " BORDER=$border" if $border;
my $out = "<TABLE ALIGN=LEFT$border>";
my @rows = split /\n+/, $input;
my ($left, $right);
for(@rows) {
$out .= '<TR><TD ALIGN=RIGHT VALIGN=TOP>';
($left, $right) = split /\s*:\s*/, $_, 2;
$out .= '<B>' unless $left =~ /</;
$out .= $left;
$out .= '</B>' unless $left =~ /</;
$out .= '</TD><TD VALIGN=TOP>';
$out .= $right;
$out .= '</TD></TR>';
$out .= "\n";
}
$out .= '</TABLE>';
}
EOR
1.1 interchange/code/UI_Tag/read_page.coretag
rev 1.1, prev_rev 1.0
Index: read_page.coretag
===================================================================
UserTag read-page Order page
UserTag read-page addAttr
UserTag read-page Documentation <<EOD
[read-page page="<filespec>"]
Returns the structure of a page.
ui_component
Returns the component settings as an array with the elements
as major keys, i.e:
[control-set]
[size]1[/size]
[color]red[/color]
[/control-set]
[control-set]
[size]5[/size]
[color]green[/color]
[banner]Very Green[/banner]
[/control-set]
becomes:
[
{ size => 1, color => 'red' },
{ size => 5, color => 'green', banner => 'Very Green' },
]
ui_component_text
The component settings as text, in the event component settings are
not to be edited.
ui_page_setting
Returns the page global settings as a hash. Reads [set|tmp|seti ..][/set]
in the area above the first template region (i.e. @_LEFTONLY_TOP_@), but outside
of the [control] region.
[set page_title]Some title[/set]
[set members_only][/set]
becomes:
{ page_title => 'Some title', members_only => 1 }
ui_page_setting_text
The text of the page setting area, used if the page settings are not to
be edited.
If the textref=1 is passed in the tag call, a stringified version is
returned.
ui_content
Returns the content, which is the section between
<!-- BEGIN CONTENT --> and <!-- END CONTENT -->.
EOD
UserTag read-page Routine <<EOR
sub {
my ($pn, $opt) = @_;
use vars qw/$Tag $Session $Variable/;
::logDebug("read_ui_page pn=$pn");
my $suffix = $Vend::Cfg->{HTMLsuffix} || '.html';
my $tmpdir = $Vend::Cfg->{ScratchDir} || 'tmp';
my $pagedir = $Vend::Cfg->{PageDir} || 'pages';
for(\$tmpdir, \$pagedir) {
$$_ =~ s!^$Vend::Cfg->{VendRoot}/!!;
}
$tmpdir .= "/pages/$Session->{id}";
File::Path::mkpath($tmpdir) unless -d $tmpdir;
my $name = $pn;
my $altname = $name;
$altname =~ s:^$pagedir/::;
$name .= $suffix unless $name =~ /$suffix$/;
my $data;
my $inprocess;
my $record;
### We look for a saved but unpublished page in
### the temporary space for the user, and use that if
### it is there. Otherwise, we read normally.
if($pn) {
FINDPN: {
$pn = "$tmpdir/$name";
if(-f $pn) {
$inprocess = 1;
last FINDPN;
}
($data, $record) = Vend::Util::readin($altname, undef, 0);
}
$data = Vend::Util::readfile($pn, $Global::NoAbsolute, 0)
unless $data;
}
else {
$data = $opt->{body} || '';
}
unless (length($data)) {
Log("page not found: %s", $pn);
Debug("page not found: $pn");
return undef;
}
my $tref;
my ($ary) = $Tag->read_ui_template( { passed => $data } );
Debug("ary from read_ui_template: $ary");
$tref = $ary->[0] if $ary;
Debug("tref from read_ui_template: $tref");
$tref ||= {};
# Read external template if not in page
if(! $tref->{ui_template_elements}) {
my $tdir = $Variable->{UI_TEMPLATE_DIR} || 'templates';
my $template = $tref->{ui_template_name};
undef $tref;
($ary) = $Tag->read_ui_template("$tdir/$template");
$tref = shift @$ary if $ary;
Debug("tref $template again from read_ui_template: $tref (no ui_template_elements)");
}
if(! $tref) {
$tref = {
ui_template_version => $Global::VERSION,
ui_template_name => 'NONE',
ui_template_elements => 'NONE, UI_CONTENT, NONE'
};
}
my $ref = {
ui_page_file => $pn,
ui_page_name => $name,
ui_component => [],
ui_page_setting => {},
ui_pre_region => [],
ui_post_region => [],
ui_page_inprocess => $inprocess,
};
if($record) {
$ref->{ui_expiration_date} = $record->{expiration_date};
$ref->{ui_show_date} = $record->{show_date};
}
my $preamble;
my $postamble;
if (
$data =~ m{
(.*)
<!--+\s+begin\s+content\s+--+>
\n?
(.*?)
\n?
<!--+\s+end\s+content\s+--+>
(.*)
}xsi
)
{
$preamble = $1;
$ref->{ui_content} = $2;
$postamble = $3;
}
else {
$ref->{ui_content} = $data;
return uneval($ref) if $opt->{textref};
return $ref;
}
my @comps;
sub _setref {
my ($ref, $key, $val) = @_;
$key = lc $key;
$key =~ tr/-/_/;
#Log("_setref key=$key val=$val");
$ref->{$key} = $val;
}
#Debug("preamble=|$preamble| postamble=|$postamble|");
if (
$preamble =~ s{
<!--+ \s+ begin\s+preamble \s+ --+>
\n?
(.*?)
\n?
<!--+ \s+end\s+preamble\s+ --+>\n?
}{}xsi
)
{
$ref->{ui_page_preamble} = $1;
#Debug("found preamble=$ref->{ui_page_preamble}");
}
if (
$postamble =~ s{
<!--+\s+begin\s+postamble\s+--+>
\n?
(.*?)
\n?
<!--+\s+end\s+postamble\s+--+>
}{}xsi
)
{
$ref->{ui_page_postamble} = $1;
}
while ($preamble =~ s/^[ \t]*((?:\@_|__|\@\@)[A-Z][A-Z_]+[A-Z](?:_\@|__|\@\@))[ \t]*$//m ) {
push @{$ref->{ui_pre_region}}, $1;
}
while($postamble =~ s/^[ \t]*((?:\@_|__|\@\@)[A-Z][A-Z_]+[A-Z](?:_\@|__|\@\@))//m ) {
push @{$ref->{ui_post_region}}, $1;
}
$postamble =~ s/^\s+//;
$postamble =~ s/\s+$//;
$ref->{ui_page_end} = $postamble;
if($preamble =~ s/
(\[control \s+ reset .*? \]
*?
\[control \s+ reset .*? \])
//six)
{
# New style
my $stuff = $1;
$ref->{ui_component_text} = $stuff;
while($stuff =~ s{\[control-set\](.*?)\[/control-set\]}{}is ) {
my $sets = $1;
my $r = {};
$sets =~ s{\[([-\w]+)\](.*?)\[/\1\]}{ _setref($r, $1, $2) }eisg;
push @comps, $r;
}
$stuff =~ s/^\s+//;
$stuff =~ s/\s+$//;
$ref->{ui_component} = \@comps;
}
# Global controls
$ref->{ui_page_setting_text} = '';
while($preamble =~ s{(\[(set|tmp|seti)\s+([^\]]+)\](.*?)\[/\2\])}{}is ) {
$tref->{$3} = $4;
$ref->{ui_page_setting_text} .= "$1\n";
}
$preamble =~ s/^\s+//;
$preamble =~ s/\s+$//;
$ref->{ui_page_begin} = $preamble;
$ref->{ui_page_setting} = $tref;
#Log("page reference: " . uneval($ref) );
return uneval_it($ref) if $opt->{textref};
return $ref unless wantarray;
return ($ref, $tref);
}
EOR
1.1 interchange/code/UI_Tag/read_shipping.coretag
rev 1.1, prev_rev 1.0
Index: read_shipping.coretag
===================================================================
UserTag read-shipping Order file
UserTag read-shipping PosNumber 1
UserTag read-shipping addAttr
UserTag read-shipping Routine <<EOR
sub {
my ($file, $opt) = @_;
my $status = read_shipping($file, $opt);
if(
$Vend::Cfg->{Shipping_line}[0]->[0] eq 'code'
and
$Vend::Cfg->{Shipping_line}[0]->[1] eq 'description'
)
{
shift (@{ $Vend::Cfg->{Shipping_line} });
delete $Vend::Cfg->{Shipping_desc}{code};
}
return $status;
}
EOR
1.1 interchange/code/UI_Tag/read_ui_page.coretag
rev 1.1, prev_rev 1.0
Index: read_ui_page.coretag
===================================================================
UserTag read-ui-page Order page
UserTag read-ui-page addAttr
UserTag read-ui-page Documentation <<EOD
[read-ui-page page="<filespec>"]
Returns the structure of a page.
ui_component
Returns the component settings as an array with the elements
as major keys, i.e:
[control-set]
[size]1[/size]
[color]red[/color]
[/control-set]
[control-set]
[size]5[/size]
[color]green[/color]
[banner]Very Green[/banner]
[/control-set]
becomes:
[
{ size => 1, color => 'red' },
{ size => 5, color => 'green', banner => 'Very Green' },
]
ui_component_text
The component settings as text, in the event component settings are
not to be edited.
ui_page_setting
Returns the page global settings as a hash. Reads [set|tmp|seti ..][/set]
in the area above the first template region (i.e. @_LEFTONLY_TOP_@), but outside
of the [control] region.
[set page_title]Some title[/set]
[set members_only][/set]
becomes:
{ page_title => 'Some title', members_only => 1 }
ui_page_setting_text
The text of the page setting area, used if the page settings are not to
be edited.
If the textref=1 is passed in the tag call, a stringified version is
returned.
ui_content
Returns the content, which is the section between
<!-- BEGIN CONTENT --> and <!-- END CONTENT -->.
EOD
UserTag read-ui-page Routine <<EOR
sub {
my ($pn, $opt) = @_;
#::logDebug("read_ui_page pn=$pn");
my $suffix = $Vend::Cfg->{HTMLsuffix} || '.html';
my $tmpdir = $Vend::Cfg->{ScratchDir} || 'tmp';
my $pagedir = $Vend::Cfg->{PageDir} || 'pages';
for(\$tmpdir, \$pagedir) {
$$_ =~ s!^$Vend::Cfg->{VendRoot}/!!;
}
$tmpdir .= "/pages/$Session->{id}";
File::Path::mkpath($tmpdir) unless -d $tmpdir;
my $name = $pn;
my $data;
my $inprocess;
my $record;
### We look for a saved but unpublished page in
### the temporary space for the user, and use that if
### it is there. Otherwise, we read normally.
if($pn) {
FINDPN: {
$pn = "$tmpdir/$name";
if(-f $pn) {
$inprocess = 1;
last FINDPN;
}
($data, $record) = Vend::Util::readin($name, undef, 0);
}
$data = Vend::Util::readfile($pn, $Global::NoAbsolute, 0)
unless $data;
}
else {
$data = $opt->{body} || '';
}
return undef unless length($data);
my $ref = {
ui_page_file => $pn,
ui_page_name => $name,
ui_component => [],
ui_page_setting => {},
ui_pre_region => [],
ui_post_region => [],
ui_page_inprocess => $inprocess,
};
if($record) {
$ref->{ui_expiration_date} = $record->{expiration_date};
$ref->{ui_show_date} = $record->{show_date};
}
my $preamble;
my $postamble;
if (
$data =~ m{
(.*)
<!--+\s+begin\s+content\s+--+>
\n?
(.*?)
\n?
<!--+\s+end\s+content\s+--+>
(.*)
}xsi
)
{
$preamble = $1;
$ref->{ui_content} = $2;
$postamble = $3;
}
else {
$ref->{ui_content} = $data;
return uneval($ref) if $opt->{textref};
return $ref;
}
my @comps;
sub _setref {
my ($ref, $key, $val) = @_;
$key = lc $key;
$key =~ tr/-/_/;
#Log("_setref key=$key val=$val");
$ref->{$key} = $val;
}
#Debug("preamble=|$preamble| postamble=|$postamble|");
if (
$preamble =~ s{
<!--+ \s+ begin\s+preamble \s+ --+>
\n?
(.*?)
\n?
<!--+ \s+end\s+preamble\s+ --+>\n?
}{}xsi
)
{
$ref->{ui_page_preamble} = $1;
#Debug("found preamble=$ref->{ui_page_preamble}");
}
if (
$postamble =~ s{
<!--+\s+begin\s+postamble\s+--+>
\n?
(.*?)
\n?
<!--+\s+end\s+postamble\s+--+>
}{}xsi
)
{
$ref->{ui_page_postamble} = $1;
}
while ($preamble =~ s/^[ \t]*((?:\@_|__|\@\@)[A-Z][A-Z_]+[A-Z](?:_\@|__|\@\@))[ \t]*$//m ) {
push @{$ref->{ui_pre_region}}, $1;
}
while($postamble =~ s/^[ \t]*((?:\@_|__|\@\@)[A-Z][A-Z_]+[A-Z](?:_\@|__|\@\@))//m ) {
push @{$ref->{ui_post_region}}, $1;
}
$postamble =~ s/^\s+//;
$postamble =~ s/\s+$//;
$ref->{ui_page_end} = $postamble;
if($preamble =~ s/
(\[control \s+ reset .*? \]
*?
\[control \s+ reset .*? \])
//six)
{
# New style
my $stuff = $1;
$ref->{ui_component_text} = $stuff;
while($stuff =~ s{\[control-set\](.*?)\[/control-set\]}{}is ) {
my $sets = $1;
my $r = {};
$sets =~ s{\[([-\w]+)\](.*?)\[/\1\]}{ _setref($r, $1, $2) }eisg;
push @comps, $r;
}
$stuff =~ s/^\s+//;
$stuff =~ s/\s+$//;
$ref->{ui_component} = \@comps;
}
my $tref = {};
# Global controls
$ref->{ui_page_setting_text} = '';
while($preamble =~ s{(\[(set|tmp|seti)\s+([^\]]+)\](.*?)\[/\2\])}{}is ) {
$tref->{$3} = $4;
$ref->{ui_page_setting_text} .= "$1\n";
}
$preamble =~ s/^\s+//;
$preamble =~ s/\s+$//;
$ref->{ui_page_begin} = $preamble;
$ref->{ui_page_setting} = $tref;
#Log("page reference: " . uneval($ref) );
return uneval_it($ref) if $opt->{textref};
return $ref;
}
EOR
1.1 interchange/code/UI_Tag/read_ui_template.coretag
rev 1.1, prev_rev 1.0
Index: read_ui_template.coretag
===================================================================
UserTag read-ui-template Order file
UserTag read-ui-template addAttr
UserTag read-ui-template Documentation <<EOD
[read-ui-template file="<filespec>" element=name* structure=1|0]
Returns the description of a page as described by a [comment] [/comment]
containing different named elements:
element: item [: optional data value]
If there is an optional data item, element becomes a hash reference
and is set as a key/value pair with "item" being the key. There can
be multiple keys. Otherwise, "element" is set to a value of "item" as the data.
If the element=name is set in the tag call, then only that element is
returned. IF called by a subroutine wanting an array, an array reference
is returned. Otherwise, a newline-separated set of values is returned.
If the structure=1 is passed in the tag call, a structure is passed
with the page name as the key, and its elements as a hash reference, i.e.
($ref) = $Tag->read_ui_template('templates/*');
$ref will be like:
{
standard => {
ui_template_description => 'Standard ....',
ui_template_elements => 'LOGOBAR, MENUBAR, LEFTSIDE, UI_CONTENT ....',
},
standalone => {
ui_template_description => 'Standalone no left side ...',
ui_template_elements => 'LOGOBAR, MENUBAR, UI_CONTENT, ....',
},
EOD
UserTag read-ui-template Routine <<EOR
sub {
my ($fn, $opt) = @_;
my @files;
my $return_structure;
if(ref $fn) {
@files = @$fn;
}
else {
@files = glob($fn);
}
my $tmpdir = $Vend::Cfg->{ScratchDir} || 'tmp';
my $pagedir = $Vend::Cfg->{PageDir} || 'pages';
for(\$tmpdir, \$pagedir) {
$$_ =~ s!^$Vend::Cfg->{VendRoot}/!!;
}
$tmpdir .= "/pages/$Session->{id}";
my $data;
my %out;
my @out;
if($opt->{passed}) {
unshift @files, '';
}
foreach my $fn (@files) {
my $name = $fn;
my $page_id = $fn;
$page_id =~ s:^$pagedir/::;
$page_id =~ s:\.html?$::;
## This will contain extended page info from database if read
## from there
my $record;
### We look for a saved but unpublished page in
### the temporary space for the user, and use that if
### it is there. Otherwise, we read normally.
my $tmp = "$tmpdir/$name";
#::logDebug("looking for inprocess file $tmp");
if(! $name and $data = $opt->{passed}) {
::logDebug("found passed data, no name");
# do nothing
}
elsif(-f $tmp) {
#::logDebug("found inprocess file $tmp");
# force substitution of [L..]-stuff off by defining third param
$data = Vend::Util::readfile($tmp, $Global::NoAbsolute, 0);
}
elsif ($tmp .= ".html" and -f $tmp) {
#::logDebug("found inprocess file $tmp");
$data = Vend::Util::readfile($tmp, $Global::NoAbsolute, 0);
}
else {
# force substitution of [L..]-stuff off by defining third param
#::logDebug("no inprocess, readin $fn");
($data, $record) = Vend::Util::readin($page_id, undef, 0);
$data = Vend::Util::readfile($fn, $Global::NoAbsolute, 0)
if ! length($data);
}
next unless length($data);
$name =~ s:.*/::;
my $ref = {};
$data =~ m{\[comment\]\s*(ui_.*?)\[/comment\]\s*(.*)}s;
my $structure = $1 || '';
next unless $structure;
$ref->{ui_current_content} = $2;
if($record) {
$ref->{ui_expiration_date} = $record->{expiration_date};
$ref->{ui_show_date} = $record->{show_date};
}
my @lines = split /\n/, $structure;
my $found;
for(;;) {
my $i = -1;
for(@lines) {
$i++;
next unless s/\\$//;
$found = $i;
last;
}
last unless defined $found;
if (defined $found) {
my $add = splice @lines, $found + 1, 1;
#::logDebug("Add is '$add', found index=$found");
$lines[$found] .= $add;
#::logDebug("Complete line now is '$lines[$found]'");
undef $found;
}
}
$ref->{ui_definition} = join "\n", @lines;
my $current;
for(@lines) {
if(/^\s*ui_/) {
my ($el, $el_item, $el_data) = split /\s*:\s*/, $_;
#::logDebug("found el=$el el_item=$el_item el_data=$el_data");
if(defined $el_data) {
$ref->{$el} = { } if ! ref($ref->{$el});
$ref->{$el}{$el_item} = $el_data;
}
else {
$ref->{$el} = $el_item;
}
}
elsif ( /^(\w+)\s*:\s*(.*)$/) {
$current = $1;
$ref->{element}{$current} = $2;
$ref->{ui_display_order} = [] if ! $ref->{ui_display_order};
push @{$ref->{ui_display_order}}, $current;
}
elsif( /^\s+(\w+)\s*:\s*(.*)/ ) {
my ($fn, $fv) = ( lc($1), $2 );
$ref->{$fn}{$current} = $fv;
}
}
if($opt->{structure}) {
$out{$fn} = $ref;
}
elsif($opt->{element}) {
push @out, $ref->{$opt->{element}};
}
else {
push @out, $ref;
}
}
if(wantarray) {
return \%out if $opt->{structure};
return \@out;
}
elsif($opt->{structure}) {
return ::uneval(\%out);
}
else {
return join "\n", @out;
}
}
EOR
1.1 interchange/code/UI_Tag/reconfig.coretag
rev 1.1, prev_rev 1.0
Index: reconfig.coretag
===================================================================
UserTag reconfig Order name
UserTag reconfig PosNumber 1
UserTag reconfig Routine <<EOR
use strict;
sub {
my $name = shift || $Vend::Cfg->{CatalogName};
my $myname = $Vend::Cfg->{CatalogName};
#::logGlobal("Trying to reconfig $name");
if($myname ne '_mv_admin' and $myname ne $name) {
$::Values{mv_error_tag_restart} =
"Not authorized to reconfig that catalog.";
return undef;
}
#::logGlobal("Passed name check on reconfig $name");
logData("$Global::RunDir/reconfig", $Global::Catalog{$name}->{'script'});
return 1;
}
EOR
1.1 interchange/code/UI_Tag/reconfig_time.coretag
rev 1.1, prev_rev 1.0
Index: reconfig_time.coretag
===================================================================
UserTag reconfig-time Order name
UserTag reconfig-time Routine <<EOR
sub {
my $name = shift || $Vend::Cfg->{CatalogName};
my $myname = $Vend::Cfg->{CatalogName};
return '' unless $myname eq '_mv_admin' or $myname eq $name;
return Vend::Util::readfile($Global::RunDir . '/status.' . $name);
}
EOR
1.1 interchange/code/UI_Tag/reconfig_wait.coretag
rev 1.1, prev_rev 1.0
Index: reconfig_wait.coretag
===================================================================
UserTag reconfig-wait Order name
UserTag reconfig-wait Routine <<EOR
sub {
my $name = shift || $Vend::Cfg->{CatalogName};
my $myname = $Vend::Cfg->{CatalogName};
return '' unless $myname eq '_mv_admin' or $myname eq $name;
my $now = time();
my $mod = ( stat("$Global::RunDir/status." . $Vend::Cfg->{CatalogName}))[9];
if( ($now - $mod) < $Global::HouseKeeping ) {
$::Scratch->{possible_timeout} = 0;
$::Scratch->{reconfigured} = 1;
return '';
}
else {
sleep 1;
$::Scratch->{possible_timeout} = 1;
return errmsg('please wait') . '...<BR>';
}
}
EOR
1.1 interchange/code/UI_Tag/regenerate.coretag
rev 1.1, prev_rev 1.0
Index: regenerate.coretag
===================================================================
UserTag regenerate Order initial
UserTag regenerate PosNumber 1
UserTag regenerate Routine <<EOR
my @regen_messages;
my %regen_reject = qw/ ui 1 minimate 1 process 1 search 1 order 1 obtain 1 /;
my %force_build;
my %never_build;
my $regen_scan;
my $regen_out;
my $regen_arg;
my $initial;
sub regen_track {
return unless $Vend::Cfg->{StaticTrack};
my(@parm) = @_;
Vend::Util::logData(
$Vend::Cfg->{StaticTrack},
POSIX::strftime('%Y%m%d %H%M%S', localtime()),
join('&', @parm),
);
return;
}
sub regen_build {
my $ref = shift;
my $page;
undef $regen_scan;
undef $regen_arg;
undef $regen_out;
if($ref->[1]) {
$initial = $ref->[1][0];
$regen_arg = $ref->[1][1];
$regen_out = $ref->[0];
}
else {
$initial = $ref->[0];
$regen_out = $ref->[0];
}
my ($action, $path) = split m:/:, $initial, 2;
return undef if $regen_reject{$action};
$Vend::Session = {
'ohost' => 'REGENERA',
'browser' => "Interchange $::VERSION regenerator",
'values' => { %{$Vend::Cfg->{ValuesDefault}} },
'carts' => {main => []},
};
my ($key, $value);
while (($key, $value) = each (%{$Vend::Cfg->{StaticSessionDefault}})) {
$Vend::Session->{$key} = $value;
}
$CGI::values = ();
($Vend::Session->{arg} = $Vend::Argument = $CGI::values{mv_arg} = $regen_arg)
if $regen_arg;
if($action eq 'scan') {
$regen_scan = 1;
my $c = {};
::find_search_params($c, $path);
$c->{mv_more_id} = 'static';
$Vend::SearchObject{''} = perform_search($c);
$initial = $Vend::SearchObject{''}->{mv_search_page}
|| find_special_page('search');
}
my $actual;
$page = readin($initial);
if(! defined $page) {
$page = Vend::Interpolate::fly_page($initial);
$actual = $Global::Variable->{MV_PAGE};
}
$actual = $initial unless $actual;
#::logDebug("checking for force of: $actual");
if (defined $never_build{$actual}) {
undef $Vend::ForceBuild;
undef $Vend::CachePage;
}
elsif (defined $force_build{$actual}) {
$Vend::ForceBuild = 1;
}
return unless defined $page;
my $pageref;
my $scratch = $::Scratch;
$::Scratch = { %{$Vend::Cfg->{ScratchDefault}},
mv_no_session_id => 1,
mv_no_count => 1,
};
# bindings for Safe are no longer valid
$Vend::Calc_initialized = 0;
eval {
($pageref) = ::cache_html($page, 1);
};
$::Scratch = $scratch;
#::logDebug(<<EOF);
#finished regen_build:
# out=$regen_out
# arg=$regen_arg
# scan=$regen_scan
# page=$pageref
# force=$Vend::ForceBuild
# cache=$Vend::Cache
#EOF
if($@) {
push @regen_messages, "$ref->[0]: $@";
regen_track("Problem with $ref->[0]: $@");
undef $Vend::CachePage;
undef $Vend::ForceBuild;
}
return $pageref;
}
sub {
$initial = shift || $CGI::values{ui_initial_page} || $Vend::Cfg->{SpecialPage}{catalog};
my $verbose = $CGI::values{ui_build_verbose} || '';
my $max_links = $CGI::values{ui_max_build} || '500';
my $links_done = 0;
if($CGI::values{ui_force_build}) {
my @tmp = split /\0/, $CGI::values{ui_force_build};
#::logDebug("force build of: @tmp");
@force_build{@tmp} = (@tmp);
}
if($CGI::values{ui_never_build}) {
my @tmp = split /\0/, $CGI::values{ui_never_build};
#::logDebug("never build of: @tmp");
@never_build{@tmp} = (@tmp);
}
my $save_session = $Vend::Session;
my $save_status = $Vend::StatusLine;
my %save_cgi = %CGI::values;
my %done;
my $start = (times)[0];
require File::Path;
$regen_reject{$Vend::Cfg->{UI_BASE}} = 1;
for (keys %{$Vend::Cfg->{ActionMap}}) {
$regen_reject{$_} = 1;
}
my $spacer = $::Scratch->{spacer} || ' ';
my $output = <<EOF;
$Global::Variable->{UI_STD_HEAD}
Entry page $initial.
<br><p></p>
</td>
</tr>
</table>
</td>
</tr>
</table>
</center>
EOF
::response(::interpolate_html ($output));
::response(" " x 1024);
::response("<PRE> Checking for links.....\n");
regen_track("Starting static page build");
my $suffix = $Vend::Cfg->{StaticSuffix} || '.html';
$output = '';
$Vend::Cookie = 'REGENERA';
$Vend::AccumulatingLinks = 1;
untie %Vend::StaticDBM;
$Vend::Cfg->{Static} = 1;
my @links = ( [ $initial, '' ] );;
for my $force (keys %force_build) {
push (@links, [ $force, '' ]);
}
my %found;
%Vend::Links = ();
%Vend::LinkFound = ();
#::logDebug( "default search=$::Variable->{MV_DEFAULT_SEARCH_FILE}");
my ($page);
while(@links) {
if($links_done++ > $max_links) {
::response("Reached maximum link count of $max_links, stopping.\n");
regen_track("Reached maximum link count of $max_links");
last;
}
$output .= '.';
my $ref = shift @links;
next if exists $done{$ref->[0]};
@Vend::Links = ();
%Vend::LinkFound = (%found);
undef $Vend::Argument;
undef $Vend::CachePage;
undef $Vend::ForceBuild;
$verbose and ::response(qq{ Checking page $ref->[0]....});
regen_track("Checking $ref->[0]");
regen_build($ref);
regen_track("Finished with $ref->[0]");
if($Vend::CachePage || $Vend::ForceBuild) {
$verbose and ::response(qq{will build.\n});
push (@links, @Vend::Links);
#::logDebug("links: @Vend::Links");
for (keys %Vend::LinkFound) {
::response(" Found link $_.\n")
if $verbose and ! $found{$_};
#::logDebug("link: found $_");
$found{$_} = 1;
}
#if($regen_scan) {
# $$pageref =~ s!($Vend::Cfg->{VendURL})/scan/MM=[^"]+!$1/$ref->[0]!g;
#}
if($regen_scan) {
$regen_out = $ref->[0];
$regen_out =~ s:^scan/::;
$regen_out = Vend::Util::generate_key($regen_out);
$regen_out = "scan/$regen_out$suffix";
}
elsif ($regen_arg) {
$regen_arg =~ s:([^-\w/]):sprintf '%%%02x', ord($1):eg;
$regen_out = "$initial/$regen_arg$suffix";
}
else {
$regen_out = "$regen_out$suffix";
}
$Vend::StaticDBM{$ref->[0]} = $regen_out;
$done{$ref->[0]} = $ref;
}
else {
$verbose and ::response(qq{no.\n});
$done{$ref->[0]} = 0;
}
}
::response( " done with link checks, $links_done checked.\n" );
for(keys %done) {
$output .= "$_ = $done{$_}<br>\n";
}
undef $Vend::AccumulatingLinks;
::response("\n\n Generating....\n");
# we need to restore some settings from the original configuration
# for static page building first
my @confsafe = ('ImageDir', 'ImageDirSecure', 'VendURL');
my %safehash;
for (@confsafe) {$safehash{$_} = $Vend::Cfg->{$_}}
$Vend::Cfg->{ImageDir} = $Vend::Cfg->{ImageDirOriginal};
$Vend::Cfg->{ImageDirSecure} = $Vend::Cfg->{ImageDirSecureOriginal};
$Vend::Cfg->{VendURL} = $Vend::Cfg->{VendURLOriginal};
my $umask = umask(022);
my $statpath = 'http://' . $::Variable->{SERVER_NAME} . $Vend::Cfg->{StaticPath};
my @bad;
my $base = $Vend::Cfg->{StaticDir};
eval {
File::Path::rmtree($base);
File::Path::mkpath($base);
my ($dir, $file);
for(keys %Vend::StaticDBM) {
my $ref = delete $done{$_};
next unless $ref;
$dir = $file = "$base/$Vend::StaticDBM{$_}";
$dir =~ s:/[^/]+$::;
if(! -d $dir) {
die "Wild directory $dir" if -e $dir;
File::Path::mkpath($dir);
}
open(REGENFILE, ">$file")
or die "create $file: $!\n";
regen_track("Building $ref->[0]");
my $pageref = regen_build($ref);
regen_track("Finished with $ref->[0]");
if(! $pageref) {
push (@regen_messages, "problem building $_.");
push @bad, $_;
close REGENFILE;
unlink $file;
next;
}
print REGENFILE $$pageref;
close REGENFILE;
my $dispfile = $file;
$dispfile =~ s:^$base/::o;
$dispfile = qq{<A HREF="$statpath/$dispfile"><U>$dispfile</U></A>};
::response(" Generated $dispfile.\n")
if $verbose;
}
};
# get back to the UI configuration settings
for (@confsafe) {$Vend::Cfg->{$_} = $safehash{$_}}
my $success;
if($@) {
push (@regen_messages, "during file write: $@\n");
::response("\n Failed to write all files.\n</PRE>");
}
else {
::response("\n Finished writing files.\n</PRE>");
$success = 1;
}
umask($umask);
if($success) {
my %my_static;
%my_static = %Vend::StaticDBM;
$Vend::Cfg->{StaticDBM} = $Vend::Cfg->{SaveStaticDBM}
if ! $Vend::Cfg->{StaticDBM};
if(::tie_static_dbm(1)) {
my @del = keys %Vend::StaticDBM;
for(@del) {
delete $Vend::StaticDBM{$_};
}
my ($k, $v);
while( ($k, $v) = each %my_static) {
$Vend::StaticDBM{$k} = $v;
}
}
}
$Vend::Session = $save_session;
$Vend::StatusLine = $save_status;
%CGI::values = %save_cgi;
if(@regen_messages) {
my $out = "Messages during regen:<blockquote>";
$out .= join "<br>", @regen_messages;
$out .= "</blockquote>";
regen_track(join("\n", @regen_messages));
::response($out);
}
my $end = (times)[0] - $start;
$end = int($end);
regen_track("Finished static page building in $end seconds.");
::response(::interpolate_html(<<EOF, 1));
<table cellpadding=2 cellspacing=0 width=__UI_OVERALL_WIDTH__ bgcolor=__UI_C_TITLEBARBG__ border=0>
<tr>
<td>
<table cellpadding=0 cellspacing=0 width=100% bgcolor=__UI_T_BG__ border=0>
<tr>
<td colspan=2 align="center">
<table width=90% cellpadding=0 cellspacing=0 border=0>
<tr>
<td>
<br><br>
<img src="icon_regen.gif"
width=16 height=16 border=0 valign=top>
<font size="+1" face="Verdana,arial,helvetica,sans-serif" color="#000000">Regeneration complete in $end seconds. <br></font></td></tr>
</table>
</td>
</tr>
<tr>
<td colspan="2">
<style type="text/css">
<!--
td{font-family:arial, helvetica, sans-serif}
-->
</style>
<center>
$Global::Variable->{UI_STD_FOOTER};
EOF
return;
}
EOR
1.1 interchange/code/UI_Tag/return_to.coretag
rev 1.1, prev_rev 1.0
Index: return_to.coretag
===================================================================
UserTag return_to Order type table_hack
UserTag return_to addAttr
UserTag return_to Routine <<EOR
sub {
use vars qw/$Tag/;
my ($type, $tablehack, $opt) = @_;
$type = 'form' unless $type;
my ($page, @args) = split /\0/, $CGI::values{ui_return_to};
if($CGI::values{ui_target}) {
push @args, "ui_target=$CGI::values{ui_target}";
}
my $out = '';
if ($opt->{page}) {
$page = $opt->{page};
}
my $extra;
if($tablehack) {
my $found;
for (@args) {
if(s/^mv_data_table=(.*)//) {
$extra = "mv_return_table=$1\n";
}
elsif (s/^(ui|mv)_return_table=//) {
$found = "mv_return_table=$_\n";
}
}
$extra = $found if $found;
}
if($type eq 'click') {
$out .= qq{mv_nextpage=$page\n} if $page;
for(@args) {
my ($k, $v) = split /\s*=\s*/, $_, 2;
next unless length $k;
next if $k =~ /$opt->{exclude}/;
$v =~ s/__NULL__/\0/g;
$out .= qq{$k=$v\n};
}
if($opt->{stack} or $CGI::values{ui_return_stack}) {
$type = 'formlink';
}
else {
$type = 'done';
$out .= "ui_return_to=\n";
}
}
if($type eq 'formlink') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= qq{ui_return_to=$page\n};
for(@args) {
tr/\n/\r/;
$out .= qq{ui_return_to=$_\n}
}
}
elsif($type eq 'url') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= $Tag->area( {
href => $page,
form => join("\n", @args),
});
}
elsif ($type eq 'form') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="$page">\n};
for(@args) {
s/"/"/g;
$out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="$_">\n}
}
}
elsif ($type eq 'regen') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="ui_return_to=$page">\n};
for(@args) {
s/"/"/g;
$out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="ui_return_to=$_">\n}
}
}
$out .= $extra if $extra;
$::Scratch->{ui_location} = $Tag->area({
href => $page,
form => join "\n", @args,
})
if $opt->{scratch};
return $out;
}
EOR
1.1 interchange/code/UI_Tag/rotate_file.coretag
rev 1.1, prev_rev 1.0
Index: rotate_file.coretag
===================================================================
UserTag rotate_file Order file rollback
UserTag rotate_file PosNumber 2
UserTag rotate_file Routine <<EOR
sub {
my($file, $rollback) = @_;
return UI::Primitive::rotate($file, $rollback);
}
EOR
1.1 interchange/code/UI_Tag/rotate_table.coretag
rev 1.1, prev_rev 1.0
Index: rotate_table.coretag
===================================================================
UserTag rotate-table Order rotate
UserTag rotate-table PosNumber 1
UserTag rotate-table Interpolate 1
UserTag rotate-table HasEndTag 1
UserTag rotate-table Routine <<EOR
sub {
my ($rotate, $text) = @_;
return $text unless $rotate;
my $rotated = '';
$text =~ s/(.*<TABLE.*?>)//si;
my $out = $1 || '';
$text =~ s:(.*?)</table\s*>:</TABLE>:si;
my $table = $1;
my @cols;
while ($table =~ m:<TR.*?>(.*?)</TR>:sig) {
push @cols, $1;
}
my $i = 0;
my @rows;
my @meta;
my $rows = 0;
my @r; my @c; my @m;
my ($r,$c);
for (@cols) {
while(m:<T([HD])(.*?)>(.*?)</T\1>:sig) {
my $meta = $1 . $2;
push @r, $3;
if($meta =~ /SPAN/i) {
$meta =~ s/\bcolspan\s*=/ROWMETASPAN=/ig;
$meta =~ s/\browspan\s*=/COLMETASPAN=/ig;
$meta =~ s/(ROW|COL)META/$1/g;
}
push @m, $meta;
}
$meta[$i] = [@m];
$rows[$i] = [@r];
$i++;
$rows = $rows < $#r ? $#r : $rows;
undef @m;
undef @r;
}
foreach $r (0 .. $rows) {
$rotated .= "<TR>\n";
foreach $c (0 .. $#cols) {
$rotated .= "<T" . $meta[$c]->[$r] . ">";
$rotated .= "$rows[$c]->[$r]";
$rotated .= "</TD>\n"
}
$rotated .= "</TR>\n";
}
return $out . $rotated . $text;
}
EOR
1.1 interchange/code/UI_Tag/row_edit.coretag
rev 1.1, prev_rev 1.0
Index: row_edit.coretag
===================================================================
UserTag row-edit HasEndTag
UserTag row-edit Order key table size columns
UserTag row-edit addAttr
UserTag row-edit Interpolate 1
UserTag row-edit Routine <<EOR
sub {
my ($key,$table,$size,$columns,$opt) = @_;
use vars qw/$CGI %Db $Values $Variable/;
#::logDebug("row_edit options=" . ::uneval($opt));
$table = $table || $CGI::values{mv_data_table} || return "BLANK DB";
my $db = $Db{$table} || Vend::Data::database_exists_ref($table);
my $mtab = $Variable->{UI_META_TABLE} || 'mvmetadata';
my $mdb = $Db{$mtab} || Vend::Data::database_exists_ref($mtab);
$opt->{view} ||= $CGI->{ui_meta_view};
my $view = UI::Primitive::meta_record($table, $opt->{view}) || {};
return errmsg("non-existent table '%s' for row-edit", $table)
unless $db;
$db = $db->ref();
my $acl = UI::Primitive::get_ui_table_acl();
my $bad;
if ($key) {
eval {
$bad = ! $db->record_exists($key);
$bad = 'DELETED' if $bad;
};
$bad = 'ERROR' if $@;
if(! $bad and $acl) {
$bad = 'Not available'
if ! UI::Primitive::ui_acl_atom($acl, 'keys', $key);
}
}
my @cols;
if($columns ||= $view->{spread_cols} || $view->{attribute}) {
@cols = split /[\s,\0]+/, $columns;
my %col;
for(@cols) {
$col{$_} = 1;
}
@cols = grep defined $col{$_}, $db->columns();
}
else {
@cols = $db->columns();
}
if($acl) {
@cols = UI::Primitive::ui_acl_grep( $acl, 'fields', @cols);
}
# See if we have a textarea reference
my %ta;
if($opt->{textarea}) {
my @tmp = split /[\s,\0]+/, $opt->{textarea};
for(@tmp) {
$ta{$_} = 1;
}
}
my $out = '';
my $meta = $CGI->{ui_no_meta_display} ? '' : $view->{type};
my $tmp;
$size = $size || $view->{width} || 12;
if($bad) {
for(@cols) {
$out .= "<TD>$bad</TD>";
}
}
elsif($key) {
my $text;
for(@cols) {
eval {
$text = $db->field($key,$_);
};
$text = 'DELETED' if $@;
my $msg = '';
if($meta) {
if ( $view->{type} =~ /combo|checkbox|multi|date|image|option_format/) {
$msg = '<br><small><small>unable to display with field info</small></small>';
}
else {
my $tmp = UI::Primitive::meta_display($table,$_,$key,$text);
$out .= "<TD>$tmp</TD>";
next;
}
}
if($ta{$_} || $text =~ /\n/) {
my $rows = $opt->{height} || 4;
$text =~ s/</</g;
$text =~ s/\[/[/g;
$out .= <<EOF;
<TD><TEXTAREA NAME="$_" COLS="$size" ROWS="$rows">$text</TEXTAREA>$msg</TD>
EOF
}
else {
$text =~ s/"/"/g;
$out .= <<EOF;
<TD><INPUT NAME="$_" SIZE=$size VALUE="$text">$msg</TD>
EOF
}
}
}
elsif($opt->{blank}) {
for(@cols) {
$out .= <<EOF;
<TD><INPUT NAME="$_" SIZE=$size VALUE=""></TD>
EOF
}
}
else {
for(@cols) {
$out .= <<EOF;
<TH ALIGN=left>$_</TH>
EOF
}
}
return $out;
}
EOR
1.1 interchange/code/UI_Tag/run_profile.coretag
rev 1.1, prev_rev 1.0
Index: run_profile.coretag
===================================================================
UserTag run-profile Order check cgi profile
UserTag run-profile addAttr
UserTag run-profile Routine <<EOR
sub {
my ($check, $cgi, $profile, $opt) = @_;
#::logDebug("call check $check");
my $ref = $cgi ? (\%CGI::values) : $::Values;
# check scratch for profile if none specified
$profile = $Scratch->{"profile_$check"} unless $profile;
#::logDebug("PROFILE(" . $Tag->var('MV_PAGE',1) . "):***$profile***");
# test passes if no profile exists
return 1 if ! $profile;
$opt->{no_error} = 1 unless defined $opt->{no_error};
my $pname = 'tmp_profile.' . $Vend::Session->{id};
#Debug("running check $check, pname=$pname profile=$profile");
$profile .= "\n&fatal=1\n";
$profile = "&noerror=1\n$profile" if $opt->{no_error};
$profile = "&overwrite=1\n$profile" if $opt->{overwrite_error};
$::Scratch->{$pname} = $profile;
my ($status) = ::check_order($pname, $ref);
delete $::Scratch->{$pname};
return $status;
}
EOR
1.1 interchange/code/UI_Tag/set_alias.coretag
rev 1.1, prev_rev 1.0
Index: set_alias.coretag
===================================================================
UserTag set-alias Order alias real permanent
UserTag set-alias PosNumber 3
UserTag set-alias Routine <<EOR
sub {
my ($alias, $real, $permanent) = @_;
my $one = $permanent ? 'path_alias' : 'one_time_path_alias';
$Vend::Session->{$one} = {}
if ! defined $Vend::Session->{$one};
$Vend::Session->{$one}{$alias} = $real;
return;
}
EOR
1.1 interchange/code/UI_Tag/substitute_file.coretag
rev 1.1, prev_rev 1.0
Index: substitute_file.coretag
===================================================================
UserTag substitute_file Order file
UserTag substitute_file addAttr
UserTag substitute_file hasEndTag
UserTag substitute_file Routine <<EOR
## This is a stupid thing to make 5.6.1 and File::Copy
## compatible with Safe
require File::Copy;
package File::Copy;
require File::Basename;
import File::Basename 'basename';
package Vend::Interpolate;
sub {
my ($file, $opt, $replace) = @_;
my $die = sub {
my @args = @_;
$::Scratch->{ui_failure} = errmsg(@args);
return undef;
};
return $die->("substitute_file - %s: file does not exist", $file)
if ! -f $file;
return $die->("substitute_file - %s: file not writeable", $file)
if ! -w $file;
if($opt->{content}) {
$opt->{begin} = '<!--+\s*begin\s+content\s*--+>';
$opt->{end} = '<!--+\s*end\s+content\s*--+>';
$opt->{newline} = 1 if ! defined $opt->{newline};
}
if($opt->{scratch}) {
$opt->{begin} = '\[(?:tmp|seti?)\s*' . $opt->{scratch} . '\]';
$opt->{end} = '\[/(?:tmp|seti?)\]';
$opt->{greedy} = 0 if ! defined $opt->{greedy};
$opt->{newline} = 1 if ! defined $opt->{newline};
}
if (! length($opt->{begin}) or ! length($opt->{end})) {
return $die->("missing begin or end marker");
}
my $bak = POSIX::tmpnam();
File::Copy::copy($file, $bak)
or return $die->(
"substitute_file - %s: unable to backup to %s",
$file, $bak,
);
my $data = Vend::Util::readfile($file);
return $die->("substitute_file - %s: file has no data", $file)
unless length $data;
my $exist;
if(defined $opt->{greedy} and ! Vend::Util::is_yes($opt->{greedy}) ) {
$exist = $opt->{newline} ? '[\s\S]*?' : '.*?';
}
else {
$exist = $opt->{newline} ? '[\s\S]*' : '.*';
}
my $begin = $opt->{begin};
my $end = $opt->{end};
my $subbed;
my $sub = sub {
my ($begin, $replace, $end) = @_;
return $replace if $opt->{replace};
return $begin . $replace . $end;
};
if($opt->{case} and $opt->{global}) {
$subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ge;
}
elsif($opt->{global}) {
$subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ige;
}
elsif($opt->{case}) {
$subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}e;
}
else {
$subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ie;
}
if( $subbed ) {
open(SUBFILE, ">$file")
or return $die->(
"substitute_file: cannot write %s, backup in %s",
$file, $bak,
);
print SUBFILE $data
or return $die->(
"substitute_file: error writing %s, backup in %s",
$file, $bak,
);
close SUBFILE
or return $die->(
"substitute_file: error closing %s, backup in %s",
$file, $bak,
);
unlink $bak;
}
else {
unlink $bak;
return 0;
}
}
EOR
1.1 interchange/code/UI_Tag/table_editor.coretag
rev 1.1, prev_rev 1.0
Index: table_editor.coretag
===================================================================
UserTag table-editor Order mv_data_table item_id
UserTag table-editor addAttr
UserTag table-editor AttrAlias clone ui_clone_id
UserTag table-editor AttrAlias table mv_data_table
UserTag table-editor AttrAlias fields ui_data_fields
UserTag table-editor AttrAlias mv_data_fields ui_data_fields
UserTag table-editor AttrAlias key item_id
UserTag table-editor AttrAlias view ui_meta_view
UserTag table-editor AttrAlias profile ui_profile
UserTag table-editor AttrAlias email_fields ui_display_only
#UserTag table-editor Documentation <<EOD
#=head1 NAME
#
#[table-editor]
#
#=head1 SYNOPSIS
#
# [table-editor
# table=ic_table
# cgi=1*
# item-id="key"
# across=n*
# noexport=1*
#
# wizard=1*
# next_text='Next -->'*
# cancel_text='Cancel'*
# back_text='<-- Back'*
#
# hidden.formvarname="value"
#
# item_id_left="keys remaining"
# mv_blob_field=column*
# mv_blob_nick=name*
# mv_blob_pointer="current name"*
# mv_blob_label="Label text"
# mv_blob_title="Title HTML"
#
# ui_break_before="field1 field2"
# ui_break_before_label="field1=Label 1, field2=Label 2"
# ui_data_fields="field1 field2 fieldn ..."*
# ui_data_fields_all=1*
# ui_display_only="no_set_field"*
# ui_hide_key=1*
# ui_meta_specific=1*
# ui_meta_view="viewname"
# ui_nextpage="next_destination"
# ui_prevpage="back_destination"
# ui_return_to="cancel_destination"
# ui_new_item=1*
# ui_sequence_edit=1*
# ui_clone_id="key"
# ui_clone_tables="table1 table2 ..."
# ui_delete_box=1*
# mv_update_empty=0*
#
# widget.field="select|text|any ic widget"
# label.field="Field Label"
# help.field="Help text"
# help-url.field="http://url/to/more/help"
# default.field="preset value"*
# override.field="forced value"*
# filter.field="filter1 filter2"
# pre-filter.field="filter1 filter2"
# error.field=1*
# height.field=N
# width.field=N
# passed.field="val1=Label 1, val2=Label 2"
# lookup.field="lookup_field"
# database.field="table"
# field.field="column"
# outboard.field="key"
# append.field="HTML"
# prepend.field="HTML"
#
# ]
#
#=head1 DESCRIPTION
#
#The [table-editor] tag produces an HTML form that edits a database
#table or collects values for a "wizard". It is extremely configurable
#as to display and characteristics of the widgets used to collect the
#input.
#
#The widget types are based on the Interchange C<[display ...]> UserTag,
#which in turn is heavily based on the ITL core C<[accessories ...]> tag.
#
#The C<simplest> form of C<[table-editor]> is:
#
# [table-editor table=foo]
#
#A page which contains only that tag will edit the table C<foo>, where
#C<foo> is the name of an Interchange table to edit. If no C<foo> table
#is C<defined>, then nothing will be displayed.
#
#If the C<mv_metadata> entry "foo" is present, it is used as the
#definition for table display, including the fields to edit and labels
#for sections of the form. If C<ui_data_fields> is defined, this
#cancels fetch of the view and any breaks and labels must be
#defined with C<ui_break_before> and C<ui_break_before_label>. More
#on the view concept later.
#
#A simple "wizard" can be made with:
#
# [table-editor
# wizard=1
# ui_wizard_fields="foo bar"
# mv_nextpage=wizard2
# mv_prevpage=wizard_intro
# ]
#
#The purpose of a "wizard" is to collect values from the user and
#place them in the $Values array. A next page value (option mv_nextpage)
#must be defined to give a destination; if mv_prevpage is defined then
#a "Back" button is presented to allow paging backward in the wizard.
#
#EOD
UserTag table-editor hasEndTag
UserTag table-editor Routine <<EOR
sub {
my ($table, $key, $opt, $template) = @_;
package Vend::Interpolate;
use vars qw/$Values $Scratch $Db $Tag $Config $CGI $Variable $safe_safe/;
init_calc() if ! $Vend::Calc_initialized;
my @messages;
my @errors;
#Debug("labels=" . uneval($opt->{label}));
FORMATS: {
no strict 'refs';
my $ref;
for(qw/
default
error
extra
filter
height
help
label
override
passed
options
outboard
append
prepend
lookup
field
pre_filter
widget
width
/ )
{
#::logDebug("doing te_hash $_");
next if ref $opt->{$_};
#::logDebug("te_hash $_ not a ref");
($opt->{$_} = {}, next) if ! $opt->{$_};
#::logDebug("te_hash $_ has a value");
my $ref = {};
my $string = $opt->{$_};
#::logDebug("te_hash $_ = $string");
$string =~ s/^\s+//gm;
$string =~ s/\s+$//gm;
#::logDebug("te_hash $_ now = $string");
while($string =~ m/^(.+?)=\s*(.+)/mg) {
$ref->{$1} = $2;
#::logDebug("te_hash $1 = $2");
}
$opt->{$_} = $ref;
}
}
my $rowcount = 0;
my $rowdiv = $opt->{across} || 1;
my $span = $rowdiv * 2;
my $oddspan = $span - 1;
$opt->{table_width} = '60%' if ! $opt->{table_width};
$opt->{left_width} = '30%' if ! $opt->{left_width};
if (! $opt->{inner_table_width}) {
if($opt->{table_width} =~ /%/) {
$opt->{inner_table_width} = '100%';
}
elsif ($opt->{table_width} =~ /^\d+$/) {
$opt->{inner_table_width} = $opt->{table_width} - 2;
}
else {
$opt->{inner_table_width} = $opt->{table_width};
}
}
my $check = $opt->{check};
my $default = $opt->{default};
my $error = $opt->{error};
my $extra = $opt->{extra};
my $filter = $opt->{filter};
my $height = $opt->{height};
my $help = $opt->{help};
my $help_url = $opt->{help_url};
my $label = $opt->{label};
my $override = $opt->{override};
my $pre_filter = $opt->{pre_filter};
my $passed = $opt->{passed};
my $options = $opt->{options};
my $outboard = $opt->{outboard};
my $prepend = $opt->{prepend};
my $append = $opt->{append};
my $lookup = $opt->{lookup};
my $database = $opt->{database};
my $field = $opt->{field};
my $widget = $opt->{widget};
my $width = $opt->{width};
#::logDebug("widget=" . ::uneval_it($widget) );
#::logDebug("label=" . ::uneval_it($label) );
#my $blabel = $opt->{begin_label} || '<b>';
#my $elabel = $opt->{end_label} || '</b>';
my $blabel ;
my $elabel ;
my $mlabel = '';
if($opt->{wizard}) {
$opt->{noexport} = 1;
$opt->{next_text} = 'Next -->' unless $opt->{next_text};
$opt->{cancel_text} = 'Cancel' unless $opt->{cancel_text};
$opt->{back_text} = '<-- Back' unless $opt->{back_text};
}
else {
$opt->{cancel_text} = 'Cancel' unless $opt->{cancel_text};
$opt->{next_text} = "Ok" unless $opt->{next_text};
}
for(qw/ next_text cancel_text back_text/ ) {
$opt->{$_} = errmsg($opt->{$_});
}
my $ntext;
my $btext;
my $ctext;
unless ($opt->{wizard} || $opt->{nosave}) {
$Scratch->{$opt->{next_text}} = $Tag->return_to('click', 1);
}
else {
if($opt->{action_click}) {
$ntext = <<EOF;
mv_todo=return
ui_wizard_action=Next
mv_click=$opt->{action_click}
EOF
}
else {
$ntext = <<EOF;
mv_todo=return
ui_wizard_action=Next
mv_click=ui_override_next
EOF
}
$Scratch->{$opt->{next_text}} = $ntext;
my $hidgo = $opt->{mv_cancelpage} || $opt->{hidden}{ui_return_to} || $CGI->{return_to};
$hidgo =~ s/\0.*//s;
$ctext = $Scratch->{$opt->{cancel_text}} = <<EOF;
mv_form_profile=
ui_wizard_action=Cancel
mv_nextpage=$hidgo
mv_todo=back
EOF
if($opt->{mv_prevpage}) {
$btext = $Scratch->{$opt->{back_text}} = <<EOF;
mv_form_profile=
ui_wizard_action=Back
mv_nextpage=$opt->{mv_prevpage}
mv_todo=return
EOF
}
else {
delete $opt->{back_text};
}
}
for(qw/next_text back_text cancel_text/) {
$opt->{"orig_$_"} = $opt->{$_};
}
$Scratch->{$opt->{next_text}} = $ntext if $ntext;
$Scratch->{$opt->{cancel_text}} = $ctext if $ctext;
$Scratch->{$opt->{back_text}} = $btext if $btext;
$opt->{next_text} = HTML::Entities::encode($opt->{next_text});
$opt->{back_text} = HTML::Entities::encode($opt->{back_text});
$opt->{cancel_text} = HTML::Entities::encode($opt->{cancel_text});
$Scratch->{$opt->{next_text}} = $ntext if $ntext;
$Scratch->{$opt->{cancel_text}} = $ctext if $ctext;
$Scratch->{$opt->{back_text}} = $btext if $btext;
if($opt->{wizard} and ! $table) {
$table = 'mv_null';
$Vend::Database{mv_null} =
bless [
{},
undef,
[ 'code', 'value' ],
[ 'code' => 0, 'value' => 1 ],
0,
{ },
], 'Vend::Table::InMemory';
}
my @mapdirect = qw/
mv_data_decode
mv_data_table
mv_blob_field
mv_blob_nick
mv_blob_pointer
mv_blob_label
mv_blob_title
left_width
table_width
ui_break_before
ui_break_before_label
ui_data_fields
ui_data_fields_all
ui_data_key_name
ui_display_only
ui_hide_key
ui_meta_specific
ui_meta_view
ui_nextpage
ui_new_item
ui_delete_box
mv_update_empty
/;
$table = $CGI->{mv_data_table} if $CGI->{mv_data_table} and ! $table;
my $tmeta = UI::Primitive::meta_record($table, $opt->{ui_meta_view}) || {};
for(grep defined $tmeta->{$_}, @mapdirect) {
$opt->{$_} ||= $tmeta->{$_};
}
if($opt->{cgi}) {
unshift @mapdirect, qw/
item_id
item_id_left
ui_clone_id
ui_clone_tables
ui_sequence_edit
/;
for(@mapdirect) {
next if ! defined $CGI->{$_};
$opt->{$_} = $CGI->{$_};
}
my @hmap = (
[ qr/^ui_te_check:/, $check ],
[ qr/^ui_te_default:/, $default ],
[ qr/^ui_te_extra:/, $extra ],
[ qr/^ui_te_widget:/, $widget ],
[ qr/^ui_te_passed:/, $passed ],
[ qr/^ui_te_options:/, $options ],
[ qr/^ui_te_outboard:/, $outboard ],
[ qr/^ui_te_prepend:/, $prepend ],
[ qr/^ui_te_append:/, $append ],
[ qr/^ui_te_lookup:/, $lookup ],
[ qr/^ui_te_database:/, $database ],
[ qr/^ui_te_field:/, $field ],
[ qr/^ui_te_override:/, $override ],
[ qr/^ui_te_filter:/, $filter ],
[ qr/^ui_te_pre_filter:/, $pre_filter ],
[ qr/^ui_te_height:/, $height ],
[ qr/^ui_te_width:/, $width ],
[ qr/^ui_te_help:/, $help ],
[ qr/^ui_te_help_url:/, $help_url ],
);
my @cgi = keys %{$CGI};
foreach my $row (@hmap) {
my @keys = grep $_ =~ $row->[0], @cgi;
for(@keys) {
#::logDebug("found key $_");
/^ui_\w+:(\S+)/
and $row->[1]->{$1} = $CGI->{$_};
#::logDebug("set $1=$_");
}
}
$table = $opt->{mv_data_table};
$key = $opt->{item_id};
}
$opt->{color_success} = $Variable->{UI_C_SUCCESS} || '#00FF00'
if ! $opt->{color_success};
$opt->{color_fail} = $Variable->{UI_CONTRAST} || '#FF0000'
if ! $opt->{color_fail};
### Build the error checking
my $error_show_var = 1;
my $have_errors;
if($opt->{ui_profile} or $check) {
$Tag->error( { all => 1 } ) if ! $CGI->{mv_form_profile};
my $prof = $opt->{ui_profile} || '';
if ($prof =~ s/^\*//) {
# special notation ui_profile="*whatever" means
# use automatic checklist-related profile
my $name = $prof;
$prof = $Scratch->{"profile_$name"} || '';
if ($prof) {
$prof =~ s/^\s*(\w+)[\s=]+required\b/$1=mandatory/mg;
for (grep /\S/, split /\n/, $prof) {
if (/^\s*(\w+)\s*=(.+)$/) {
my $k = $1; my $v = $2;
$v =~ s/\s+$//;
$v =~ s/^\s+//;
$error->{$k} = 1;
$error_show_var = 0 if $v =~ /\S /;
}
}
$prof = '&calc delete \\$Values->{step_' . $name . "}\n" . $prof;
$opt->{ui_profile_success} = "&set=step_$name 1";
}
}
my $success = $opt->{ui_profile_success};
if(ref $check) {
while ( my($k, $v) = each %$check ) {
$error->{$k} = 1;
$v =~ s/\s+$//;
$v =~ s/^\s+//;
$v =~ s/\s+$//mg;
$v =~ s/^\s+//mg;
$v =~ s/^required\b/mandatory/mg;
unless ($v =~ /^\&/m) {
$error_show_var = 0 if $v =~ /\S /;
$v =~ s/^/$k=/mg;
$v =~ s/\n/\n&and\n/g;
}
$prof .= "$v\n";
}
}
elsif ($check) {
for (@_ = grep /\S/, split /[\s,]+/, $check) {
$error->{$_} = 1;
$prof .= "$_=mandatory\n";
}
}
$opt->{hidden} = {} if ! $opt->{hidden};
$opt->{hidden}{mv_form_profile} = 'ui_profile';
my $fail = $opt->{mv_failpage} || $Global::Variable->{MV_PAGE};
$Scratch->{ui_profile} = <<EOF;
[perl]
#Debug("cancel='$opt->{orig_cancel_text}' back='$opt->{orig_back_text}' click=\$CGI->{mv_click}");
my \@clicks = split /\\0/, \$CGI->{mv_click};
my \$fail = '$fail';
for( qq{$opt->{orig_cancel_text}}, qq{$opt->{orig_back_text}}) {
#Debug("compare is '\$_'");
next unless \$_;
my \$cancel = \$_;
for(\@clicks) {
#Debug("click is '\$_'");
return if \$_ eq \$cancel;
}
}
return <<EOP;
$prof
&fail=$fail
&fatal=1
$success
mv_form_profile=mandatory
&set=mv_todo set
EOP
[/perl]
EOF
$blabel = '<span style="font-weight: normal">';
$elabel = '</span>';
$mlabel = ($opt->{message_label} || ' <B>Bold</B> fields are required');
$have_errors = $Tag->error( {
all => 1,
show_var => $error_show_var,
show_error => 1,
joiner => '<BR>',
keep => 1}
);
if($opt->{all_errors}) {
if($have_errors) {
$mlabel .= '<P>Errors:';
$mlabel .= qq{<FONT COLOR="$opt->{color_fail}">};
$mlabel .= "<BLOCKQUOTE>$have_errors</BLOCKQUOTE></FONT>";
}
}
}
### end build of error checking
$opt->{clear_image} = "bg.gif" if ! $opt->{clear_image};
#::logDebug("table-editor opt: " . ::uneval($opt));
my $die = sub {
::logError(@_);
$Scratch->{ui_error} .= "<BR>\n" if $Scratch->{ui_error};
$Scratch->{ui_error} .= ::errmsg(@_);
return undef;
};
my $db = Vend::Data::database_exists_ref($table)
or return $die->('table-editor: bad table %s', $table);
if($opt->{ui_wizard_fields}) {
$opt->{ui_data_fields} = $opt->{ui_display_only} = $opt->{ui_wizard_fields};
}
my $keycol = $db->config('KEY');
$opt->{form_name} = qq{ NAME="$opt->{form_name}"}
if $opt->{form_name};
###############################################################
# Get the field display information including breaks and labels
###############################################################
if( ! $opt->{ui_data_fields} and ! $opt->{ui_data_fields_all}) {
$opt->{ui_data_fields} = $tmeta->{ui_data_fields} || $tmeta->{options};
}
$opt->{ui_data_fields} =~ s/\r\n/\n/g;
$opt->{ui_data_fields} =~ s/\r/\n/g;
if($opt->{ui_data_fields} =~ /\n\n/) {
#::logDebug("Found break fields");
my @breaks;
my @break_labels;
while ($opt->{ui_data_fields} =~ s/\n+(?:\n[ \t]*=(.*))?\n+[ \t]*(\w[:.\w]+)/\n$2/) {
push @breaks, $2;
push @break_labels, "$2=$1" if $1;
}
$opt->{ui_break_before} = join(" ", @breaks)
if ! $opt->{ui_break_before};
#::logDebug("break_before=$opt->{ui_break_before}");
$opt->{ui_break_before_label} = join(",", @break_labels)
if ! $opt->{ui_break_before_label};
#::logDebug("break_before_label=$opt->{ui_break_before_label}");
}
$opt->{ui_data_fields} = $opt->{mv_data_fields} || (join " ", $db->columns())
if ! $opt->{ui_data_fields};
$opt->{ui_data_fields} =~ s/[,\0\s]+/ /g;
###############################################################
my $linecount;
CANONCOLS: {
my @cols = split /[,\0\s]/, $opt->{ui_data_fields};
#@cols = grep /:/ || $db->column_exists($_), @cols;
$opt->{ui_data_fields} = join " ", @cols;
$linecount = scalar @cols;
}
my $url = $Tag->area('ui');
my $key_message;
if($opt->{ui_new_item}) {
if( ! $db->config('_Auto_number') ) {
$db->config('AUTO_NUMBER', '000001');
$key = $db->autonumber($key);
}
else {
$key = '';
$opt->{mv_data_auto_number} = 1;
$key_message = '(new key will be assigned if left blank)';
}
}
my $data;
my $exists;
if($opt->{ui_clone_id} and $db->record_exists($opt->{ui_clone_id})) {
$data = $db->row_hash($opt->{ui_clone_id})
or
return $die->('table-editor: row_hash function failed for %s.', $key);
$data->{$keycol} = $key;
}
elsif ($db->record_exists($key)) {
$data = $db->row_hash($key);
$exists = 1;
}
if ($opt->{reload} and $have_errors) {
if($data) {
for(keys %$data) {
$data->{$_} = $CGI->{$_}
if defined $CGI->{$_};
}
}
else {
$data = { %$CGI };
}
}
my $blob_data;
my $blob_widget;
if($opt->{mailto} and $opt->{mv_blob_field}) {
$opt->{hidden}{mv_blob_only} = 1;
$opt->{hidden}{mv_blob_nick}
= $opt->{mv_blob_nick}
|| POSIX::strftime("%Y%m%d%H%M%S", localtime());
}
elsif($opt->{mv_blob_field}) {
#::logDebug("checking blob");
my $blob_pointer;
$blob_pointer = $data->{$opt->{mv_blob_pointer}}
if $opt->{mv_blob_pointer};
$blob_pointer ||= $opt->{mv_blob_nick};
DOBLOB: {
unless ( $db->column_exists($opt->{mv_blob_field}) ) {
push @errors, ::errmsg(
"blob field %s not in database.",
$opt->{mv_blob_field},
);
last DOBLOB;
}
my $bstring = $data->{$opt->{mv_blob_field}};
#::logDebug("blob: bstring=$bstring");
my $blob;
if(length $bstring) {
$blob = $safe_safe->reval($bstring);
if($@) {
push @errors, ::errmsg("error reading blob data: %s", $@);
last DOBLOB;
}
#::logDebug("blob evals to " . ::uneval_it($blob));
if(ref($blob) !~ /HASH/) {
push @errors, ::errmsg("blob data not a storage book.");
undef $blob;
}
}
else {
$blob = {};
}
my %wid_data;
my %url_data;
my @labels = keys %$blob;
for my $key (@labels) {
my $ref = $blob->{$_};
my $lab = $ref->{$opt->{mv_blob_label} || 'name'};
if($lab) {
$lab =~ s/,/,/g;
$wid_data{$lab} = "$key=$key - $lab";
$url_data{$lab} = $Tag->page( {
href => $Global::Variable->{MV_PAGE},
form => "
item_id=$opt->{item_id}
mv_blob_nick=$key
",
});
$url_data{$lab} .= "$key - $lab</A>";
}
else {
$wid_data{$key} = $key;
$url_data{$key} = $Tag->page( {
href => $Global::Variable->{MV_PAGE},
form => "
item_id=$opt->{item_id}
mv_blob_nick=$key
",
});
$url_data{$key} .= "$key</A>";
}
}
#::logDebug("wid_data is " . ::uneval_it(\%wid_data));
$opt->{mv_blob_title} = "Stored settings"
if ! $opt->{mv_blob_title};
$opt->{mv_blob_title} = errmsg($opt->{mv_blob_title});
$Scratch->{Load} = <<EOF;
[return-to type=click stack=1 page="$Global::Variable->{MV_PAGE}"]
ui_nextpage=
[perl]Log("tried to go to $Global::Variable->{MV_PAGE}"); return[/perl]
mv_todo=back
EOF
#::logDebug("blob_pointer=$blob_pointer blob_nick=$opt->{mv_blob_nick}");
my $loaded_from;
my $lfrom_msg;
if( $opt->{mv_blob_nick} ) {
$lfrom_msg = $opt->{mv_blob_nick};
}
else {
$lfrom_msg = errmsg("current values");
}
$lfrom_msg = errmsg("loaded from %s", $lfrom_msg);
$loaded_from = <<EOF;
<I>($lfrom_msg)</I><BR>
EOF
if(@labels) {
$loaded_from .= errmsg("Load from") . ":<BLOCKQUOTE>";
$loaded_from .= join (" ", @url_data{ sort keys %url_data });
$loaded_from .= "</BLOCKQUOTE>";
}
my $checked;
my $set;
if( $opt->{mv_blob_only} and $opt->{mv_blob_nick}) {
$checked = ' CHECKED';
$set = $opt->{mv_blob_nick};
}
unless ($opt->{nosave}) {
$blob_widget = $Tag->widget({
name => 'mv_blob_nick',
type => $opt->{ui_blob_widget} || 'combo',
filter => 'nullselect',
override => 1,
set => "$set",
passed => join (",", @wid_data{ sort keys %wid_data }) || 'default',
});
my $msg1 = errmsg('Save to');
my $msg2 = errmsg('Save here only');
for (\$msg1, \$msg2) {
$$_ =~ s/ / /g;
}
$blob_widget = <<EOF unless $opt->{ui_blob_hidden};
<B>$msg1:</B> $blob_widget
<INPUT TYPE=checkbox NAME=mv_blob_only VALUE=1$checked> $msg2</SMALL>
EOF
}
$blob_widget = <<EOF unless $opt->{ui_blob_hidden};
<TR class=rnorm>
<td class=clabel width="$opt->{left_width}">
<SMALL>$opt->{mv_blob_title}<BR>
$loaded_from
</td>
<td class=cwidget>
$blob_widget
</td>
</TR>
<tr class=rtitle>
<td colspan=$span><img src="$opt->{clear_image}" width=1 height=3 alt=x></td>
</tr>
EOF
if($opt->{mv_blob_nick}) {
my @keys = split /::/, $opt->{mv_blob_nick};
my $ref = $blob->{shift @keys};
for(@keys) {
my $prior = $ref;
undef $ref;
eval {
$ref = $prior->{$_};
};
last DOBLOB unless ref $ref;
}
for(keys %$ref) {
$data->{$_} = $ref->{$_};
}
}
}
}
#::logDebug("data is: " . ::uneval($data));
$data = { $keycol => $key }
if ! $data;
if(! $opt->{mv_data_function}) {
$opt->{mv_data_function} = $exists ? 'update' : 'insert';
}
$opt->{mv_nextpage} = $Global::Variable->{MV_PAGE} if ! $opt->{mv_nextpage};
$opt->{mv_update_empty} = 1 unless defined $opt->{mv_update_empty};
my $url_base = $opt->{secure} ? $Config->{SecureURL} : $Config->{VendURL};
#Debug("Urlbase=$url_base");
$opt->{href} = "$url_base/ui" if ! $opt->{href};
$opt->{href} = "$url_base/$opt->{href}"
if $opt->{href} !~ m{^(https?:|)/};
#Debug("href=$opt->{href}");
my $sidstr;
if ($opt->{get}) {
$opt->{method} = 'GET';
$sidstr = '';
} else {
$opt->{method} = 'POST';
$sidstr = qq{<INPUT TYPE=hidden NAME=mv_session_id VALUE="$Session->{id}">
};
}
$opt->{enctype} = $opt->{file_upload} ? ' ENCTYPE="multipart/form-data"' : '';
my $out = <<EOF;
[restrict]
<FORM METHOD=$opt->{method} ACTION="$opt->{href}"$opt->{form_name}$opt->{enctype}>
$sidstr<INPUT TYPE=hidden NAME=mv_todo VALUE="set">
<INPUT TYPE=hidden NAME=mv_click VALUE="process_filter">
<INPUT TYPE=hidden NAME=mv_nextpage VALUE="$opt->{mv_nextpage}">
<INPUT TYPE=hidden NAME=mv_data_table VALUE="$table">
<INPUT TYPE=hidden NAME=mv_data_key VALUE="$keycol">
EOF
my @opt_set = (qw/
ui_meta_specific
ui_hide_key
ui_meta_view
ui_data_decode
mv_blob_field
mv_blob_label
mv_blob_title
mv_blob_pointer
mv_update_empty
mv_data_auto_number
mv_data_function
/ );
my @cgi_set = ( qw/
item_id_left
ui_sequence_edit
/ );
push(@opt_set, splice(@cgi_set, 0)) if $opt->{cgi};
for(@opt_set) {
next unless length $opt->{$_};
my $val = $opt->{$_};
$val =~ s/"/"/g;
$out .= qq{<INPUT TYPE=hidden NAME=$_ VALUE="$val">\n};
}
for (@cgi_set) {
next unless length $CGI->{$_};
my $val = $CGI->{$_};
$val =~ s/"/"/g;
$out .= qq{<INPUT TYPE=hidden NAME=$_ VALUE="$val">\n};
}
if($opt->{mailto}) {
$opt->{mailto} =~ s/\s+/ /g;
$Scratch->{mv_email_enable} = $opt->{mailto};
$opt->{hidden}{mv_data_email} = 1;
}
$Vend::Session->{ui_return_stack} ||= [];
if($opt->{cgi}) {
my $r_ary = $Vend::Session->{ui_return_stack};
#::logDebug("ready to maybe push/pop return-to from stack, stack = " . ::uneval($r_ary));
if($CGI::values{ui_return_stack}++) {
push @$r_ary, $CGI::values{ui_return_to};
$CGI::values{ui_return_to} = $r_ary->[0];
}
elsif ($CGI::values{ui_return_to}) {
@$r_ary = ( $CGI::values{ui_return_to} );
}
$out .= $Tag->return_to();
#::logDebug("return-to stack = " . ::uneval($r_ary));
}
if(ref $opt->{hidden}) {
my ($hk, $hv);
while ( ($hk, $hv) = each %{$opt->{hidden}} ) {
$out .= qq{<INPUT TYPE=hidden NAME="$hk" VALUE="$hv">\n};
}
}
$out .= <<EOF;
<table class=touter border="" cellspacing="0" cellpadding="0" width="$opt->{table_width}">
<tr>
<td>
<table class=tinner width="$opt->{inner_table_width}" cellspacing=0 cellmargin=0 width="100%" cellpadding="2" align="center" border="0">
EOF
$out .= <<EOF unless $opt->{no_top};
<tr class=rtitle>
<td align=right colspan=$span><img src="$opt->{clear_image}" width=1 height=3 alt=x></td>
</tr>
EOF
#### Extra buttons
my $extra_ok = $blob_widget
|| $linecount > 4
|| defined $opt->{include_form}
|| $mlabel;
if ($extra_ok and ! $opt->{no_top} and ! $opt->{nosave}) {
if($opt->{back_text}) {
$out .= <<EOF;
<TR class=rnorm>
<td> </td>
<td align=left colspan=$oddspan class=cdata>
EOF
$out .= <<EOF if ! $opt->{bottom_buttons};
<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{back_text}"> <INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}"> <B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
<BR>
EOF
$out .= <<EOF;
$mlabel
</TD>
</TR>
<tr class=rspacer>
<td colspan=$span><img src="$opt->{clear_image}" width=1 height=3 alt=x></td>
</tr>
EOF
}
elsif ($opt->{wizard}) {
$out .= <<EOF;
<TR class=rnorm>
<td> </td>
<td align=left colspan=$oddspan class=cdata>
EOF
$out .= <<EOF if ! $opt->{bottom_buttons};
<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}"> <B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
<BR>
EOF
$out .= <<EOF;
$mlabel
</TD>
</TR>
<tr class=rspacer>
<td colspan=$span><img src="$opt->{clear_image}" width=1 height=3 alt=x></td>
</tr>
EOF
}
else {
$out .= <<EOF;
<TR class=rnorm>
<td> </td>
<td align=left colspan=$oddspan class=cdata>
<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}">
</B>
<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}">$mlabel
</TD>
</TR>
<tr class=rspacer>
<td colspan=$span><img src="$opt->{clear_image}" width=1 height=3 alt=x></td>
</tr>
EOF
}
}
$out .= $blob_widget;
#### Extra buttons
if($opt->{ui_new_item} and $opt->{ui_clone_tables}) {
my @sets;
my %seen;
my @tables = split /[\s\0,]+/, $opt->{ui_clone_tables};
for(@tables) {
if(/:/) {
push @sets, $_;
}
s/:.*//;
}
@tables = grep ! $seen{$_}++ && defined $Config->{Database}{$_}, @tables;
my $tab = '';
my $set .= <<'EOF';
[flag type=write table="_TABLES_"]
[perl tables="_TABLES_"]
delete $Scratch->{clone_tables};
return if ! $CGI->{ui_clone_id};
return if ! $CGI->{ui_clone_tables};
my $id = $CGI->{ui_clone_id};
my $out = "Cloning id=$id...";
my $new = $CGI->{$CGI->{mv_data_key}}
or do {
$out .= ("clone $id: no mv_data_key '$CGI->{mv_data_key}'");
$Scratch->{ui_message} = $out;
return;
};
if($new =~ /\0/) {
$new =~ s/\0/,/g;
Log("cannot clone multiple keys '$new'.");
return;
}
my %possible;
my @possible = qw/_TABLES_/;
@possible{@possible} = @possible;
my @tables = grep /\S/, split /[\s,\0]+/, $CGI->{ui_clone_tables};
my @sets = grep /:/, @tables;
@tables = grep $_ !~ /:/, @tables;
for(@tables) {
next unless $possible{$_};
my $db = $Db{$_};
next unless $db;
my $new =
my $res = $db->clone_row($id, $new);
if($res) {
$out .= "cloned $id to to $new in table $_<BR>\n";
}
else {
$out .= "FAILED clone of $id to to $new in table $_<BR>\n";
}
}
for(@sets) {
my ($t, $col) = split /:/, $_;
my $db = $Db{$t} or next;
my $res = $db->clone_set($col, $id, $new);
if($res) {
$out .= "cloned $col=$id to to $col=$new in table $t<BR>\n";
}
else {
$out .= "FAILED clone of $col=$id to to $col=$new in table $t<BR>\n";
}
}
$Scratch->{ui_message} = $out;
return;
[/perl]
EOF
my $tabform = '';
@tables = grep $Tag->if_mm( { table => "$_=i" } ), @tables;
for(@tables) {
my $db = Vend::Data::database_exists_ref($_)
or next;
next unless $db->record_exists($opt->{ui_clone_id});
$tabform .= <<EOF;
<INPUT TYPE=CHECKBOX NAME=ui_clone_tables VALUE="$_"> clone to <b>$_</B><BR>
EOF
}
for(@sets) {
my ($t, $col) = split /:/, $_;
$tabform .= <<EOF;
<INPUT TYPE=CHECKBOX NAME=ui_clone_tables VALUE="$_"> clone entries of <b>$t</B> matching on <B>$col</B><BR>
EOF
}
my $tabs = join " ", @tables;
$set =~ s/_TABLES_/$tabs/g;
$Scratch->{clone_tables} = $set;
$out .= <<EOF;
<tr class=rtitle>
<td colspan=$span>
$tabform<INPUT TYPE=hidden NAME=mv_check VALUE="clone_tables">
<INPUT TYPE=hidden NAME=ui_clone_id VALUE="$opt->{ui_clone_id}">
</td>
</tr>
EOF
}
my %break;
my %break_label;
if($opt->{ui_break_before}) {
my @tmp = grep /\S/, split /[\s,\0]+/, $opt->{ui_break_before};
@break{@tmp} = @tmp;
if($opt->{ui_break_before_label}) {
@tmp = grep /\S/, split /\s*[,\0]\s*/, $opt->{ui_break_before_label};
for(@tmp) {
my ($br, $lab) = split /\s*=\s*/, $_;
$break_label{$br} = $lab;
}
}
}
if(!$db) {
return "<TR><TD>Broken table '$table'</TD></TR>";
}
my $passed_fields = $opt->{ui_data_fields};
my @extra_cols;
my %email_cols;
my %ok_col;
while($passed_fields =~ s/(\w+[.:]+\S+)//) {
push @extra_cols, $1;
}
my %display_only;
my @do = grep /\S/, split /[\0,\s]+/, $opt->{ui_display_only};
for(@do) {
$email_cols{$_} = 1 if $opt->{mailto};
$display_only{$_} = 1;
push @extra_cols, $_;
}
my @cols;
my (@dbcols) = split /\s+/, $Tag->db_columns( {
name => $table,
columns => $passed_fields,
passed_order => 1,
});
if($opt->{ui_data_fields}) {
for(@dbcols, @extra_cols) {
unless (/^(\w+)([.:]+)(\S+)/) {
$ok_col{$_} = 1;
next;
}
my $t = $1;
my $s = $2;
my $c = $3;
if($s eq '.') {
$c = $t;
$t = $table;
}
else {
$c =~ s/\..*//;
}
next unless $Tag->db_columns( { name => $t, columns => $c, });
$ok_col{$_} = 1;
}
}
@cols = grep $ok_col{$_}, split /\s+/, $opt->{ui_data_fields};
if($opt->{defaults}) {
for(@cols) {
if($opt->{wizard}) {
$default->{$_} = $::Values->{$_} if defined $::Values->{$_};
}
else {
next if defined $default->{$_};
next unless defined $::Values->{$_};
$default->{$_} = $::Values->{$_};
}
}
}
my $super = $Tag->if_mm('super');
my $refkey = $key;
my @data_enable = ($opt->{mv_blob_pointer}, $opt->{mv_blob_field});
my @ext_enable;
my $row_template = $opt->{row_template} || <<EOF;
<td class=clabel width="$opt->{left_width}">
$blabel\$LABEL\$$elabel~META~
</td>
<td class=cdata>
<table cellspacing=0 cellmargin=0 width="100%">
<tr>
<td class=cwidget>
\$WIDGET\$
</td>
<td class=chelp>~TKEY~<i>\$HELP\$</i>{HELP_URL}<BR><A HREF="\$HELP_URL\$">help</A>{/HELP_URL}</FONT></td>
</tr>
</table>
</td>
EOF
$row_template =~ s/~OPT:(\w+)~/$opt->{$1}/g;
$row_template =~ s/~BLABEL~/$blabel/g;
$row_template =~ s/~ELABEL~/$elabel/g;
my %serialize;
my %serial_data;
foreach my $col (@cols) {
my $t;
my $c;
my $k;
my $tkey_message;
if($col eq $keycol) {
if($opt->{ui_hide_key}) {
my $kval = $key || $override->{$col} || $default->{$col};
$out .= <<EOF;
<INPUT TYPE=hidden NAME="$col" VALUE="$kval">
EOF
next;
}
elsif ($opt->{ui_new_item}) {
$tkey_message = $key_message;
}
}
my $do = $display_only{$col};
my $currval;
my $serialize;
if($col =~ /(\w+):+([^:]+)(?::+(\S+))?/) {
$t = $1;
$c = $2;
$c =~ /(.+?)\.\w.*/
and $col = "$t:$1"
and $serialize = $c;
$k = $3 || undef;
push @ext_enable, ("$t:$c" . $k ? ":$k" : '')
unless $do;
}
else {
$t = $table;
$c = $col;
$c =~ /(.+?)\.\w.*/
and $col = $1
and $serialize = $c;
push @data_enable, $col
unless $do and ! $opt->{mailto};
}
my $type;
my $overridden;
$currval = $data->{$col} if defined $data->{$col};
if (defined $override->{$c} ) {
$currval = $override->{$c};
$overridden = 1;
#::logDebug("hit override for $col,currval=$currval");
}
elsif (defined $CGI->{"ui_preload:$t:$c"} ) {
$currval = delete $CGI->{"ui_preload:$t:$c"};
$overridden = 1;
#::logDebug("hit preload for $col,currval=$currval");
}
elsif( ($do && ! $currval) or $col =~ /:/) {
if(defined $k) {
my $check = $k;
undef $k;
for( $override, $data, $default) {
next unless defined $_->{$check};
$k = $_->{$check};
last;
}
}
else {
$k = defined $key ? $key : $refkey;
}
$currval = tag_data($t, $c, $k) if defined $k;
#::logDebug("hit display_only for $col, t=$t, c=$c, k=$k, currval=$currval");
}
elsif (defined $default->{$c} and ! length($data->{$c}) ) {
$currval = $default->{$c};
#::logDebug("hit preload for $col,currval=$currval");
}
else {
#::logDebug("hit data->col for $col, t=$t, c=$c, k=$k, currval=$currval");
$currval = length($data->{$col}) ? $data->{$col} : '';
$overridden = 1;
}
my $namecol;
if($serialize) {
#Debug("serialize=$serialize");
if($serialize{$col}) {
push @{$serialize{$col}}, $serialize;
}
else {
my $sd;
if($col =~ /:/) {
my ($tt, $tc) = split /:+/, $col;
$sd = tag_data($tt, $tc, $k);
}
else {
$sd = $data->{$col} || $::Values->{$col};
}
#Debug("serial_data=$sd");
$serial_data{$col} = $sd;
$opt->{hidden}{$col} = $data->{$col};
$serialize{$col} = [$serialize];
}
$c =~ /\.(.*)/;
my $hk = $1;
#Debug("fetching serial_data for $col hk=$hk data=$serial_data{$col}");
$currval = dotted_hash($serial_data{$col}, $hk);
#Debug("fetched hk=$hk value=$currval");
$overridden = 1;
$namecol = $c = $serialize;
}
$namecol = $col unless $namecol;
$type = 'value' if $do and ! ($opt->{wizard} || ! $opt->{mailto});
if (! length $currval and defined $default->{$c}) {
$currval = $default->{$c};
}
my $meta = '';
my $template = $row_template;
if($error->{$c}) {
my $parm = {
name => $c,
std_label => '$LABEL$',
required => 1,
};
if($opt->{all_errors}) {
$parm->{keep} = 1;
$parm->{text} = <<EOF;
<FONT COLOR="$opt->{color_fail}">\$LABEL\$</FONT><!--%s-->
[else]{REQUIRED <B>}{LABEL}{REQUIRED </B>}[/else]
EOF
}
$template =~ s/\$LABEL\$/$Tag->error($parm)/eg;
}
$template =~ s/~TKEY~/$tkey_message || ''/eg;
#::logDebug("col=$c widget=$widget->{$c} label=$label->{$c} (type=$type)");
my $display = $Tag->display({
applylocale => 1,
arbitrary => $opt->{ui_meta_view},
column => $c,
default => $currval,
extra => $extra->{$c},
fallback => 1,
field => $field->{$c},
filter => $filter->{$c},
height => $height->{$c},
help => $help->{$c},
help_url => $help_url->{$c},
label => $label->{$c},
key => $key,
name => $namecol,
override => $overridden,
passed => $passed->{$c},
options => $options->{$c},
outboard => $outboard->{$c},
append => $append->{$c},
prepend => $prepend->{$c},
lookup => $lookup->{$c},
db => $database->{$c},
pre_filter => $pre_filter->{$c},
table => $t,
type => $widget->{$c} || $type,
width => $width->{$c},
template => $template,
});
if($super and ! $opt->{no_meta} and ($Variable->{UI_META_LINK} || $::Values->{ui_meta_force}) ) {
$meta .= '<BR><FONT SIZE=1>';
# Get global variables
my $base = $Tag->var('UI_BASE', 1);
my $page = $Tag->var('MV_PAGE', 1);
my $id = $t . "::$c";
$id = $opt->{ui_meta_view} . "::$id"
if $opt->{ui_meta_view} and $opt->{ui_meta_view} ne 'metaconfig';
my $return = <<EOF;
ui_return_to=$page
ui_return_to=item_id=$opt->{item_id}
ui_return_to=ui_meta_view=$opt->{ui_meta_view}
ui_return_to=mv_return_table=$t
mv_return_table=$table
ui_return_stack=$CGI->{ui_return_stack}
EOF
$meta .= $Tag->page(
{ href => "$base/meta_editor",
form => qq{
item_id=$id
$return
}
});
$meta .= 'meta</A>';
$meta .= '<br>' . $Tag->page(
{ href => "$base/meta_editor",
form => qq{
item_id=${t}::${c}::$key
$return
}
}) . 'item-specific meta</A></FONT>'
if $opt->{ui_meta_specific};
$meta .= '</FONT>';
}
$display =~ s/\~META\~/$meta/g;
$display =~ s/\~ERROR\~/$Tag->error({ name => $c, keep => 1 })/eg;
if ($break{$namecol}) {
while($rowcount % $rowdiv) {
$out .= '<TD> </td><TD> </td>';
$rowcount++;
}
$out .= "</TR>\n";
$out .= <<EOF if $break{$namecol};
<TR class=rbreak>
<TD COLSPAN=$span class=cbreak>$break_label{$namecol}<IMG SRC="$opt->{clear_image}" WIDTH=1 HEIGHT=1 alt=x></TD>
</TR>
EOF
$rowcount = 0;
}
$out .= "<tr class=rnorm>" unless $rowcount++ % $rowdiv;
$out .= $display;
$out .= "</TR>\n" unless $rowcount % $rowdiv;
}
while($rowcount % $rowdiv) {
$out .= '<TD> </td><TD> </td>';
$rowcount++;
}
$Scratch->{mv_data_enable} = '';
if($opt->{auto_secure}) {
$Scratch->{mv_data_enable} .= "$table:" . join(",", @data_enable) . ':';
$Scratch->{mv_data_enable_key} = $opt->{item_id};
}
if(@ext_enable) {
$Scratch->{mv_data_enable} .= " " . join(" ", @ext_enable) . " ";
}
#Debug("setting mv_data_enable to $Scratch->{mv_data_enable}");
my @serial = keys %serialize;
my @serial_fields;
for (@serial) {
#Debug("$_ serial_data=$serial_data{$_}");
$serial_data{$_} = uneval($serial_data{$_})
if is_hash($serial_data{$_});
$serial_data{$_} =~ s/\&/&/g;
$serial_data{$_} =~ s/"/"/g;
$out .= qq{<INPUT TYPE=hidden NAME="$_" VALUE="$serial_data{$_}">};
push @serial_fields, @{$serialize{$_}};
}
if(@serial_fields) {
$out .= qq{<INPUT TYPE=hidden NAME="ui_serial_fields" VALUE="};
$out .= join " ", @serial_fields;
$out .= qq{">};
}
###
### Here the user can include some extra stuff in the form....
###
$out .= <<EOF if $opt->{include_form};
<tr class=rnorm>
<td colspan=$span>$opt->{include_form}</td>
</tr>
EOF
### END USER INCLUDE
unless ($opt->{mailto} and $opt->{mv_blob_only}) {
@cols = grep ! $display_only{$_}, @cols;
}
$passed_fields = join " ", @cols;
$out .= <<EOF;
<INPUT TYPE=hidden NAME=mv_data_fields VALUE="$passed_fields">
<tr class=rspacer>
<td colspan=$span ><img src="$opt->{clear_image}" height=3 alt=x></td>
</tr>
EOF
SAVEWIDGETS: {
last SAVEWIDGETS if $opt->{nosave};
if($opt->{back_text}) {
$out .= <<EOF;
<TR class=rnorm>
<td> </td>
<td align=left colspan=$oddspan class=cdata>
<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{back_text}"> <INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}"> <B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
EOF
}
elsif($opt->{wizard}) {
$out .= <<EOF;
<TR class=rnorm>
<td> </td>
<td align=left colspan=$oddspan class=cdata>
<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}"> <B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
EOF
}
else {
$out .= <<EOF;
<TR class=rnorm>
<td> </td>
<td align=left colspan=$oddspan class=cdata>
<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B> <INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}">
EOF
}
#
# $out .= <<EOF;
#
#<TR class=rnorm>
#<td> </td>
#<td align=left colspan=$oddspan>
#<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
#
#
#<INPUT TYPE=submit NAME=mv_click VALUE=$opt->{cancel_text}>
#EOF
if($Tag->if_mm('tables', "$table=x") and ! $db->config('LARGE') ) {
my $checked = ' CHECKED';
$checked = ''
if defined $opt->{mv_auto_export} and ! $opt->{mv_auto_export};
my $autoexpstr = errmsg('Auto-export');
$out .= <<EOF unless $opt->{noexport} or $opt->{nosave};
<small>
<INPUT TYPE=checkbox NAME=mv_auto_export VALUE="$table"$checked> $autoexpstr
EOF
}
if($exists and ! $opt->{nodelete} and $Tag->if_mm('tables', "$table=d")) {
my $extra = $Tag->return_to( { type => 'click', tablehack => 1 });
my $page = $CGI->{ui_return_to};
$page =~ s/\0.*//s;
my $url = $Tag->area( {
href => $page,
form => qq!
deleterecords=1
ui_delete_id=$key
mv_data_table=$table
mv_click=db_maintenance
mv_action=back
$extra
!,
});
$out .= <<EOF if ! $opt->{nosave};
<BR><BR><A
onClick="return confirm('Are you sure you want to delete $key?')"
HREF="$url"><IMG SRC="delete.gif" ALT="Delete $key" BORDER=0></A> Delete
EOF
}
$out .= <<EOF;
</small>
</td>
</tr>
EOF
} # end SAVEWIDGETS
my $message = '';
# if($opt->{bottom_errors}) {
# my $err = $Tag->error( {
# show_var => $error_show_var,
# show_error => 1,
# joiner => '<BR>',
# }
# );
# push @errors, $err if $err;
# }
if(@errors) {
$message .= '<P>Errors:';
$message .= qq{<FONT COLOR="$opt->{color_fail}">};
$message .= '<BLOCKQUOTE>';
$message .= join "<BR>", @errors;
$message .= '</BLOCKQUOTE></FONT>';
}
if(@messages) {
$message .= '<P>Messages:';
$message .= qq{<FONT COLOR="$opt->{color_success}">};
$message .= '<BLOCKQUOTE>';
$message .= join "<BR>", @messages;
$message .= '</BLOCKQUOTE></FONT>';
}
$Tag->error( { all => 1 } );
$out .= <<EOF unless $opt->{no_bottom} and ! $message;
<tr class=rtitle>
<td colspan=$span><!-- $Scratch->{$opt->{next_text}} -->$message<img src="$opt->{clear_image}" height=3 alt=x></td>
</tr>
EOF
$out .= <<EOF;
</table>
</td></tr></table>
</form>
[/restrict]
EOF
}
EOR
1.1 interchange/code/UI_Tag/uneval.coretag
rev 1.1, prev_rev 1.0
Index: uneval.coretag
===================================================================
UserTag uneval Order ref
UserTag uneval PosNumber 1
UserTag uneval Routine <<EOR
sub {
#::logError("args: @_" . Vend::Util::uneval_it(@_));
return Vend::Util::uneval_it(@_);
}
EOR
1.1 interchange/code/UI_Tag/unlink_file.coretag
rev 1.1, prev_rev 1.0
Index: unlink_file.coretag
===================================================================
UserTag unlink_file Order name prefix
UserTag unlink_file PosNumber 2
UserTag unlink_file Routine <<EOR
sub {
my ($file, $prefix) = @_;
#::logDebug("got to unlink: file=$file prefix=$prefix");
$prefix = 'tmp/' unless $prefix;
return if Vend::Util::file_name_is_absolute($file);
return if $file =~ /\.\./;
return unless $file =~ /^$prefix/;
#::logDebug("got to unlink: $file qualifies");
unlink $file;
}
EOR
1.1 interchange/code/UI_Tag/version.coretag
rev 1.1, prev_rev 1.0
Index: version.coretag
===================================================================
UserTag version Order extended
UserTag version attrAlias module_test modtest
UserTag version attrAlias moduletest modtest
UserTag version attrAlias require modtest
UserTag version addAttr
UserTag version Routine <<EOR
sub {
return $::VERSION unless shift;
my $opt = shift;
my $joiner = $opt->{joiner} || '<BR>';
my @out;
my $done_something;
if($opt->{global_error}) {
push @out, $Global::ErrorFile;
$done_something = 1;
}
if($opt->{local_error}) {
my $fn = $Vend::Cfg->{ErrorFile};
push @out, $Tag->page( "$::Variable->{UI_BASE}/do_view", $fn) . "$fn</A>";
$done_something = 1;
}
if($opt->{env}) {
push @out,
ref $Global::Environment eq 'ARRAY' ?
join ' ', @{$Global::Environment} :
'(none)';
$done_something = 1;
}
if($opt->{safe}) {
push @out, join " ", @{$Global::SafeUntrap};
$done_something = 1;
}
if($opt->{child_pid}) {
push @out, $$;
$done_something = 1;
}
if($opt->{modtest}) {
eval "require $opt->{modtest}";
if($@) {
push @out, 0;
}
else {
push @out, 1;
}
$done_something = 1;
}
if($opt->{pid}) {
push @out, ::readfile($Global::PIDfile);
$done_something = 1;
}
if($opt->{uid}) {
push @out, scalar getpwuid($>) . " (uid $>)";
$done_something = 1;
}
if($opt->{global_locale_options}) {
my @loc;
my $curr = $Global::Locale;
while ( my($k,$v) = each %$Global::Locale_repository ) {
next unless $k =~ /_/;
push @loc, "$v->{MV_LANG_NAME}~:~$k=$v->{MV_LANG_NAME}";
}
if(@loc > 1) {
push @out, join ",", map { s/.*~:~//; $_ } sort @loc;
}
$done_something = 1;
}
if($opt->{perl}) {
push @out, ($^V ? sprintf("%vd", $^V) : $]) . errmsg(" (called with: %s)", $^X);
$done_something = 1;
}
if($opt->{perl_config}) {
require Config;
push @out, "<PRE>\n" . Config::myconfig() . "</PRE>";
$done_something = 1;
}
if(not $opt->{db} || $opt->{modules} || $done_something) {
$opt->{db} = 1;
push @out, "Interchange Version $::VERSION";
push @out, "";
}
if($opt->{db}) {
if($Global::GDBM) {
push @out, errmsg('%s available (v%s)', 'GDBM', $GDBM_File::VERSION);
}
else {
push @out, errmsg('No %s.', 'GDBM');
}
if($Global::DB_File) {
push @out, errmsg('%s available (v%s)', 'Berkeley DB_File', $DB_File::VERSION);
}
else {
push @out, errmsg('No %s.', 'Berkeley DB_File');
}
if($Global::LDAP) {
push @out, errmsg('%s available (v%s)', 'LDAP', $Net::LDAP::VERSION);
}
if($Global::DBI and $DBI::VERSION) {
push @out, errmsg ('DBI enabled (v%s), available drivers:', $DBI::VERSION);
my $avail = join $joiner, DBI->available_drivers;
push @out, "<BLOCKQUOTE>$avail</BLOCKQUOTE>";
}
}
if($opt->{modules}) {
my %wanted = ( qw/
Safe::Hole Safe::Hole
SQL::Statement SQL::Statement
Digest::MD5 Digest::MD5
LWP::Simple LWP
Tie::Watch Tie::Watch
MIME::Base64 MIME::Base64
URI::URL URI::URL
Storable Storable
/);
my %info = (
'Safe::Hole' => 'IMPORTANT: SQL and some tags will not work in embedded Perl.',
'SQL::Statement'=> 'IMPORTANT: UI Database editors will not work properly.',
'Digest::MD5' => 'IMPORTANT: cache keys and other search-related functions will not work.',
'LWP::Simple' => 'External UPS lookup and other internet-related functions will not work.',
'Tie::Watch' => 'Minor: cannot set watch points in catalog.cfg.',
'MIME::Base64' => 'Minor: Internal HTTP server will not work.',
'URI::URL' => 'Minor: Internal HTTP server will not work.',
'Storable' => 'Session and search storage will be slower.',
);
for( sort keys %wanted) {
eval "require $_";
if($@) {
my $info = errmsg($info{$_} || "May affect program operation.");
push @out, "$_ " . errmsg('not found') . ". $info"
}
else {
no strict 'refs';
my $ver = ${"$_" . "::VERSION"};
$ver = $ver ? "v$ver" : 'no version info';
push @out, "$_ " . errmsg('found') . " ($ver).";
}
}
}
return join $joiner, @out;
}
EOR
1.1 interchange/code/UI_Tag/widget.coretag
rev 1.1, prev_rev 1.0
Index: widget.coretag
===================================================================
UserTag widget Order name
UserTag widget PosNumber 1
UserTag widget attrAlias table db
UserTag widget attrAlias field column
UserTag widget attrAlias outboard key
UserTag widget addAttr
UserTag widget HasEndTag 1
UserTag widget Interpolate 1
UserTag widget Routine <<EOR
sub {
my($name, $opt, $string) = @_;
#my($name, $type, $value, $table, $column, $key, $data, $string) = @_;
my $value;
if(defined $opt->{set}) {
$value = $opt->{set};
}
else {
$value = $::Values->{$name} || $opt->{default};
}
if($opt->{pre_filter}) {
#::logDebug("pre-filter with $opt->{pre_filter}");
$value = $Tag->filter($opt->{pre_filter}, $value);
}
my $ref = {
attribute => $opt->{attribute} || 'attribute',
db => $opt->{table},
field => $opt->{field},
extra => $opt->{extra} || $opt->{js},
cols => $opt->{cols},
delimiter => $opt->{delimiter},
rows => $opt->{rows} || undef,
name => $name,
outboard => $opt->{key},
passed => $opt->{data} || $opt->{passed} || $string,
type => $opt->{type} || 'select',
};
my $item = { $ref->{attribute} => $value };
if($ref->{type} =~ /date/i) {
return UI::Primitive::date_widget($name, $value);
}
my $w = Vend::Interpolate::tag_accessories('', '', $ref, $item);
if($opt->{filter}) {
$w .= qq{<INPUT TYPE=hidden NAME="ui_filter:$name" VALUE="};
$w .= $opt->{filter};
$w .= '">';
}
return $w;
}
EOR
1.1 interchange/code/UI_Tag/with.coretag
rev 1.1, prev_rev 1.0
Index: with.coretag
===================================================================
UserTag with routine sub { $Vend::Session->{scratch}->{$_[0]} = $_[1]; return '' }
UserTag with Order param value
1.1 interchange/code/UI_Tag/write_page.coretag
rev 1.1, prev_rev 1.0
Index: write_page.coretag
===================================================================
UserTag write-page Documentation <<EOD
=head2 write-page
usage: [write-page file=name]content[/write-page]
Writes a file C<name> in the catalog directory. Name must be relative; it will
return undef if the file name is absolute or contains C<..>.
EOD
UserTag write-page Order page
UserTag write-page addAttr
UserTag write-page hasEndTag
UserTag write-page Routine <<EOR
sub {
my ($page, $opt, $data) = @_;
$opt ||= {};
use vars qw/$Tag $CGI/;
$page = $Tag->filter('filesafe', $page);
my $page_id = "$Vend::Cfg->{VendRoot}/$page";
$page_id =~ s!^$Vend::Cfg->{PageDir}/!!;
$page_id =~ s!\.html?$!!;
my $tmpdir = $Vend::Cfg->{ScratchDir} || 'tmp';
my $pagedir = $Vend::Cfg->{PageDir} || 'pages';
for(\$tmpdir, \$pagedir) {
$$_ =~ s!^$Vend::Cfg->{VendRoot}/!!;
}
$tmpdir .= "/pages/$Session->{id}";
$page .= $Vend::Cfg->{HTMLsuffix}
unless $page =~ /$Vend::Cfg->{HTMLsuffix}$/;
Debug("final page=$page page_id=$page_id");
my $ptab = $Vend::Cfg->{PageTables};
my $db;
my $ok;
my $wrote_db;
my $wrote_bak;
if($opt->{publish} and $ptab and $db = database_exists_ref($ptab->[0]) ) {
my $map = $Vend::Cfg->{PageTableMap};
my ($cf, $bf, $sf, $ef, $tf) = @{$map}{qw/
code
base_page
show_date
expiration_date
page_text
/};
my $date = $Tag->time( { body => '%Y%m%d%H%M%S' } );
my $now = time;
my %record = (
$bf => $page_id,
$tf => $data,
$sf => $opt->{show_date},
$ef => $opt->{expiration_date},
);
my $curr = $db->row_hash($page_id) || {};
my $code;
my $bukey;
if(! $curr->{$cf}) {
$code = $page_id;
}
elsif (! $opt->{show_date} or $opt->{show_date} lt $date) {
$bukey = "$page_id.$now";
$code = $page_id;
}
else {
$code = "$page_id.$now";
}
if($bukey) {
$wrote_bak = $db->clone_row($page_id, $bukey);
}
$wrote_db = 1;
$ok = $db->set_slice($code, \%record);
}
elsif (! $opt->{publish}) {
$page = "$tmpdir/$page";
}
if(! $wrote_db) {
$ok = $Tag->write_relative_file($page, $data);
}
if(! $ok) {
Debug("failed to write page=$page dbwrite=$wrote_db");
$::Scratch->{ui_error} = errmsg("Couldn't save page %s.", $page);
}
elsif($opt->{publish}) {
my $unlink = $Tag->unlink_file("$tmpdir/$page");
Debug("unlink=$unlink file=$tmpdir/$page");
}
::logDebug("wrote page=$page page_id=$page_id db=$wrote_db");
return $ok;
}
EOR
1.1 interchange/code/UI_Tag/write_relative_file.coretag
rev 1.1, prev_rev 1.0
Index: write_relative_file.coretag
===================================================================
UserTag write-relative-file Documentation <<EOD
=head2 write-relative-file
usage: [write-relative-file file=name]content[/write-relative-file]
Writes a file C<name> in the catalog directory. Name must be relative; it will
return undef if the file name is absolute or contains C<..>.
EOD
UserTag write-relative-file Order file
UserTag write-relative-file hasEndTag
UserTag write-relative-file Routine <<EOR
sub {
my ($file, $data) = @_;
#::logDebug("writing $file");
$file =~ m:(.*)/:;
return undef if Vend::Util::file_name_is_absolute($file);
return undef if $file =~ /\.\./;
my $dir = $1;
use File::Path;
if($dir and ! -d $dir) {
return undef if -e $dir;
File::Path::mkpath([$dir]);
}
Vend::Util::writefile(">$file", $data);
}
EOR
1.1 interchange/code/UI_Tag/write_shipping.coretag
rev 1.1, prev_rev 1.0
Index: write_shipping.coretag
===================================================================
UserTag write-shipping Order file
UserTag write-shipping PosNumber 1
UserTag write-shipping addAttr
UserTag write-shipping Routine <<EOR
sub {
my ($file, $opt) = @_;
if(! $file) {
$file = $Vend::Cfg->{Special}{'shipping.asc'}
|| Vend::Util::catfile($Vend::Cfg->{ProductDir},'shipping.asc');
}
my $lines = $Vend::Cfg->{Shipping_line};
my @outlines;
for (@$lines) {
# 0 1 2 3 4 5 6 7
# ($mode, $desc, $crit, $min, $max, $cost, $query, $opt)
my @line = @$_;
my $opt = '';
if (ref($line[7]) =~ /HASH/) {
$line[7] = ::uneval_it($line[7]);
}
push @outlines, \@line;
}
rename($file, "$file.bak");
open(SHIPOUT, ">$file")
or die errmsg("Can't write shipping to %s: %s", $file, $!);
for(@outlines) {
print SHIPOUT join "\t", @$_;
print SHIPOUT "\n";
}
close SHIPOUT;
}
EOR
1.1 interchange/code/UserTag/bar_button.tag
rev 1.1, prev_rev 1.0
Index: bar_button.tag
===================================================================
UserTag bar-button Order page current
UserTag bar-button PosNumber 2
UserTag bar-button HasEndTag 1
UserTag bar-button Routine <<EOR
sub {
use strict;
my ($page, $current, $html) = @_;
$current = $Global::Variable->{MV_PAGE}
if ! $current;
$html =~ s:\[selected\]([\000-\377]*)\[/selected]::i;
my $alt = $1;
return $html if $page ne $current;
return $alt;
}
EOR
1.1 interchange/code/UserTag/button.tag
rev 1.1, prev_rev 1.0
Index: button.tag
===================================================================
UserTag button Order name src text
UserTag button addAttr
UserTag button attrAlias value text
UserTag button hasEndTag
UserTag button Documentation <<EOD
This tag creates an mv_click button either as a <INPUT TYPE=submit ...>
or a JavaScript-linked <A HREF=....><img src=...> combination.
[button text="Delete item" confirm="Are you sure?" src="delete.gif"]
[comment]
This is the action, same as [set Delete item] action [/set]
[/comment]
[mvtag] Use any Interchange tag here, i.e. ....[/mvtag]
[perl] # code to delete item [/perl]
[/button]
Parameters:
name Name of the variable, by default mv_click.
src Image source file. If it is a relative image, the existence
of the file is checked for
text The text of the button, also the name of the scratch action
(VALUE is an alias for TEXT.)
border, height, width, vspace, hspace, AND
align The image alignment parameters. Border defaults to 0.
form The name of the form, defaults to document.forms[0] -- be careful!
confirm The text to use for a JavaScript confirm, if any.
getsize If true, tries to use Image::Size to add height=Y width=X.
alt The alt text to be displayed in window.status and balloons.
Defaults to the same as TEXT.
anchor Set to the anchor text value, defaults to TEXT
hidetext Set true if you don't want the anchor displayed
EOD
UserTag button Routine <<EOR
sub {
my ($name, $src, $text, $opt, $action) = @_;
my @js;
my $image;
if($src) {
my $dr = $::Variable->{DOCROOT};
my $id = $Tag->image( { dir_only => 1 } );
$id =~ s:/+$::;
$id =~ s:/~[^/]+::;
if( $src =~ m{^https?:}i ) {
$image = $src;
}
elsif( $dr and $id and $src =~ m{^[^/]} and -f "$dr$id/$src" ) {
$image = $src;
}
elsif( $dr and $src =~ m{^/} and -f "$dr/$src" ) {
$image = "$id/$src";
}
}
my $onclick = '';
while($action =~ s! \[
(
j (?:ava)? s (?:cript)?
)
\]
(.*?)
\[ / \1 \]
!!xgis
)
{
my $script = $2;
$script =~ s/\s+$//;
$script =~ s/^\s+//;
if($script =~ s/\bonclick\s*=\s*"(.*?)"//is) {
$onclick = $1;
next;
}
push @js, $script;
}
if(! $name or $name eq 'mv_click') {
$action =~ s/^\s+//;
$action =~ s/\s+$//;
$::Scratch->{$text} = $action;
$name = 'mv_click' if ! $name;
}
my $out = '';
my $confirm = '';
$opt->{extra} = $opt->{extra} ? " $opt->{extra}" : '';
if($opt->{confirm}) {
$opt->{confirm} =~ s/'/\\'/g;
$confirm = "confirm('$opt->{confirm}')";
}
if($onclick) {
$confirm .= ' && ' if $confirm;
$onclick = qq{onClick="$confirm$onclick"};
}
# Constructing form button. Will be sent back in all cases,
# either as the primary button or as the <noscript> option
# for JavaScript-challenged browsers.
$text =~ s/"/"/g;
$name =~ s/"/"/g;
if(! $onclick and $confirm) {
$onclick = qq{ onclick="return $confirm"};
}
$out = qq{<INPUT TYPE="submit" NAME="$name" VALUE="$text"$onclick>};
if (@js) {
$out =~ s/ /join "\n", '', @js, ''/e;
}
# return submit button if not an image
if(! $image) {
$text =~ s/"/"/g;
$name =~ s/"/"/g;
if(! $onclick and $confirm) {
$onclick = qq{ onclick="return $confirm"};
}
my $out = $opt->{bold} ? "<B>" : '';
$out .= qq{<INPUT$opt->{extra} TYPE="submit" NAME="$name" VALUE="$text"$onclick>};
$out .= "</B>" if $opt->{bold};
if(@js) {
$out =~ s/ /join "\n", '', @js, ''/e;
}
return $out;
}
# If we got here the button is an image
# Wrap form button code in <noscript>
my $no_script = qq{<noscript>$out</noscript>\n};
$out = '';
my $wstatus = $opt->{alt} || $text;
$wstatus =~ s/'/\\'/g;
my $clickname = $name;
$out .= "</B>" if $opt->{bold};
my $clickvar = $name;
if($image and $name eq 'mv_click') {
$clickvar = $text;
$clickvar =~ s/\W/_/g;
$clickname = "mv_click_$clickvar";
$out = qq{<INPUT TYPE=hidden NAME="mv_click_map" VALUE="$clickvar">};
}
$out .= qq{<INPUT TYPE=hidden NAME="$clickname" VALUE="">} if $image;
my $formname;
$opt->{form} = 'document.forms[0]'
if ! $opt->{form};
$confirm .= ' && ' if $confirm;
$opt->{border} = 0 if ! $opt->{border};
if($opt->{getsize}) {
eval {
require Image::Size;
($opt->{width}, $opt->{height}) = Image::Size::imgsize($image);
};
}
$opt->{align} = 'top' if ! $opt->{align};
my $position = '';
for(qw/height width vspace hspace align/) {
$position .= " $_=$opt->{$_}" if $opt->{$_};
}
my $anchor = '';
unless( $opt->{hidetext}) {
$anchor = $opt->{anchor} || $text;
$anchor =~ s/ / /g;
$anchor = "<b>$anchor</b>";
}
$out .= <<EOF;
<A HREF="javascript:void 0"$opt->{extra} onMouseOver="window.status='$wstatus'"
onClick="$confirm ($opt->{form}.$clickname.value='$text') && $opt->{form}.submit(); return(false);"
ALT="$wstatus"><IMG ALT="$wstatus" SRC="$src" border=$opt->{border}$position></A>$anchor
EOF
# Must escape backslashes and single quotes for JavaScript write function.
# Also must get rid of newlines and carriage returns.
$out =~ s/(['\\])/\\$1/g;
$out =~ s/[\n\r]+/ /g;
$out = <<EOV;
<script language="javascript1.2">
<!--
document.write('$out');
// -->
</script>
$no_script
EOV
return $out;
}
EOR
1.1 interchange/code/UserTag/convert_date.tag
rev 1.1, prev_rev 1.0
Index: convert_date.tag
===================================================================
UserTag convert-date Order days
UserTag convert-date PosNumber 1
UserTag convert-date addAttr
UserTag convert-date AttrAlias fmt format
UserTag convert-date HasEndTag
UserTag convert-date Interpolate
UserTag convert-date Routine <<EOR
sub {
my ($days, $opt, $text) = @_;
my @t;
if(! ref $opt) {
my $raw = $opt ? 1 : 0;
$opt = {};
$opt->{raw} = 1 if $raw;
}
my $fmt = $opt->{format} || '';
if($text =~ /^(\d\d\d\d)-(\d?\d)-(\d?\d)$/) {
$t[5] = $1 - 1900;
$t[4] = $2 - 1;
$t[3] = $3;
}
elsif($text =~ /\d/) {
$text =~ s/\D//g;
$text =~ /(\d\d\d\d)(\d\d)(\d\d)(?:(\d\d)(\d\d))?/;
$t[2] = $4 || undef;
$t[1] = $5 || undef;
$t[3] = $3;
$t[4] = $2 - 1;
$t[5] = $1;
$t[5] -= 1900;
}
else {
my $now = time();
if ($days) {
$now += $days * 86400;
}
@t = localtime($now);
}
if (defined $opt->{raw} and Vend::Util::is_yes($opt->{raw})) {
$fmt = $t[2] && $text ? '%Y%m%d%H%M' : '%Y%m%d';
}
if (! $fmt) {
if ($t[2]) {
$fmt = '%d-%b-%Y %I:%M%p';
} else {
$fmt = '%d-%b-%Y';
}
}
my ($current, $out);
if ($Scratch->{mv_locale}) {
$current = POSIX::setlocale(&POSIX::LC_TIME);
POSIX::setlocale(&POSIX::LC_TIME, $Scratch->{mv_locale});
$out = POSIX::strftime($fmt, @t);
POSIX::setlocale(&POSIX::LC_TIME, $current);
} else {
$out = POSIX::strftime($fmt, @t);
}
$out =~ s/\b0(\d)\b/$1/g if $opt->{zerofix};
return $out;
}
EOR
1.1 interchange/code/UserTag/db_date.tag
rev 1.1, prev_rev 1.0
Index: db_date.tag
===================================================================
# [db-date table format]
#
# This tag returns the last-modified time of a database table,
# 'products' by default. Accepts a POSIX strftime value for
# date format; uses '%A %d %b %Y' by default.
#
UserTag db-date Order table format
UserTag db-date PosNumber 2
UserTag db-date Routine <<EOF
sub {
my ($db, $format) = @_;
my ($dbfile, $mtime);
# use defaults if necessary
$db = 'products' unless $db;
$format = '%A %d %b %Y' unless $format;
# build database file name
$dbfile = $Vend::Cfg->{ProductDir} . '/'
. $Vend::Cfg->{Database}{$db}{'file'};
# get last modified time
$mtime = (stat ($dbfile))[9];
if (defined ($mtime)) {
return POSIX::strftime($format, localtime($mtime));
} else {
logError ("Couldn't stat $dbfile: $!\n");
}
}
EOF
1.1 interchange/code/UserTag/delete_cart.tag
rev 1.1, prev_rev 1.0
Index: delete_cart.tag
===================================================================
UserTag delete_cart Order nickname
UserTag delete_cart Routine <<EOR
sub {
my($nickname) = @_;
$Tag->userdb({function => 'delete_cart', nickname => $nickname});
return '';
}
EOR
1.1 interchange/code/UserTag/email.tag
rev 1.1, prev_rev 1.0
Index: email.tag
===================================================================
UserTag email Order to subject reply from extra
UserTag email hasEndTag
UserTag email addAttr
UserTag email Interpolate
UserTag email Routine <<EOR
sub {
my ($to, $subject, $reply, $from, $extra, $opt, $body) = @_;
my $ok = 0;
$subject = '<no subject>' unless defined $subject && $subject;
$reply = '' unless defined $reply;
$reply = "Reply-to: $reply\n" if $reply;
if (! $from) {
$from = $Vend::Cfg->{MailOrderTo};
$from =~ s/,.*//;
}
$extra =~ s/\s*$/\n/ if $extra;
SEND: {
open(Vend::MAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
print Vend::MAIL
"To: $to\n",
"From: $from\n",
$reply,
$extra || '',
"Subject: $subject\n\n",
$body
or last SEND;
close Vend::MAIL or last SEND;
$ok = ($? == 0);
}
if (!$ok) {
logError("Unable to send mail using $Vend::Cfg->{'SendMailProgram'}\n" .
"To '$to'\n" .
"From '$from'\n" .
"With extra headers '$extra'\n" .
"With reply-to '$reply'\n" .
"With subject '$subject'\n" .
"And body:\n$body");
}
return $opt->{hide} ? '' : $ok;
}
EOR
1.1 interchange/code/UserTag/email_raw.tag
rev 1.1, prev_rev 1.0
Index: email_raw.tag
===================================================================
UserTag email_raw Documentation <<EOD
This tag takes a raw email message, *including headers*, and
users the SendmailProgram with -t option. Example:
[email-raw]
From: foo@bar.com
To: bar@foo.com
Subject: baz
The text of the message.
[/email-raw]
The headers must be at the beginning of the line, and the header
must have a valid To: or it will not be delivered.
EOD
UserTag email-raw hasEndTag
UserTag email-raw addAttr
UserTag email-raw Interpolate
UserTag email-raw Routine <<EOR
sub {
my($opt, $body) = @_;
my($ok);
$body =~ s/^\s+//;
SEND: {
open(Vend::MAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND;
print Vend::MAIL $body
or last SEND;
close Vend::MAIL
or last SEND;
$ok = ($? == 0);
}
if (!$ok) {
::logError("Unable to send mail using $Vend::Cfg->{SendMailProgram}\n" .
"Message follows:\n\n$body");
}
return $opt->{hide} ? '' : $ok;
}
EOR
1.1 interchange/code/UserTag/env.tag
rev 1.1, prev_rev 1.0
Index: env.tag
===================================================================
#
# Interchange UserTag env - see documentation for more information
#
# Copyright 2001 by Ed LaFrance <edl@newmediaems.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., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA.
#
#
# SUMMARY: Provides read only access to the http evironment
# variables; individually by name, or the full
# list.
#
# USEAGE: to see a the full list as a table:
# [env]
#
# to return one the value of one variable:
# [env VARNAME]
# [env arg="VARNAME"]
#
# NOTES: Works when configured in either catalog.cfg
# or interchange.cfg. Thanks to Mike Heins and
# the programming team at RH/Akopia for the
# numerous examples in the demos and UI - I
# don't think I could come up with stuff like
# this without it.
Usertag env Order arg
Usertag env PosNumber 1
Usertag env Routine <<EOR
sub {
my $arg = shift;
my $env = ::http()->{env};
my $out;
if (! $arg) {
$out = "<table cellpadding=2 cellspacing=1 border=1>\n";
foreach ((keys %$env)) {
$out .= "<tr><td><b>$_\ <\/b><\/td><td>";
$out .= "$env->{$_}\ <\/td>\n<\/tr><tr>\n";
}
$out .= "<\/table>\n";
}
else {
$out = $env->{$arg};
}
return $out;
}
EOR
1.1 interchange/code/UserTag/fcounter.tag
rev 1.1, prev_rev 1.0
Index: fcounter.tag
===================================================================
UserTag fcounter Order file
UserTag fcounter PosNumber 1
UserTag fcounter addAttr
UserTag fcounter Routine <<EOF
sub {
my $file = shift || 'etc/counter';
my $opt = shift;
$file = $Vend::Cfg->{VendRoot} . "/$file"
unless index($file, '/') == 0;
my $ctr = new File::CounterFile $file, $opt->{start} || undef;
return $ctr->inc();
}
EOF
1.1 interchange/code/UserTag/fedex_query.tag
rev 1.1, prev_rev 1.0
Index: fedex_query.tag
===================================================================
UserTag fedex-query Order mode weight
UserTag fedex-query attrAlias origin_zip origin
UserTag fedex-query addAttr
UserTag fedex-query Documentation <<EOD
Required Variables
Construct a Rate request using the URL, variables, and values shown
below. If a value is not predetermined, the maximum length is shown in
parenthesis:
http://grd.fedex.com/cgi-bin/rrr2010.exe
Variable Name
Value
?func
=
Rate
Screen = Ground or HomeD
OriginZip = U.S. or Canada origin postal code.
OriginCountryCode = Origin country code:
US for United States
CA for Canada
DestZip = U.S., Canada, or Mexico destination postal
code.
DestCountryCode = Destination country code:
US for United States
CA for Canada
MX for Mexico
Weight = Weight, in pounds or kilograms, rounded to
the nearest whole number.
WeightUnit = The Unit of measure for the given weight:
KGS for kilograms
LBS for pounds (The default value is
Lbs)
Length = Optional: Length, in inches or centimeters,
rounded to the nearest whole number. To
calculate dimensional weight, values must be
entered for length, width, and height.
Width = Optional: Width, in inches or centimeters,
rounded to the nearest whole number. To
calculate dimensional weight, values must be
entered for length, width, and height.
Height = Optional: Height, in inches or centimeters,
rounded to the nearest whole number. To
calculate dimensional weight, values must be
entered for length, width, and height.
DimUnit = Optional: The Unit of measure for the given
dimensions (Length, Width, Height):
IN for Inches (The default value is IN)
CM for centimeters
AccessReturn = Optional: The number of accessorials
included in the request, plus the accessorial
description(s), plus =1, except for the
declared value accessorial, where the 1 is
replaced by the amount. Use a semicolon to
separate the number of accessorials included
from the first desciption, and a semicolon to
separate accessorials. The following are valid
accessorial values (values are
case-sensitive):
U.S. to U.S.
USCOD: C.O.D.or E.C.O.D. collection
USCT: Call tag
USECT: Electronic call tag
USAOD: Acknowledgement of delivery
USHazMat: Hazardous material
USDecVal: Declared value, each
additional $100
USRS: Residential surcharge
USANAC: Not in appropriate container
or single dimension greater than 60
inches
USAPOD: Auto proof of delivery
U.S. to Canada
USCODC: C.O.D. collection to Canada
USAOD: Acknowlegement of delivery
USDecVal: Declared value, each
additional $100
USANAC: Not in appropriate container
or single dimension greater than 60
inches
USRS: Residential surcharge
USAPOD: Auto proof of delivery
U.S. to Mexico
USDecVal: Declared value, each
additional $100
USRS: Residential surcharge
USANAC: Not in appropriate container
or single dimension greater than 60
inches
Canada to Canada
CACOD: C.O.D. or E.C.O.D. collection
CACT: Call tag
CAAOD: Acknowlegement of delivery
CADecVal: Declared value, each
additional $100
CARS: Residential surcharge
CAANAC: Not in appropriate container
or single dimension greater than 60
inches
CAAPOD: Auto proof of delivery
Canada to U.S.
CACOD: C.O.D. collection
CADecVal: Declared value, each
additional $100
CAANAC: Not in appropriate container
or single dimension greater than 60
inches
CAAPOD: Auto proof of delivery
U.S. to U.S. - Home Delivery
USFHDAC: Address Correction
USFHDANAC: Not in Approp. Container
or Single Dim. > 60 in.
USFHDAOD: Acknowledgement of
Delivery
USFHDDV: Declared Value Each
Additional $100
USFHDGAD: FedEx Appointment Home
Delivery
USFHDGADAPOD: FedEx Appointment
Home Delivery and Auto POD
USFHDGED: FedEx Evening Home
Delivery
USFHDGEDS: FedEx Evening Home
Delivery with Signature
USFHDGEDSAP: FedEx Evening Home
Delivery with Signature and Auto POD
USFHDGSDD: FedEx Date Certain
Home Delivery
USFHDGSDDS: FedEx Date Certain
Day Home Delivery with Signature
USFHDGSDDSAP: FedEx Date Certain
Day Home Delivery with Signature and
Auto POD
USFHDGSS: FedEx Signature Home
Service
USFHDGSSAPOD: FedEx Signature
Home Service and Auto POD
Top
Example
A URL for a Rate request without dimensional weight, oversize, or
accessorials would be constructed as follows:
!!! Line breaks are used here for clarity; URLs cannot include line breaks or
spaces.
http://grd.fedex.com/cgi-bin/rrr2010.exe
?func=Rate
&Screen=Ground
&OriginZip=44429
&OriginCountryCode=US
&DestZip=C1C1C1
&DestCountryCode=CA
&Weight=50
The URL for a Rate request that includes dimensions, oversize indicator,
and accessorials would be as follows:
http://grd.fedex.com/cgi-bin/rrr2010.exe
?func=Rate
&Screen=Ground
&OriginZip=C1C1C1
&OriginCountryCode=CA
&DestZip=44429
&DestCountryCode=US
&Weight=50
&WeightUnit=KGS
&Length=36
&Width=36
&Height=30
&DimUnit=CM
&AccessReturn=2;USCODC=1;USDecVal=500
EOD
UserTag fedex-query Routine <<EOR
my $can_do_ground;
my $can_do_express;
sub {
my( $mode, $weight, $opt) = @_;
BEGIN {
eval {
require LWP::Simple;
$can_do_ground = 1;
};
};
BEGIN {
eval {
require Business::Fedex;
$can_do_express = 1;
};
};
my $die = sub {
my ($msg, @args) = @_;
$msg = ::errmsg($msg, @args);
$Vend::Session->{ship_message} .= " $msg";
return 0;
};
my $fed;
$opt->{target_url} = 'http://grd.fedex.com/cgi-bin/rrr2010.exe'
unless $opt->{target_url};
$opt->{origin} = $::Variable->{UPS_ORIGIN}
if ! $opt->{origin};
$opt->{country} = $::Values->{$::Variable->{UPS_COUNTRY_FIELD}}
if ! $opt->{country};
$opt->{zip} = $::Values->{$::Variable->{UPS_POSTCODE_FIELD}}
if ! $opt->{zip};
$opt->{country} = uc $opt->{country};
$opt->{origin_country} = $::Variable->{COUNTRY} || 'US'
if ! $opt->{origin_country};
if($can_do_express and (! $opt->{cache} || ! $Vend::fedex_object) ) {
eval {
$Vend::fedex_object = new Business::Fedex (
orig_country => $opt->{origin_country},
orig_zip => $opt->{origin},
weight => $opt->{weight},
dest_country => $opt->{country},
dest_zip => $opt->{zip},
packaging => $opt->{packaging} || 'My Packaging',
);
$Vend::fedex_object->getrate;
};
return $die->($@) if $@;
}
$fed = $Vend::fedex_object if $can_do_express;
my %is_express = (
'FPO' => 1,
'FSO' => 1,
'F2D' => 1,
'FES' => 1,
'FIE' => 1,
'FIP' => 1,
);
my %fe_map = (
'FedEx Ground' => 'FEG',
'FedEx Home Delivery' => 'FEH',
'FedEx Priority Overnight' => 'FPO',
'FedEx Standard Overnight' => 'FSO',
'FedEx 2-Day' => 'F2D',
'FedEx Express Saver' => 'FES',
'FedEx International Priority' => 'FIP',
'FedEx International Economy' => 'FIE',
);
@fe_map{values %fe_map} = @fe_map{keys %fe_map};
Debug("fed=" . ::uneval($fed));
my @services;
Debug("can_ground=$can_do_ground country=$opt->{country} orig_country=$opt->{origin_country}");
if($opt->{services}) {
Debug("can_ground=$can_do_ground country=$opt->{country} orig_country=$opt->{origin_country}");
if(
$can_do_ground
and ($opt->{country} eq 'US' or $opt->{country} eq 'CA')
and $opt->{origin_country} eq 'US'
)
{
push @services, 'FEG';
push @services, 'FEH';
}
if($fed) {
for ( $fed->services() ) {
push @services, $fe_map{$_->{service}};
}
}
return join ( ($opt->{joiner} || ' '), @services);
}
if($fed and $is_express{$opt->{mode}}) {
for ( $fed->services() ) {
next unless $fe_map{$_->{service}} eq $opt->{mode};
return $_->{total};
}
return 0;
}
#::logGlobal("calling with: " . join("|", $mode, $origin, $zip, $weight, $country));
if($opt->{mode} eq 'FEH') {
$opt->{mode} = 'HomeD';
}
else {
$opt->{mode} = 'Ground';
}
my @required = qw/
function
mode
origin
origin_country
zip
country
weight
/;
my @opt = qw/
length
height
width
dimunit
weightunit
accessorial
/;
my %map = qw/
function func
zip DestZip
country DestCountryCode
weight Weight
mode Screen
origin OriginZip
origin_country OriginCountryCode
length Length
height Height
width Width
dimunit DimUnit
weightunit WeightUnit
accessorial AccessReturn
/;
$opt->{function} = 'Rate'
unless length $opt->{function};
my @parms;
for(@required) {
return $die->("Fedex mode %s: required parameter %s missing", $mode, $_)
unless length $opt->{$_};
push @parms, "$map{$_}=" . Vend::Util::hexify($opt->{$_});
}
for(@opt) {
next unless length $opt->{$_};
push @parms, "$map{$_}=" . Vend::Util::hexify($opt->{$_});
}
my $url = $opt->{target_url} . '?' . join('&', @parms);
return $url if $opt->{test};
my $return = LWP::Simple::get($url);
return $die->('Unable to access Fedex calculator.')
if ! length($return);
my %result;
while( $return =~ m{<!(\w+)>(.*)<!/\1>}gs ) {
$result{$1} = $2;
}
return $Vend::Interpolate::Tmp->{$opt->{hashref}} = \%result
if $opt->{hashref};
if(! $result{TotalCharges}) {
return $die->("Error on Fedex calculation: %s", $result{Error});
}
return $result{TransitTime} if $opt->{transit_time};
Debug("mode=$opt->{mode} total=$result{TotalCharges}");
return $result{TotalCharges};
}
EOR
1.1 interchange/code/UserTag/formel.tag
rev 1.1, prev_rev 1.0
Index: formel.tag
===================================================================
#
# UserTag formel - see POD documentation for more information
#
# Copyright 2000,2001 by Stefan Hornburg (Racke) <racke@linuxia.de>
#
# 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., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA.
UserTag formel Order label name type size
UserTag formel Version 0.07
UserTag formel addAttr
UserTag formel Routine <<EOF
sub {
my ($label, $name, $type, $size, $opt) = @_;
my ($labelhtml, $elhtml, $fmt);
my $contrast = $::Variable->{CONTRAST} || 'red';
my $checkfor = $opt->{'checkfor'} || $name;
my $sizestr = '';
my $labelproc;
$labelproc = sub {
my ($label, $keep) = @_;
if ($Tag->error({name => $checkfor, keep => $keep})) {
if ($opt->{signal}) {
sprintf($opt->{signal}, $label);
} else {
qq{<font color="$contrast">$label</font>};
}
} else {
$label;
}
};
# set defaults
$type = 'text' unless $type;
for ('format', 'order', 'reset', 'signal', 'size') {
next if $opt->{$_};
if ($::Values->{"mv_formel_$_"}) {
$opt->{$_} = $::Values->{"mv_formel_$_"};
}
}
if ($opt->{'format'}) {
$fmt = $opt->{'format'};
} else {
$fmt = '%s %s %s';
}
if ($opt->{'size'}) {
if ($type eq 'textarea') {
my ($cols, $rows) = split (/\s*[,x\s]\s*/, $opt->{'size'});
$sizestr = " rows=$rows cols=$cols";
} else {
$sizestr = " size=$opt->{size}";
}
}
if ($opt->{'maxlength'}) {
$sizestr .= " maxlength=$opt->{maxlength}";
}
if ($type eq 'radio' || $type eq 'checkbox') {
my ($rlabel, $rvalue, $select);
for my $button (split (/\s*,\s*/, $opt->{choices})) {
$select = '';
if ($button =~ /^(.*?)=(.*)$/) {
$rvalue = $1;
$rlabel = $2;
} else {
$rvalue = $rlabel = $button;
}
if ($::Values->{$name} eq $rvalue) {
$select = ' checked';
}
$rlabel = &$labelproc($rlabel, 1);
$elhtml .= qq{<input type=$type name=$name value="${rvalue}"$select> $rlabel};
}
# delete error implicitly
&$labelproc();
return sprintf ($fmt, $labelhtml, $elhtml);
}
$labelhtml = &$labelproc($label);
if ($type eq 'select') {
my ($rlabel, $rvalue, $select);
for my $option (split (/\s*,\s*/, $opt->{choices})) {
$select = '';
if ($option =~ /^(.*?)=(.*)$/) {
$rvalue = $1;
$rlabel = $2;
} else {
$rvalue = $rlabel = $option;
}
if ($::Values->{$name} eq $rvalue) {
$select = ' selected';
}
if ($rvalue eq $rlabel) {
$elhtml .= qq{<option $select>$rlabel};
} else {
$elhtml .= qq{<option value="$rvalue"$select>$rlabel};
}
}
return sprintf ($fmt, $labelhtml,
qq{<select name=$name>$elhtml</select>});
}
if ($opt->{reset}) {
if ($type eq 'textarea') {
$elhtml = qq{<textarea name="${name}"$sizestr></textarea>};
} else {
$elhtml = qq{<input type=$type name="${name}"$sizestr>};
}
} else {
if ($type eq 'textarea') {
$elhtml = qq{<textarea name="${name}"$sizestr>$::Values->{$name}</textarea>};
} else {
$elhtml = qq{<input type=$type name=$name value="$::Values->{$name}"$sizestr>};
}
}
if ($opt->{order}) {
# display form element first
sprintf ($fmt, $elhtml, $labelhtml, $opt->{help});
} else {
# display label first
sprintf ($fmt, $labelhtml, $elhtml, $opt->{help});
}
}
EOF
UserTag formel Documentation <<EOD
=head2 formel
This tag generates a HTML form element. It preserves the user input from
the last display of the current page and looks for
input value errors (using the C<error> tag).
The user-visible description will be displayed
in the color defined by the variable C<CONTRAST> or in red if the
variable is not set.
Parameters for this tag are:
=over 4
=item label
The user-visible description of the form element's purpose.
=item name
The name of the form element which appears in the C<NAME>
attribute of the HTML tag.
=item type
The type of the form element (supported are text, textarea,
checkbox, radio and select).
=item size
The width of the form element. For textarea elements you can
specify width and height (e.g. 70x10 or 20,4).
=back
Other options are:
=item checkfor
The name which get passed to the Error tag. The default
is the name of the form element.
=item choices
Comma-separated list of choices for radio, checkbox and select types.
To display labels different from the values, use the
C<value1=label1,value2=label2,...> notation.
=item format
The container format string for the label and the form element.
The default is C<%s %s %s>.
=item help
Help text for this form element.
=item maxlength
Add attribute C<maxlength> to the input tag.
=item order
Whether the user-visible description or the form element
comes first. Default is the first (order=0).
=item reset
Discards the user input if set to 1.
=item signal
Label container in case of errors. The default is
<font color="__CONTRAST__">%s</font>. If the variable
CONTRAST doesn't exist, the color red is used instead.
=back
You can set defaults for format, order, reset, signal and size with the
corresponding mv_formel_... form variable values, e.g.:
[value name="mv_formel_format" set="<TR><TD>%s</TD><TD>%s</TD></TR>" hide=1]
[value name="mv_formel_order" set=1 hide=1]
[value name="mv_formel_signal" set="<BLINK>%s</BLINK>" hide=1]
To display the label and the form element seperately call C<formel> twice:
[formel label=Username: name=login format="%s"]
[formel name=login order=1 format="%s"]
You may add a help text for the form element.
[formel label=Username: name=login help="alphanumeric (5-10 characters)"]
EOD
1.1 interchange/code/UserTag/fortune.tag
rev 1.1, prev_rev 1.0
Index: fortune.tag
===================================================================
UserTag fortune Order short
UserTag fortune addAttr
UserTag fortune Documentation <<EOF
This tag uses the fortune(1) command to display a randome saying.
Options:
short=yes|no* Select only short (< 160 chars) fortunes
a=1 Select from all fortunes, even potentially offensive ones.
o=1 Select only from potentially offensive fortunes.
raw=1 Don't do any HTML formatting
Example:
[fortune short=yes]
EOF
UserTag fortune Routine <<EOR
sub {
my ($short, $opt) = @_;
my $cmd = $Global::Variable->{MV_FORTUNE_COMMAND} || '/usr/games/fortune';
my @flags;
push @flags, '-s' if is_yes($short);
for(grep length($_) == 1, keys %$opt) {
push @flags, "-$_" if $opt->{$_};
}
my $out = '';
open(FORT, '-|') || exec ($cmd, @flags);
while (<FORT>) {
$out .= $_
}
unless($opt->{raw}) {
$out = filter_value('text2html', $out);
$out =~ s/--(?!:.*--)/<br>--/s;
}
return $out;
}
EOR
1.1 interchange/code/UserTag/get_url.tag
rev 1.1, prev_rev 1.0
Index: get_url.tag
===================================================================
UserTag get-url Order url
UserTag get-url AddAttr
UserTag get-url Documentation <<EOD
usage: [get-url url="valid_url" strip=1*]
Uses the LWP libraries to fetch a URL and return the contents.
If the strip option is set, strips everything up to <body> and
everything after </body>
EOD
UserTag get-url Routine <<EOR
sub {
my ($url, $opt) = @_;
eval {
require LWP::Simple;
};
if($@) {
::logError("Cannot use get-url tag, no LWP modules installed.");
return undef;
}
my $html = LWP::Simple::get($url);
if($opt->{strip}) {
$html =~ s/.*<body[^>]*>//si;
$html =~ s:</body>.*::si;
}
return $html;
}
EOR
1.1 interchange/code/UserTag/history_scan.tag
rev 1.1, prev_rev 1.0
Index: history_scan.tag
===================================================================
UserTag history-scan Order find exclude default
UserTag history-scan addAttr
UserTag history-scan Routine <<EOR
my %var_exclude = ( qw/
mv_credit_card_number 1
mv_pc 1
mv_session_id 1
/);
sub {
my ($find, $exclude, $default) = @_;
my $ref = $Vend::Session->{History}
or return $Tag->area($default || $Config->{SpecialPage}{catalog});
my ($hist, $href, $cgi);
$exclude = qr/$exclude/ if $exclude;
for(my $i = $#$ref; $i >= 0; $i--) {
#Log("checking $ref->[$i][0] for $exclude");
if ($exclude and $ref->[$i][0] =~ $exclude) {
next;
}
if($find) {
next unless $ref->[$i][0] =~ /$find/;
}
($href, $cgi) = @{$ref->[$i]};
last;
}
return $Tag->area($default || $Config->{SpecialPage}{catalog})
if ! $href;
my $form = '';
for(grep !$var_exclude{$_}, keys %$cgi) {
$form .= "\n$_=";
$form .= join("\n$_=", split /\0/, $cgi->{$_});
}
return $Tag->area( { href => $href, form => $form} );
}
EOR
1.1 interchange/code/UserTag/image.tag
rev 1.1, prev_rev 1.0
Index: image.tag
===================================================================
UserTag image Version 0.02
UserTag image Order src
UserTag image AddAttr
UserTag image Documentation <<EOD
=head2 image
This is a general-purpose tag for inserting HTML <img> tags based on
various settings, with the ability to test whether an image exists,
predetermine its pixel dimensions, retrieve the image name from the
product database field B<image> for that sku, automatically pull product
descriptions from the database for use in the B<alt> and B<title>
attributes, and access http/secure and storefront/admin UI image
directory names.
A convenient use is for displaying product images, for example on the
flypage:
[image [item-code]]
Given sku os29000 in the Foundation demo, and assuming the products
database specifies os29000.gif in the B<image> field for os29000,
the tag returns HTML code something like this:
<img src="/foundation/images/os29000.gif" width=120 height=150
alt="3' Step Ladder" title="3' Step Ladder">
If file os29000.gif hadn't existed, or the products database B<image>
field were empty, the tag would check for files called "(sku).jpg",
"(sku).gif", etc. and use the first one it found.
You can also specify a particular image filename, but also give the
sku to look up the description in the database:
[image sku="[item-code]" src="/foundation/silly/putty.jpg"]
You can force the use of an image filename even if the file doesn't
exist (for example, if it is on a different server). Any absolute URL
(http://... or https://...) is always accepted without checking, and
the B<force> attribute overrides checking on any filename.
One peculiar use is with the B<dir_only> parameter to return the correct
prefix for images (normal or secure), primarily for adding to image names
found in e.g. JavaScript code (rollovers, etc.) that we can't hope to
have Interchange parse on its own as it does for plain HTML by default.
Parameters for this tag are:
=over 4
=item alt
Text to use for the <img alt="..."> attribute. By default, this will
be filled with the B<description> from the product database if a sku is
provided.
=item default
Set this attribute to an image filename or relative or absolute URL
to use if the file named in the B<src> attribute or the filename
found in the product table B<image> field are not found.
Defaults to scratch mv_defaultimage if set.
=item dir_only
Set this attribute to 1 to return only the text of configuration
variable ImageDir or ImageDirSecure, depending on whether the page is
being delivered through the web server by http or https.
=item force
Skip checking for existence of image file.
=item getsize
Use the Perl Image::Size module, if available, to determine the image's
width and height in pixels, and pass them as arguments to the <img> tag.
This is the default behavior; pass B<getsize=0> to disable.
=item imagesubdir
Look for any image filenames in the named subdirectory of the ImageDir,
rather than directly in the ImageDir.
For example, with the Foundation demo, the individual product images are
in the subdirectory B<items/>, so you would set B<imagesubdir=items>. This
is better than passing in B<src="items/os28009.gif"> because the tag
knows the sku and can do products database lookups based on it.
Defaults to scratch mv_imagesubdir if set.
=item secure
This attribute forces using either secure or insecure image directories,
regardless of the actual current delivery method. Set to 1 to force
secure, 0 to force insecure. Note that this is not a quick way to force
using a secure B<URL> -- just a secure directory path.
=item sku
Specify a sku explicitly if you want to first try an arbitrarily-named
image in B<src>, then if it does not exist, fall back to sku-derived
image filenames.
=item src
Image filename to use. May also be a plain sku, or an image basename
which will be tried with various image suffixes (.jpg, .gif, .png, etc.)
=item title
Text to use for the <img title="..."> attribute, used by more recent
browsers for e.g. rollover tip text display. This attribute defaults the
same text as the B<alt> attribute.
=item ui
Set this attribute to 1 to use admin UI image URL prefixes in catalog or
global variables UI_IMAGE_DIR and UI_IMAGE_DIR_SECURE instead of regular
catalog image prefixes from ImageDir and ImageDirSecure.
=back
EOD
UserTag image Routine <<EOR
sub {
my ($src, $opt) = @_;
my ($image, $path, $secure, $sku);
my ($imagedircurrent, $imagedir, $imagedirsecure);
my @descriptionfields = qw( description );
my @imagefields = qw( image );
my @imagesuffixes = qw( jpg gif png jpeg );
my $filere = qr/\.\w{2,4}$/;
my $absurlre = qr/^(?i:https?)/;
if ($opt->{ui}) {
# unless no image dir specified, add locale string
my $locale = $Scratch->{mv_locale} ? $Scratch->{mv_locale} : 'en_US';
$imagedir = $::Variable->{UI_IMAGE_DIR}
|| $Global::Variable->{UI_IMAGE_DIR};
$imagedirsecure = $::Variable->{UI_IMAGE_DIR}
|| $Global::Variable->{UI_IMAGE_DIR};
for ($imagedir, $imagedirsecure) {
if ($_) {
$_ .= '/' if substr($_, -1, 1) ne '/';
$_ .= $locale . '/';
}
}
} else {
$imagedir = $Vend::Cfg->{ImageDir};
$imagedirsecure = $Vend::Cfg->{ImageDirSecure};
}
# make sure there's a trailing slash on directories
for ($imagedir, $imagedirsecure) {
$_ .= '/' if $_ and substr($_, -1, 1) ne '/';
}
if (defined $opt->{secure}) {
$secure = $opt->{secure} ? 1 : 0;
} else {
$secure = $CGI::secure;
}
$imagedircurrent = $secure ? $imagedirsecure : $imagedir;
return $imagedircurrent if $opt->{dir_only};
$opt->{getsize} = 1 unless defined $opt->{getsize};
$opt->{imagesubdir} ||= $::Scratch->{mv_imagesubdir}
if defined $::Scratch->{mv_imagesubdir};
$opt->{default} ||= $::Scratch->{mv_imagedefault}
if defined $::Scratch->{mv_imagedefault};
if ($opt->{sku}) {
$sku = $opt->{sku};
} else {
# assume src option is a sku if it doesn't look like a filename
if ($src !~ /$filere/) {
$sku = $src;
undef $src;
}
}
if ($src =~ /$absurlre/) {
# we have no way to check validity of full URLs,
# so we just assume they're good
$image = $src;
} else {
my @srclist;
push @srclist, $src if $src;
if ($sku) {
# check all products tables for image fields
for ( @{$Vend::Cfg->{ProductFiles}} ) {
my $db = Vend::Data::database_exists_ref($_)
or die "Bad database $_?";
$db = $db->ref();
my $view = $db->row_hash($sku)
if $db->record_exists($sku);
if (ref $view eq 'HASH') {
for (@imagefields) {
push @srclist, $view->{$_} if $view->{$_};
}
# grab product description for alt attribute
unless (defined $opt->{alt}) {
for (@descriptionfields) {
($opt->{alt} = $view->{$_}, last)
if $view->{$_};
}
}
}
}
}
push @srclist, $sku if $sku;
push @srclist, $opt->{default} if $opt->{default};
if ($opt->{imagesubdir}) {
$opt->{imagesubdir} .= '/' unless $opt->{imagesubdir} =~ m:/$:;
}
my $dr = $::Variable->{DOCROOT};
my $id = $imagedircurrent;
$id =~ s:/+$::;
$id =~ s:/~[^/]+::;
IMAGE_EXISTS:
for my $try (@srclist) {
($image = $try, last) if $try =~ /$absurlre/;
$try = $opt->{imagesubdir} . $try;
my @trylist;
if ($try and $try !~ /$filere/) {
@trylist = map { "$try.$_" } @imagesuffixes;
} else {
@trylist = ($try);
}
for (@trylist) {
if ($id and m{^[^/]}) {
if ($opt->{force} or ($dr and -f "$dr$id/$_")) {
$image = $_;
$path = "$dr$id/$_";
}
} elsif (m{^/}) {
if ($opt->{force} or ($dr and -f "$dr/$_")) {
$image = $_;
$path = "$dr/$_";
}
}
last IMAGE_EXISTS if $image;
}
}
return unless $image;
if ($opt->{getsize} and $path) {
eval {
require Image::Size;
my ($width, $height) = Image::Size::imgsize($path);
($opt->{width}, $opt->{height}) = ($width, $height)
if $width and $height;
};
}
}
$opt->{title} = $opt->{alt} if ! defined $opt->{title} and $opt->{alt};
my $opts = '';
for (qw: width height alt title border hspace vspace :) {
if (defined $opt->{$_}) {
my $val = $opt->{$_};
$val = '"' . HTML::Entities::encode($val) . '"'
if $val =~ /\W/;
$val = '""' if $val eq '';
$opts .= qq{ $_=$val};
}
}
$image = $imagedircurrent . $image unless
$image =~ /$absurlre/ or substr($image, 0, 1) eq '/';
$image =~ s/"/"/g;
return qq{<img src="$image"$opts>};
}
EOR
1.1 interchange/code/UserTag/load_cart.tag
rev 1.1, prev_rev 1.0
Index: load_cart.tag
===================================================================
UserTag load_cart Order nickname
UserTag load_cart Routine <<EOR
sub {
my($nickname) = @_;
my($jn,$updated,$recurring) = split(':',$nickname);
$Tag->userdb({function => 'get_cart', nickname => $nickname, merge => 1});
$Scratch->{just_nickname} = $jn;
if($recurring eq 'c') {
$Tag->userdb({function => 'delete_cart', nickname => $nickname});
}
return '';
}
EOR
1.1 interchange/code/UserTag/loc.tag
rev 1.1, prev_rev 1.0
Index: loc.tag
===================================================================
# [loc locale*] message [/loc]
#
# This tag is the equivalent of [L] ... [/L] localization, except
# it works with contained tags
#
UserTag loc hasEndTag 1
UserTag loc Interpolate 1
UserTag loc Order locale
UserTag loc Routine <<EOF
sub {
my ($locale, $message) = @_;
return $message unless $Vend::Cfg->{Locale};
my $ref;
if($locale) {
return $message
unless defined $Vend::Cfg->{Locale_repository}{$locale};
$ref = $Vend::Cfg->{Locale_repository}{$locale}
}
else {
$ref = $Vend::Cfg->{Locale};
}
return defined $ref->{$message} ? $ref->{$message} : $message;
}
EOF
1.1 interchange/code/UserTag/rand.tag
rev 1.1, prev_rev 1.0
Index: rand.tag
===================================================================
UserTag rand Order file
UserTag rand posNumber 1
UserTag rand addAttr
UserTag rand hasEndTag
UserTag rand Routine <<EOR
sub {
my ($file, $opt, $inline) = @_;
my $sep = $opt->{separator} || '\[alt\]';
$inline = ::readfile($file)
if $file;
my @pieces = split /$sep/, $inline;
return $pieces[int(rand(scalar @pieces))] ;
}
EOR
1.1 interchange/code/UserTag/save_cart.tag
rev 1.1, prev_rev 1.0
Index: save_cart.tag
===================================================================
UserTag save_cart Order nickname recurring
UserTag save_cart Routine <<EOR
sub {
my($nickname,$recurring) = @_;
my $add = 0;
my %names = ();
$nickname =~ s/://g;
$recurring = ($recurring?"r":"c");
foreach(split("\n",$Tag->value('carts'))) {
my($n,$t,$r) = split(':',$_);
$names{$n} = $r;
if($r eq $recurring) {
if($n eq $nickname) {
#$Tag->userdb({function => 'delete_cart', nickname => $_});
$add = 1;
}
}
}
if($add) {
while($names{"$nickname,$add"} eq $recurring) {
$add++;
}
$nickname .= ",$add";
}
my $nn = join(':',$nickname,time(),$recurring);
$Tag->userdb({function => 'set_cart', nickname => $nn});
$Carts->{main} = [];
return '';
}
EOR
1.1 interchange/code/UserTag/summary.tag
rev 1.1, prev_rev 1.0
Index: summary.tag
===================================================================
# [summary amount=n.nn
# name=label*
# hide=1*
# total=1*
# reset=1*
# format="%.2f"*
# currency=1* ]
#
# Calculates column totals (if used properly. 8-\)
#
#
UserTag summary Order amount
UserTag summary PosNumber 1
UserTag summary addAttr
UserTag summary Routine <<EOF
use vars qw/%summary_hash/;
sub {
my ($amount, $opt) = @_;
my $name;
unless ($name = $opt->{name} ) {
$name = 'ONLY0000';
%summary_hash = () if Vend::Util::is_yes($opt->{reset});
}
else {
$summary_hash{$name} = 0 if Vend::Util::is_yes($opt->{reset});
}
$summary_hash{$name} += $amount if length $amount;
$amount = $summary_hash{$name} if Vend::Util::is_yes($opt->{total});
return '' if $opt->{hide};
return sprintf($opt->{format}, $amount) if $opt->{format};
return Vend::Util::currency($amount) if $opt->{currency};
return $amount;
}
EOF
1.1 interchange/code/UserTag/table_organize.tag
rev 1.1, prev_rev 1.0
Index: table_organize.tag
===================================================================
UserTag table-organize Order cols
UserTag table-organize attrAlias columns cols
UserTag table-organize Interpolate
UserTag table-organize addAttr
UserTag table-organize hasEndTag
UserTag table-organize Documentation <<EOD
=head2 table-organize
usage: [table-organize <options>]
[loop ....] <td> [loop-tags] </td> [/loop]
[/table-organize]
Takes an unorganized set of table cells and organizes them into
rows based on the number of columns; it will also break them into
separate tables.
If the number of cells are not on an even modulus of the number of columns,
then "filler" cells are pushed on.
Parameters:
=over 4
=item cols (or columns)
Number of columns. This argument defaults to 2 if not present.
=item rows
Optional number of rows. Implies "table" parameter.
=item table
If present, will cause a surrounding <TABLE > </TABLE> pair with the attributes
specified in this option.
=item caption
Table <CAPTION> container text, if any. Can be an array.
=item td
Attributes for table cells. Can be an array.
=item tr
Attributes for table rows. Can be an array.
=item columnize
Will display cells in (newspaper) column order, i.e. rotated.
=item pretty
Adds newline and tab characters to provide some reasonable indenting.
=item filler
Contents to place in empty cells put on as filler. Defaults to C< >.
=item limit
Maximum number of cells to use. Truncates extra cells silently.
=item embed
If you want to embed other tables inside, make sure they are called with
lower case <td> elements, then set the embed tag and make the cells you wish
to organize be <TD> elements. To switch that sense, and make the upper-case
or mixed case be the ignored cells, set the embed parameter to C<lc>.
[table-organize embed=lc]
<td>
<TABLE>
<TR>
<TD> something
</TD>
</TR>
</table>
</td>
[/table-organize
or
[table-organize embed=uc]
<TD>
<table>
<tr>
<td> something
</td>
</tr>
</table>
</TD>
[/table-organize]
=back
The C<tr>, C<td>, and C<caption> attributes can be specified with indexes;
if they are, then they will alternate according to the modulus.
The C<td> option array size should probably always equal the number of columns;
if it is bigger, then trailing elements are ignored. If it is smaller, no attribute
is used.
For example, to produce a table that 1) alternates rows with background
colors C<#EEEEEE> and C<#FFFFFF>, and 2) aligns the columns RIGHT CENTER
LEFT, do:
[table-organize
cols=3
pretty=1
tr.0='bgcolor="#EEEEEE"'
tr.1='bgcolor="#FFFFFF"'
td.0='align=right'
td.1='align=center'
td.2='align=left'
]
[loop list="1 2 3 1a 2a 3a 1b"] <td> [loop-code] </td> [/loop]
[/table-organize]
which will produce:
<tr bgcolor="#EEEEEE">
<td align=right>1</td>
<td align=center>2</td>
<td align=left>3</td>
</tr>
<tr bgcolor="#FFFFFF">
<td align=right>1a</td>
<td align=center>2a</td>
<td align=left>3a</td>
</tr>
<tr bgcolor="#EEEEEE">
<td align=right>1b</td>
<td align=center> </td>
<td align=left> </td>
</tr>
If the attribute columnize=1 is present, the result will look like:
<tr bgcolor="#EEEEEE">
<td align=right>1</td>
<td align=center>1a</td>
<td align=left>1b</td>
</tr>
<tr bgcolor="#FFFFFF">
<td align=right>2</td>
<td align=center>2a</td>
<td align=left> </td>
</tr>
<tr bgcolor="#EEEEEE">
<td align=right>3</td>
<td align=center>3a</td>
<td align=left> </td>
</tr>
See the source for more ideas on how to extend this tag.
EOD
UserTag table-organize Routine <<EOR
sub {
my ($cols, $opt, $body) = @_;
$cols = int($cols) || 2;
$body =~ s/(.*?)(<td)\b/$2/is
or return;
my $out = $1;
$body =~ s:(</td>)(?!.*</td>)(.*):$1:is;
my $postamble = $2;
my @cells;
if($opt->{embed}) {
if($opt->{embed} eq 'lc') {
push @cells, $1 while $body =~ s:(<td\b.*?</td>)::s;
}
else {
push @cells, $1 while $body =~ s:(<TD\b.*?</TD>)::s;
}
}
else {
push @cells, $1 while $body =~ s:(<td\b.*?</td>)::is;
}
if(int($opt->{limit}) and $opt->{limit} < scalar(@cells) ) {
splice(@cells, $opt->{limit});
}
for(qw/ table/) {
$opt->{$_} = defined $opt->{$_} ? " $opt->{$_}" : '';
}
my @td;
if(! $opt->{td}) {
@td = '' x $cols;
}
elsif (ref $opt->{td} ) {
@td = @{$opt->{td}};
push @td, '' while scalar(@td) < $cols;
}
else {
@td = (" $opt->{td}") x $cols;
}
my %attr;
for(qw/caption tr pre post/) {
if( ! $opt->{$_} ) {
#do nothing
}
elsif (ref $opt->{$_}) {
$attr{$_} = $opt->{$_};
}
else {
$attr{$_} = [$opt->{$_}];
}
}
my $pretty = $opt->{pretty};
#$opt->{td} =~ s/^(\S)/ $1/;
#$opt->{tr} =~ s/^(\S)/ $1/;
my @rest;
my $rows;
my $rmod;
my $tmod = 0;
my $total_mod;
$opt->{filler} = ' ' if ! defined $opt->{filler};
my $td_beg;
my $td_end;
if($opt->{font}) {
$td_beg = qq{<FONT $opt->{font}>};
$td_end = qq{</FONT>};
}
if($rows = int($opt->{rows}) ) {
$total_mod = $rows * $cols;
@rest = splice(@cells, $total_mod)
if $total_mod < @cells;
$opt->{table} = ' ' if ! $opt->{table};
}
my $joiner = $pretty ? "\n\t\t" : "";
while(@cells) {
while (scalar(@cells) % $cols) {
push @cells, "<td>$opt->{filler}</td>";
}
if( $opt->{columnize}) {
my $nr_of_rows = scalar(@cells) / $cols;
my @tmp = splice(@cells,0);
my $index;
my $r = 0;
while ($r < $nr_of_rows) {
my $c = 0;
while ($c < $cols) {
$index = $r + $nr_of_rows * $c;
push @cells, $tmp[$index];
$c++;
}
$r++;
}
}
#$out .= "<!-- starting table tmod=$tmod -->";
if($opt->{table}) {
$out .= "<table$opt->{table}>";
$out .= "\n" if $pretty;
if($opt->{caption}) {
my $idx = $tmod % scalar(@{$attr{caption}});
#$out .= "<!-- caption index $idx -->";
$out .= "\n" if $pretty;
$out .= "<CAPTION>" . $attr{caption}[$idx] . "</CAPTION>";
$out .= "\n" if $pretty;
}
}
$rmod = 0;
while(@cells) {
$out .= "\t" if $pretty;
$out .= "<tr";
if($opt->{tr}) {
my $idx = $rmod % scalar(@{$attr{tr}});
$out .= " " . $attr{tr}[$idx];
}
$out .= ">";
$out .= "\n\t\t" if $pretty;
my @op = splice (@cells, 0, $cols);
if($opt->{td}) {
for ( my $i = 0; $i < $cols; $i++) {
$op[$i] =~ s/(<td)/$1 $td[$i]/i;
}
}
if($opt->{td}) {
for ( my $i = 0; $i < $cols; $i++) {
$op[$i] =~ s/(<td)/$1 $td[$i]/i;
}
}
@op = map { s/>/>$td_beg/; $_ } @op if $td_beg;
@op = map { s/(<[^<]+)$/$td_end$1/; $_ } @op if $td_end;
$out .= join($joiner, @op);
$out .= "\n\t" if $pretty;
$out .= "</tr>";
$out .= "\n" if $pretty;
$rmod++;
}
if($opt->{table}) {
$out .= "</table>";
$out .= "\n" if $pretty;
}
if(@rest) {
my $num = $total_mod < scalar(@rest) ? $total_mod : scalar(@rest);
@cells = splice(@rest, 0, $num);
}
$tmod++;
}
return $out . $postamble;
}
EOR
1.1 interchange/code/UserTag/title_bar.tag
rev 1.1, prev_rev 1.0
Index: title_bar.tag
===================================================================
UserTag title-bar Order width size color
UserTag title-bar PosNumber 3
UserTag title-bar Interpolate 1
UserTag title-bar HasEndTag 1
UserTag title-bar Routine <<EOR
sub {
my ($width, $size, $color, $text) = @_;
$width = 500 unless defined $width;
$size = 6 unless defined $size;
$color = ($::Variable->{HEADERBG} || '#444444') unless defined $color;
$color = qq{BGCOLOR="$color"} unless $color =~ /^\s*bgcolor=/i;
my $tcolor = $::Variable->{HEADERTEXT} || 'WHITE';
$text = qq{<FONT COLOR="$tcolor" SIZE="$size">$text</FONT>};
return <<EOF;
<TABLE CELLSPACING=0 CELLPADDING=6 WIDTH="$width"><TR><TD VALIGN=CENTER $color>$text</TD></TR></TABLE>
EOF
}
EOR
1.1 interchange/code/UserTag/ups_query.tag
rev 1.1, prev_rev 1.0
Index: ups_query.tag
===================================================================
UserTag ups-query Order mode origin zip weight country
UserTag ups-query Routine <<EOR
sub {
my( $mode, $origin, $zip, $weight, $country) = @_;
BEGIN {
eval {
require Business::UPS;
import Business::UPS;
};
};
$origin = $::Variable->{UPS_ORIGIN}
if ! $origin;
$country = $::Values->{$::Variable->{UPS_COUNTRY_FIELD}}
if ! $country;
$zip = $::Values->{$::Variable->{UPS_POSTCODE_FIELD}}
if ! $zip;
$country = uc $country;
#::logGlobal("calling with: " . join("|", $mode, $origin, $zip, $weight, $country));
my ($shipping, $zone, $error) =
getUPS( $mode, $origin, $zip, $weight, $country);
#::logGlobal("received back: " . join("|", $shipping, $zone, $error));
if($error) {
$Vend::Session->{ship_message} .= " $mode: $error";
return 0;
}
return $shipping;
}
EOR
1.1 interchange/code/UserTag/usertrack.tag
rev 1.1, prev_rev 1.0
Index: usertrack.tag
===================================================================
UserTag usertrack Order tag value
UserTag usertrack Routine sub { $Vend::Track->user(@_); }
1.1 interchange/code/UserTag/var.tag
rev 1.1, prev_rev 1.0
Index: var.tag
===================================================================
# [var name=variablename global=1|2]
#
# This tag allows access to variables within other variables (or
# anywhere else, but in regular pages the direct non-tag notations
# shown on the right-hand side below are faster).
#
# [var VARIABLE] is equivalent to __VARIABLE__
# [var VARIABLE 1] is equivalent to @@VARIABLE@@
# [var VARIABLE 2] is equivalent to @_VARIABLE_@
#
UserTag var Interpolate 1
UserTag var PosNumber 2
UserTag var Order name global
UserTag var Routine <<EOR
sub {
my ($key, $global) = @_;
$global and $global != 2 and return $Global::Variable->{$key};
return $Vend::Cfg->{Member}{$key}
if $Vend::Session->{logged_in}
&& defined $Vend::Cfg->{Member}{$key};
if($global) {
return Vend::Interpolate::dynamic_var($key) || $Global::Variable->{$key};
}
return Vend::Interpolate::dynamic_var($key);
}
EOR
1.1 interchange/code/UserTag/xml_generator.tag
rev 1.1, prev_rev 1.0
Index: xml_generator.tag
===================================================================
UserTag xml-generator Order type
UserTag xml-generator addAttr
UserTag xml-generator hasEndTag
UserTag xml-generator Interpolate
UserTag xml-generator Documentation <<EOD
=head2 xml_generator
This UserTag generates XML tags based upon one of two types of data:
=over 4
=item delimited
Accepts a delimited and separated (default is TAB delimiter and newline sepraror)
list of records such as that generated by an C<[item-list]>, C<[sql]>,
or C<[loop search=""]> MML tag.
=item session
When the type is not delimited, it can contain any hash reference into
the Interchange session. Examples are:
values The form values
scratch Scratch values
errors Error values
other Any other Session key, for example "source" for
[data session source]
If the value is a hash, then it will be sent as an XML record with the
top level equal to C<session>, and a second_level tag equal to the hash
name, and keys as separate XML container tags. If the paramater I<that is equal
to the type> is given, only those fields will be shown. Otherwise the
entire hash will be shown. For example, this tag:
[xml-generator type="values" values="fname lname"][/xml-generator]
will generate:
<session>
<values>
<fname>First</fname>
<lname>Last</lname>
</values>
</session>
it is a scalar, then only the second level will be done:
[xml-generator type="cybercash_id"][/xml-generator]
will do the equivalent of:
<session>
<cybercash_id>[data session cybercash_id]</cybercash_id>
</session>
So bringing it all together, the following:
[xml-generator type="values scratch source"
values="fname lname"
scratch="downloads"][/xml-generator]
will generate:
<session>
<values>
<fname>First</fname>
<lname>Last</lname>
</values>
<scratch>
<downloads>0</downloads>
</scratch>
<source>Partner1</source>
</session>
=back
Other parameters include:
=over 4
=item toplevel_tag
The toplevel tag name to use. Defaults to C<table> for the delimited type,
and C<session> for the other.
=item table_name
A table name to output for the delimited type, i.e.
C<<>C<table name="table_name">C<>>.
=item attributes
The attributes (if any) to pass on to the top level tag. For instance,
[xml-generator
attributes="date"
date="[tag time]%d-%b-%Y[/tag]"
toplevel_tag=order
]
will generate a toplevel tag pair of:
<order date="05-Mar-2000">
</order>
=item no_second
Prevents the second-level tags from being generated. Extending the
last example in the C<session> type above, this
[xml-generator type="values scratch source"
no_second=1
values="fname lname"
scratch="downloads"][/xml-generator]
will generate:
<session>
<fname>First</fname>
<lname>Last</lname>
<downloads>0</downloads>
<source>Partner1</source>
</session>
EOD
UserTag xml-generator Routine <<EOR
sub {
my ($type, $opt, $body) = @_;
my @fields;
my @lines;
my $out = '';
my $attr_string = '';
if($opt->{attributes}) {
my @attr = split /[\s,]+/, $opt->{attributes};
for(@attr) {
next unless length $opt->{$_};
my $v = $opt->{$_};
$v =~ s/"/\\"/g;
$attr_string .= qq{\n\t$_="$v"};
}
}
my %hash = (
spacer => '[\s,]+',
separator => "\n",
delimiter => "\t",
joiner => "\n",
n => "\n",
r => "\r",
f => "\f",
t => "\t",
0 => "\0",
);
for(qw/separator delimiter joiner spacer/) {
if($opt->{$_}) {
$opt->{$_} =~ s/\\([nrf0])/$hash{$1}/g;
}
else {
$opt->{$_} = $hash{$_};
}
}
$type = 'delimited' unless $type;
if($opt->{dbdump}) {
my ($key, @f);
$out .= qq{<database catalog="$Vend::Cfg->{CatalogName}">\n};
for( sort keys %Vend::Database) {
my $db = ::database_exists_ref($_)
or die "Bad database $_???";
$db = $db->ref();
$out .= '<';
$out .= $opt->{toplevel_tag} || 'table';
$out .= qq{ name="$_">\n};
@fields = $db->columns();
my $cnt = scalar(@fields);
my $rtag = $opt->{record_tag} || 'record';
my $ftag = $opt->{field_tag} || 'field';
while( ($key, @f) = $db->each_record() ) {
$key =~ s/"/\\"/g;
$out .= qq{\t<$rtag key="$key">\n};
for (my $i = 0; $i < $cnt; $i++) {
next if $opt->{skip_empty} && length($f[$i]) == 0;
HTML::Entities::encode_entities($f[$i]);
$out .= qq{\t\t<$ftag name="$fields[$i]">$f[$i]</$ftag>\n};
}
$out .= qq{\t</$rtag>\n};
}
$out .= "</" . ($opt->{toplevel_tag} || 'table' ) . ">\n";
}
$out .= qq{</database>\n};
}
elsif($type eq 'delimited') {
my $delim = $opt->{delimiter};
if($opt->{field_names}) {
@fields = grep /\S/, split /[\s,]+/, $opt->{field_names};
}
else {
$body =~ s/^(.*)\r?\n//;
$opt->{field_names} = $1;
$opt->{field_names} =~ s/\s+$//;
$opt->{field_names} =~ s/^\s+//;
@fields = grep /\S/, split /\t/, $opt->{field_names};
}
$body =~ s/\s+$//;
@lines = split /$opt->{separator}/, $body;
$out = '<';
$out .= $opt->{toplevel_tag} || 'table';
$out .= $attr_string;
$out .= ">\n";
my $rtag = $opt->{record_tag} || 'record';
my $keypos = 0;
if($opt->{key_name}) {
my $i = -1;
my $found;
for (@fields) {
$i++;
next unless $_ eq $opt->{key_name};
$found = 1;
last;
}
$keypos = $i if $found;
}
for(@lines) {
warn "keypos=$keypos\n";
my @f = split /$delim/o, $_;
my $key = $f[$keypos];
$key =~ s/"/\\"/g;
$out .= qq{\t<$rtag key="$key">\n};
for (my $i = 0; $i < scalar @fields; $i++) {
$out .= qq{\t\t<$fields[$i]>$f[$i]</$fields[$i]>\n};
}
$out .= qq{\t</$rtag>\n};
}
$out .= "</";
$out .= $opt->{toplevel_tag} || 'table';
$out .= ">";
}
else {
my @ones = grep /\S/, split /$opt->{spacer}/, $type;
$out = '<';
$out .= $opt->{toplevel_tag} || 'session';
$out .= $attr_string;
$out .= ">\n";
my @keys;
for(@ones) {
my $ref = $_ eq 'CGI' ? \%CGI::values : ($Vend::Session->{$_} || {});
if($opt->{$_}) {
@keys = split /$opt->{spacer}/o, $opt->{$_};
}
else {
@keys = keys %$ref;
}
my $spacer;
if($opt->{no_second}) {
$spacer = "\t";
}
else {
$out .= qq{\t<$_>\n};
$spacer = "\t\t";
}
foreach my $k (@keys) {
$out .= qq{$spacer<$k>$ref->{$k}</$k>$opt->{separator}};
}
$out .= qq{\t</$_>\n}
unless $opt->{no_second};
}
$out .= "</";
$out .= $opt->{toplevel_tag} || 'session';
$out .= ">";
}
return $out;
}
EOR
2.24 +770 -318 interchange/lib/Vend/Config.pm
rev 2.24, prev_rev 2.23
Index: Config.pm
===================================================================
RCS file: /anon_cvs/repository/interchange/lib/Vend/Config.pm,v
retrieving revision 2.23
retrieving revision 2.24
diff -u -r2.23 -r2.24
--- Config.pm 24 Jan 2002 06:41:11 -0000 2.23
+++ Config.pm 29 Jan 2002 05:52:43 -0000 2.24
@@ -1,6 +1,6 @@
# Vend::Config - Configure Interchange
#
-# $Id: Config.pm,v 2.23 2002/01/24 06:41:11 jon Exp $
+# $Id: Config.pm,v 2.24 2002/01/29 05:52:43 mheins Exp $
#
# Copyright (C) 1996-2001 Red Hat, Inc. <interchange@redhat.com>
#
@@ -31,71 +31,20 @@
@EXPORT_OK = qw( get_catalog_default get_global_default parse_time parse_database);
-my $OldDirectives = q{
- AdminDatabase
- AdminPage
- AsciiBackend
- BackendOrder
- ButtonBars
- CheckoutFrame
- CheckoutPage
- DataDir
- Delimiter
- DescriptionTrim
- DebugMode
- FieldDelimiter
- FrameFlyPage
- FrameLinkDir
- FrameOrderPage
- FrameSearchPage
- ItemLinkDir
- ItemLinkValue
- MsqlDB
- MsqlProducts
- Mv_AlinkColor
- Mv_Background
- Mv_BgColor
- Mv_LinkColor
- Mv_TextColor
- Mv_VlinkColor
- NewEscape
- NewReport
- NewTags
- OldShipping
- OrderFrame
- PageCache
- PriceDatabase
- Random
- ReceiptPage
- RecordDelimiter
- ReportIgnore
- RetireDBM
- Rotate
- SafeSignals
- SearchCache
- SearchFrame
- SearchOverMsg
- SecureOrderMsg
- SpecialFile
- SubArgs
- TcpPort
- TransparentItem
- Tracking
-};
-
use strict;
use vars qw(
$VERSION $C
@Locale_directives_ary @Locale_directives_scalar
@Locale_directives_code
@Locale_directives_currency @Locale_keys_currency
+ $GlobalRead $SystemCodeDone $CodeDest
);
use Safe;
use Fcntl;
use Vend::Parse;
use Vend::Util;
-$VERSION = substr(q$Revision: 2.23 $, 10);
+$VERSION = substr(q$Revision: 2.24 $, 10);
my %CDname;
@@ -197,6 +146,8 @@
Variable 1
));
+my $StdTags;
+
my $configfile;
### This is unset when interchange script is run, so that the default
@@ -205,15 +156,11 @@
# Report a fatal error in the configuration file.
sub config_error {
- my($msg) = @_;
-
- if($msg =~ /unknown\s+directive\s+'(\w+)/i) {
- my $check = $1;
- if($OldDirectives =~ /\b$check\b/i) {
- warn "MiniVend 3.x directive '$check' ignored at line $. of $configfile.\n";
- return 1;
- }
+ my $msg = shift;
+ if(@_) {
+ $msg = errmsg($msg, @_);
}
+
$msg = errmsg("%s\nIn line %s of the configuration file '%s':\n%s\n",
$msg,
$.,
@@ -230,8 +177,10 @@
}
sub config_warn {
- my($msg) = @_;
-
+ my $msg = shift;
+ if(@_) {
+ $msg = errmsg($msg, @_);
+ }
::logGlobal({level => 'notice'},
errmsg("%s\nIn line %s of the configuration file '%s':\n%s\n",
$msg,
@@ -270,6 +219,13 @@
['DumpStructure', 'yesno', 'No'],
['DumpAllCfg', 'yesno', 'No'],
['DisplayErrors', 'yesno', 'No'],
+ ['DeleteDirective', sub {
+ my $c = $Global::DeleteDirective || {};
+ shift;
+ my @sets = map { lc $_ } split /[,\s]+/, shift;
+ @{$c}{@sets} = map { 1 } @sets;
+ return $c;
+ }, ''],
['Inet_Mode', 'yesno', (
defined $Global::Inet_Mode
||
@@ -308,6 +264,8 @@
['IPCsocket', undef, "$Global::VendRoot/etc/socket.ipc"],
['HouseKeeping', 'integer', 60],
['Mall', 'yesno', 'No'],
+ ['TagGroup', 'tag_group', $StdTags],
+ ['TagInclude', 'tag_include', ':core'],
['ActionMap', 'action', ''],
['FormAction', 'action', ''],
['MaxServers', 'integer', 10],
@@ -319,6 +277,7 @@
['IpHead', 'yesno', 'No'],
['IpQuad', 'integer', '1'],
['TemplateDir', 'root_dir_array', ''],
+ ['TagDir', 'root_dir_array', 'code'],
['DomainTail', 'yesno', 'Yes'],
['AcrossLocks', 'yesno', 'No'],
['TolerateGet', 'yesno', 'No'],
@@ -330,6 +289,7 @@
['AllowGlobal', 'boolean', ''],
['AddDirective', 'directive', ''],
['UserTag', 'tag', ''],
+ ['CodeDef', 'mapped_code', ''],
['HotDBI', 'boolean', ''],
['AdminUser', undef, ''],
['AdminHost', undef, ''],
@@ -469,6 +429,7 @@
['CookieDomain', undef, ''],
['MasterHost', undef, ''],
['UserTag', 'tag', ''],
+ ['CodeDef', 'mapped_code', ''],
['RemoteUser', undef, ''],
['TaxShipping', undef, ''],
['FractionalItems', 'yesno', 'No'],
@@ -529,6 +490,26 @@
return $directives;
}
+sub get_parse_routine {
+ my $parse = shift
+ or return undef;
+ my $routine;
+ if(ref $parse eq 'CODE') {
+ $routine = $parse;
+ }
+ else {
+ no strict 'refs';
+ $routine = \&{'parse_' . $parse};
+ }
+
+ if(ref($routine) ne 'CODE') {
+ config_error('Unknown parse routine %s', "parse_$parse");
+ }
+
+ return $routine;
+
+}
+
sub set_directive {
my ($directive, $value, $global) = @_;
my $directives;
@@ -540,15 +521,10 @@
no strict 'refs';
foreach $d (@$directives) {
next unless (lc $directive) eq (lc $d->[0]);
- if (defined $d->[1]) {
- $parse = 'parse_' . $d->[1];
- }
- else {
- $parse = undef;
- }
+ $parse = get_parse_routine($d->[1]);
$dir = $d->[0];
- $value = &{$parse}($dir, $value)
- if defined $parse;
+ $value = $parse->($dir, $value)
+ if $parse;
last;
}
return [$dir, $value] if defined $dir;
@@ -659,8 +635,9 @@
foreach $d (@$directives) {
my $ucdir = $d->[0];
$directive = lc $d->[0];
+ next if $Global::DeleteDirective->{$directive};
$CDname{$directive} = $ucdir;
- $parse{$directive} = 'parse_' . $d->[1] if defined $d->[1];
+ $parse{$directive} = get_parse_routine($d->[1]);
}
}
@@ -670,7 +647,8 @@
foreach $d (@$directives) {
my $ucdir = $d->[0];
$directive = lc $d->[0];
- $parse = $parse{$directive} || undef;
+ next if $Global::DeleteDirective->{$directive};
+ $parse = $parse{$directive};
$value = (
! defined $MV::Default{$catalog} or
@@ -681,13 +659,13 @@
if (defined $parse and defined $value) {
#::logDebug("parsing default directive=$directive ucdir=$ucdir parse=$parse value=$value CDname=$CDname{$directive}");
- $value = &$parse($ucdir, $value);
+ $value = $parse->($ucdir, $value);
}
$C->{$CDname{$directive}} = $value;
}
}
- my(@include) = my $catalogcfg = ($passed_file || $C->{ConfigFile});
+ my(@include) = ($passed_file || $C->{ConfigFile});
my $done_one;
my ($db, $dname, $nm);
my ($before, $after);
@@ -743,7 +721,7 @@
}
# Create closure that reads and sets config values
my $read = sub {
- my ($lvar, $value, $tie) = @_;
+ my ($lvar, $value, $tie, $var) = @_;
# parse variables in the value if necessary
if($C->{ParseVariables} and $value =~ /(?:__|\@\@)/) {
@@ -753,7 +731,7 @@
# call the parsing function for this directive
$parse = $parse{$lvar};
- $value = &$parse($CDname{$lvar}, $value) if defined $parse and ! $tie;
+ $value = $parse->($CDname{$lvar}, $value) if defined $parse and ! $tie;
# and set the $C->directive variable
if($tie) {
@@ -809,7 +787,7 @@
}
if(/^\s*${leadinghash}if(n?)def\s+(.*)/i) {
if(defined $ifdef) {
- config_error("Can't overlap ifdef at line $. of $configfile");
+ config_error("Can't overlap ifdef at line %s of %s", $., $configfile);
}
$ifdef = evaluate_ifdef($2,$1);
$begin_ifdef = $.;
@@ -831,98 +809,14 @@
unshift @include, grep -f $_, glob($spec);
next CONFIGLOOP;
}
- my $tie = undef;
- s/^\s*#.*//; # comments,
- s/\s+$//; # trailing spaces
- next if $_ eq '';
- $Vend::config_line = $_;
- # lines read from the config file become untainted
- m/^[ \t]*(\w+)\s+(.*)/ or config_error("Syntax error");
- $var = $1;
- $value = $2;
- $lvar = lc $var;
-#::logDebug("parsing directive=$var lvar=$lvar CDname=$CDname{$lvar} parse=$parse{$lvar}");
- my($codere) = '[-\w_#/.:]+';
-
- if ($value =~ /^(.*)<<(\w+)\s*/) { # "here" value
- my $begin = $1 || '';
- $begin .= "\n" if $begin;
- my $mark = $2;
- my $startline = $.;
- $value = $begin . read_here(\*CONFIG, $mark, $allcfg);
- unless (defined $value) {
- config_error (sprintf('%d: %s', $startline,
- qq#no end marker ("$mark") found#));
- }
- }
- elsif ($value =~ /^(.*)<&(\w+)\s*/) { # "here sub" value
- my $begin = $1 || '';
- $begin .= "\n" if $begin;
- my $mark = $2;
- my $startline = $.;
- $value = $begin . read_here(\*CONFIG, $mark, $allcfg);
- unless (defined $value) {
- config_error (sprintf('%d: %s', $startline,
- qq#no end marker ("$mark") found#));
- }
- eval {
- require Tie::Watch;
- };
- unless ($@) {
- $tie = 1;
- }
- else {
- config_warn errmsg(
- "No Tie::Watch module installed at %s, setting %s to default.",
- $startline,
- $var,
- );
- $value = '';
- }
- }
- elsif ($value =~ /^(\S+)?(\s*)?<\s*($codere)$/o) { # read from file
- $value = $1 || '';
- my $file = $3;
- $value .= "\n" if $value;
- unless (defined $C->{ConfigDir}) {
- config_error
- ("$CDname{$lvar}: Can't read from file until ConfigDir defined");
- }
- $file = $CDname{$lvar} unless $file;
- if($Global::NoAbsolute) {
- config_error(<<EOF) if Vend::Util::file_name_is_absolute($file);
-Absolute filenames not allowed if NoAbsolute set. Contact administrator.
-EOF
- config_error(
- "No leading ../.. allowed if NoAbsolute set. Contact administrator.\n")
- if $file =~ m#^\.\./.*\.\.#;
- config_error(
- "Symbolic links not allowed if NoAbsolute set. Contact administrator.\n")
- if -l $file;
- }
- $file = "$C->{ConfigDir}/$file"
- unless Vend::Util::file_name_is_absolute($file);
- $file = escape_chars($file); # make safe for filename
- my $tmpval = readfile($file);
- unless( defined $tmpval ) {
- config_warn errmsg(
- "%s: read from non-existent file %s, skipping.",
- $CDname{$lvar},
- $file,
- );
- next;
- }
- chomp($tmpval) unless $tmpval =~ m!.\n.!;
- # untaint
- $tmpval =~ /([\000-\377]*)/;
- $value .= $1;
- }
- # Now we can give an unknown error
- config_error("Unknown directive '$var'"), next unless defined $CDname{$lvar};
+ my ($lvar, $value, $var, $tie) =
+ read_config_value($_, \*CONFIG, $allcfg);
+
+ next unless $lvar;
# Use our closure defined above
- &$read($lvar, $value, $tie);
+ $read->($lvar, $value, $tie);
# If we have passed off configuration to a database we stop here...
last if $C->{ConfigDatabase}->{ACTIVE};
@@ -943,8 +837,12 @@
# set directive name
$status = Vend::Data::set_field($db, $recno, 'directive', $nm);
- config_error("ConfigDatabase failed for $dname, field 'directive'")
- unless defined $status;
+ defined $status
+ or config_error(
+ "ConfigDatabase failed for %s, field '%s'",
+ $dname,
+ 'directive',
+ );
# use extended value field if necessary or directed
if (length($value) > 250 or $UseExtended{$nm}) {
@@ -952,14 +850,22 @@
$extended =~ s/(\S+)\s*//;
$value = $1 || '';
$status = Vend::Data::set_field($db, $recno, 'extended', $extended);
- config_error("ConfigDatabase failed for $dname, field 'extended'")
- unless defined $status;
+ defined $status
+ or config_error(
+ "ConfigDatabase failed for %s, field '%s'",
+ $dname,
+ 'extended',
+ );
}
# set value -- just a name if extended was used
$status = Vend::Data::set_field($db, $recno, 'value', $value);
- config_error("Configdatabase failed for $dname, field 'value'")
- unless defined $status;
+ defined $status
+ or config_error(
+ "ConfigDatabase failed for %s, field '%s'",
+ $dname,
+ 'value',
+ );
$recno++;
}
@@ -994,7 +900,7 @@
}
if(defined $ifdef) {
- config_error("Failed to close #ifdef on line $begin_ifdef.");
+ config_error("Failed to close #ifdef on line %s.", $begin_ifdef);
}
} # end CONFIGLOOP
@@ -1014,13 +920,16 @@
my $msg = errmsg(
"Please specify the %s directive in the configuration file '%s'",
$CDname{$var},
- $catalogcfg,
+ $configfile,
);
die "$msg\n";
}
}
}
+
+ finalize_mapped_code();
+
# Ugly legacy stuff so API won't break
$C->{Special} = $C->{SpecialPage} if defined $C->{SpecialPage};
return $C;
@@ -1046,33 +955,171 @@
return $value;
}
+use File::Find;
+sub get_system_code {
+
+ return if $CodeDest;
+
+ # defined means don't go here anymore
+ $SystemCodeDone = '';
+ my %extmap = qw/
+ ia ItemAction
+ fa FormAction
+ am ActionMap
+ oc OrderCheck
+ ut UserTag
+ fi Filter
+ tag UserTag
+ ct CoreTag
+ /;
+
+ for( values %extmap ) {
+ $extmap{lc $_} = $_;
+ }
+
+ my @files;
+
+ my $wanted = sub {
+ return unless -f $_;
+ push @files, $File::Find::name;
+ };
+ File::Find::find($wanted, @$Global::TagDir);
+ for(@files) {
+ next if m{^\.};
+ next if m{/\.};
+ next unless m{\.(\w+)$};
+ my $ext = $1;
+ $CodeDest = $extmap{lc $ext} || 'UserTag';
+ open SYSTAG, "< $_"
+ or config_error("read system tag file %s: %s", $_, $!);
+ while(<SYSTAG>) {
+ my($lvar, $value) = read_config_value($_, \*SYSTAG);
+ next unless $lvar;
+ $GlobalRead->($lvar, $value);
+ }
+ }
+
+ undef $CodeDest;
+ # 1 means read system tag directories
+ $SystemCodeDone = 1;
+}
+
+sub read_config_value {
+ local($_) = shift;
+ return undef unless $_;
+ my ($fh, $allcfg) = @_;
+
+ my $lvar;
+ my $tie;
+
+ chomp; # zap trailing newline,
+ s/^\s*#.*//; # comments,
+ # mh 2/10/96 changed comment behavior
+ # to avoid zapping RGB values
+ #
+ s/\s+$//; # trailing spaces
+ return undef unless $_;
+
+ local($Vend::config_line);
+ $Vend::config_line = $_;
+ # lines read from the config file become untainted
+ m/^[ \t]*(\w+)\s+(.*)/ or config_error("Syntax error");
+ my $var = $1;
+ my $value = $2;
+ ($lvar = $var) =~ tr/A-Z/a-z/;
+
+ config_error("Unknown directive '%s'", $lvar), next
+ unless defined $CDname{$lvar};
+
+ my($codere) = '[-\w_#/.]+';
+
+ if ($value =~ /^(.*)<<(\w+)\s*/) { # "here" value
+ my $begin = $1 || '';
+ $begin .= "\n" if $begin;
+ my $mark = $2;
+ my $startline = $.;
+ $value = $begin . read_here($fh, $mark);
+ unless (defined $value) {
+ config_error (sprintf('%d: %s', $startline,
+ qq#no end marker ("$mark") found#));
+ }
+ }
+ elsif ($value =~ /^(.*)<&(\w+)\s*/) { # "here sub" value
+ my $begin = $1 || '';
+ $begin .= "\n" if $begin;
+ my $mark = $2;
+ my $startline = $.;
+ $value = $begin . read_here($fh, $mark, $allcfg);
+ unless (defined $value) {
+ config_error (sprintf('%d: %s', $startline,
+ qq#no end marker ("$mark") found#));
+ }
+ eval {
+ require Tie::Watch;
+ };
+ unless ($@) {
+ $tie = 1;
+ }
+ else {
+ config_warn(
+ "No Tie::Watch module installed at %s, setting %s to default.",
+ $startline,
+ $var,
+ );
+ $value = '';
+ }
+ }
+ elsif ($value =~ /^(\S+)?(\s*)?<\s*($codere)$/o) { # read from file
+ $value = $1 || '';
+ my $file = $3;
+ $value .= "\n" if $value;
+ unless (defined $Global::ConfigDir) {
+ config_error(
+ "%s: Can't read from file until ConfigDir defined",
+ $CDname{$lvar},
+ );
+ }
+ $file = $CDname{$lvar} unless $file;
+ $file = "$Global::ConfigDir/$file" unless $file =~ m!^/!;
+ $file = escape_chars($file); # make safe for filename
+ my $tmpval = readfile($file);
+ unless( defined $tmpval ) {
+ config_warn(
+ "%s: read from non-existent file %s, skipping.",
+ $CDname{$lvar},
+ $file,
+ );
+ return undef;
+ }
+ chomp($tmpval) unless $tmpval =~ m!.\n.!;
+ $value .= $tmpval;
+ }
+ return($lvar, $value, $var, $tie);
+}
+
# Parse the global configuration file for directives. Each directive sets
# the corresponding variable in the Global:: package. E.g.
# "DisplayErrors No" in the config file sets Global::DisplayErrors to 0.
# Directives which have no default value ("undef") must be specified
# in the config file.
-
sub global_config {
- my($directives, $d, %name, %parse, $var, $value, $lvar, $parse);
+ my(%parse, $var, $value, $lvar, $parse);
my($directive, $seen_catalog);
no strict 'refs';
- $directives = global_directives();
+ %CDname = ();
+
+ my $directives = global_directives();
$Global::Structure = {} unless $Global::Structure;
# Prevent parsers from thinking it is a catalog
undef $C;
- foreach $d (@$directives) {
+ foreach my $d (@$directives) {
($directive = $d->[0]) =~ tr/A-Z/a-z/;
- $name{$directive} = $d->[0];
- if (defined $d->[1]) {
- $parse = 'parse_' . $d->[1];
- }
- else {
- $parse = undef;
- }
+ $CDname{$directive} = $d->[0];
+ $parse = get_parse_routine($d->[1]);
$parse{$directive} = $parse;
undef $value;
$value = (
@@ -1082,19 +1129,19 @@
? $d->[2]
: $MV::Default{mv_global}{$d->[0]};
- if (defined $DumpSource{$name{$directive}}) {
- $Global::Structure->{ $name{$directive} } = $value;
+ if (defined $DumpSource{$CDname{$directive}}) {
+ $Global::Structure->{ $CDname{$directive} } = $value;
}
if (defined $parse and defined $value) {
- $value = &$parse($d->[0], $value);
+ $value = $parse->($d->[0], $value);
}
if(defined $value) {
- ${'Global::' . $name{$directive}} = $value;
+ ${'Global::' . $CDname{$directive}} = $value;
- $Global::Structure->{ $name{$directive} } = $value
- unless defined $DontDump{ $name{$directive} };
+ $Global::Structure->{ $CDname{$directive} } = $value
+ unless defined $DontDump{ $CDname{$directive} };
}
}
@@ -1104,27 +1151,28 @@
# Create closure for reading of value
my $read = sub {
- my ($lvar, $value) = @_;
- # Error out on extra parameters only if we know
- # we are not standalone
- unless (defined $name{$lvar}) {
- config_error("Unknown directive '$var'");
+ my ($lvar, $value, $tie) = @_;
+
+ unless (defined $CDname{$lvar}) {
+ config_error("Unknown directive '%s'", $var);
return;
}
- if (defined $DumpSource{$name{$directive}}) {
- $Global::Structure->{ $name{$directive} } = $value;
+ if (defined $DumpSource{$CDname{$directive}}) {
+ $Global::Structure->{ $CDname{$directive} } = $value;
}
# call the parsing function for this directive
$parse = $parse{$lvar};
- $value = &$parse($name{$lvar}, $value) if defined $parse;
+ $value = $parse->($CDname{$lvar}, $value) if defined $parse;
# and set the Global::directive variable
- ${'Global::' . $name{$lvar}} = $value;
- $Global::Structure->{ $name{$lvar} } = $value
- unless defined $DontDump{ $name{$lvar} };
+ ${'Global::' . $CDname{$lvar}} = $value;
+ $Global::Structure->{ $CDname{$lvar} } = $value
+ unless defined $DontDump{ $CDname{$lvar} };
};
+
+ $GlobalRead = $read;
my $done_one;
GLOBLOOP:
while ($configfile = shift @include) {
@@ -1164,7 +1212,11 @@
if(/^\s*${leadinghash}if(n?)def\s+(.*)/i) {
#print "found $_";
if(defined $ifdef) {
- config_error("Can't overlap ifdef at line $. of $configfile");
+ config_error(
+ "Can't overlap ifdef at line %s of %s",
+ $.,
+ $configfile,
+ );
}
$ifdef = evaluate_ifdef($2,$1,1);
$begin_ifdef = $.;
@@ -1184,57 +1236,10 @@
unshift @include, grep -f $_, glob($spec);
next GLOBLOOP;
}
- chomp; # zap trailing newline,
- s/^\s*#.*//; # comments,
- # mh 2/10/96 changed comment behavior
- # to avoid zapping RGB values
- #
- s/\s+$//; # trailing spaces
- next if $_ eq '';
- $Vend::config_line = $_;
- # lines read from the config file become untainted
- m/^[ \t]*(\w+)\s+(.*)/ or config_error("Syntax error");
- $var = $1;
- $value = $2;
- ($lvar = $var) =~ tr/A-Z/a-z/;
- my($codere) = '[-\w_#/.]+';
-
- if ($value =~ /^(.*)<<(\w+)\s*/) { # "here" value
- my $begin = $1 || '';
- $begin .= "\n" if $begin;
- my $mark = $2;
- my $startline = $.;
- $value = $begin . read_here(\*GLOBAL, $mark);
- unless (defined $value) {
- config_error (sprintf('%d: %s', $startline,
- qq#no end marker ("$mark") found#));
- }
- }
- elsif ($value =~ /^(\S+)?(\s*)?<\s*($codere)$/o) { # read from file
- $value = $1 || '';
- my $file = $3;
- $value .= "\n" if $value;
- unless (defined $Global::ConfigDir) {
- config_error
- ("$name{$lvar}: Can't read from file until ConfigDir defined");
- }
- $file = $name{$lvar} unless $file;
- $file = "$Global::ConfigDir/$file" unless $file =~ m!^/!;
- $file = escape_chars($file); # make safe for filename
- my $tmpval = readfile($file);
- unless( defined $tmpval ) {
- config_warn errmsg(
- "%s: read from non-existent file %s, skipping.",
- $name{$lvar},
- $file,
- );
- next;
- }
- chomp($tmpval) unless $tmpval =~ m!.\n.!;
- $value .= $tmpval;
- }
- &$read($lvar, $value);
+ my ($lvar, $value, $tie) = read_config_value($_, \*GLOBAL);
+ next unless $lvar;
+ $read->($lvar, $value, $tie);
}
close GLOBAL;
@@ -1245,10 +1250,10 @@
set_global_defaults();
# check for unspecified directives that don't have default values
- foreach $var (keys %name) {
+ foreach $var (keys %CDname) {
last if defined $Vend::ExternalProgram;
- if (!defined ${'Global::' . $name{$var}}) {
- die "Please specify the $name{$var} directive in the\n" .
+ if (!defined ${'Global::' . $CDname{$var}}) {
+ die "Please specify the $CDname{$var} directive in the\n" .
"configuration file '$Global::ConfigFile'\n";
}
}
@@ -1257,9 +1262,14 @@
ADDTAGS: {
Vend::Parse::global_init;
}
+ undef $GlobalRead;
+
+ finalize_mapped_code();
dump_structure($Global::Structure, "$Global::RunDir/$Global::ExeName")
if $Global::DumpStructure and ! $Vend::ExternalProgram;
+
+ %CDname = ();
return 1;
}
@@ -1306,20 +1316,23 @@
# Set up an ActionMap or FormAction
sub parse_action {
- my ($var, $value) = @_;
+ my ($var, $value, $mapped) = @_;
return {} if ! $value;
return if $Vend::ExternalProgram;
my $c;
- if(defined $C) {
+ if($mapped) {
+ $c = $mapped;
+ }
+ elsif(defined $C) {
$c = $C->{$var};
}
else {
no strict 'refs';
$c = ${"Global::$var"};
-
}
+
if (defined $C and ! $c->{_mvsafe}) {
my $calc = Vend::Interpolate::reset_calc();
$c->{_mvsafe} = $calc;
@@ -1335,7 +1348,7 @@
if defined $Global::GlobalSub->{$_};
return $c;
}
- elsif ( $sub !~ /^sub\b/) {
+ elsif ( ! $mapped and $sub !~ /^sub\b/) {
my $code = <<EOF;
sub {
return Vend::Interpolate::interpolate_html(<<EndOfThisHaiRYTHING);
@@ -1354,7 +1367,7 @@
$c->{$name} = $c->{_mvsafe}->reval($sub);
}
if($@) {
- config_warn(errmsg("Action '%s' did not compile correctly.", $name));
+ config_warn("Action '%s' did not compile correctly.", $name);
}
return $c;
@@ -1405,7 +1418,7 @@
}
}
else {
- config_warn(::errmsg('%s directive not parsable by AutoVariable', $name));
+ config_warn('%s directive not parsable by AutoVariable', $name);
}
}
}
@@ -1419,6 +1432,91 @@
return parse_require(@_, 1, 1);
}
+sub parse_tag_group {
+ my ($var, $setting) = @_;
+
+ my $c;
+ if(defined $C) {
+ $c = $C->{$var} || {};
+ }
+ else {
+ no strict 'refs';
+ $c = ${"Global::$var"} || {};
+ }
+
+ $setting =~ tr/-/_/;
+ $setting =~ s/[,\s]+/ /g;
+ $setting =~ s/^\s+//;
+ $setting =~ s/\s+$//;
+
+ my @pairs = Text::ParseWords::shellwords($setting);
+
+ while(@pairs) {
+ my ($group, $sets) = splice @pairs, 0, 2;
+ my @sets = grep $_, split /\s+/, $sets;
+ my @groups = grep /:/, @sets;
+ @sets = grep $_ !~ /:/, @sets;
+ for(@groups) {
+ next unless $c->{$_};
+ push @sets, @{$c->{$_}};
+ }
+ $c->{$group} = \@sets;
+ }
+ return $c;
+}
+
+my %incmap = qw/TagInclude TagGroup/;
+sub parse_tag_include {
+ my ($var, $setting) = @_;
+
+ my $c;
+ my $g;
+ my $mapper = $incmap{$var} || 'TagGroup';
+ if(defined $C) {
+ $c = $C->{$var} || {};
+ $g = $C->{$mapper} || {};
+ }
+ else {
+ no strict 'refs';
+ $c = ${"Global::$var"} || {};
+ $g = ${"Global::$mapper"} || {};
+ }
+
+ $setting =~ s/"/ /g;
+ $setting =~ s/^\s+//;
+ $setting =~ s/\s+$//;
+ $setting =~ s/[,\s]+/ /g;
+
+ my @incs = Text::ParseWords::shellwords($setting);
+
+ for(@incs) {
+ my @things;
+ my $not = 0;
+ if(/:/) {
+ $not = 1 if s/^!//;
+ if(! $g->{$_}) {
+ config_warn(
+ "unknown %s %s included from %s",
+ $mapper,
+ $_,
+ $var,
+ );
+ }
+ else {
+ @things = @{$g->{$_}}
+ }
+ }
+ else {
+ @things = ($_);
+ }
+ for(@things) {
+ my $not = s/^!// ? ! $not : $not;
+ $c->{$_} = not $not;
+ }
+ }
+ return $c;
+}
+
sub parse_suggest {
return parse_require(@_, 1);
}
@@ -1461,6 +1559,22 @@
$require = $C->{Sub};
$name = 'Sub';
}
+ elsif($val =~ s/^taggroup\s+//i) {
+ $require = $Global::UserTag->{Routine};
+ my @groups = grep /\S/, split /[\s,]+/, $val;
+ my @needed;
+ my $ref;
+ for (@groups) {
+ if($ref = $Global::TagGroup->{$_}) {
+ push @needed, @$ref;
+ }
+ else {
+ push @needed, $_;
+ }
+ }
+ $name = "TagGroup $val member";
+ $val = join " ", @needed;
+ }
elsif($val =~ s/^usertag\s+//i) {
$require = $Global::UserTag->{Routine};
$name = 'UserTag';
@@ -1501,8 +1615,8 @@
$vref->{"MV_REQUIRE_${uname}_$_"} = 1;
next if defined $require->{$_};
next if $testsub->($_);
- delete $vref->{"MV_REQUIRED_${uname}_$_"};
- $carptype->( ::errmsg($error_message, $name, $_) );
+ delete $vref->{"MV_REQUIRE_${uname}_$_"};
+ $carptype->( $error_message, $name, $_ );
}
return '';
}
@@ -1727,7 +1841,7 @@
my($sethash);
if ($eval) {
$sethash = $safe->reval($settings)
- or config_warn(errmsg("bad Locale setting in %s: %s", $name,$settings)),
+ or config_warn("bad Locale setting in %s: %s", $name,$settings),
$sethash = {};
}
else {
@@ -1796,7 +1910,7 @@
my(%setting) = grep /\S/, split /[\s,]+/, $settings;
for (keys %setting) {
if($Global::NoAbsolute and file_name_is_absolute($setting{$_}) ) {
- config_warn(errmsg("Absolute file name not allowed: %s", $setting{$_}));
+ config_warn("Absolute file name not allowed: %s", $setting{$_});
next;
}
$C->{$item}{$_} = $setting{$_};
@@ -1988,13 +2102,13 @@
}
elsif(length($val) > 1) {
config_error(
- errmsg("%s character value '%s' longer than one character.", $var, $val)
+ "%s character value '%s' longer than one character.",
+ $var,
+ $val,
);
}
elsif($val !~ /[&;:]/) {
- config_warn(
- errmsg("%s character value '%s' not a recommended value.", $var, $val)
- );
+ config_warn("%s character value '%s' not a recommended value.", $var, $val);
}
if($val eq '&') {
@@ -2105,12 +2219,18 @@
sub parse_root_dir_array {
my($var, $value) = @_;
return [] unless $value;
- $value = "$Global::VendRoot/$value"
- unless Vend::Util::file_name_is_absolute($value);
- $value =~ s./+$..;
+
no strict 'refs';
my $c = ${"Global::$var"} || [];
- push @$c, $value;
+
+ my @dirs = grep /\S/, Text::ParseWords::shellwords($value);
+
+ foreach my $dir (@dirs) {
+ $dir = "$Global::VendRoot/$dir"
+ unless Vend::Util::file_name_is_absolute($dir);
+ $dir =~ s./+$..;
+ push @$c, $dir;
+ }
return $c;
}
@@ -2496,13 +2616,13 @@
push @{$d->{$p}}, @v;
}
else {
- config_warn errmsg(
- "ConfigDatabase scalar parameter %s redefined to '%s', was %s.",
- $p,
- $val,
- $d->{$p},
- )
- if defined $d->{$p};
+ defined $d->{$p}
+ and config_warn(
+ "ConfigDatabase scalar parameter %s redefined to '%s', was %s.",
+ $p,
+ $val,
+ $d->{$p},
+ );
$d->{$p} = $val;
}
}
@@ -2643,20 +2763,21 @@
}
elsif ($p eq 'ALIAS') {
if (defined $c->{$val}) {
- config_warn("Database '$val' already exists, can't alias.");
+ config_warn("Database '%s' already exists, can't alias.", $val);
}
else {
$c->{$val} = $d;
}
}
else {
- config_warn errmsg(
- "ConfigDatabase scalar parameter %s redefined to '%s', was %s.",
- $p,
- $val,
- $d->{$p},
- )
- if defined $d->{$p};
+ defined $d->{$p}
+ and
+ config_warn(
+ "ConfigDatabase scalar parameter %s redefined to '%s', was %s.",
+ $p,
+ $val,
+ $d->{$p},
+ );
$d->{$p} = $val;
}
$d->{HOT} = 1 if $d->{Class} eq 'MEMORY';
@@ -2676,10 +2797,9 @@
parse_database('Database',"$table $file $type");
unless ($C->{Database}{$table}) {
config_warn(
- errmsg( "Bad $var value '%s': %s\n%s",
- "Database $table $file $type",
- ::uneval($C->{Database}),
- )
+ "Bad $var value '%s': %s\n%s",
+ "Database $table $file $type",
+ ::uneval($C->{Database}),
);
return '';
}
@@ -2692,17 +2812,13 @@
unless ($db = $C->{Database}{$table}) {
return if $Vend::ExternalProgram;
my $err = $@;
- config_warn(
- errmsg("Bad $var '%s': %s", $table, $err)
- );
+ config_warn("Bad $var '%s': %s", $table, $err);
return '';
}
$db = Vend::Data::import_database($db);
if(! $db) {
my $err = $@;
- config_warn(
- errmsg("Bad $var '%s': %s", $table, $err)
- );
+ config_warn("Bad $var '%s': %s", $table, $err);
return '';
}
return ($db, $table);
@@ -2940,6 +3056,16 @@
cannest canNest
documentation Documentation
endhtml endHTML
+ gobble Gobble
+
+ group Group
+ actionmap ActionMap
+ filter Filter
+ formaction FormAction
+ ordercheck OrderCheck
+ usertag UserTag
+ systemtag SystemTag
+
hasendtag hasEndTag
implicit Implicit
inserthtml insertHTML
@@ -2973,13 +3099,120 @@
canNest 1
isEndAnchor 1
addAttr 1
+ Filter 1
+ ItemAction 1
+ ActionMap 1
+ FormAction 1
+ OrderCheck 1
+ UserTag 1
isOperator 1
! );
+my %current_dest;
+my %valid_dest = qw/
+ filter Filter
+ itemaction ItemAction
+ actionmap ActionMap
+ formaction FormAction
+ ordercheck OrderCheck
+ coretag UserTag
+ usertag UserTag
+ /;
+
+sub finalize_mapped_code {
+ my $c = $C ? $C->{CodeDef} : $Global::CodeDef;
+ my $ref;
+ my $cfg;
+
+ if(! $C and my $ref = $c->{Filter}) {
+ next unless $ref = $ref->{Routine};
+ for(keys %$ref) {
+ $Vend::Interpolate::Filter{$_} = $ref->{$_};
+ }
+ }
+
+ if(! $C and $ref = $c->{OrderCheck} and $ref->{Routine}) {
+ $Vend::Order::OrderCheck = $ref->{Routine};
+ }
+
+ no strict 'refs';
+ for my $type (qw/ ActionMap FormAction ItemAction /) {
+ my $ref;
+ my $r;
+ next unless $r = $c->{$type};
+ next unless $ref = $r->{Routine};
+ my $cfg = $C
+ ? ($C->{$type} ||= {})
+ : (${"Global::$type"} ||= {})
+ ;
+ for(keys %$ref ) {
+ $cfg->{$_} = $ref->{$_};
+ }
+ }
+}
+
+sub parse_mapped_code {
+ my ($var, $value) = @_;
+
+ return '' if ! $value;
+
+ ## Can't give CodeDef a default or this will be premature
+ get_system_code() unless defined $SystemCodeDone;
+
+ my($tag,$p,$val) = split /\s+/, $value, 3;
+
+ # Canonicalize
+ $p = $tagCanon{lc $p};
+ $tag =~ tr/-/_/;
+ $tag =~ s/\W//g
+ and config_warn("Bad characters removed from '%s'.", $tag);
+
+ my $repos = $C ? ($C->{CodeDef} ||= {}) : ($Global::CodeDef ||= {});
+
+ my $dest = $valid_dest{lc $p} || $current_dest{$tag} || $CodeDest;
+
+ if(! $dest) {
+ config_warn("no destination for %s %s, skipping.", $var, $tag);
+ return $repos;
+ }
+ $current_dest{$tag} = $dest;
+ $repos->{$dest} ||= {};
+
+ my $c = $repos->{$dest};
+
+ if($p eq 'Routine') {
+ $c->{Routine} ||= {};
+ parse_action($var, "$tag $val", $c->{Routine});
+ }
+ elsif(defined $tagAry{$p}) {
+ my(@v) = Text::ParseWords::shellwords($val);
+ $c->{$p}{$tag} = [] unless defined $c->{$p}{$tag};
+ push @{$c->{$p}{$tag}}, @v;
+ }
+ elsif(defined $tagHash{$p}) {
+ my(%v) = Text::ParseWords::shellwords($val);
+ $c->{$p}{$tag} = {} unless defined $c->{$p}{$tag};
+ for (keys %v) {
+ $c->{$p}{$tag}{$_} = $v{$_};
+ }
+ }
+ elsif(defined $tagBool{$p}) {
+ $c->{$p}{$tag} = 1
+ unless defined $val and $val =~ /^[0nf]/i;
+ }
+ else {
+ config_warn("%s %s scalar parameter %s redefined.", $var, $tag, $p)
+ if defined $c->{$p}{$tag};
+ $c->{$p}{$tag} = $val;
+ }
+
+ return $repos;
+}
+
# Parses the user tags
sub parse_tag {
my ($var, $value) = @_;
- my ($c, $new);
+ my ($new);
return if $Vend::ExternalProgram;
@@ -2987,7 +3220,12 @@
return {};
}
- $c = defined $C ? $C->{UserTag} : $Global::UserTag;
+ return parse_mapped_code($var, $value)
+ if $var ne 'UserTag';
+
+ get_system_code() unless defined $SystemCodeDone;
+
+ my $c = defined $C ? $C->{UserTag} : $Global::UserTag;
my($tag,$p,$val) = split /\s+/, $value, 3;
@@ -2995,13 +3233,17 @@
$p = $tagCanon{lc $p};
$tag =~ tr/-/_/;
$tag =~ s/\W//g
- and config_warn("Bad characters removed from '$tag'.");
+ and config_warn("Bad characters removed from '%s'.", $tag);
unless ($p) {
- config_warn "Bad user tag parameter '$p' for '$tag', skipping.";
+ config_warn("Bad user tag parameter '%s' for '%s', skipping.", $p, $tag);
return $c;
}
+ if($CodeDest and $CodeDest eq 'CoreTag') {
+ return $c unless $Global::TagInclude->{$tag};
+ }
+
if($p eq 'Routine' or $p eq 'posRoutine') {
my $sub;
@@ -3016,11 +3258,9 @@
$sub = $safe->reval($code);
if($@) {
config_warn(
- errmsg(
"UserTag '%s' subroutine failed safe check: %s",
$tag,
$@,
- )
);
return $c;
}
@@ -3036,22 +3276,19 @@
}
if($@ or $fail) {
config_warn(
- errmsg(
"UserTag '%s' subroutine failed compilation:\n\n\t%s",
$tag,
"$fail $@",
- )
);
return $c;
}
else {
config_warn(
- errmsg(
"UserTag '%s' code is not a subroutine reference",
$tag,
- )
) unless ref($sub) =~ /CODE/;
}
+
$c->{$p}{$tag} = $sub;
$c->{Order}{$tag} = []
unless defined $c->{Order}{$tag};
@@ -3081,7 +3318,7 @@
unless defined $val and $val =~ /^[0nf]/i;
}
else {
- config_warn errmsg("UserTag %s scalar parameter %s redefined.", $tag, $p)
+ config_warn("UserTag %s scalar parameter %s redefined.", $tag, $p)
if defined $c->{$p}{$tag};
$c->{$p}{$tag} = $val;
}
@@ -3146,12 +3383,7 @@
my $alt = $2;
$name =~ s/\s+//;
$alt =~ s/\s+//;
- config_warn(
- errmsg(
- "%s %s: named also %s?",
- $var, $name, $alt,
- )
- );
+ config_warn("%s %s: named also %s?", $var, $name, $alt);
}
else {
@@ -3236,6 +3468,226 @@
}
$_;
}
+
+$StdTags = <<'EOF';
+ :core "
+ accessories
+ area
+ assign
+ attr_list
+ banner
+ calc
+ cart
+ catch
+ cgi
+ charge
+ checked
+ control
+ control_set
+ counter
+ currency
+ data
+ default
+ description
+ discount
+ dump
+ ecml
+ either
+ error
+ export
+ field
+ file
+ filter
+ flag
+ fly_list
+ fly_tax
+ handling
+ harness
+ html_table
+ import
+ include
+ index
+ input_filter
+ item_list
+ log
+ loop
+ mail
+ msg
+ mvasp
+ nitems
+ onfly
+ options
+ order
+ page
+ perl
+ price
+ process
+ profile
+ query
+ read_cookie
+ record
+ region
+ row
+ salestax
+ scratch
+ scratchd
+ search_region
+ selected
+ set
+ set_cookie
+ seti
+ setlocale
+ shipping
+ shipping_desc
+ soap
+ sql
+ strip
+ subtotal
+ tag
+ time
+ timed_build
+ tmp
+ total_cost
+ tree
+ try
+ update
+ userdb
+ value
+ value_extended
+ warnings
+ "
+ :base "
+ area
+ cgi
+ data
+ either
+ filter
+ flag
+ loop
+ page
+ query
+ scratch
+ scratchd
+ set
+ seti
+ tag
+ tmp
+ value
+ "
+ :commerce "
+ assign
+ cart
+ charge
+ currency
+ description
+ discount
+ ecml
+ error
+ field
+ fly_list
+ fly_tax
+ handling
+ item_list
+ nitems
+ onfly
+ options
+ order
+ price
+ salestax
+ shipping
+ shipping_desc
+ subtotal
+ total_cost
+ userdb
+ "
+ :data "
+ data
+ export
+ field
+ flag
+ import
+ index
+ query
+ record
+ sql
+ "
+ :form "
+ accessories
+ cgi
+ checked
+ error
+ flag
+ input_filter
+ msg
+ process
+ profile
+ selected
+ update
+ value_extended
+ warnings
+ "
+ :debug "
+ catch
+ dump
+ error
+ flag
+ harness
+ log
+ msg
+ tag
+ try
+ warnings
+ "
+ :file "
+ counter
+ file
+ include
+ log
+ value_extended
+ "
+ :http "
+ area
+ cgi
+ filter
+ input_filter
+ page
+ process
+ read_cookie
+ set_cookie
+ value_extended
+ "
+ :crufty "
+ banner
+ default
+ ecml
+ html_table
+ onfly
+ sql
+ "
+ :text "
+ row
+ strip
+ filter
+ "
+ :html "
+ accessories
+ checked
+ filter
+ html_table
+ process
+ "
+ :mail "
+ mail
+ "
+ :perl "
+ perl
+ calc
+ mvasp
+ "
+ :time "
+ time
+ "
+EOF
1;
2.44 +27 -996 interchange/lib/Vend/Interpolate.pm
rev 2.44, prev_rev 2.43
Index: Interpolate.pm
===================================================================
RCS file: /anon_cvs/repository/interchange/lib/Vend/Interpolate.pm,v
retrieving revision 2.43
retrieving revision 2.44
diff -u -r2.43 -r2.44
--- Interpolate.pm 25 Jan 2002 19:46:04 -0000 2.43
+++ Interpolate.pm 29 Jan 2002 05:52:43 -0000 2.44
@@ -1,6 +1,6 @@
# Vend::Interpolate - Interpret Interchange tags
#
-# $Id: Interpolate.pm,v 2.43 2002/01/25 19:46:04 jon Exp $
+# $Id: Interpolate.pm,v 2.44 2002/01/29 05:52:43 mheins Exp $
#
# Copyright (C) 1996-2001 Red Hat, Inc. <interchange@redhat.com>
#
@@ -27,7 +27,7 @@
require Exporter;
@ISA = qw(Exporter);
-$VERSION = substr(q$Revision: 2.43 $, 10);
+$VERSION = substr(q$Revision: 2.44 $, 10);
@EXPORT = qw (
@@ -645,11 +645,20 @@
return $parse->{OUT};
}
+my $Filters_initted;
+
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(! $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;
@@ -681,48 +690,6 @@
return $value;
}
-sub tag_record {
- my ($opt) = @_;
- my $db = $Vend::Database{$opt->{table}};
- return undef if ! $db;
- $db = $db->ref();
- # This can be called from Perl
- my (@cols, @vals);
- my $hash = $opt->{col};
- my $filter = $opt->{filter};
-
- return undef unless defined $opt->{key};
- my $key = $opt->{key};
- return undef unless ref $hash;
- undef $filter unless ref $filter;
- @cols = keys %$hash;
- @vals = values %$hash;
-
- RESOLVE: {
- my $i = -1;
- for(@cols) {
- $i++;
- if(! defined $db->test_column($_) ) {
- splice (@cols, $i, 1);
- my $tmp = splice (@vals, $i, 1);
- ::logError("bad field %s in record update, value=%s", $_, $tmp);
- redo RESOLVE;
- }
- next unless defined $filter->{$_};
- $vals[$i] = filter_value($filter->{$_}, $vals[$i], $_);
- }
- }
-
- my $status;
- eval {
- my $status = $db->set_slice($key, \@cols, \@vals);
- };
- if($@) {
- return $@ if $opt->{show_error};
- }
- return $status;
-}
-
sub try {
my ($label, $opt, $body) = @_;
$label = 'default' unless $label;
@@ -754,55 +721,8 @@
return $out;
}
-sub catch {
- my ($label, $opt, $body) = @_;
- $label = 'default' unless $label;
- my $patt;
- return pull_else($body)
- unless $patt = $Vend::Session->{try}{$label};
-
- $body = pull_if($body);
-
- if ( $opt->{exact} ) {
- #----------------------------------------------------------------
- # Convert multiple errors to 'or' list and compile it.
- # Note also the " at (eval ...)" kludge to strip the line numbers
- $patt =~ s/(?: +at +\(eval .+\).+)?\n\s*/|/g;
- $patt =~ s/^\s*//;
- $patt =~ s/\|$//;
- $patt = qr($patt);
- #----------------------------------------------------------------
- }
-
- my $found;
- while ($body =~ s{
- \[/
- (.+?)
- /\]
- (.*?)
- \[/
- (?:\1)?/?
- \]}{}sx ) {
- my $re;
- my $error = $2;
- eval {
- $re = qr{$1}
- };
- next if $@;
- next unless $patt =~ $re;
- $found = $error;
- last;
- }
- $body = $found if $found;
-
- $body =~ s/\s+$//;
- $body =~ s/^\s+//;
- return $body;
-}
-
-
# Returns the text of a configurable database field or a
-# variable
+# session variable
sub tag_data {
my($selector,$field,$key,$opt,$flag) = @_;
$CacheInvalid = 1 if defined $Vend::Cfg->{DynamicData}->{$selector};
@@ -914,8 +834,8 @@
%Filter = (
- 'value' => sub { $::Values->{$_[0]} },
- 'cgi' => sub { $CGI::values{$_[0]} },
+ 'value' => sub { return $::Values->{$_[0]}; },
+ 'cgi' => sub { return $CGI::values{$_[0]}; },
'filesafe' => sub {
return Vend::Util::escape_chars(shift);
},
@@ -1063,10 +983,6 @@
my @items = split /\r?\n/, shift;
return join "\t", @items;
},
- 'lc' => sub {
- use locale;
- return lc(shift);
- },
'digits_dot' => sub {
my $val = shift;
$val =~ s/[^\d.]+//g;
@@ -1978,14 +1894,6 @@
return $opt->{success};
}
-sub tag_price {
- my($code,$ref) = @_;
- my $amount = Vend::Data::item_price($ref,$ref->{quantity} || 1);
- $amount = discount_price($ref,$amount, $ref->{quantity})
- if $ref->{discount};
- return currency( $amount, $ref->{noformat} );
-}
-
sub tag_options {
my ($sku, $opt) = @_;
my $item;
@@ -2178,16 +2086,16 @@
$sku,
'',
{
- passed => join(",", @out),
- type => $opt->{type} || $ref->[8] || 'select',
attribute => 'code',
- name => 'mv_sku',
- price_data => $price,
- price => $opt->{price},
- item => $item,
+ default => undef,
extra => $opt->{extra},
+ item => $item,
js => $opt->{js},
- default => undef,
+ name => 'mv_sku',
+ passed => join(",", @out),
+ price => $opt->{price},
+ price_data => $price,
+ type => $opt->{type} || $ref->[8] || 'select',
},
$item || undef,
);
@@ -2221,15 +2129,15 @@
$sku,
'',
{
- passed => $ref->[3],
- type => $opt->{type} || $ref->[5] || 'select',
attribute => $ref->[2],
- price_data => $ref->[6],
- price => $opt->{price},
- item => $item,
+ default => undef,
extra => $opt->{extra},
+ item => $item,
js => $opt->{js},
- default => undef,
+ passed => $ref->[3],
+ price => $opt->{price},
+ price_data => $ref->[6],
+ type => $opt->{type} || $ref->[5] || 'select',
},
$item || undef,
);
@@ -3397,80 +3305,6 @@
return ($opt->{success} || $ok);
}
-sub tag_weighted_banner {
- my ($category, $opt) = @_;
- my $dir = catfile($Vend::Cfg->{ScratchDir}, 'Banners');
- mkdir $dir, 0777 if ! -d $dir;
- if($category) {
- my $c = $category;
- $c =~ s/\W//g;
- $dir .= "/$c";
- }
-#::logDebug("banner category=$category dir=$dir");
- my $statfile = $Vend::Cfg->{ConfDir};
- $statfile .= "/status.$Vend::Cat";
-#::logDebug("banner category=$category dir=$dir statfile=$statfile");
- my $start_time;
- if($opt->{once}) {
- $start_time = 0;
- }
- elsif(! -f $statfile) {
- Vend::Util::writefile( $statfile, "banners initialized " . time() . "\n");
- $start_time = time();
- }
- else {
- $start_time = (stat(_))[9];
- }
- my $weight_file = "$dir/total_weight";
-#::logDebug("banner category=$category dir=$dir statfile=$statfile wfile=$weight_file");
- initialize_banner_directory($dir, $category, $opt)
- if (
- ! -f $weight_file
- or
- (stat(_))[9] < $start_time
- );
- my $n = int( rand( readfile($weight_file) ) );
-#::logDebug("weight total n=$n, file=$dir/$n");
- return Vend::Util::readfile("$dir/$n");
-}
-
-sub tag_banner {
- my ($place, $opt) = @_;
-
- return tag_weighted_banner($place, $opt) if $opt->{weighted};
-
-#::logDebug("banner, place=$place opt=" . ::uneval_it($opt));
- my $table = $opt->{table} || 'banner';
- my $r_field = $opt->{r_field} || 'rotate';
- my $b_field = $opt->{b_field} || 'banner';
- my $sep = $opt->{separator} || ':';
- my $delim = $opt->{delimiter} || "{or}";
- $place = 'default' if ! $place;
- my $totrot;
- do {
- my $banner_data;
- $totrot = tag_data($table, $r_field, $place);
- if(! length $totrot) {
- # No banner present
- unless ($place =~ /$sep/ or $place eq 'default') {
- $place = 'default';
- redo;
- }
- }
- elsif ($totrot) {
- my $current = $::Scratch->{"rotate_$place"}++ || 0;
- my $data = tag_data($table, $b_field, $place);
- my(@banners) = split /\Q$delim/, $data;
- return '' unless @banners;
- return $banners[$current % scalar(@banners)];
- }
- else {
- return tag_data($table, $b_field, $place);
- }
- } while $place =~ s/(.*)$sep.*/$1/;
- return;
-}
-
# Returns the text of a user entered field named VAR.
sub tag_value {
my($var,$opt) = @_;
@@ -3497,40 +3331,6 @@
return $value;
}
-# Returns the contents of a file. Won't allow any arbitrary file unless
-# NoAbsolute is not set.
-sub tag_file {
- my ($file, $type) = @_;
- return readfile($file, $Global::NoAbsolute)
- unless $type;
- return readfile($file, $Global::NoAbsolute, 0)
- if $type eq 'raw';
- my $text = readfile($file, $Global::NoAbsolute);
- if($type =~ /mac/i) {
- $text =~ tr/\n/\r/;
- }
- elsif($type =~ /dos|window/i) {
- $text =~ s/\n/\r\n/g;
- }
- elsif($type =~ /unix/i) {
- if($text=~ /\n/) {
- $text =~ tr/\r/\n/;
- }
- else {
- $text =~ s/\r\n/\n/g;
- }
- }
- return $text;
-}
-
-# Returns the text of a user entered field named VAR.
-# Same as tag value except returns 'default' if not present
-sub tag_default {
- my($var, $default, $opt) = @_;
- $opt->{default} = !(length $default) ? 'default' : $default;
- return tag_value($var, $opt);
-}
-
sub esc {
my $string = shift;
$string =~ s!(\W)!'%' . sprintf '%02x', ord($1)!eg;
@@ -3743,18 +3543,6 @@
$Vend::Cfg->{Shipping_desc}->{$mode};
}
-# Returns the href to process the completed order form or do the search.
-
-sub tag_process {
- my($target,$secure,$opt) = @_;
-
- $secure = defined $secure ? $secure : $CGI::secure;
-
- my $url = $secure ? secure_vendUrl('process') : vendUrl('process');
- return $url unless $target;
- return qq{$url" TARGET="$target};
-}
-
sub tag_calc {
my($body) = @_;
my $result;
@@ -5213,168 +5001,6 @@
return undef;
}
-sub tag_tree {
- my($table, $parent, $sub, $start_item, $opt, $text) = @_;
-
-#::logDebug("tree-list: received parent=$parent sub=$sub start=$start_item");
-
- my $db = ::database_exists_ref($table)
- or return error_opt($opt, "Database %s doesn't exist", $table);
- $db->column_exists($parent)
- or return error_opt($opt, "Parent column %s doesn't exist", $parent);
- $db->column_exists($sub)
- or return error_opt($opt, "Subordinate column %s doesn't exist", $sub);
-
- my $qkey = $db->quote($start_item, $parent);
-
- my @outline = (1);
- if(defined $opt->{outline}) {
- $opt->{outline} =~ s/[^a-zA-Z0-9]+//g;
- @outline = split //, $opt->{outline};
- @outline = (qw/1 A 1 a 1 a/) if scalar @outline < 2;
- }
-
- my $mult = ( int($opt->{spacing}) || 10 );
- my $keyfield = $db->config('KEY');
- $opt->{code_field} = $keyfield if ! $opt->{code_field};
-
- my $sort = '';
- if($opt->{sort}) {
- $sort .= ' ORDER BY ';
- my @sort;
- @sort = ref $opt->{sort}
- ? @{$opt->{sort}}
- : ( $opt->{sort} );
- for(@sort) {
- s/\s*[=:]\s*([rnxf]).*//;
- $_ .= " DESC" if $1 eq 'r';
- }
- $sort .= join ", ", @sort;
- undef $opt->{sort};
- }
-
- my $qb = "select * from $table where $parent = $qkey$sort";
- my $ary = $db->query( {
- hashref => 1,
- sql => $qb,
- });
-
- my $memo;
- if( $opt->{memo} ) {
- $memo = ($::Scratch->{$opt->{memo}} ||= {});
- my $toggle;
- if($opt->{toggle} and $toggle = $CGI::values{$opt->{toggle}}) {
- $memo->{$toggle} = ! $memo->{$toggle};
- }
- }
-
- if($opt->{collapse} and $CGI::values{$opt->{collapse}}) {
- $memo = {};
- delete $::Scratch->{$opt->{memo}} if $opt->{memo};
- }
-
- my $explode;
- if($opt->{full} or $opt->{explode} and $CGI::values{$opt->{explode}}) {
- $explode = 1;
- }
-
- my $enable;
-
-
- $memo = {} if ! $memo;
-
- my $stop_sub;
-
-#::logDebug("tree-list: valid parent=$parent sub=$sub start=$start_item mult=$mult");
-
- my @ary_stack = ( $ary ); # Stacks the rows
- my @above_stack = { $start_item => 1 }; # Holds the previous levels
- my @inc_stack = ($outline[0]); # Holds the increment characters
- my @rows;
- my $row;
-
- ARY: for (;;) {
-#::logDebug("next ary");
- my $ary = pop(@ary_stack)
- or last ARY;
- my $above = pop(@above_stack);
- my $level = scalar(@ary_stack);
- my $increment = pop(@inc_stack);
- ROW: for(;;) {
-#::logDebug("next row level=$level increment=$increment");
- my $prev = $row;
- $row = shift @$ary
- or ($prev and $prev->{mv_last} = 1), last ROW;
- $row->{mv_level} = $level;
- $row->{mv_spacing} = $level * $mult;
- $row->{mv_spacer} = $opt->{spacer} x $row->{mv_spacing}
- if $opt->{spacer};
- $row->{mv_increment} = $increment++;
- push(@rows, $row);
- my $code = $row->{$keyfield};
- $row->{mv_toggled} = 1 if $memo->{$code};
-#::logDebug("next row sub=$sub=$row->{$sub}");
- my $next = $row->{$sub}
- or next ROW;
-
- my $stop;
- $row->{mv_children} = 1
- if ($opt->{stop} and ! $row->{ $opt->{stop} } )
- or ($opt->{continue} and $row->{ $opt->{continue} })
- or ($opt->{autodetect});
-
- $stop = 1 if ! $explode and ! $memo->{$code};
-#::logDebug("next row sub=$sub=$next stop=$stop explode=$explode memo=$memo->{$code}");
-
- if($above->{$next} and ($opt->{autodetect} or ! $stop) ) {
- my $fmt = <<EOF;
-Endless tree detected at key %s in table %s.
-Parent %s, would traverse to %s.
-EOF
- my $msg = ::errmsg($fmt, $code, $table, $row->{$parent}, $next);
- if(! $opt->{pedantic}) {
- error_opt($opt, $msg);
- next ROW;
- }
- else {
- $opt->{log_error} = 1 unless $opt->{show_error};
- return error_opt($opt, $msg);
- }
- }
-
- my $a;
- if ($opt->{autodetect} or ! $stop) {
- my $key = $db->quote($next, $parent);
- my $q = "SELECT * FROM $table WHERE $parent = $key$sort";
-#::logDebug("next row query=$q");
- $a = $db->query(
- {
- hashref => 1,
- sql => $q,
- }
- );
- $above->{$next} = 1 if $a and scalar @{$a};
- }
-
- if($opt->{autodetect}) {
- $row->{mv_children} = $a ? scalar(@$a) : 0;
- }
-
- if (! $stop) {
- push(@ary_stack, $ary);
- push(@above_stack, $above);
- push(@inc_stack, $increment);
- $level++;
- $increment = defined $outline[$level] ? $outline[$level] : 1;
- $ary = $a;
- }
- } # END ROW
-#::logDebug("last row");
- } # END ARY
-#::logDebug("last ary, results =" . ::uneval(\@rows));
- return labeled_list($opt, $text, {mv_results => \@rows});
-}
-
sub query {
if(ref $_[0]) {
unshift @_, '';
@@ -5401,23 +5027,6 @@
$db->query($opt, $text);
}
-sub tag_item_list {
- my($cart,$opt,$text) = @_;
-#::logDebug("tag_item_list: " . ::uneval(\@_));
- my $obj = {
- mv_results => $cart ? ($::Carts->{$cart} ||= [] ) : $Vend::Items,
- };
- return if ! $text;
-#::logDebug("tag_item_list obj=" . ::uneval($obj));
-#::logDebug("Vend::Items obj=" . ::uneval($Vend::Items));
- $CacheInvalid = 1;
- $opt->{prefix} = 'item' unless defined $opt->{prefix};
-# LEGACY
- list_compat($opt->{prefix}, \$text);
-# END LEGACY
- return labeled_list($opt, $text, $obj);
-}
-
sub html_table {
my($opt, $ary, $na) = @_;
@@ -6273,117 +5882,6 @@
*custom_shipping = \&shipping;
-# Returns 'SELECTED' when a value is present on the form
-# Must match exactly, but NOT case-sensitive
-
-sub tag_selected {
- my ($field,$value,$opt) = @_;
- $value = '' unless defined $value;
- my $ref = $opt->{cgi} ? $CGI::values{$field} : $::Values->{$field};
- return ' SELECTED' if ! length($ref) and $opt->{default};
-
- if(! $opt->{case}) {
- $ref = lc($ref);
- $value = lc($value);
- }
-
- my $r = '';
-
- return ' SELECTED' if $ref eq $value;
- if ($opt->{multiple}) {
- my $regex = quotemeta $value;
- return ' SELECTED' if $ref =~ /(?:^|\0)$regex(?:$|\0)/i;
- }
-
- return '';
-}
-
-sub tag_checked {
- my ($field,$value,$opt) = @_;
-
- $value = 'on' unless defined $value;
-
- my $ref = $opt->{cgi} ? $CGI::values{$field} : $::Values->{$field};
- return 'CHECKED' if ! length($ref) and $opt->{default};
-
- if(! $opt->{case}) {
- $ref = lc($ref);
- $value = lc($value);
- }
-
- return 'CHECKED' if $ref eq $value;
-
- if ($opt->{multiple}) {
- my $regex = quotemeta $value;
- return 'CHECKED' if $ref =~ /(?:^|\0)$regex(?:$|\0)/i;
- }
-
- return '';
-}
-
-# Returns an href to place an order for the product PRODUCT_CODE.
-# If AlwaysSecure is set, goes by the page accessed, otherwise
-# if a secure order has been started (with a call to at least
-# one secure_vendUrl), then it will be given the secure URL
-
-sub tag_order {
- my($code,$quantity,$opt) = @_;
- $opt = {} unless $opt;
- my($r);
- my @parms = (
- "mv_action=refresh",
- );
-
- push(@parms, "mv_order_item=$code");
- push(@parms, "mv_order_mv_ib=$opt->{base}")
- if($opt->{base});
-
- push(@parms, "mv_cartname=$opt->{cart}")
- if($opt->{cart});
-
- push(@parms, "mv_order_quantity=$quantity")
- if($quantity);
-
- $opt->{form} = join "\n", @parms;
-
- $opt->{page} = find_special_page('order')
- unless $opt->{page};
-
- return form_link($opt->{area}, $opt->{arg}, $opt)
- if $opt->{area};
- return tag_page($opt->{page}, $opt->{arg}, $opt);
-}
-
-# Sets the value of a discount field
-sub tag_discount {
- my($code, $opt, $value) = @_;
-
- # API compatibility
- if(! ref $opt) {
- $value = $opt;
- $opt = {};
- }
-
- if($opt->{subtract}) {
- $value = <<EOF;
-my \$tmp = \$s - $opt->{subtract};
-\$tmp = 0 if \$tmp < 0;
-return \$tmp;
-EOF
- }
- elsif ($opt->{level}) {
- $value = <<EOF;
-return (\$s * \$q) if \$q < $opt->{level};
-my \$tmp = \$s / \$q;
-return \$s - \$tmp;
-EOF
- }
- $Vend::Session->{discount}{$code} = $value;
- delete $Vend::Session->{discount}->{$code}
- unless (defined $value and $value);
- return '';
-}
-
# Sets the value of a scratchpad field
sub set_scratch {
my($var,$val) = @_;
@@ -6399,68 +5897,6 @@
return '';
}
-# Returns the value of a control field named VAR.
-sub tag_control {
- my ($name, $default, $opt) = @_;
-
- if(! $name) {
- # Here we either reset the index or increment it
- # Done this way for speed, no blocks to enter other than top one
- if($opt->{space}) {
- $::Control = $Tmp->{$opt->{space}} ||= [];
- return set_tmp('control_index', 0);
- }
- else {
- ($::Scratch->{control_index} = 0, return) if $opt->{reset};
- return set_tmp('control_index', ++$::Scratch->{control_index});
- }
- }
-
- $name = lc $name;
- $name =~ s/-/_/g;
- $opt ||= {};
- if (! defined $default and $opt->{set}) {
- $::Control->[$::Scratch->{control_index}]{$name} = $::Scratch->{$name};
- return;
- }
-
- return defined $::Control->[$::Scratch->{control_index}]{$name}
- ? ( $::Control->[$::Scratch->{control_index}]{$name} || $default )
- : ( length($::Scratch->{$name}) ? ($::Scratch->{$name}) : $default )
-}
-
-# Batch sets a set of controls without affecting Scratch
-# Increments the index afterwards unless index is defined
-sub tag_control_set {
- my ($index, $opt, $body) = @_;
-
- my $inc;
- unless($index) {
- $index = $::Scratch->{control_index} || 0;
- $inc = 1;
- }
-
- while($body =~ m{\[([-\w]+)\](.*)\[/\1\]}sg) {
- my $name = lc $1;
- my $val = $2;
- $name =~ s/-/_/g;
- $::Control->[$index]{$name} = $val;
- }
- $::Scratch->{control_index}++;
- return;
-}
-
-sub tag_scratchd {
- my $var = shift;
- return delete $::Scratch->{$var};
-}
-
-# Returns the value of a scratchpad field named VAR.
-sub tag_scratch {
- my $var = shift;
- return $::Scratch->{$var};
-}
-
sub tag_lookup {
my($selector,$field,$key,$rest) = @_;
return $rest if (defined $rest and $rest);
@@ -6613,22 +6049,6 @@
my $Ship_its = 0;
-sub set_error {
- my ($error, $var, $opt) = @_;
- $var = 'default' unless $var;
- $opt = { keep => 1 } if ! $opt;
- my $ref = $Vend::Session->{errors};
- if($ref->{$var} and ! $opt->{overwrite}) {
- $ref->{$var} .= errmsg(" AND ");
- }
- else {
- $ref->{$var} = '';
- }
-
- $ref->{$var} .= $error;
- return tag_error($var, $opt);
-}
-
sub push_warning {
$Vend::Session->{warnings} = [$Vend::Session->{warnings}]
if ! ref $Vend::Session->{warnings};
@@ -6636,381 +6056,6 @@
return;
}
-sub tag_warnings {
- my($message, $opt) = @_;
-
- if($message) {
- my $param = ref $opt->{param} ? $opt->{param} : [$opt->{param}];
- push_warning($opt->{message}, @$param);
- return unless $opt->{show};
- }
-
- return unless $Vend::Session->{warnings};
-
- my $out = $opt->{header} || "";
- $out .= '<ul><li>' if $opt->{auto};
- if(! length($opt->{joiner})) {
- $opt->{joiner} = $opt->{auto} ? '<li>' : "\n";
- }
- $out .= join $opt->{joiner}, @{$Vend::Session->{warnings}};
- $out .= '</ul>' if $opt->{auto};
- $out .= $opt->{footer} if length($opt->{footer});
- delete $Vend::Session->{warnings} unless $opt->{keep};
- return $out;
-}
-
-sub tag_error {
- my($var, $opt) = @_;
- $Vend::Session->{errors} = {}
- unless defined $Vend::Session->{errors};
- if($opt->{set}) {
- $opt->{keep} = 1 unless defined $opt->{keep};
- my $error = delete $opt->{set};
- return set_error($error, $var, $opt);
- }
- my $err_ref = $Vend::Session->{errors};
- my $text;
- $text = $opt->{text} if $opt->{text};
- my @errors;
- my $found_error = '';
-#::logDebug("tag_error: var=$var text=$text opt=" . ::uneval($opt));
-#::logDebug("tag_error: var=$var text=$text");
- if($opt->{all}) {
- $opt->{joiner} = "\n" unless defined $opt->{joiner};
- for(sort keys %$err_ref) {
- my $err = $err_ref->{$_};
- delete $err_ref->{$_} unless $opt->{keep};
- next unless $err;
- $found_error++;
- my $string = '';
- if ($opt->{show_label}) {
- if ($string = $Vend::Session->{errorlabels}{$_}) {
- $string =~ s/[:\s]+$//;
- $string .= " ($_)" if $opt->{show_var};
- $string .= ": ";
- } else {
- $string .= "($_): ";
- }
- } else {
- $string .= "$_: " if $opt->{show_var};
- }
- $string .= $err;
- push @errors, $string;
- }
-#::logDebug("error all=1 found=$found_error contents='@errors'");
- return $found_error unless $text || $opt->{show_error};
- $text .= "%s" if $text !~ /\%s/;
- $text = pull_else($text, $found_error);
- return sprintf $text, join($opt->{joiner}, @errors);
- }
- $found_error = ! (not $err_ref->{$var});
- my $err = $err_ref->{$var} || '';
- delete $err_ref->{$var} unless $opt->{keep};
-#::logDebug("error found=$found_error contents='$err'");
- return !(not $found_error)
- unless $opt->{std_label} || $text || $opt->{show_error};
- if($opt->{std_label}) {
- # store the error label in user's session for later
- # possible use in [error show_label=1] calls
- $Vend::Session->{errorlabels}{$var} = $opt->{std_label};
- if($text) {
- }
- elsif(defined $::Variable->{MV_ERROR_STD_LABEL}) {
- $text = $::Variable->{MV_ERROR_STD_LABEL};
- }
- else {
- $text = <<EOF;
-<FONT COLOR=RED>{LABEL} <SMALL><I>(%s)</I></SMALL></FONT>
-[else]{REQUIRED <B>}{LABEL}{REQUIRED </B>}[/else]
-EOF
- }
- $text =~ s/{LABEL}/$opt->{std_label}/g;
- $text =~ s/{REQUIRED\s+([^}]*)}/$opt->{required} ? $1 : ''/ge;
- $err =~ s/\s+$//;
- }
- $text = '' unless defined $text;
- $text .= '%s' unless $text =~ /\%s/;
- $text = pull_else($text, $found_error);
- return sprintf($text, $err);
-}
-
-sub tag_msg {
- my ($key, $opt, $body) = @_;
- my (@args, $message, $out, $startlocale);
-
- unless ($opt->{raw}) {
- if (ref $opt->{arg} eq 'ARRAY') {
- @args = @{ $opt->{arg} };
- } elsif (ref $opt->{arg} eq 'HASH') {
- @args = map { $opt->{arg}->{$_} } sort keys %{ $opt->{arg} };
- } elsif (! ref $opt->{arg}) {
- @args = $opt->{arg};
- }
- }
-
- if ($opt->{locale}) {
- # we only mess with scratch mv_locale because
- # Vend::Util::find_locale_bit uses it to determine current locale
- $startlocale = $::Scratch->{mv_locale};
- Vend::Util::setlocale($opt->{locale}, undef, { persist => 1 });
- }
-
- if ($opt->{inline}) {
- $message = Vend::Util::find_locale_bit($body);
- } else {
- $message = $body;
- }
-
- if ($key) {
- if ($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$key}) {
- $message = $Vend::Cfg->{Locale}{$key};
- } elsif ($Global::Locale and defined $Global::Locale->{$key}) {
- $message = $Global::Locale->{$key};
- }
- }
-
- if ($opt->{raw}) {
- $out = $message;
- } else {
- $out = errmsg($message, @args);
- }
-
- if ($opt->{locale}) {
- $::Scratch->{mv_locale} = $startlocale;
- Vend::Util::setlocale();
- }
-
- return $out;
-}
-
-sub tag_column {
- my($spec,$text) = @_;
- my($append,$f,$i,$line,$usable);
- my(%def) = qw(
- width 0
- spacing 1
- gutter 2
- wrap 1
- html 0
- align left
- );
- my(%spec) = ();
- my(@out) = ();
- my(@lines) = ();
-
- $spec =~ s/\n/ /g;
- $spec =~ s/^\s+//;
- $spec =~ s/\s+$//;
- $spec = lc $spec;
-
- $spec =~ s/\s*=\s*/=/;
- $spec =~ s/^(\d+)/width=$1/;
- %spec = split /[\s=]+/, $spec;
-
- for(keys %def) {
- $spec{$_} = $def{$_} unless defined $spec{$_};
- }
-
- if($spec{'html'} && $spec{'wrap'}) {
- ::logError("tag_column: can't have 'wrap' and 'html' specified at same time.");
- $spec{wrap} = 0;
- }
-
- if(! $spec{align} or $spec{align} !~ /^n/i) {
- $text =~ s/\s+/ /g;
- }
-
- my $len = sub {
- my($txt) = @_;
- if (1 or $spec{html}) {
- $txt =~
- s{ <
- (
- [^>'"] +
- |
- ".*?"
- |
- '.*?'
- ) +
- >
- }{}gsx;
- }
- return length($txt);
- };
-
- $usable = $spec{'width'} - $spec{'gutter'};
- return "BAD_WIDTH" if $usable < 1;
-
- if($spec{'align'} =~ /^[ln]/i) {
- $f = sub {
- $_[0] .
- ' ' x ($usable - $len->($_[0])) .
- ' ' x $spec{'gutter'};
- };
- }
- elsif($spec{'align'} =~ /^r/i) {
- $f = sub {
- ' ' x ($usable - $len->($_[0])) .
- $_[0] .
- ' ' x $spec{'gutter'};
- };
- }
- elsif($spec{'align'} =~ /^i/i) {
- $spec{'wrap'} = 0;
- $usable = 9999;
- $f = sub { @_ };
- }
- else {
- return "BAD JUSTIFICATION SPECIFICATION: $spec{'align'}";
- }
-
- $append = '';
- if($spec{'spacing'} > 1) {
- $append .= "\n" x ($spec{'spacing'} - 1);
- }
-
- if($spec{'align'} =~ /^n/i) {
- @lines = split(/\r?\n/, $text);
- }
- elsif(is_yes($spec{'wrap'}) and length($text) > $usable) {
- @lines = wrap($text,$usable);
- }
- elsif($spec{'align'} =~ /^i/i) {
- $lines[0] = ' ' x $spec{'width'};
- $lines[1] = $text . ' ' x $spec{'gutter'};
- }
- elsif (! $spec{'html'}) {
- $lines[0] = substr($text,0,$usable);
- }
-
- foreach $line (@lines) {
- push @out , &{$f}($line);
- for($i = 1; $i < $spec{'spacing'}; $i++) {
- push @out, '';
- }
- }
- @out;
-}
-
-sub wrap {
- my ($str, $width) = @_;
- my @a = ();
- my ($l, $b);
-
- for (;;) {
- $str =~ s/^ +//;
- $l = length($str);
- last if $l == 0;
- if ($l <= $width) {
- push @a, $str;
- last;
- }
- $b = rindex($str, " ", $width - 1);
- if ($b == -1) {
- push @a, substr($str, 0, $width);
- $str = substr($str, $width);
- }
- else {
- push @a, substr($str, 0, $b);
- $str = substr($str, $b + 1);
- }
- }
- return @a;
-}
-
-sub tag_row {
- my($width,$text) = @_;
- my($col,$spec);
- my(@lines);
- my(@len);
- my(@out);
- my($i,$j,$k);
- my($x,$y,$line);
-
- $i = 0;
- #while( $text =~ s!$QR{col}!! ) {
- while( $text =~ s!\[col(?:umn)?\s+
- ([^\]]+)
- \]
- ([\000-\377]*?)
- \[/col(?:umn)?\] !!ix ) {
- $spec = $1;
- $col = $2;
- $lines[$i] = [];
- @{$lines[$i]} = tag_column($spec,$col);
- # Discover X dimension
- $len[$i] = length(${$lines[$i]}[0]);
- if(defined ${$lines[$i]}[1] and ${$lines[$i]}[1] =~ /^<\s*input\s+/i) {
- shift @{$lines[$i]};
- }
- $i++;
- }
- my $totlen = 0;
- for(@len) { $totlen += $_ }
- if ($totlen > $width) {
- return " B A D R O W S P E C I F I C A T I O N - columns too wide.\n"
- }
-
- # Discover y dimension
- $j = $#{$lines[0]};
- for ($k = 1; $k < $i; $k++) {
- $j = $#{$lines[$k]} > $j ? $#{$lines[$k]} : $j;
- }
-
- for($y = 0; $y <= $j; $y++) {
- $line = '';
- for($x = 0; $x < $i; $x++) {
- if(defined ${$lines[$x]}[$y]) {
- $line .= ${$lines[$x]}[$y];
- $line =~ s/\s+$//
- if ($i - $x) == 1;
- }
- elsif (($i - $x) > 1) {
- $line .= ' ' x $len[$x];
- }
- else {
- $line =~ s/\s+$//;
- }
- }
- push @out, $line;
- }
- join "\n", @out;
-}
-
-my %_assignable = (qw/
- salestax 1
- shipping 1
- handling 1
- subtotal 1
- /);
-
-sub tag_assign {
- my ($opt) = @_;
- if($opt->{clear}) {
- delete $Vend::Session->{assigned};
- return;
- }
- $Vend::Session->{assigned} ||= {};
- for(keys %$opt) {
- next unless $_assignable{$_};
- my $value = $opt->{$_};
- $value =~ s/^\s+//;
- $value =~ s/\s+$//;
- if($value =~ /^-?\d+\.?\d*$/) {
- $Vend::Session->{assigned}{$_} = $value;
- }
- else {
- ::logError(
- "Attempted assign of non-numeric '%s' to %s. Deleted.",
- $value,
- $_,
- );
- delete $Vend::Session->{assigned}{$_};
- }
- }
- return;
-}
-
sub shipping {
my($mode, $opt) = @_;
return undef unless $mode;
@@ -7783,15 +6828,6 @@
return $subtotal;
}
-sub tag_subtotal {
- my($cart, $noformat) = @_;
- return currency( subtotal($cart), $noformat);
-}
-
-sub tag_salestax {
- my($cart, $noformat) = @_;
- return currency( salestax($cart), $noformat);
-}
# Returns the total cost of items ordered.
@@ -7818,11 +6854,6 @@
$Vend::Items = $save if defined $save;
$Vend::Session->{latest_total} = $total;
return $total;
-}
-
-sub tag_total_cost {
- my($cart, $noformat) = @_;
- return currency( total_cost($cart), $noformat);
}
sub tag_ups {
2.13 +26 -7 interchange/lib/Vend/Order.pm
rev 2.13, prev_rev 2.12
Index: Order.pm
===================================================================
RCS file: /anon_cvs/repository/interchange/lib/Vend/Order.pm,v
retrieving revision 2.12
retrieving revision 2.13
diff -u -r2.12 -r2.13
--- Order.pm 8 Nov 2001 20:19:05 -0000 2.12
+++ Order.pm 29 Jan 2002 05:52:43 -0000 2.13
@@ -1,6 +1,6 @@
# Vend::Order - Interchange order routing routines
#
-# $Id: Order.pm,v 2.12 2001/11/08 20:19:05 mheins Exp $
+# $Id: Order.pm,v 2.13 2002/01/29 05:52:43 mheins Exp $
#
# Copyright (C) 1996-2001 Red Hat, Inc. <interchange@redhat.com>
#
@@ -28,7 +28,7 @@
package Vend::Order;
require Exporter;
-$VERSION = substr(q$Revision: 2.12 $, 10);
+$VERSION = substr(q$Revision: 2.13 $, 10);
@ISA = qw(Exporter);
@@ -67,6 +67,7 @@
my $Fail_page;
my $Success_page;
my $No_error;
+use vars qw/$OrderCheck/;
my %Parse = (
@@ -229,17 +230,27 @@
my (@return);
- if( defined $Parse{$routine}) {
- @return = $Parse{$routine}->($var, $val, $message);
+::logDebug("OrderCheck = $OrderCheck routine=$routine");
+ my $sub;
+ my @args;
+ if( $sub = $Parse{$routine}) {
+ @args = ($var, $val, $message);
undef $message;
}
+ elsif ($OrderCheck and $sub = $OrderCheck->{$routine}) {
+::logDebug("Using coderef OrderCheck = $sub");
+ @args = ($ref,$var,$val);
+ }
elsif (defined &{"_$routine"}) {
- @return = &{'_' . $routine}($ref,$var,$val);
+ $sub = \&{"_$routine"};
+ @args = ($ref,$var,$val);
}
else {
return (undef, $var, errmsg("No format check routine for '%s'", $routine));
}
+ @return = $sub->(@args);
+
if(! $return[0] and $message) {
$return[2] = $message;
}
@@ -827,8 +838,8 @@
}
$val =~ s/&#(\d+);/chr($1)/ge;
- if (defined $Parse{$var}) {
- ($val, $var, $message) = &{$Parse{$var}}($ref, $val, $m);
+ if ($Parse{$var}) {
+ ($val, $var, $message) = $Parse{$var}->($ref, $val, $m);
}
else {
logError( "Unknown order check parameter in profile %s: %s=%s",
@@ -865,9 +876,17 @@
my $ref = \%CGI::values;
$params = interpolate_html($params);
$params =~ s/\\\n//g;
+
@Errors = ();
$And = 1;
$Fatal = $Final = 0;
+
+ my $r;
+ if( $r = $Vend::Cfg->{CodeDef}{OrderCheck} and $r = $r->{Routine}) {
+ for(keys %$r) {
+ $OrderCheck->{$_} = $r->{$_};
+ }
+ }
my($var,$val,$message);
my $status = 1;
2.9 +15 -570 interchange/lib/Vend/Parse.pm
rev 2.9, prev_rev 2.8
Index: Parse.pm
===================================================================
RCS file: /anon_cvs/repository/interchange/lib/Vend/Parse.pm,v
retrieving revision 2.8
retrieving revision 2.9
diff -u -r2.8 -r2.9
--- Parse.pm 9 Jan 2002 19:29:47 -0000 2.8
+++ Parse.pm 29 Jan 2002 05:52:43 -0000 2.9
@@ -1,6 +1,6 @@
# Vend::Parse - Parse Interchange tags
#
-# $Id: Parse.pm,v 2.8 2002/01/09 19:29:47 jon Exp $
+# $Id: Parse.pm,v 2.9 2002/01/29 05:52:43 mheins Exp $
#
# Copyright (C) 1996-2001 Red Hat, Inc. <interchange@redhat.com>
#
@@ -35,7 +35,7 @@
@ISA = qw(Exporter Vend::Parser);
-$VERSION = substr(q$Revision: 2.8 $, 10);
+$VERSION = substr(q$Revision: 2.9 $, 10);
@EXPORT = ();
@EXPORT_OK = qw(find_matching_end);
@@ -49,296 +49,33 @@
my %PosNumber = ( qw!
- accessories 2
- and 1
- area 2
- assign 0
- attr_list 1
- banner 1
bounce 2
- cart 1
- cgi 1
- charge 1
- checked 2
- control 2
- control_set 1
- counter 1
- currency 2
- data 3
- default 2
- description 2
- discount 1
- dump 1
- ecml 2
- either 0
- error 1
- warnings 1
- export 1
- field 2
- file 2
- filter 1
- flag 1
- fly_list 2
- fly_tax 1
- goto 2
- handling 1
- harness 0
- html_table 0
+ label 1
if 1
unless 1
- import 2
- include 2
- index 1
- input_filter 1
- label 1
- log 1
- loop 1
- mail 1
- msg 1
- mvasp 1
- nitems 1
- onfly 2
- options 1
+ and 1
or 1
- order 2
- page 2
- perl 1
- price 1
- profile 1
- query 1
- record 0
- region 0
- row 1
- salestax 2
- scratch 1
- scratchd 1
- search_region 0
- selected 2
- set 1
- seti 1
- setlocale 2
- shipping 1
- shipping_desc 1
- soap 3
- sql 2
- strip 0
- subtotal 2
- tag 2
- time 1
- timed_build 1
- tmp 1
- total_cost 2
- try 1
- userdb 1
- value 1
- value_extended 1
! );
my %Order = (
-
- accessories => [qw( code arg )],
- attr_list => [qw( hash )],
- area => [qw( href arg )],
- assign => [],
- banner => [qw( category )],
bounce => [qw( href if )],
- calc => [],
- cart => [qw( name )],
- catch => [qw( label )],
- cgi => [qw( name )],
- currency => [qw( convert noformat )],
- charge => [qw( route )],
- checked => [qw( name value )],
- counter => [qw( file )],
- data => [qw( table field key )],
- default => [qw( name default )],
- dump => [qw( key )],
- description => [qw( code base )],
- discount => [qw( code )],
- ecml => [qw( name function )],
- either => [qw( )],
- error => [qw( name )],
- warnings => [qw( message )],
- export => [qw( table )],
- field => [qw( name code )],
- file => [qw( name type )],
- filter => [qw( op )],
- flag => [qw( type )],
- time => [qw( locale )],
- fly_tax => [qw( area )],
- fly_list => [qw( code )],
goto => [qw( name if)],
- harness => [qw( )],
- html_table => [qw( )],
+ label => [qw( name )],
if => [qw( type term op compare )],
unless => [qw( type term op compare )],
or => [qw( type term op compare )],
and => [qw( type term op compare )],
- index => [qw( table )],
- import => [qw( table type )],
- input_filter => [qw( name )],
- include => [qw( file locale )],
- item_list => [qw( name )],
- label => [qw( name )],
- log => [qw( file )],
- loop => [qw( list )],
- nitems => [qw( name )],
- onfly => [qw( code quantity )],
- order => [qw( code quantity )],
- page => [qw( href arg )],
- perl => [qw( tables )],
- mail => [qw( to )],
- msg => [qw( key )],
- mvasp => [qw( tables )],
- options => [qw( code )],
- price => [qw( code )],
- profile => [qw( name )],
- process => [qw( target secure )],
- query => [qw( sql )],
- read_cookie => [qw( name )],
- row => [qw( width )],
- salestax => [qw( name noformat)],
- scratch => [qw( name )],
- scratchd => [qw( name )],
- search_region => [qw( arg )],
- region => [qw( )],
- record => [qw( )],
- restrict => [qw( enable )],
- control => [qw( name default )],
- control_set => [qw( index )],
- selected => [qw( name value )],
- set_cookie => [qw( name value expire domain path )],
- setlocale => [qw( locale currency )],
- set => [qw( name )],
- seti => [qw( name )],
- tree => [qw( table master subordinate start )],
- tmp => [qw( name )],
- shipping => [qw( mode )],
- handling => [qw( mode )],
- shipping_desc => [qw( mode )],
- soap => [qw( call uri proxy )],
-# SQL
- sql => [qw( type query)],
-# END SQL
- strip => [],
- subtotal => [qw( name noformat )],
- tag => [qw( op arg )],
- timed_build => [qw( file )],
- total_cost => [qw( name noformat )],
- try => [qw( label )],
- userdb => [qw( function ) ],
- update => [qw( function ) ],
- value => [qw( name )],
- value_extended => [qw( name )],
-
);
my %addAttr = (
- qw(
- accessories 1
- area 1
- assign 1
- banner 1
- catch 1
- cgi 1
- charge 1
- checked 1
- counter 1
- control 1
- control_set 1
- data 1
- default 1
- ecml 1
- error 1
- warnings 1
- export 1
- flag 1
- fly_list 1
- harness 1
- html_table 1
- import 1
- index 1
- input_filter 1
- item_list 1
- loop 1
- onfly 1
- order 1
- page 1
- mail 1
- msg 1
- mvasp 1
- nitems 1
- options 1
- perl 1
- price 1
- profile 1
- process 1
- query 1
- soap 1
- sql 1
- selected 1
- setlocale 1
- restrict 1
- record 1
- region 1
- search_region 1
- shipping 1
- handling 1
- tag 1
- log 1
- time 1
- timed_build 1
- tree 1
- try 1
- update 1
- userdb 1
- value 1
- value_extended 1
- )
);
my %hasEndTag = (
qw(
- catch 1
- control_set 1
- either 1
- harness 1
- attr_list 1
- calc 1
- currency 1
- discount 1
- filter 1
- fly_list 1
- html_table 1
if 1
- import 1
- input_filter 1
- item_list 1
- log 1
- loop 1
- mail 1
- msg 1
- mvasp 1
- perl 1
- query 1
- region 1
- restrict 1
- row 1
- search_region 1
- set 1
- seti 1
- sql 1
- strip 1
- tag 1
- time 1
- timed_build 1
- tmp 1
- tree 1
- try 1
unless 1
-
)
);
@@ -346,56 +83,13 @@
my %InvalidateCache = (
qw(
- cgi 1
- cart 1
- charge 1
- checked 1
- counter 1
- default 1
- discount 1
- export 1
- flag 1
- item_list 1
- import 1
- index 1
- input_filter 1
- if 1
- unless 1
- mail 1
- mvasp 1
- nitems 1
- perl 1
- profile 1
- salestax 1
- scratch 1
- scratchd 1
- selected 1
- read_cookie 1
- set_cookie 1
- set 1
- soap 1
- tmp 1
- seti 1
- shipping 1
- handling 1
- sql 1
- subtotal 1
- total_cost 1
- userdb 1
- update 1
- value 1
- value_extended 1
-
+ if 1
+ unless 1
)
);
my %Implicit = (
- data => { qw( increment increment ) },
- checked => { qw( multiple multiple default default ) },
- page => { qw( secure secure ) },
- area => { qw( secure secure ) },
-
unless => { qw(
!= op
!~ op
@@ -458,129 +152,13 @@
my %Routine = (
- accessories => \&Vend::Interpolate::tag_accessories,
- attr_list => \&Vend::Interpolate::tag_attr_list,
- area => \&Vend::Interpolate::tag_area,
- assign => \&Vend::Interpolate::tag_assign,
- banner => \&Vend::Interpolate::tag_banner,
bounce => sub { return '' },
- calc => \&Vend::Interpolate::tag_calc,
- cart => \&Vend::Interpolate::tag_cart,
- catch => \&Vend::Interpolate::catch,
- cgi => \&Vend::Interpolate::tag_cgi,
- charge => \&Vend::Payment::charge,
- checked => \&Vend::Interpolate::tag_checked,
- control => \&Vend::Interpolate::tag_control,
- control_set => \&Vend::Interpolate::tag_control_set,
- counter => \&Vend::Interpolate::tag_counter,
- currency => sub {
- my($convert,$noformat,$amount) = @_;
- return &Vend::Util::currency(
- $amount,
- $noformat,
- $convert);
- },
- data => \&Vend::Interpolate::tag_data,
- default => \&Vend::Interpolate::tag_default,
- dump => \&::full_dump,
- description => \&Vend::Data::product_description,
- discount => \&Vend::Interpolate::tag_discount,
- ecml => sub {
- require Vend::ECML;
- return Vend::ECML::ecml(@_);
- },
- either => sub {
- my @ary = split /\[or\]/, shift;
- my $result;
- while(@ary) {
- $result = interpolate_html(shift @ary);
- $result =~ s/^\s+//;
- $result =~ s/\s+$//;
- return $result if $result;
- }
- return;
- },
- error => \&Vend::Interpolate::tag_error,
- warnings => \&Vend::Interpolate::tag_warnings,
- export => \&Vend::Interpolate::export,
- field => \&Vend::Data::product_field,
- file => \&Vend::Interpolate::tag_file,
- filter => \&Vend::Interpolate::filter_value,
- flag => \&Vend::Interpolate::flag,
- fly_tax => \&Vend::Interpolate::fly_tax,
- fly_list => \&Vend::Interpolate::fly_page,
- harness => \&harness,
- html_table => \&Vend::Interpolate::html_table,
- index => \&Vend::Data::index_database,
- import => \&Vend::Data::import_text,
- include => sub {
- &Vend::Interpolate::interpolate_html(
- &Vend::Util::readfile
- ($_[0], $Global::NoAbsolute, $_[1])
- );
- },
- input_filter => \&Vend::Interpolate::input_filter,
- item_list => \&Vend::Interpolate::tag_item_list,
if => \&Vend::Interpolate::tag_self_contained_if,
unless => \&Vend::Interpolate::tag_unless,
or => sub { return &Vend::Interpolate::tag_self_contained_if(@_, 1) },
and => sub { return &Vend::Interpolate::tag_self_contained_if(@_, 1) },
goto => sub { return '' },
label => sub { return '' },
- log => \&Vend::Interpolate::log,
- loop => \&Vend::Interpolate::tag_loop_list,
- nitems => \&Vend::Util::tag_nitems,
- onfly => \&Vend::Order::onfly,
- options => \&Vend::Interpolate::tag_options,
- order => \&Vend::Interpolate::tag_order,
- page => \&Vend::Interpolate::tag_page,
- perl => \&Vend::Interpolate::tag_perl,
- mail => \&Vend::Interpolate::tag_mail,
- msg => \&Vend::Interpolate::tag_msg,
-# MVASP
- mvasp => \&Vend::Interpolate::mvasp,
-# END MVASP
- price => \&Vend::Interpolate::tag_price,
- process => \&Vend::Interpolate::tag_process,
- profile => \&Vend::Interpolate::tag_profile,
- query => \&Vend::Interpolate::query,
- read_cookie => \&Vend::Util::read_cookie,
-
- row => \&Vend::Interpolate::tag_row,
- salestax => \&Vend::Interpolate::tag_salestax,
- scratch => \&Vend::Interpolate::tag_scratch,
- scratchd => \&Vend::Interpolate::tag_scratchd,
- record => \&Vend::Interpolate::tag_record,
- region => \&Vend::Interpolate::region,
- search_region => \&Vend::Interpolate::tag_search_region,
- selected => \&Vend::Interpolate::tag_selected,
- setlocale => \&Vend::Util::setlocale,
- set_cookie => \&Vend::Util::set_cookie,
- set => \&Vend::Interpolate::set_scratch,
- seti => \&Vend::Interpolate::set_scratch,
- shipping => \&Vend::Interpolate::tag_shipping,
- handling => \&Vend::Interpolate::tag_handling,
- shipping_desc => \&Vend::Interpolate::tag_shipping_desc,
- sql => \&Vend::Data::sql_query,
- soap => \&Vend::SOAP::tag_soap,
- subtotal => \&Vend::Interpolate::tag_subtotal,
- strip => sub {
- local($_) = shift;
- s/^\s+//;
- s/\s+$//;
- return $_;
- },
- tag => \&Vend::Interpolate::do_tag,
- tmp => \&Vend::Interpolate::set_tmp,
- tree => \&Vend::Interpolate::tag_tree,
- try => \&Vend::Interpolate::try,
- time => \&Vend::Interpolate::mvtime,
- timed_build => \&Vend::Interpolate::timed_build,
- total_cost => \&Vend::Interpolate::tag_total_cost,
- userdb => \&Vend::UserDB::userdb,
- update => \&Vend::Interpolate::update,
- value => \&Vend::Interpolate::tag_value,
- value_extended => \&Vend::Interpolate::tag_value_extended,
);
@@ -637,68 +215,6 @@
};
my %attrAlias = (
- counter => { 'name' => 'file' },
- query => { 'query' => 'sql' },
- tree => { 'sub' => 'subordinate' },
- perl => { 'table' => 'tables' },
- mvasp => { 'table' => 'tables' },
- price => { 'base' => 'mv_ib' },
- query => { 'base' => 'table' },
- page => {
- 'base' => 'arg',
- },
- record => {
- 'column' => 'col',
- 'code' => 'key',
- 'field' => 'col',
- },
- flag => {
- 'flag' => 'type',
- 'name' => 'type',
- 'tables' => 'table',
- },
- field => {
- 'field' => 'name',
- 'column' => 'name',
- 'col' => 'name',
- 'key' => 'code',
- 'row' => 'code',
- },
- 'index' => {
- 'database' => 'table',
- 'base' => 'table',
- },
- import => {
- 'database' => 'table',
- 'base' => 'table',
- },
- input_filter => {
- 'ops' => 'op',
- 'var' => 'name',
- 'variable' => 'name',
- },
- accessories => {
- 'database' => 'table',
- 'db' => 'table',
- 'base' => 'table',
- 'field' => 'column',
- 'col' => 'column',
- 'key' => 'code',
- 'row' => 'code',
- },
- export => {
- 'database' => 'table',
- 'base' => 'table',
- },
- data => {
- 'database' => 'table',
- 'base' => 'table',
- 'name' => 'field',
- 'column' => 'field',
- 'col' => 'field',
- 'code' => 'key',
- 'row' => 'key',
- },
'or' => {
'comp' => 'compare',
'operator' => 'op',
@@ -709,25 +225,6 @@
'operator' => 'op',
'base' => 'type',
},
- 'userdb' => {
- 'table' => 'db',
- 'name' => 'nickname',
- },
- 'shipping' => {
- 'name' => 'mode',
- 'tables' => 'table',
- 'modes' => 'mode',
- 'carts' => 'cart',
- },
- 'handling' => {
- 'name' => 'mode',
- 'tables' => 'table',
- 'modes' => 'mode',
- 'carts' => 'cart',
- },
- 'salestax' => { 'cart' => 'name', },
- 'subtotal' => { 'cart' => 'name', },
- 'total_cost' => { 'cart' => 'name', },
'unless' => {
'comp' => 'compare',
'condition' => 'compare',
@@ -740,18 +237,6 @@
'operator' => 'op',
'base' => 'type',
},
- search_region => { search => 'arg',
- params => 'arg',
- args => 'arg', },
- region => { search => 'arg',
- params => 'arg',
- args => 'arg', },
- loop => { args => 'list',
- arg => 'list', },
- item_list => { cart => 'name', },
- tag => { description => 'arg', },
- log => { arg => 'file', },
- msg => { lc => 'inline', },
);
my %Alias = (
@@ -770,6 +255,13 @@
buzzard => 'data table=products column=artist key=',
);
+my %replaceAttr = (
+ area => { qw/ a href form action/},
+ process => { qw/ form action /},
+ checked => { qw/ input checked /},
+ selected => { qw/ option selected /},
+ );
+
my %replaceHTML = (
qw(
del .*
@@ -779,13 +271,6 @@
)
);
-my %replaceAttr = (
- area => { qw/ a href form action/},
- process => { qw/ form action /},
- checked => { qw/ input checked /},
- selected => { qw/ option selected /},
- );
-
my %insertHTML = (
qw(
@@ -835,19 +320,10 @@
my %Interpolate = (
qw(
- calc 1
- currency 1
- import 1
- msg 1
- row 1
- seti 1
- tmp 1
)
);
my %NoReparse = ( qw/
- mvasp 1
- restrict 1
/ );
my %Gobble = ( qw/
@@ -857,38 +333,6 @@
my $Initialized = 0;
-my $Test = 'test001';
-sub harness {
- my ($opt, $input) = @_;
- my $not;
- my $expected = $opt->{expected} || 'OK';
- $input =~ s:^\s+::;
- $input =~ s:\s+$::;
- $input =~ s:\s*\[expected\](.*)\[/expected\]\s*::s
- and $expected = $1;
- $input =~ s:\[not\](.*)\[/not\]::s
- and $not = $1;
- my $name = $Test++;
- $name = $opt->{name}
- if defined $opt->{name};
- my $result;
- eval {
- $result = Vend::Interpolate::interpolate_html($input);
- };
- if($@) {
- my $msg = "DIED in test $name. \$\@: $@";
-#::logDebug($msg);
- return $msg;
- }
- if($expected) {
- return "NOT OK $name: $result!=$expected" unless $result =~ /$expected/;
- }
- if($not) {
- return "NOT OK $name: $result==$not" unless $result !~ /$not/;
- }
- return "OK $name";
-}
-
sub global_init {
add_tags($Global::UserTag);
my $tag;
@@ -1008,6 +452,7 @@
sub add_tags {
return unless @_;
my $ref = shift;
+ return unless $ref->{Routine} or $ref->{Alias};
my $area;
no strict 'refs';
foreach $area (keys %myRefs) {
2.14 +19 -2 interchange/lib/Vend/Util.pm
rev 2.14, prev_rev 2.13
Index: Util.pm
===================================================================
RCS file: /anon_cvs/repository/interchange/lib/Vend/Util.pm,v
retrieving revision 2.13
retrieving revision 2.14
diff -u -r2.13 -r2.14
--- Util.pm 22 Jan 2002 02:07:08 -0000 2.13
+++ Util.pm 29 Jan 2002 05:52:43 -0000 2.14
@@ -1,6 +1,6 @@
# Vend::Util - Interchange utility functions
#
-# $Id: Util.pm,v 2.13 2002/01/22 02:07:08 mheins Exp $
+# $Id: Util.pm,v 2.14 2002/01/29 05:52:43 mheins Exp $
#
# Copyright (C) 1996-2001 Red Hat, Inc. <interchange@redhat.com>
#
@@ -81,7 +81,7 @@
use Safe;
use subs qw(logError logGlobal);
use vars qw($VERSION @EXPORT @EXPORT_OK);
-$VERSION = substr(q$Revision: 2.13 $, 10);
+$VERSION = substr(q$Revision: 2.14 $, 10);
BEGIN {
eval {
@@ -106,6 +106,8 @@
'-:_.$/'
;
+my $need_escape;
+
sub setup_escape_chars {
my($ok, $i, $a, $t);
@@ -120,6 +122,9 @@
$ESCAPE_CHARS::translate[$i] = $t;
}
+ my $string = "[^$ESCAPE_CHARS::ok_in_filename]";
+ $need_escape = qr{$string};
+
}
# Replace any characters that might not be safe in a filename (especially
@@ -378,6 +383,16 @@
@{$curr}{@Vend::Config::Locale_keys_currency};
}
+ if(my $ref = $Vend::Cfg->{CodeDef}{LocaleChange}) {
+ $ref = $ref->{Routine};
+ if($ref->{all}) {
+ $ref->{all}->($locale, $opt);
+ }
+ if($ref->{lc $locale}) {
+ $ref->{lc $locale}->($locale, $opt);
+ }
+ }
+
$::Scratch->{mv_locale} = $locale if $opt->{persist} and $locale;
$::Scratch->{mv_currency} = $currency if $opt->{persist} and $currency;
return '';
@@ -1165,6 +1180,8 @@
$ct = ++$Vend::Session->{pageCount}
unless $can_cache and $::Scratch->{mv_no_count};
+ $path = escape_chars($path)
+ if $path =~ $need_escape;
$r .= '/' . $path;
$r .= '.html' if $::Scratch->{mv_add_dot_html} and $r !~ /\.html?$/;
push @parms, "$::VN->{mv_session_id}=$id" if defined $id;