* The great tag breakout!
Mike Heins [Tue, 29 Jan 2002 05:52:43 +0000 (05:52 +0000)]
* 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.

182 files changed:
code/ActionMap/foo.am [new file with mode: 0644]
code/Filter/lc.filter [new file with mode: 0644]
code/SystemTag/accessories.coretag [new file with mode: 0644]
code/SystemTag/area.coretag [new file with mode: 0644]
code/SystemTag/assign.coretag [new file with mode: 0644]
code/SystemTag/attr_list.coretag [new file with mode: 0644]
code/SystemTag/banner.coretag [new file with mode: 0644]
code/SystemTag/calc.coretag [new file with mode: 0644]
code/SystemTag/cart.coretag [new file with mode: 0644]
code/SystemTag/catch.coretag [new file with mode: 0644]
code/SystemTag/cgi.coretag [new file with mode: 0644]
code/SystemTag/charge.coretag [new file with mode: 0644]
code/SystemTag/checked.coretag [new file with mode: 0644]
code/SystemTag/control.coretag [new file with mode: 0644]
code/SystemTag/control_set.coretag [new file with mode: 0644]
code/SystemTag/counter.coretag [new file with mode: 0644]
code/SystemTag/currency.coretag [new file with mode: 0644]
code/SystemTag/data.coretag [new file with mode: 0644]
code/SystemTag/default.coretag [new file with mode: 0644]
code/SystemTag/description.coretag [new file with mode: 0644]
code/SystemTag/discount.coretag [new file with mode: 0644]
code/SystemTag/dump.coretag [new file with mode: 0644]
code/SystemTag/ecml.coretag [new file with mode: 0644]
code/SystemTag/either.coretag [new file with mode: 0644]
code/SystemTag/error.coretag [new file with mode: 0644]
code/SystemTag/export.coretag [new file with mode: 0644]
code/SystemTag/field.coretag [new file with mode: 0644]
code/SystemTag/file.coretag [new file with mode: 0644]
code/SystemTag/filter.coretag [new file with mode: 0644]
code/SystemTag/flag.coretag [new file with mode: 0644]
code/SystemTag/fly_list.coretag [new file with mode: 0644]
code/SystemTag/fly_tax.coretag [new file with mode: 0644]
code/SystemTag/handling.coretag [new file with mode: 0644]
code/SystemTag/harness.coretag [new file with mode: 0644]
code/SystemTag/html_table.coretag [new file with mode: 0644]
code/SystemTag/import.coretag [new file with mode: 0644]
code/SystemTag/include.coretag [new file with mode: 0644]
code/SystemTag/index.coretag [new file with mode: 0644]
code/SystemTag/input_filter.coretag [new file with mode: 0644]
code/SystemTag/item_list.coretag [new file with mode: 0644]
code/SystemTag/log.coretag [new file with mode: 0644]
code/SystemTag/loop.coretag [new file with mode: 0644]
code/SystemTag/mail.coretag [new file with mode: 0644]
code/SystemTag/msg.coretag [new file with mode: 0644]
code/SystemTag/mvasp.coretag [new file with mode: 0644]
code/SystemTag/nitems.coretag [new file with mode: 0644]
code/SystemTag/onfly.coretag [new file with mode: 0644]
code/SystemTag/options.coretag [new file with mode: 0644]
code/SystemTag/order.coretag [new file with mode: 0644]
code/SystemTag/page.coretag [new file with mode: 0644]
code/SystemTag/perl.coretag [new file with mode: 0644]
code/SystemTag/price.coretag [new file with mode: 0644]
code/SystemTag/process.coretag [new file with mode: 0644]
code/SystemTag/profile.coretag [new file with mode: 0644]
code/SystemTag/query.coretag [new file with mode: 0644]
code/SystemTag/read_cookie.coretag [new file with mode: 0644]
code/SystemTag/record.coretag [new file with mode: 0644]
code/SystemTag/region.coretag [new file with mode: 0644]
code/SystemTag/row.coretag [new file with mode: 0644]
code/SystemTag/salestax.coretag [new file with mode: 0644]
code/SystemTag/scratch.coretag [new file with mode: 0644]
code/SystemTag/scratchd.coretag [new file with mode: 0644]
code/SystemTag/search_region.coretag [new file with mode: 0644]
code/SystemTag/selected.coretag [new file with mode: 0644]
code/SystemTag/set.coretag [new file with mode: 0644]
code/SystemTag/set_cookie.coretag [new file with mode: 0644]
code/SystemTag/seti.coretag [new file with mode: 0644]
code/SystemTag/setlocale.coretag [new file with mode: 0644]
code/SystemTag/shipping.coretag [new file with mode: 0644]
code/SystemTag/shipping_desc.coretag [new file with mode: 0644]
code/SystemTag/soap.coretag [new file with mode: 0644]
code/SystemTag/sql.coretag [new file with mode: 0644]
code/SystemTag/strip.coretag [new file with mode: 0644]
code/SystemTag/subtotal.coretag [new file with mode: 0644]
code/SystemTag/tag.coretag [new file with mode: 0644]
code/SystemTag/time.coretag [new file with mode: 0644]
code/SystemTag/timed_build.coretag [new file with mode: 0644]
code/SystemTag/tmp.coretag [new file with mode: 0644]
code/SystemTag/total_cost.coretag [new file with mode: 0644]
code/SystemTag/tree.coretag [new file with mode: 0644]
code/SystemTag/try.coretag [new file with mode: 0644]
code/SystemTag/update.coretag [new file with mode: 0644]
code/SystemTag/userdb.coretag [new file with mode: 0644]
code/SystemTag/value.coretag [new file with mode: 0644]
code/SystemTag/value_extended.coretag [new file with mode: 0644]
code/SystemTag/warnings.coretag [new file with mode: 0644]
code/UI_Tag/add_gpg_key.coretag [new file with mode: 0644]
code/UI_Tag/available_ups_internal.coretag [new file with mode: 0644]
code/UI_Tag/available_www_shipping.coretag [new file with mode: 0644]
code/UI_Tag/backup_database.coretag [new file with mode: 0644]
code/UI_Tag/backup_file.coretag [new file with mode: 0644]
code/UI_Tag/base_url.coretag [new file with mode: 0644]
code/UI_Tag/check_upload.coretag [new file with mode: 0644]
code/UI_Tag/component_editor.coretag [new file with mode: 0644]
code/UI_Tag/cp.coretag [new file with mode: 0644]
code/UI_Tag/crypt.coretag [new file with mode: 0644]
code/UI_Tag/db_columns.coretag [new file with mode: 0644]
code/UI_Tag/db_hash.coretag [new file with mode: 0644]
code/UI_Tag/dbinfo.coretag [new file with mode: 0644]
code/UI_Tag/diff.coretag [new file with mode: 0644]
code/UI_Tag/diffmerge.coretag [new file with mode: 0644]
code/UI_Tag/directive_value.coretag [new file with mode: 0644]
code/UI_Tag/display.coretag [new file with mode: 0644]
code/UI_Tag/dump_session.coretag [new file with mode: 0644]
code/UI_Tag/e.coretag [new file with mode: 0644]
code/UI_Tag/export_database.coretag [new file with mode: 0644]
code/UI_Tag/file_info.coretag [new file with mode: 0644]
code/UI_Tag/file_navigator.coretag [new file with mode: 0644]
code/UI_Tag/filters.coretag [new file with mode: 0644]
code/UI_Tag/get_gpg_keys.coretag [new file with mode: 0644]
code/UI_Tag/global_value.coretag [new file with mode: 0644]
code/UI_Tag/grep_mm.coretag [new file with mode: 0644]
code/UI_Tag/if_key_exists.coretag [new file with mode: 0644]
code/UI_Tag/if_mm.coretag [new file with mode: 0644]
code/UI_Tag/if_sql.coretag [new file with mode: 0644]
code/UI_Tag/image_collate.coretag [new file with mode: 0644]
code/UI_Tag/import_fields.coretag [new file with mode: 0644]
code/UI_Tag/list_databases.coretag [new file with mode: 0644]
code/UI_Tag/list_glob.coretag [new file with mode: 0644]
code/UI_Tag/list_keys.coretag [new file with mode: 0644]
code/UI_Tag/list_pages.coretag [new file with mode: 0644]
code/UI_Tag/load_templates.coretag [new file with mode: 0644]
code/UI_Tag/meta_record.coretag [new file with mode: 0644]
code/UI_Tag/mm_locale.coretag [new file with mode: 0644]
code/UI_Tag/mm_value.coretag [new file with mode: 0644]
code/UI_Tag/newer.coretag [new file with mode: 0644]
code/UI_Tag/quick_table.coretag [new file with mode: 0644]
code/UI_Tag/read_page.coretag [new file with mode: 0644]
code/UI_Tag/read_shipping.coretag [new file with mode: 0644]
code/UI_Tag/read_ui_page.coretag [new file with mode: 0644]
code/UI_Tag/read_ui_template.coretag [new file with mode: 0644]
code/UI_Tag/reconfig.coretag [new file with mode: 0644]
code/UI_Tag/reconfig_time.coretag [new file with mode: 0644]
code/UI_Tag/reconfig_wait.coretag [new file with mode: 0644]
code/UI_Tag/regenerate.coretag [new file with mode: 0644]
code/UI_Tag/return_to.coretag [new file with mode: 0644]
code/UI_Tag/rotate_file.coretag [new file with mode: 0644]
code/UI_Tag/rotate_table.coretag [new file with mode: 0644]
code/UI_Tag/row_edit.coretag [new file with mode: 0644]
code/UI_Tag/run_profile.coretag [new file with mode: 0644]
code/UI_Tag/set_alias.coretag [new file with mode: 0644]
code/UI_Tag/substitute_file.coretag [new file with mode: 0644]
code/UI_Tag/table_editor.coretag [new file with mode: 0644]
code/UI_Tag/uneval.coretag [new file with mode: 0644]
code/UI_Tag/unlink_file.coretag [new file with mode: 0644]
code/UI_Tag/version.coretag [new file with mode: 0644]
code/UI_Tag/widget.coretag [new file with mode: 0644]
code/UI_Tag/with.coretag [new file with mode: 0644]
code/UI_Tag/write_page.coretag [new file with mode: 0644]
code/UI_Tag/write_relative_file.coretag [new file with mode: 0644]
code/UI_Tag/write_shipping.coretag [new file with mode: 0644]
code/UserTag/bar_button.tag [new file with mode: 0644]
code/UserTag/button.tag [new file with mode: 0644]
code/UserTag/convert_date.tag [new file with mode: 0644]
code/UserTag/db_date.tag [new file with mode: 0644]
code/UserTag/delete_cart.tag [new file with mode: 0644]
code/UserTag/email.tag [new file with mode: 0644]
code/UserTag/email_raw.tag [new file with mode: 0644]
code/UserTag/env.tag [new file with mode: 0644]
code/UserTag/fcounter.tag [new file with mode: 0644]
code/UserTag/fedex_query.tag [new file with mode: 0644]
code/UserTag/formel.tag [new file with mode: 0644]
code/UserTag/fortune.tag [new file with mode: 0644]
code/UserTag/get_url.tag [new file with mode: 0644]
code/UserTag/history_scan.tag [new file with mode: 0644]
code/UserTag/image.tag [new file with mode: 0644]
code/UserTag/load_cart.tag [new file with mode: 0644]
code/UserTag/loc.tag [new file with mode: 0644]
code/UserTag/rand.tag [new file with mode: 0644]
code/UserTag/save_cart.tag [new file with mode: 0644]
code/UserTag/summary.tag [new file with mode: 0644]
code/UserTag/table_organize.tag [new file with mode: 0644]
code/UserTag/title_bar.tag [new file with mode: 0644]
code/UserTag/ups_query.tag [new file with mode: 0644]
code/UserTag/usertrack.tag [new file with mode: 0644]
code/UserTag/var.tag [new file with mode: 0644]
code/UserTag/xml_generator.tag [new file with mode: 0644]
lib/Vend/Config.pm
lib/Vend/Interpolate.pm
lib/Vend/Order.pm
lib/Vend/Parse.pm
lib/Vend/Util.pm

