[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*)~&lt;$1~g;
		$value =~ s/\[/&#91;/g;
    }
	if($opt->{filter}) {
		$value = filter_value($opt->{filter}, $value, $var);
		$CGI::values{$var} = $value unless $opt->{keep};
	}

    return '' if $opt->{hide};

	$value =~ s/</&lt;/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", "&nbsp;" ) {
								$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 &#91;).
#
# 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>&nbsp;%s&nbsp;<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>&nbsp;%s&nbsp;<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>&nbsp;%s&nbsp;<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>&nbsp;%s&nbsp;<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>&nbsp;%s&nbsp;<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/ /&nbsp;/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&#44;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/</&lt;/g;
		$text =~ s/>/&gt;/g;
		$text =~ s/,/&#44;/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} || '&nbsp;&nbsp;&nbsp;&nbsp;';
	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> &nbsp;
       <font size="+1" face="Verdana,arial,helvetica,sans-serif" color="#000000">Regeneration complete in $end seconds.&nbsp;<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/"/&quot;/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/"/&quot;/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/</&lt;/g;
				$text =~ s/\[/&#91;/g;
				$out .= <<EOF;
<TD><TEXTAREA NAME="$_" COLS="$size" ROWS="$rows">$text</TEXTAREA>$msg</TD>
EOF
			}
			else {
				$text =~ s/"/&quot;/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} || '&nbsp;&nbsp;&nbsp;<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/,/&#44/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/ /&nbsp;/g;
				}
				$blob_widget = <<EOF unless $opt->{ui_blob_hidden};
<B>$msg1:</B> $blob_widget&nbsp;
<INPUT TYPE=checkbox NAME=mv_blob_only VALUE=1$checked>&nbsp;$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&nbsp;
	 </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/"/&quot;/g;
		$out .= qq{<INPUT TYPE=hidden NAME=$_ VALUE="$val">\n};
	}

	for (@cgi_set) {
		next unless length $CGI->{$_};
		my $val = $CGI->{$_};
		$val =~ s/"/&quot;/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>&nbsp;</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}">&nbsp;<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}">&nbsp;<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>&nbsp;</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}">&nbsp;<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>&nbsp;</td>
<td align=left colspan=$oddspan class=cdata>
<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}">
</B>
&nbsp;
<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>&nbsp;</td><TD>&nbsp;</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>&nbsp;</td><TD>&nbsp;</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/\&/&amp;/g;
		$serial_data{$_} =~ s/"/&quot;/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>&nbsp;</td>
<td align=left colspan=$oddspan class=cdata>
<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{back_text}">&nbsp;<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}">&nbsp;<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
EOF
		}
		elsif($opt->{wizard}) {
		  $out .= <<EOF;
<TR class=rnorm>
<td>&nbsp;</td>
<td align=left colspan=$oddspan class=cdata>
<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}">&nbsp;<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
EOF
		}
		else {
		  $out .= <<EOF;
<TR class=rnorm>
<td>&nbsp;</td>
<td align=left colspan=$oddspan class=cdata>
<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>&nbsp;<INPUT TYPE=submit NAME=mv_click VALUE="$opt->{cancel_text}">
EOF
		}
#
#	$out .= <<EOF;
#
#<TR class=rnorm>
#<td>&nbsp;</td>
#<td align=left colspan=$oddspan>
#<B><INPUT TYPE=submit NAME=mv_click VALUE="$opt->{next_text}"></B>
#&nbsp;
#&nbsp;
#<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>
&nbsp;
&nbsp;
&nbsp;
&nbsp;
&nbsp;
	<INPUT TYPE=checkbox NAME=mv_auto_export VALUE="$table"$checked>&nbsp;$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/"/&quot;/g;
	$name =~ s/"/&quot;/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/"/&quot;/g;
		$name =~ s/"/&quot;/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/ /&nbsp;/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>$_\&nbsp;<\/b><\/td><td>";
			$out .= "$env->{$_}\&nbsp;<\/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/"/&quot;/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<&nbsp;>.

=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>&nbsp;</td>
                <td align=left>&nbsp;</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>&nbsp;</td>
            </tr>
            <tr bgcolor="#EEEEEE">
                    <td align=right>3</td>
                    <td align=center>3a</td>
                    <td align=left>&nbsp;</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} = '&nbsp;' 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;