diff --git a/code/ActionMap/foo.am b/code/ActionMap/foo.am
new file mode 100644 (file)
index 0000000..e3dd86f
--- /dev/null
@@ -0,0 +1,6 @@
+CodeDef foo ActionMap
+CodeDef foo Routine <<EOR
+sub {
+       $CGI->{mv_nextpage} = 'aboutus';
+}
+EOR
diff --git a/code/Filter/lc.filter b/code/Filter/lc.filter
new file mode 100644 (file)
index 0000000..af7955f
--- /dev/null
@@ -0,0 +1,7 @@
+CodeDef lc Filter
+CodeDef lc Routine <<EOR
+sub {
+       use locale;
+       return lc(shift);
+}
+EOR
diff --git a/code/SystemTag/accessories.coretag b/code/SystemTag/accessories.coretag
new file mode 100644 (file)
index 0000000..1976f16
--- /dev/null
@@ -0,0 +1,11 @@
+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
diff --git a/code/SystemTag/area.coretag b/code/SystemTag/area.coretag
new file mode 100644 (file)
index 0000000..62b5d18
--- /dev/null
@@ -0,0 +1,7 @@
+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
diff --git a/code/SystemTag/assign.coretag b/code/SystemTag/assign.coretag
new file mode 100644 (file)
index 0000000..6b5e1c6
--- /dev/null
@@ -0,0 +1,36 @@
+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
diff --git a/code/SystemTag/attr_list.coretag b/code/SystemTag/attr_list.coretag
new file mode 100644 (file)
index 0000000..214a475
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag attr-list           Order        hash
+UserTag attr-list           hasEndTag
+UserTag attr-list           PosNumber    1
+UserTag attr-list           MapRoutine   Vend::Interpolate::tag_attr_list
diff --git a/code/SystemTag/banner.coretag b/code/SystemTag/banner.coretag
new file mode 100644 (file)
index 0000000..a5e02dc
--- /dev/null
@@ -0,0 +1,72 @@
+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
diff --git a/code/SystemTag/calc.coretag b/code/SystemTag/calc.coretag
new file mode 100644 (file)
index 0000000..853966c
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag calc                hasEndTag
+UserTag calc                Interpolate
+UserTag calc                MapRoutine   Vend::Interpolate::tag_calc
diff --git a/code/SystemTag/cart.coretag b/code/SystemTag/cart.coretag
new file mode 100644 (file)
index 0000000..d311435
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag cart                Order        name
+UserTag cart                InvalidateCache
+UserTag cart                PosNumber    1
+UserTag cart                MapRoutine   Vend::Interpolate::tag_cart
diff --git a/code/SystemTag/catch.coretag b/code/SystemTag/catch.coretag
new file mode 100644 (file)
index 0000000..23f2aa5
--- /dev/null
@@ -0,0 +1,52 @@
+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
diff --git a/code/SystemTag/cgi.coretag b/code/SystemTag/cgi.coretag
new file mode 100644 (file)
index 0000000..62c8b78
--- /dev/null
@@ -0,0 +1,29 @@
+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
diff --git a/code/SystemTag/charge.coretag b/code/SystemTag/charge.coretag
new file mode 100644 (file)
index 0000000..3ac5b7f
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag charge              Order        route
+UserTag charge              addAttr
+UserTag charge              InvalidateCache
+UserTag charge              PosNumber    1
+UserTag charge              MapRoutine   Vend::Payment::charge
diff --git a/code/SystemTag/checked.coretag b/code/SystemTag/checked.coretag
new file mode 100644 (file)
index 0000000..2488691
--- /dev/null
@@ -0,0 +1,31 @@
+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
diff --git a/code/SystemTag/control.coretag b/code/SystemTag/control.coretag
new file mode 100644 (file)
index 0000000..bd64538
--- /dev/null
@@ -0,0 +1,35 @@
+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
diff --git a/code/SystemTag/control_set.coretag b/code/SystemTag/control_set.coretag
new file mode 100644 (file)
index 0000000..01235ad
--- /dev/null
@@ -0,0 +1,26 @@
+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
diff --git a/code/SystemTag/counter.coretag b/code/SystemTag/counter.coretag
new file mode 100644 (file)
index 0000000..843904b
--- /dev/null
@@ -0,0 +1,6 @@
+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
diff --git a/code/SystemTag/currency.coretag b/code/SystemTag/currency.coretag
new file mode 100644 (file)
index 0000000..150a72f
--- /dev/null
@@ -0,0 +1,10 @@
+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
diff --git a/code/SystemTag/data.coretag b/code/SystemTag/data.coretag
new file mode 100644 (file)
index 0000000..72930fb
--- /dev/null
@@ -0,0 +1,12 @@
+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
diff --git a/code/SystemTag/default.coretag b/code/SystemTag/default.coretag
new file mode 100644 (file)
index 0000000..c6204bd
--- /dev/null
@@ -0,0 +1,14 @@
+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
diff --git a/code/SystemTag/description.coretag b/code/SystemTag/description.coretag
new file mode 100644 (file)
index 0000000..6e0cfeb
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag description         Order        code base
+UserTag description         PosNumber    2
+UserTag description         MapRoutine   Vend::Data::product_description
diff --git a/code/SystemTag/discount.coretag b/code/SystemTag/discount.coretag
new file mode 100644 (file)
index 0000000..a528857
--- /dev/null
@@ -0,0 +1,35 @@
+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
diff --git a/code/SystemTag/dump.coretag b/code/SystemTag/dump.coretag
new file mode 100644 (file)
index 0000000..85de43e
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag dump                Order        key
+UserTag dump                PosNumber    1
+UserTag dump                MapRoutine   ::full_dump
diff --git a/code/SystemTag/ecml.coretag b/code/SystemTag/ecml.coretag
new file mode 100644 (file)
index 0000000..91ac578
--- /dev/null
@@ -0,0 +1,9 @@
+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
diff --git a/code/SystemTag/either.coretag b/code/SystemTag/either.coretag
new file mode 100644 (file)
index 0000000..cb4324b
--- /dev/null
@@ -0,0 +1,15 @@
+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
diff --git a/code/SystemTag/error.coretag b/code/SystemTag/error.coretag
new file mode 100644 (file)
index 0000000..1fab40f
--- /dev/null
@@ -0,0 +1,101 @@
+### 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
diff --git a/code/SystemTag/export.coretag b/code/SystemTag/export.coretag
new file mode 100644 (file)
index 0000000..00984bc
--- /dev/null
@@ -0,0 +1,7 @@
+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
diff --git a/code/SystemTag/field.coretag b/code/SystemTag/field.coretag
new file mode 100644 (file)
index 0000000..592376f
--- /dev/null
@@ -0,0 +1,8 @@
+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
diff --git a/code/SystemTag/file.coretag b/code/SystemTag/file.coretag
new file mode 100644 (file)
index 0000000..0c7c264
--- /dev/null
@@ -0,0 +1,29 @@
+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
diff --git a/code/SystemTag/filter.coretag b/code/SystemTag/filter.coretag
new file mode 100644 (file)
index 0000000..5266145
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag filter              Order        op
+UserTag filter              hasEndTag
+UserTag filter              PosNumber    1
+UserTag filter              MapRoutine   Vend::Interpolate::filter_value
diff --git a/code/SystemTag/flag.coretag b/code/SystemTag/flag.coretag
new file mode 100644 (file)
index 0000000..53b0b2a
--- /dev/null
@@ -0,0 +1,8 @@
+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
diff --git a/code/SystemTag/fly_list.coretag b/code/SystemTag/fly_list.coretag
new file mode 100644 (file)
index 0000000..ee754a9
--- /dev/null
@@ -0,0 +1,5 @@
+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
diff --git a/code/SystemTag/fly_tax.coretag b/code/SystemTag/fly_tax.coretag
new file mode 100644 (file)
index 0000000..c07b397
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag fly-tax             Order        area
+UserTag fly-tax             PosNumber    1
+UserTag fly-tax             MapRoutine   Vend::Interpolate::fly_tax
diff --git a/code/SystemTag/handling.coretag b/code/SystemTag/handling.coretag
new file mode 100644 (file)
index 0000000..5d6210c
--- /dev/null
@@ -0,0 +1,9 @@
+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
diff --git a/code/SystemTag/harness.coretag b/code/SystemTag/harness.coretag
new file mode 100644 (file)
index 0000000..a517e4d
--- /dev/null
@@ -0,0 +1,36 @@
+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
diff --git a/code/SystemTag/html_table.coretag b/code/SystemTag/html_table.coretag
new file mode 100644 (file)
index 0000000..0d79a6e
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag html-table          addAttr
+UserTag html-table          hasEndTag
+UserTag html-table          PosNumber    0
+UserTag html-table          MapRoutine   Vend::Interpolate::html_table
diff --git a/code/SystemTag/import.coretag b/code/SystemTag/import.coretag
new file mode 100644 (file)
index 0000000..e830d9e
--- /dev/null
@@ -0,0 +1,9 @@
+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
diff --git a/code/SystemTag/include.coretag b/code/SystemTag/include.coretag
new file mode 100644 (file)
index 0000000..42cae8a
--- /dev/null
@@ -0,0 +1,10 @@
+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
diff --git a/code/SystemTag/index.coretag b/code/SystemTag/index.coretag
new file mode 100644 (file)
index 0000000..9b867c3
--- /dev/null
@@ -0,0 +1,7 @@
+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
diff --git a/code/SystemTag/input_filter.coretag b/code/SystemTag/input_filter.coretag
new file mode 100644 (file)
index 0000000..4fe0df2
--- /dev/null
@@ -0,0 +1,9 @@
+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
diff --git a/code/SystemTag/item_list.coretag b/code/SystemTag/item_list.coretag
new file mode 100644 (file)
index 0000000..e4e1ac8
--- /dev/null
@@ -0,0 +1,19 @@
+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
diff --git a/code/SystemTag/log.coretag b/code/SystemTag/log.coretag
new file mode 100644 (file)
index 0000000..e56828c
--- /dev/null
@@ -0,0 +1,6 @@
+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
diff --git a/code/SystemTag/loop.coretag b/code/SystemTag/loop.coretag
new file mode 100644 (file)
index 0000000..cf5c82d
--- /dev/null
@@ -0,0 +1,7 @@
+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
diff --git a/code/SystemTag/mail.coretag b/code/SystemTag/mail.coretag
new file mode 100644 (file)
index 0000000..6156003
--- /dev/null
@@ -0,0 +1,6 @@
+UserTag mail                Order        to
+UserTag mail                addAttr
+UserTag mail                hasEndTag
+UserTag mail                InvalidateCache
+UserTag mail                PosNumber    1
+UserTag mail                MapRoutine   Vend::Interpolate::tag_mail
diff --git a/code/SystemTag/msg.coretag b/code/SystemTag/msg.coretag
new file mode 100644 (file)
index 0000000..d601289
--- /dev/null
@@ -0,0 +1,56 @@
+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
diff --git a/code/SystemTag/mvasp.coretag b/code/SystemTag/mvasp.coretag
new file mode 100644 (file)
index 0000000..219b7f8
--- /dev/null
@@ -0,0 +1,9 @@
+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
diff --git a/code/SystemTag/nitems.coretag b/code/SystemTag/nitems.coretag
new file mode 100644 (file)
index 0000000..67b0065
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag nitems              Order        name
+UserTag nitems              addAttr
+UserTag nitems              InvalidateCache
+UserTag nitems              PosNumber    1
+UserTag nitems              MapRoutine   Vend::Util::tag_nitems
diff --git a/code/SystemTag/onfly.coretag b/code/SystemTag/onfly.coretag
new file mode 100644 (file)
index 0000000..907507a
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag onfly               Order        code quantity
+UserTag onfly               addAttr
+UserTag onfly               PosNumber    2
+UserTag onfly               MapRoutine   Vend::Order::onfly
diff --git a/code/SystemTag/options.coretag b/code/SystemTag/options.coretag
new file mode 100644 (file)
index 0000000..b3e095a
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag options             Order        code
+UserTag options             addAttr
+UserTag options             PosNumber    1
+UserTag options             MapRoutine   Vend::Interpolate::tag_options
diff --git a/code/SystemTag/order.coretag b/code/SystemTag/order.coretag
new file mode 100644 (file)
index 0000000..e4049d6
--- /dev/null
@@ -0,0 +1,36 @@
+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
diff --git a/code/SystemTag/page.coretag b/code/SystemTag/page.coretag
new file mode 100644 (file)
index 0000000..ff7a5e8
--- /dev/null
@@ -0,0 +1,6 @@
+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
diff --git a/code/SystemTag/perl.coretag b/code/SystemTag/perl.coretag
new file mode 100644 (file)
index 0000000..dbe4dcc
--- /dev/null
@@ -0,0 +1,7 @@
+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
diff --git a/code/SystemTag/price.coretag b/code/SystemTag/price.coretag
new file mode 100644 (file)
index 0000000..e69f2db
--- /dev/null
@@ -0,0 +1,13 @@
+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
diff --git a/code/SystemTag/process.coretag b/code/SystemTag/process.coretag
new file mode 100644 (file)
index 0000000..b0b9128
--- /dev/null
@@ -0,0 +1,15 @@
+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
diff --git a/code/SystemTag/profile.coretag b/code/SystemTag/profile.coretag
new file mode 100644 (file)
index 0000000..a30a573
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag profile             Order        name
+UserTag profile             addAttr
+UserTag profile             InvalidateCache
+UserTag profile             PosNumber    1
+UserTag profile             MapRoutine   Vend::Interpolate::tag_profile
diff --git a/code/SystemTag/query.coretag b/code/SystemTag/query.coretag
new file mode 100644 (file)
index 0000000..60f02b7
--- /dev/null
@@ -0,0 +1,6 @@
+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
diff --git a/code/SystemTag/read_cookie.coretag b/code/SystemTag/read_cookie.coretag
new file mode 100644 (file)
index 0000000..b67d29f
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag read-cookie         Order        name
+UserTag read-cookie         InvalidateCache
+UserTag read-cookie         MapRoutine   Vend::Util::read_cookie
diff --git a/code/SystemTag/record.coretag b/code/SystemTag/record.coretag
new file mode 100644 (file)
index 0000000..e9d5caf
--- /dev/null
@@ -0,0 +1,48 @@
+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
diff --git a/code/SystemTag/region.coretag b/code/SystemTag/region.coretag
new file mode 100644 (file)
index 0000000..aefdb3b
--- /dev/null
@@ -0,0 +1,7 @@
+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
diff --git a/code/SystemTag/row.coretag b/code/SystemTag/row.coretag
new file mode 100644 (file)
index 0000000..ec6c757
--- /dev/null
@@ -0,0 +1,198 @@
+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
diff --git a/code/SystemTag/salestax.coretag b/code/SystemTag/salestax.coretag
new file mode 100644 (file)
index 0000000..e02badd
--- /dev/null
@@ -0,0 +1,10 @@
+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
diff --git a/code/SystemTag/scratch.coretag b/code/SystemTag/scratch.coretag
new file mode 100644 (file)
index 0000000..c0bbe88
--- /dev/null
@@ -0,0 +1,9 @@
+UserTag scratch             Order        name
+UserTag scratch             InvalidateCache
+UserTag scratch             PosNumber    1
+UserTag scratch             Routine <<EOR
+sub {
+       my $var = shift;
+    return $::Scratch->{$var};
+}
+EOR
diff --git a/code/SystemTag/scratchd.coretag b/code/SystemTag/scratchd.coretag
new file mode 100644 (file)
index 0000000..ff78fd0
--- /dev/null
@@ -0,0 +1,9 @@
+UserTag scratchd            Order        name
+UserTag scratchd            InvalidateCache
+UserTag scratchd            PosNumber    1
+UserTag scratchd            Routine <<EOR
+sub {
+       my $var = shift;
+       return delete $::Scratch->{$var};
+}
+EOR
diff --git a/code/SystemTag/search_region.coretag b/code/SystemTag/search_region.coretag
new file mode 100644 (file)
index 0000000..5e21d02
--- /dev/null
@@ -0,0 +1,8 @@
+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
diff --git a/code/SystemTag/selected.coretag b/code/SystemTag/selected.coretag
new file mode 100644 (file)
index 0000000..55545fd
--- /dev/null
@@ -0,0 +1,30 @@
+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
diff --git a/code/SystemTag/set.coretag b/code/SystemTag/set.coretag
new file mode 100644 (file)
index 0000000..d886489
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag set                 Order        name
+UserTag set                 hasEndTag
+UserTag set                 InvalidateCache
+UserTag set                 PosNumber    1
+UserTag set                 MapRoutine   Vend::Interpolate::set_scratch
diff --git a/code/SystemTag/set_cookie.coretag b/code/SystemTag/set_cookie.coretag
new file mode 100644 (file)
index 0000000..09ce0ea
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag set-cookie          Order        name value expire domain path
+UserTag set-cookie          InvalidateCache
+UserTag set-cookie          MapRoutine   Vend::Util::set_cookie
diff --git a/code/SystemTag/seti.coretag b/code/SystemTag/seti.coretag
new file mode 100644 (file)
index 0000000..0eea4c5
--- /dev/null
@@ -0,0 +1,6 @@
+UserTag seti                Order        name
+UserTag seti                hasEndTag
+UserTag seti                Interpolate
+UserTag seti                InvalidateCache
+UserTag seti                PosNumber    1
+UserTag seti                MapRoutine   Vend::Interpolate::set_scratch
diff --git a/code/SystemTag/setlocale.coretag b/code/SystemTag/setlocale.coretag
new file mode 100644 (file)
index 0000000..9e72314
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag setlocale           Order        locale currency
+UserTag setlocale           addAttr
+UserTag setlocale           PosNumber    2
+UserTag setlocale           MapRoutine   Vend::Util::setlocale
diff --git a/code/SystemTag/shipping.coretag b/code/SystemTag/shipping.coretag
new file mode 100644 (file)
index 0000000..da84292
--- /dev/null
@@ -0,0 +1,9 @@
+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
diff --git a/code/SystemTag/shipping_desc.coretag b/code/SystemTag/shipping_desc.coretag
new file mode 100644 (file)
index 0000000..e7b5281
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag shipping-desc       Order        mode
+UserTag shipping-desc       PosNumber    1
+UserTag shipping-desc       MapRoutine   Vend::Interpolate::tag_shipping_desc
diff --git a/code/SystemTag/soap.coretag b/code/SystemTag/soap.coretag
new file mode 100644 (file)
index 0000000..e4b6d16
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag soap                Order        call uri proxy
+UserTag soap                addAttr
+UserTag soap                InvalidateCache
+UserTag soap                PosNumber    3
+UserTag soap                MapRoutine   Vend::SOAP::tag_soap
diff --git a/code/SystemTag/sql.coretag b/code/SystemTag/sql.coretag
new file mode 100644 (file)
index 0000000..127ab4a
--- /dev/null
@@ -0,0 +1,6 @@
+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
diff --git a/code/SystemTag/strip.coretag b/code/SystemTag/strip.coretag
new file mode 100644 (file)
index 0000000..4e0c062
--- /dev/null
@@ -0,0 +1,10 @@
+UserTag strip               hasEndTag
+UserTag strip               PosNumber    0
+UserTag strip               Routine      <<EOR
+sub {
+       local($_) = shift;
+       s/^\s+//;
+       s/\s+$//;
+       return $_;
+}
+EOR
diff --git a/code/SystemTag/subtotal.coretag b/code/SystemTag/subtotal.coretag
new file mode 100644 (file)
index 0000000..45538ee
--- /dev/null
@@ -0,0 +1,10 @@
+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
diff --git a/code/SystemTag/tag.coretag b/code/SystemTag/tag.coretag
new file mode 100644 (file)
index 0000000..1440217
--- /dev/null
@@ -0,0 +1,6 @@
+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
diff --git a/code/SystemTag/time.coretag b/code/SystemTag/time.coretag
new file mode 100644 (file)
index 0000000..6a2233e
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag time                Order        locale
+UserTag time                addAttr
+UserTag time                hasEndTag
+UserTag time                PosNumber    1
+UserTag time                MapRoutine   Vend::Interpolate::mvtime
diff --git a/code/SystemTag/timed_build.coretag b/code/SystemTag/timed_build.coretag
new file mode 100644 (file)
index 0000000..1d7fb66
--- /dev/null
@@ -0,0 +1,6 @@
+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
diff --git a/code/SystemTag/tmp.coretag b/code/SystemTag/tmp.coretag
new file mode 100644 (file)
index 0000000..3a75892
--- /dev/null
@@ -0,0 +1,6 @@
+UserTag tmp                 Order        name
+UserTag tmp                 hasEndTag
+UserTag tmp                 Interpolate
+UserTag tmp                 InvalidateCache
+UserTag tmp                 PosNumber    1
+UserTag tmp                 MapRoutine   Vend::Interpolate::set_tmp
diff --git a/code/SystemTag/total_cost.coretag b/code/SystemTag/total_cost.coretag
new file mode 100644 (file)
index 0000000..8856edf
--- /dev/null
@@ -0,0 +1,10 @@
+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
diff --git a/code/SystemTag/tree.coretag b/code/SystemTag/tree.coretag
new file mode 100644 (file)
index 0000000..bf37588
--- /dev/null
@@ -0,0 +1,167 @@
+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
diff --git a/code/SystemTag/try.coretag b/code/SystemTag/try.coretag
new file mode 100644 (file)
index 0000000..06cf5ab
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag try                 Order        label
+UserTag try                 addAttr
+UserTag try                 hasEndTag
+UserTag try                 PosNumber    1
+UserTag try                 MapRoutine   Vend::Interpolate::try
diff --git a/code/SystemTag/update.coretag b/code/SystemTag/update.coretag
new file mode 100644 (file)
index 0000000..f190a19
--- /dev/null
@@ -0,0 +1,4 @@
+UserTag update              Order        function
+UserTag update              addAttr
+UserTag update              InvalidateCache
+UserTag update              MapRoutine   Vend::Interpolate::update
diff --git a/code/SystemTag/userdb.coretag b/code/SystemTag/userdb.coretag
new file mode 100644 (file)
index 0000000..20ad409
--- /dev/null
@@ -0,0 +1,7 @@
+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
diff --git a/code/SystemTag/value.coretag b/code/SystemTag/value.coretag
new file mode 100644 (file)
index 0000000..60811a3
--- /dev/null
@@ -0,0 +1,5 @@
+UserTag value               Order        name
+UserTag value               addAttr
+UserTag value               InvalidateCache
+UserTag value               PosNumber    1
+UserTag value               MapRoutine   Vend::Interpolate::tag_value
diff --git a/code/SystemTag/value_extended.coretag b/code/SystemTag/value_extended.coretag
new file mode 100644 (file)
index 0000000..1728963
--- /dev/null
@@ -0,0 +1,5 @@
+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
diff --git a/code/SystemTag/warnings.coretag b/code/SystemTag/warnings.coretag
new file mode 100644 (file)
index 0000000..b5414ac
--- /dev/null
@@ -0,0 +1,27 @@
+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
diff --git a/code/UI_Tag/add_gpg_key.coretag b/code/UI_Tag/add_gpg_key.coretag
new file mode 100644 (file)
index 0000000..5506414
--- /dev/null
@@ -0,0 +1,57 @@
+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
diff --git a/code/UI_Tag/available_ups_internal.coretag b/code/UI_Tag/available_ups_internal.coretag
new file mode 100644 (file)
index 0000000..05effcd
--- /dev/null
@@ -0,0 +1,13 @@
+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
diff --git a/code/UI_Tag/available_www_shipping.coretag b/code/UI_Tag/available_www_shipping.coretag
new file mode 100644 (file)
index 0000000..d83c7aa
--- /dev/null
@@ -0,0 +1,75 @@
+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
diff --git a/code/UI_Tag/backup_database.coretag b/code/UI_Tag/backup_database.coretag
new file mode 100644 (file)
index 0000000..f981aba
--- /dev/null
@@ -0,0 +1,221 @@
+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
diff --git a/code/UI_Tag/backup_file.coretag b/code/UI_Tag/backup_file.coretag
new file mode 100644 (file)
index 0000000..19327bd
--- /dev/null
@@ -0,0 +1,36 @@
+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
diff --git a/code/UI_Tag/base_url.coretag b/code/UI_Tag/base_url.coretag
new file mode 100644 (file)
index 0000000..ffb1b3c
--- /dev/null
@@ -0,0 +1 @@
+UserTag base-url Routine sub { return $Vend::Cfg->{VendURL} }
diff --git a/code/UI_Tag/check_upload.coretag b/code/UI_Tag/check_upload.coretag
new file mode 100644 (file)
index 0000000..7badcd5
--- /dev/null
@@ -0,0 +1,19 @@
+
+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
+
diff --git a/code/UI_Tag/component_editor.coretag b/code/UI_Tag/component_editor.coretag
new file mode 100644 (file)
index 0000000..968bc65
--- /dev/null
@@ -0,0 +1,193 @@
+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
diff --git a/code/UI_Tag/cp.coretag b/code/UI_Tag/cp.coretag
new file mode 100644 (file)
index 0000000..e992262
--- /dev/null
@@ -0,0 +1,18 @@
+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
diff --git a/code/UI_Tag/crypt.coretag b/code/UI_Tag/crypt.coretag
new file mode 100644 (file)
index 0000000..77a4046
--- /dev/null
@@ -0,0 +1,7 @@
+UserTag crypt Order value
+UserTag crypt Routine <<EOR
+sub {
+       return crypt(shift, Vend::Util::random_string(2))
+}
+EOR
+
diff --git a/code/UI_Tag/db_columns.coretag b/code/UI_Tag/db_columns.coretag
new file mode 100644 (file)
index 0000000..8712e8c
--- /dev/null
@@ -0,0 +1,53 @@
+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
+
diff --git a/code/UI_Tag/db_hash.coretag b/code/UI_Tag/db_hash.coretag
new file mode 100644 (file)
index 0000000..b04d922
--- /dev/null
@@ -0,0 +1,54 @@
+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
diff --git a/code/UI_Tag/dbinfo.coretag b/code/UI_Tag/dbinfo.coretag
new file mode 100644 (file)
index 0000000..59b5cca
--- /dev/null
@@ -0,0 +1,93 @@
+# 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
+
diff --git a/code/UI_Tag/diff.coretag b/code/UI_Tag/diff.coretag
new file mode 100644 (file)
index 0000000..6ce8a27
--- /dev/null
@@ -0,0 +1,52 @@
+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
diff --git a/code/UI_Tag/diffmerge.coretag b/code/UI_Tag/diffmerge.coretag
new file mode 100644 (file)
index 0000000..067b098
--- /dev/null
@@ -0,0 +1,120 @@
+# 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
diff --git a/code/UI_Tag/directive_value.coretag b/code/UI_Tag/directive_value.coretag
new file mode 100644 (file)
index 0000000..ad12a62
--- /dev/null
@@ -0,0 +1,15 @@
+
+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
+
diff --git a/code/UI_Tag/display.coretag b/code/UI_Tag/display.coretag
new file mode 100644 (file)
index 0000000..a7eec05
--- /dev/null
@@ -0,0 +1,91 @@
+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
+
diff --git a/code/UI_Tag/dump_session.coretag b/code/UI_Tag/dump_session.coretag
new file mode 100644 (file)
index 0000000..ac1b803
--- /dev/null
@@ -0,0 +1,36 @@
+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
diff --git a/code/UI_Tag/e.coretag b/code/UI_Tag/e.coretag
new file mode 100644 (file)
index 0000000..964daf8
--- /dev/null
@@ -0,0 +1,8 @@
+UserTag e HasEndTag
+UserTag e Routine <<EOR
+sub {
+       my $text = shift;
+       HTML::Entities::encode($text);
+}
+EOR
+
diff --git a/code/UI_Tag/export_database.coretag b/code/UI_Tag/export_database.coretag
new file mode 100644 (file)
index 0000000..4b4f9d0
--- /dev/null
@@ -0,0 +1,37 @@
+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
+
diff --git a/code/UI_Tag/file_info.coretag b/code/UI_Tag/file_info.coretag
new file mode 100644 (file)
index 0000000..2934556
--- /dev/null
@@ -0,0 +1,48 @@
+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
+
diff --git a/code/UI_Tag/file_navigator.coretag b/code/UI_Tag/file_navigator.coretag
new file mode 100644 (file)
index 0000000..b7c0ec7
--- /dev/null
@@ -0,0 +1,312 @@
+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
diff --git a/code/UI_Tag/filters.coretag b/code/UI_Tag/filters.coretag
new file mode 100644 (file)
index 0000000..64ccc61
--- /dev/null
@@ -0,0 +1,59 @@
+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
diff --git a/code/UI_Tag/get_gpg_keys.coretag b/code/UI_Tag/get_gpg_keys.coretag
new file mode 100644 (file)
index 0000000..a77a13d
--- /dev/null
@@ -0,0 +1,36 @@
+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
diff --git a/code/UI_Tag/global_value.coretag b/code/UI_Tag/global_value.coretag
new file mode 100644 (file)
index 0000000..d8ecc1d
--- /dev/null
@@ -0,0 +1,9 @@
+UserTag  global-value  Order  name
+UserTag  global-value  Routine <<EOR
+sub {
+       no strict 'refs';
+       defined ${$_[0]} and return ${$_[0]};
+       return '';
+}
+EOR
+
diff --git a/code/UI_Tag/grep_mm.coretag b/code/UI_Tag/grep_mm.coretag
new file mode 100644 (file)
index 0000000..3f2ce26
--- /dev/null
@@ -0,0 +1,16 @@
+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
+
diff --git a/code/UI_Tag/if_key_exists.coretag b/code/UI_Tag/if_key_exists.coretag
new file mode 100644 (file)
index 0000000..c81e48c
--- /dev/null
@@ -0,0 +1,19 @@
+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
+
diff --git a/code/UI_Tag/if_mm.coretag b/code/UI_Tag/if_mm.coretag
new file mode 100644 (file)
index 0000000..ecd777e
--- /dev/null
@@ -0,0 +1,156 @@
+
+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
+
diff --git a/code/UI_Tag/if_sql.coretag b/code/UI_Tag/if_sql.coretag
new file mode 100644 (file)
index 0000000..d37cf8d
--- /dev/null
@@ -0,0 +1,13 @@
+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
+
diff --git a/code/UI_Tag/image_collate.coretag b/code/UI_Tag/image_collate.coretag
new file mode 100644 (file)
index 0000000..f34109f
--- /dev/null
@@ -0,0 +1,204 @@
+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
+
diff --git a/code/UI_Tag/import_fields.coretag b/code/UI_Tag/import_fields.coretag
new file mode 100644 (file)
index 0000000..b4e0204
--- /dev/null
@@ -0,0 +1,275 @@
+
+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
+
diff --git a/code/UI_Tag/list_databases.coretag b/code/UI_Tag/list_databases.coretag
new file mode 100644 (file)
index 0000000..7f2dacc
--- /dev/null
@@ -0,0 +1,39 @@
+
+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
+
diff --git a/code/UI_Tag/list_glob.coretag b/code/UI_Tag/list_glob.coretag
new file mode 100644 (file)
index 0000000..987be38
--- /dev/null
@@ -0,0 +1,9 @@
+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
+
diff --git a/code/UI_Tag/list_keys.coretag b/code/UI_Tag/list_keys.coretag
new file mode 100644 (file)
index 0000000..91d74e0
--- /dev/null
@@ -0,0 +1,68 @@
+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
+
diff --git a/code/UI_Tag/list_pages.coretag b/code/UI_Tag/list_pages.coretag
new file mode 100644 (file)
index 0000000..e35ff39
--- /dev/null
@@ -0,0 +1,19 @@
+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
+
diff --git a/code/UI_Tag/load_templates.coretag b/code/UI_Tag/load_templates.coretag
new file mode 100644 (file)
index 0000000..a4cc318
--- /dev/null
@@ -0,0 +1,90 @@
+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
diff --git a/code/UI_Tag/meta_record.coretag b/code/UI_Tag/meta_record.coretag
new file mode 100644 (file)
index 0000000..0c59d90
--- /dev/null
@@ -0,0 +1,3 @@
+UserTag meta-record Order item view source
+UserTag meta-record attrAlias  table item
+UserTag meta-record MapRoutine UI::Primitive::meta_record
diff --git a/code/UI_Tag/mm_locale.coretag b/code/UI_Tag/mm_locale.coretag
new file mode 100644 (file)
index 0000000..cf3e2d5
--- /dev/null
@@ -0,0 +1,20 @@
+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
\ No newline at end of file
diff --git a/code/UI_Tag/mm_value.coretag b/code/UI_Tag/mm_value.coretag
new file mode 100644 (file)
index 0000000..506303d
--- /dev/null
@@ -0,0 +1,46 @@
+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
+
diff --git a/code/UI_Tag/newer.coretag b/code/UI_Tag/newer.coretag
new file mode 100644 (file)
index 0000000..d406065
--- /dev/null
@@ -0,0 +1,30 @@
+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
+
diff --git a/code/UI_Tag/quick_table.coretag b/code/UI_Tag/quick_table.coretag
new file mode 100644 (file)
index 0000000..d37d6ce
--- /dev/null
@@ -0,0 +1,25 @@
+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
+
diff --git a/code/UI_Tag/read_page.coretag b/code/UI_Tag/read_page.coretag
new file mode 100644 (file)
index 0000000..74b4d8a
--- /dev/null
@@ -0,0 +1,268 @@
+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
diff --git a/code/UI_Tag/read_shipping.coretag b/code/UI_Tag/read_shipping.coretag
new file mode 100644 (file)
index 0000000..940ddd4
--- /dev/null
@@ -0,0 +1,20 @@
+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
+
diff --git a/code/UI_Tag/read_ui_page.coretag b/code/UI_Tag/read_ui_page.coretag
new file mode 100644 (file)
index 0000000..cd6f6cd
--- /dev/null
@@ -0,0 +1,234 @@
+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
diff --git a/code/UI_Tag/read_ui_template.coretag b/code/UI_Tag/read_ui_template.coretag
new file mode 100644 (file)
index 0000000..88e0559
--- /dev/null
@@ -0,0 +1,184 @@
+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
diff --git a/code/UI_Tag/reconfig.coretag b/code/UI_Tag/reconfig.coretag
new file mode 100644 (file)
index 0000000..9c5ad74
--- /dev/null
@@ -0,0 +1,22 @@
+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
+
diff --git a/code/UI_Tag/reconfig_time.coretag b/code/UI_Tag/reconfig_time.coretag
new file mode 100644 (file)
index 0000000..9a0d9b3
--- /dev/null
@@ -0,0 +1,11 @@
+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
+
+
diff --git a/code/UI_Tag/reconfig_wait.coretag b/code/UI_Tag/reconfig_wait.coretag
new file mode 100644 (file)
index 0000000..5bc71b7
--- /dev/null
@@ -0,0 +1,21 @@
+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
+
diff --git a/code/UI_Tag/regenerate.coretag b/code/UI_Tag/regenerate.coretag
new file mode 100644 (file)
index 0000000..ab5ee9b
--- /dev/null
@@ -0,0 +1,366 @@
+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
diff --git a/code/UI_Tag/return_to.coretag b/code/UI_Tag/return_to.coretag
new file mode 100644 (file)
index 0000000..1471f17
--- /dev/null
@@ -0,0 +1,94 @@
+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
+
diff --git a/code/UI_Tag/rotate_file.coretag b/code/UI_Tag/rotate_file.coretag
new file mode 100644 (file)
index 0000000..065b970
--- /dev/null
@@ -0,0 +1,9 @@
+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
+