Interchange Reference Pages: Tags

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: accessories.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

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         Version      $Revision: 1.4 $
UserTag accessories         MapRoutine   Vend::Interpolate::tag_accessories

sub tag_accessories {
my($code,$extra,$opt,$item) = @_;

my $ishash;
if(ref $item) {
#::logDebug("tag_accessories: item is a hash");
  $ishash = 1;
}

# Had extra if got here
#::logDebug("tag_accessories: code=$code opt=" . uneval_it($opt) . " item=" \
 . uneval_it($item) . " extra=$extra");
my($attribute, $type, $field, $db, $name, $outboard, $passed);
$opt = {} if ! $opt;
if($extra) {
  $extra =~ s/^\s+//;
  $extra =~ s/\s+$//;
  @{$opt}{qw/attribute type column table name outboard passed/} =
    split /\s*,\s*/, $extra;
}
($attribute, $type, $field, $db, $name, $outboard, $passed) = 
  @{$opt}{qw/attribute type column table name outboard passed/};

## Code only passed when we are a product
if($code) {
  GETACC: {
    my $col =  $opt->{column} || $opt->{attribute};
    my $key = $opt->{outboard} || $code;
    last GETACC if ! $col;
    if($opt->{table}) {
      $opt->{passed} ||= tag_data($opt->{table}, $col, $key);
    }
    else {
      $opt->{passed} ||= product_field($col, $key);
    }
  }

  return unless $opt->{passed} || $opt->{type};
  $opt->{type} ||= 'select';
  return unless
    $opt->{passed}
      or
    $opt->{type} =~ /^(text|password|hidden)/i;
}

return Vend::Form::display($opt, $item);
}

sub tag_accessories {
my($code,$extra,$opt,$item) = @_;

my $ishash;
if(ref $item) {
#::logDebug("tag_accessories: item is a hash");
  $ishash = 1;
}

# Had extra if got here
#::logDebug("tag_accessories: code=$code opt=" . uneval_it($opt) . " item=" \
 . uneval_it($item) . " extra=$extra");
my($attribute, $type, $field, $db, $name, $outboard, $passed);
$opt = {} if ! $opt;
if($extra) {
  $extra =~ s/^\s+//;
  $extra =~ s/\s+$//;
  @{$opt}{qw/attribute type column table name outboard passed/} =
    split /\s*,\s*/, $extra;
}
($attribute, $type, $field, $db, $name, $outboard, $passed) = 
  @{$opt}{qw/attribute type column table name outboard passed/};

## Code only passed when we are a product
if($code) {
  GETACC: {
    my $col =  $opt->{column} || $opt->{attribute};
    my $key = $opt->{outboard} || $code;
    last GETACC if ! $col;
    if($opt->{table}) {
      $opt->{passed} ||= tag_data($opt->{table}, $col, $key);
    }
    else {
      $opt->{passed} ||= product_field($col, $key);
    }
  }

  return unless $opt->{passed} || $opt->{type};
  $opt->{type} ||= 'select';
  return unless
    $opt->{passed}
      or
    $opt->{type} =~ /^(text|password|hidden)/i;
}

return Vend::Form::display($opt, $item);
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: accounting.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag accounting Order   function
UserTag accounting addAttr
UserTag accounting Version $Revision: 1.5 $
UserTag accounting Routine <<EOR
my %account_super = (qw/
noparts_update 1
/);
my %account_admin = (qw/
inventory_update 1
/);

sub {
my ($func, $opt) = @_;

use vars qw/$Tag/;
die "Accounting not enabled!"
  unless $Vend::Cfg->{Accounting};

my $enable;
if($account_super{$func}) {
  eval {
    $enable = $Vend::admin && $Tag->if_mm('super');
  };
}
elsif($account_admin{$func}) {
  $enable = $Vend::admin;
}
else {
  $enable = 1;
}

if(! $enable) {
  die errmsg("Function '%s' not enabled for current user level.", $func);
}

if(my $sys = $opt->{system}) {
  my $former = $Vend::Cfg->{Accounting};
  $Vend::Cfg->{Accounting} = $Vend::Cfg->{Accounting_repository}{$sys}
    or do {
      logError(
        "Failed to change accounting system to %s, returning to %s.",
        $opt->{system},
        $former->{Class},
      );
      $Vend::Cfg->{Accounting} = $former;
      return undef;
    };
}

my $a = $Vend::Cfg->{Accounting} 
  or do {
    logError("No accounting system present. Aborting.");
    return undef;
  };

my $class = $a->{Class};
my $self = new $class;
my $can;
unless( $can = $self->can($func) ) {
  logError(
    "No function '%s' in accounting system %s. Aborting.",
    $func,
    $class,
  );
  return undef;
}

return $can if $opt->{can_do_function};

return $self->$func($opt);
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: add_gpg_key.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag add-gpg-key Order   name
UserTag add-gpg-key addAttr
UserTag add-gpg-key Version $Revision: 1.6 $
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\s+(\w+)\s*:\s+(public\s+key|)(.*)(imported|not\s+changed)/i;
    $id = $1;
    last;
  }
  close GETGPGID;
  return $id || 'Failed ID get?';
  
}
elsif (defined $opt->{success}) {
  return $opt->{success};
}
else {
  return 1;
}
}
EOR

sub tag_address {
my ($count, $item, $hash, $opt, $body) = @_;
#::logDebug("in ship_address");
return pull_else($body) if defined $opt->{if} and ! $opt->{if};
return pull_else($body) if ! $Vend::username || ! $Vend::Session->{logged_in};
#::logDebug("logged in with usernam=$Vend::username");

my $tag = 'address';
my $attr = 'mv_ad';
my $nattr = 'mv_an';
my $pre = '';
if($opt->{billing}) {
  $tag = 'b_address';
  $attr = 'mv_bd';
  $nattr = 'mv_bn';
  $pre = 'b_';
}

#  if($item->{$attr} and ! $opt->{set}) {
#    my $pre = $opt->{prefix};
#    $pre =~ s/[-_]/[-_]/g;
#    $body =~ s:\[$pre\]($Some)\[/$pre\]:$item->{$attr}:g;
#    return pull_if($body);
#  }

my $nick = $opt->{nick} || $opt->{nickname} || $item->{$nattr};

#::logDebug("nick=$nick");

my $user;
if(not $user = $Vend::user_object) {
   $user = new Vend::UserDB username => ($opt->{username} || $Vend::username);
}
#::logDebug("user=$user");
! $user and return pull_else($body);

my $blob = $user->get_hash('SHIPPING')   or return pull_else($body);
#::logDebug("blob=$blob");
my $addr = $blob->{$nick};

if (! $addr) {
  %$addr = %{ $::Values };
}

#::logDebug("addr=" . uneval($addr));

$addr->{mv_an} = $nick;
my @nick = sort keys %$blob;
my $label;
if($label = $opt->{address_label}) {
  @nick = sort { $blob->{$a}{$label} cmp  $blob->{$a}{$label} } @nick;
  @nick = map { "$_=" . ($blob->{$_}{$label} || $_) } @nick;
  for(@nick) {
    s/,/,/g;
  }
}
$opt->{blank} = '--select--' unless $opt->{blank};
unshift(@nick, "=$opt->{blank}");
$opt->{address_book} = join ",", @nick
  unless $opt->{address_book};

my $joiner = get_joiner($opt->{joiner}, "<br$Vend::Xtrailer>");
if(! $opt->{no_address}) {
  my @vals = map { $addr->{$_} }
        grep /^address_?\d*$/ && length($addr->{$_}), keys %$addr;
  $addr->{address} = join $joiner, @vals;
}

if($opt->{widget}) {
  $addr->{address_book} = tag_accessories(
                $item->{code},
                undef,
                {
                  attribute => $nattr,
                  type => $opt->{widget},
                  passed => $opt->{address_book},
                  form => $opt->{form},
                },
                $item
                );
}

if($opt->{set} || ! $item->{$attr}) {
  my $template = '';
  if($::Variable->{MV_SHIP_ADDRESS_TEMPLATE}) {
    $template .= $::Variable->{MV_SHIP_ADDRESS_TEMPLATE};
  }
  else {
    $template .= "{company}\n" if $addr->{"${pre}company"};
    $template .= <<EOF;
{address}
{city}, {state} {zip} 
{country} -- {phone_day}
EOF
  }
  $template =~ s/{(\w+.*?)}/{$pre$1}/g if $pre;
  $addr->{mv_ad} = $item->{$attr} = tag_attr_list($template, $addr);
}
else {
  $addr->{mv_ad} = $item->{$attr};
}

if($opt->{textarea}) {
  $addr->{textarea} = tag_accessories(
                $item->{code},
                undef,
                {
                  attribute => $attr,
                  type => 'textarea',
                  rows => $opt->{rows} || '4',
                  cols => $opt->{cols} || '40',
                },
                $item
                );
}

$body =~ s:\[$tag\]($Some)\[/$tag\]:tag_attr_list($1, $addr):eg;
return pull_if($body);
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: area.coretag,v 1.6 2007-09-21 16:15:48 kwalsh Exp $

UserTag href Alias        area

UserTag area Order        href arg
UserTag area addAttr
UserTag area Implicit     secure secure
UserTag area PosNumber    2
UserTag area Version      $Revision: 1.6 $
UserTag area MapRoutine   Vend::Interpolate::tag_area

sub tag_area {
  ($page, $arg, $opt) = @_;

$page = '' if ! defined $page;

if( $page and $opt->{alias}) {
  my $aloc = $opt->{once} ? 'one_time_path_alias' : 'path_alias';
  $Vend::Session->{$aloc}{$page} = {}
    if not defined $Vend::Session->{path_alias}{$page};
  $Vend::Session->{$aloc}{$page} = $opt->{alias};
}

my ($r, $subname);

if ($opt->{search}) {
  $page = escape_scan($opt->{search});
}
elsif ($page =~ /^[a-z][a-z]+:/) {
  ### Javascript or absolute link
  return $page unless $opt->{form};
  $page =~ s{(\w+://[^/]+)/}{}
    or return $page;
  my $intro = $1;
  my @pieces = split m{/}, $page, 9999;
  $page = pop(@pieces);
  if(! length($page)) {
    $page = pop(@pieces);
    if(! length($page)) {
      $r = $intro;
      $r =~ s{/([^/]+)}{};
      $page = "$1/";
    }
    else {
      $page .= "/";
    }
  }
  $r = join "/", $intro, @pieces unless $r;
  $opt->{add_dot_html} = 0;
  $opt->{no_session} = 1;
  $opt->{secure} = 0;
  $opt->{no_count} = 1;
}
elsif ($page eq 'scan') {
  $page = escape_scan($arg);
  undef $arg;
}

elsif ($subname = $Vend::Cfg->{SpecialSub}{areapage}) {
          my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
          my $newpage = $sub->($page, $opt);
          $page = $newpage if defined $newpage;
          $arg = $opt->{arg};
      }

$urlroutine = $opt->{secure} ? \&secure_vendUrl : \&vendUrl;

return $urlroutine->($page, $arg, undef, $opt);
}

sub tag_area {
  ($page, $arg, $opt) = @_;

$page = '' if ! defined $page;

if( $page and $opt->{alias}) {
  my $aloc = $opt->{once} ? 'one_time_path_alias' : 'path_alias';
  $Vend::Session->{$aloc}{$page} = {}
    if not defined $Vend::Session->{path_alias}{$page};
  $Vend::Session->{$aloc}{$page} = $opt->{alias};
}

my ($r, $subname);

if ($opt->{search}) {
  $page = escape_scan($opt->{search});
}
elsif ($page =~ /^[a-z][a-z]+:/) {
  ### Javascript or absolute link
  return $page unless $opt->{form};
  $page =~ s{(\w+://[^/]+)/}{}
    or return $page;
  my $intro = $1;
  my @pieces = split m{/}, $page, 9999;
  $page = pop(@pieces);
  if(! length($page)) {
    $page = pop(@pieces);
    if(! length($page)) {
      $r = $intro;
      $r =~ s{/([^/]+)}{};
      $page = "$1/";
    }
    else {
      $page .= "/";
    }
  }
  $r = join "/", $intro, @pieces unless $r;
  $opt->{add_dot_html} = 0;
  $opt->{no_session} = 1;
  $opt->{secure} = 0;
  $opt->{no_count} = 1;
}
elsif ($page eq 'scan') {
  $page = escape_scan($arg);
  undef $arg;
}

elsif ($subname = $Vend::Cfg->{SpecialSub}{areapage}) {
          my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
          my $newpage = $sub->($page, $opt);
          $page = $newpage if defined $newpage;
          $arg = $opt->{arg};
      }

$urlroutine = $opt->{secure} ? \&secure_vendUrl : \&vendUrl;

return $urlroutine->($page, $arg, undef, $opt);
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: assign.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag assign              addAttr
UserTag assign              PosNumber    0
UserTag assign              Version      $Revision: 1.5 $
UserTag assign              Routine      <<EOR
my %_assignable = (qw/
      salestax  1
      shipping  1
      handling  1
      subtotal  1
      credit    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 {
          if ($value) {
        logError(
          "Attempted assign of non-numeric '%s' to %s. Deleted.",
          $value,
          $_,
        );
          }
    delete $Vend::Session->{assigned}{$_};
  }
}
return;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: assume_identity.tag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag assume-identity   Order        file locale
UserTag assume-identity   addAttr
UserTag assume-identity   PosNumber    2
UserTag assume-identity   Version      $Revision: 1.5 $
UserTag assume-identity   Routine      <<EOR
sub {
my ($file, $locale, $opt) = @_;
my $pn;
if($opt and $opt->{name}) {
$pn = $opt->{name};
}
else {
$pn = $file;
$pn =~ s/\.\w+$//;
$pn =~ s:^pages/::;
}
$Global::Variable->{MV_PAGE} = $pn;
$locale = 1 unless defined $locale;
return Vend::Interpolate::interpolate_html(
Vend::Util::readfile($file, undef, $locale)
);
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: attr_list.coretag,v 1.8 2008-07-12 19:27:12 docelic Exp $

UserTag attr_list           addAttr
UserTag attr_list           hasEndTag
UserTag attr_list           PosNumber    0
UserTag attr_list           noRearrange
UserTag attr_list           Version      $Revision: 1.8 $
UserTag attr_list           Routine      <<EOR
sub {
my ($opt, $body) = @_;
if( ref $opt->{hash} ) {
  $opt = $opt->{hash};
}
return Vend::Interpolate::tag_attr_list($body, $opt);
}
EOR

No extracted context

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: auto_wizard.coretag,v 1.20 2007-03-30 23:40:54 pajamian Exp $

UserTag  auto-wizard  Order     name
UserTag  auto-wizard  AddAttr
UserTag  auto-wizard  HasEndTag
UserTag  auto-wizard  Version   $Revision: 1.20 $
UserTag  auto-wizard  Routine   <<EOR

use vars qw/$Session $Tag $CGI $Tmp $Scratch $Values $ready_safe/;
 
my @wanted_opts = qw/
 already_message
 already_title
 bottom_buttons
 break_row_class
 combo_row_class
 data_cell_class
 data_row_class
 display_type
 help_cell_class
 intro_text
 label_cell_class
 left_width
 output_type
 spacer_row_class
 table_width
 thanks_message
 thanks_title
 top_buttons
 widget_cell_class
 email_from
 email_cc
 email_subject
 email_template
 continue_template
 row_template
 output_email
 output_fields
 output_repeated
/;

my %overall_opt;
@overall_opt{@wanted_opts} = @wanted_opts;

sub thanks_title {
 my ($opt, $already, $default) = @_;
 my $tt = $already
     ?  ($opt->{already_title} ||= "You already did that survey!" )
     :  ($opt->{thanks_title} ||= $default || "Thanks for completing the survey!");
 return errmsg($tt);
}

sub thanks_message {
 my ($opt, $already) = @_;
 my $tm;
 if($already) {
   $opt->{already_message} ||=
     "We only want to collect information once from each person. Thank you.";
   $tm = $opt->{already_message};
 }
 else {
   $opt->{thanks_message} ||= "Your survey is complete. Thank you.";
   $tm = $opt->{thanks_message};
 }
 return errmsg($tm);
 $opt->{intro_text} .= "<h1>$tm</h1>" if $already;
}

sub title_and_message {
 my ($opt, $already) = @_;
 my $tt = thanks_title($opt, $already);
 my $tm = thanks_message($opt, $already);
 return (
       '',
       "final: $tt",
       'template: <<EOF',
       $tm,
       'EOF',
     );
}

sub already {
 my ($wizname, $set) = @_;
 my $surv = $Vend::Session->{surveys} ||= {};
 if(defined $set) {
   $surv->{$wizname} = $set;
 }

 if ($Vend::Session->{logged_in} and ! $Vend::admin) {
   if (! defined $surv->{$wizname}) {
     my $o = {
       function => 'check_file_acl',
       location => "survey/$wizname",
     };
     $surv->{$wizname} = $Tag->userdb($o);
   }
   else {
     my $o = {
       function => 'set_file_acl',
       location => "survey/$wizname",
       mode => $surv->{$wizname},
     };
     $Tag->userdb($o);
   }
 }

 return $surv->{$wizname};
}

sub survey_log_generate_final {
 my ($wizname, $opt, $ary) = @_;

 ref($opt) eq 'HASH'
   or die "bad call to generate_final routine, output options not hash ref ($opt)";
 ref($ary) eq 'ARRAY'
   or die "bad call to generate_final routine, output not array ref ($ary)";

 my $done = already($wizname);

 push @$ary, title_and_message($opt, $done);

 if ( $done ) {
   $opt->{intro_text} .= '<h1>' . thanks_title($opt, 1) . '</h1>';
 }
#  else {
#    $opt->{survey_counter}  ||= "logs/survey/$wizname.cnt";
#    $opt->{survey_file}    ||= "logs/survey/$wizname.txt";
#    push @$ary, "\tsurvey_file: $opt->{survey_file}";
#    push @$ary, "\tsurvey_counter: $opt->{survey_counter}";
#  }
 return;
}

sub gen_email_header {
 my ($wizname, $ref, $opt, $fnames) = @_;
 my $subject = errmsg($opt->{email_subject} || "Response to %s", $wizname);
 my $from_addr = $opt->{email_from};
 my $cc_addr = $opt->{email_cc};
 for(qw/ EMAIL_SURVEY EMAIL_INFO EMAIL_SERVICE /) {
   next unless $from_addr = $::Variable->{$_};
   last;
 }
 $from_addr ||= $Vend::Cfg->{MailOrderFrom} || $Vend::Cfg->{MailOrderTo};
 my $tpl = <<EOF;
From: $from_addr
Subject: $subject
To: {output_email}
EOF
 $tpl .= "Cc: $cc_addr\n" if $cc_addr;
 return $tpl;
}

sub gen_email_template {
 my ($wizname, $ref, $opt, $fnames) = @_;
 my $tpl = gen_email_header($wizname, $ref, $opt, $fnames);
 $tpl .= <<EOF;

{code?}Sequence: {code}
{/code?}Username: {username}
IP Address: $CGI::remote_addr
Host: $CGI::remote_host
Date: {date}
--------------------------------------------
EOF

 my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
 if(! @fields) {
   @fields = @$fnames;
 }

 for(@fields) {
   $tpl .= "$_: {$_}\n";
 }
 $tpl .= "--------------------------------------------\n";
 return $tpl;
}

sub email_output {
 my ($wizname, $ref, $opt, $fnames) = @_;
#::logDebug("Called email_output");
 return unless  $opt->{output_email};

#::logDebug("email_output has an address of $opt->{output_email}");
 ## Check and see if already sent
 if(! $opt->{output_repeated} and already($wizname)) {
#::logDebug("email_output already done, repeated=$opt->{output_repeated} \
 already=" . ::uneval($Vend::Session->{surveys}));
   return;
 }

#::logDebug("email_output is continuing");
 my $tpl   = $opt->{email_template};
 if(! $tpl or $tpl !~ /\S/) {
   $tpl = gen_email_template($wizname, $ref, $opt, $fnames);
 }
 else {
   $opt->{email_template} =~ s/\s+$//;
   $opt->{email_template} =~ s/^\s+//;
   if($opt->{email_template} !~ /[\r\n]/) {
     $tpl = interpolate_html(Vend::Util::readfile($opt->{email_template}));
   }
   else {
     $tpl = $opt->{email_template};
   }
   if($tpl !~ /^[-\w]+:/) {
     $tpl = join "\n", gen_email_header($wizname, $ref, $opt, $fnames), $tpl;
   }
 }

#::logDebug("email_output tpl=$tpl");

 my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
 if(! @fields) {
   @fields = @$fnames;
 }
 
 my $outref = { %$opt };

 $outref->{ip_address} = $CGI::remote_addr;
 $outref->{host_name} = $CGI::remote_host;
 $outref->{username} = $Vend::username || 'anonymous';
 $outref->{date} = POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime());

 for(@fields) {
   $outref->{$_} = $Values->{$_};
 }
 my $out = tag_attr_list($tpl, $outref);

 my $status;
 $status = $Tag->email_raw({}, $out)
   or ::logError("Failed to send survey email output:\n$out");
#::logDebug("email_output status=$status");
 return $status;
}

sub survey_log_to_file {
 my ($wizname, $ref, $opt, $fnames) = @_;

if(! $opt->{output_repeated} and already($wizname)) {
 return template_attr($wizname, $ref, $opt, $fnames);
}

my $fn   = $ref->{survey_file};
my $cfn  = $ref->{survey_counter};
my $sqlc = $ref->{survey_counter_sql};

if(! $fn) {
 $fn = $::Variable->{SURVEY_LOG_DIR} || 'logs/survey';
 $fn .= "/$wizname.txt";
}

if(! $cfn and ! $sqlc) {
   $cfn = $fn;
   $cfn =~ s/\.txt$//;
   $cfn .= '.cnt';
   $cfn =~ s:(.*/):$1.:;
 }

 my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
 if(! @fields) {
   @fields = @$fnames;
 }
 if(! -f $fn) {
   my $string = join "\t",
           'code', 'ip_address', 'username', 'date', @fields;
   $string .= "\n";
   $Tag->write_relative_file($fn, $string);
 }

 my @o = $Tag->counter({file => $cfn, sql => $sqlc});
 push @o, $CGI::remote_addr;
 push @o, $Vend::username || 'anonymous';
 push @o, POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime());

 for(@fields) {
   my $result = $Values->{$_};
   $result =~ s/\r?\n/\r/g;
   $result =~ s/\t/  /g;
   push @o, $result;
 }

 ::logData($fn, @o);
 email_output($wizname, $ref, $opt, $fnames);
 already($wizname => 1) unless $opt->{output_repeated};
 return template_attr($wizname, $ref, $opt, $fnames);
}

my %survey_genfinal = (
 survey_log => \&survey_log_generate_final,
 email_only => sub {
   my ($wizname, $opt, $ary) = @_;
   push @$ary, title_and_message($opt, already($wizname));
   if($opt->{continue_template}) {
     push @$ary, "template: <<EOF";
     push @$ary, $opt->{continue_template};
     push @$ary, 'EOF';
   }
   return;
 },
 default => sub {
   my ($wizname, $opt, $ary) = @_;
   my $line = "final: ";
   $line .= thanks_title(
           $opt,
           $Vend::Session->{surveys}{$wizname},
           errmsg("Finished with %s", $wizname),
         );
   push @$ary, '';
   push @$ary, $line;
   if($opt->{continue_template}) {
     push @$ary, "template: <<EOF";
     push @$ary, $opt->{continue_template};
     push @$ary, 'EOF';
   }
   return;
 },
);

sub template_attr {
 my ($wizname, $ref, $opt, $fields) = @_; 
 my %attr;

 if(ref($fields) eq 'hash') {
   %attr = { %$fields };
 }

 $attr{TITLE} = $ref->{_page_title} || "Finished with $wizname...";
 $attr{PROMPT} = $ref->{prompt};
 $attr{ANCHOR} = $ref->{anchor} || 'Go';
 $attr{EXTRA} = $ref->{extra} || '';
 $attr{EXTRA} = " $attr{EXTRA}" if $attr{EXTRA};
 $attr{URL} = wizard_url($ref, $opt, $fields);
#::logDebug("generated ATTR is: " . uneval(\%attr));
 my $template = $ref->{template} || <<EOF;
<H1>{TITLE}</h1>
{PROMPT}
<p>
<blockquote>
<A HREF="{URL}"{EXTRA}>{ANCHOR}</A>
</blockquote>
EOF
 return tag_attr_list($template, \%attr);
}

sub wizard_url {
 my ($ref, $opt, $fields) = @_; 
 my %attr;
 my %ignore = qw/
         page 
         href
         template
         remap
         /;
       
 my $form = { };
 for(keys %$ref) {
   next if /^_/;
   next if $ignore{$_};
   $form->{$_} = $ref->{$_};
 }

 $form->{href} = $opt->{output_href} || $ref->{href} || $ref->{page};
 if($opt->{output_parm}) {
   my $ref = Vend::Util::scalar_to_hash($opt->{output_parm}) || {};
   for (keys %$ref) {
     $form->{$_} = $ref->{$_};
   }
 }
 $form->{form} = 'auto';
 for(@$fields) {
   $form->{$_} = $Values->{$_};
 }

 my $save = { };
 if($ref->{remap}) {
   my @pairs = split /[\s,\0]+/, $ref->{remap};
   for(@pairs) {
     my ($k, $v) = split /=/, $_;
     next unless $k and $v;
     my $val = delete($form->{$k}) || $save->{$k};
     $save->{$k} = $val;
     $form->{$v} = $val;
   }
 }

 return $Tag->area($form);
}

my %survey_auto = qw/
           survey_log   1
           email_only   1
           auto_bounce  1
         /;
## Called with:
##
##  $$dest = $sub->($wizname, $ref, $opt, \@vals);
##
##   $wizname name of wizard/survey
##   $ref     copy of final stanza of auto_wizard, hash ref with keys, can modify
##   %opts    Options auto_wizard was created with, can modify
##   @vals    Fields names collected in the wizard, can modify

my %survey_action = (
 survey_log => \&survey_log_to_file,
 auto_bounce => sub {
   my ($wizname, $ref, $opt, $fnames) = @_;
   my $url = wizard_url($ref, $opt, $fnames);
   email_output($wizname, $ref, $opt, $fnames);
   my $status = $Tag->deliver( { type => 'text/html', location => $url });
   return $status;
 },
 default => sub {
   my ($wizname, $ref, $opt, $fnames) = @_;
   $ref->{wizard_name} = $wizname;
   email_output($wizname, $ref, $opt, $fnames);
   return template_attr($wizname, $ref, $opt, $fnames);
 },
);

sub compile_wizard {
 my ($wizname, $opt, $script) = @_;
#Debug("script in: $script");
 $script =~ s/^\s+//;
 $script =~ s/\r\n/\n/g;
 $script =~ s/\r/\n/g;
 my @lines = split /\n/, $script;
 my $ref;

 my @pages;

 my $qip; # question in progress
 my $iip; # item in progress
 my $fip; # final in progress
 my $bip; # breaks in progress
 my $blip; # break labels in progress
 my $began; # We have begun

 my $sip;
 my $vip;
 my $mark;
 my $break;
 my %opts;

 if($opt->{db_id}) {
#Debug("found db_id=$opt->{db_id}");
   my ($t, $k) = split /:+/, $opt->{db_id}, 2;
   BUILDWIZ: {
     my $met = $Tag->meta_record($k, undef, $t)
       or last BUILDWIZ;
     my($structure) = delete $met->{ui_data_fields};
     delete $met->{extended};
     %opts = %$met;
#Debug("display type=$opts{display_type} met=" . ::uneval($met) );
     $met->{row_template} = $opt->{row_template}
       if $opt->{row_template};
     my $ids = $t . '::' . $k . '::';
     $structure =~ s/\r\n?/\n/g;
     my $string = "\n\n$structure";
     my %break;
     while ($string =~ s/\n+(?:\n[ \t]*=(.*))?\n+[ \t]*(\w[:.\w]+)/\n$2/) {
       $break{$2} = $1;
     }
     $string =~ s/^[\s,\0]+//;
     $string =~ s/[\s,\0]+$//;
     $string =~ s/[,\0\s]+/ /g;
     my @fields = split /\s+/, $string;
     my @out = "$k: $met->{label}";
     my $i = 1;
     my $fields_line = join "\t", @fields;
     for(@fields) {
       if($break{$_}) {
         push @out, "$i: $break{$_}";
         $i++;
       }
       push @out, "\tdb_id: $ids$_";
       push @out, '';
     }
     $opts{output_fields} ||= join " ", @fields;
     my $otype = $opts{output_type} || 'default';
     my $sub = $survey_genfinal{$otype} || $survey_genfinal{default};
     $sub->($k, \%opts, \@out);
     @lines = @out;
   }
 }

#Debug("Found some lines, number=" . scalar @lines);
#Debug("display type=$opts{display_type}");
 for(@lines) {
   if($mark) {
     $sip .= "$_\n", next
       unless $_ eq $mark;
     $_ = $sip;
     undef $mark;
     undef $sip;
   }

   if (s/<<(\w+)$//) {
     $mark = $1;
     $sip = $_;
     next;
   }

   s/\s+$//;

   if(! $_) {
     undef $iip;
     next;
   }

   if(! $ref) {
     if(/^(\w+):\s*(.*)/) {
       $began = 1;
       $wizname ||= $1;
       my $title = $2;
       $ref = {
           _page_name => 'begin',
           _name => [],
           title => $title,
           %opts,
         };
     }
     next;
   }

   if(/^(\d+)[:.]\s*(.*)/) {
     my $pn = $1; my $title = $2;
     push @pages, $ref;
     my $lastpage = $ref->{_page_name};
     $qip = [];
     undef $bip;
     undef $blip;
     $ref = {  
           _page_name    => $pn,
           _name      => $qip,
           _breaks      => $bip,
           _break_labels  => $blip,
           _page_title    => $title,
           };
     next;
   }
   if(/^final[:.]\s*(.*)/) {
     undef $qip;
     undef $iip;
     $fip = 1;
     my $title = $1;
     push @pages, $ref;
     my $lastpage = $ref->{_page_name};
     $ref = { _page_name => 'final', _page_title => $title};
     next;
   }


   if($fip) {
     s/^\s+//;
     unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
       $Tag->warnings(qq{Unrecognized "$_" in middle of script.});
       next;
     }
     my $thing    = $1;
     my $modifier = $2;
     my $value    = $3;
     if($modifier) {
       $ref->{_modifier} ||= {};
       $ref->{_modifier}{$thing} = $modifier;
     }
     $ref->{$thing} = $value;
     next;
   }

   if($qip) {
     if(/^(itl|perl)(?:_condition)?:\s*(.*)$/s) {
       if(! $ref->{_condition}) {
         $ref->{_condition_type} = $1;
         $ref->{_condition} = $2;
       }
       else {
         $Tag->error(
           "%s_condition: cannot set twice in wizard %s screen %s",
           $1,
           $pages[0]->{_title},
           $ref->{_page_name},
         );
         return;
       }
       next;
     }
     elsif(/^opt:\s*(.*)$/s) {
       my $option = $1;
       $option =~ s/\s+$//;
       my ($n, $v) = split /=/, $option, 2;
       my $o = $ref->{_options} ||= [];
       push @$o, $n, $v;
       next;
     }

     s/^\s+//;
     unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
       $Tag->warnings(qq{Unrecognized "$_" in middle of script.});
       next;
     }
     my $thing = $1;
     my $modifier = $2;
     my $value = $3;

     if(! $iip) {

       ## This redoes the loop
       if($thing eq 'name') {
         $thing = $value;
         undef $value;
       }
       elsif($thing eq 'break') {
         $break = $value;
         $break =~ s/,/&#41;/g;
         $ref->{_breaks} ||= ($bip = []);
         $ref->{_break_labels} ||= ($blip = []);
         next;
       }
       elsif($thing eq 'db_id') {
         my ($t, $survey, $name) = split /:+/, $value, 3;
         $thing = $name;
         my $key = $survey . '::' . $name;
         my $meta = $Tag->meta_record($key, undef, $t);
         if($meta) {
           for(keys %$meta) {
             $ref->{$_} ||= {};
             $ref->{$_}{$thing} = $meta->{$_};
           }
         }
         $ref->{name}{$thing} = $thing;
#::logDebug("meta record is " . ::uneval($meta));

         undef $value;
       }

       $iip = $thing;
       push @$qip, $iip;
       if($break) {
         push @$bip, $iip;
         push @$blip, "$iip=$break";
         undef $break;
       }
       $ref->{label}{$iip} = $value if $value;
       next;
     }

     if($modifier) {
       $ref->{_modifier} ||= {};
       $ref->{_modifier}{$thing} ||= {};
       $ref->{_modifier}{$thing}{$iip} = $modifier;
     }
     $ref->{$thing} ||= {};
     $ref->{$thing}{$iip} = $value;
   }
   else {
     unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
       $Tag->warnings(qq{Unrecognized "$_" in beginning section of script.});
       next;
     }
     my $thing = $1;
     my $modifier = $2;
     my $value = $3;
     $ref->{$thing} = $value;
   }
 }
 push @pages, $ref;
 $wizname ||= 'default';
 my $wiz_ary = $Session->{auto_wizard} ||= {};
 $wiz_ary->{$wizname} = \@pages;
#Debug("Wizard $wizname=" . ::uneval(\@pages));
 return $wizname;
}

sub {
 my ($wizname, $opt, $body) = @_;

 my $dest;
 $wizname ||= $CGI->{wizard_name};

 if($opt->{scratch}) {
   $Tag->tmp($opt->{scratch});
   $::Scratch->{$opt->{scratch}} ||= '';
   $dest = \$::Scratch->{$opt->{scratch}};
 }
 else {
   $Tmp->{auto_wizard} ||= '';
   $dest = \$Tmp->{auto_wizard};
 }
 return $$dest if $opt->{show} and ! $opt->{run};

 if($opt->{compile} eq 'auto') {
   $Session->{auto_wizard} ||= {};
   undef $opt->{compile} if $wizname && $Session->{auto_wizard}{$wizname};
   $opt->{show} = 1 unless defined $opt->{show};
   $opt->{run} = 1;
 }

 if($opt->{compile}) {
   my $n;
   $n = compile_wizard(@_)
     or do {
       ::logError(
         $$dest = errmsg(
                     "Wizard %s failed to compile.",
                     $wizname,
                   )
             );
       return;
       };
#Debug("compiler returned wizname=$n");
   $wizname = $n;
   undef $body;
 }

 if(! defined $opt->{run}) {
   $opt->{run} = 1;
   $opt->{show} = 0 if ! defined $opt->{show};
 }

 my $title_var = $opt->{title_scratch}   || 'page_title';
 my $banner_var = $opt->{banner_scratch} || 'page_banner';
 my $wiz;

 $wizname ||= $CGI->{wizard_name} || 'default';
#Debug("wizname=$wizname");

 return unless $wiz = $Vend::Session->{auto_wizard}{$wizname};
#Debug("we have a wiz! wizname=$wizname");

 my $beg = $wiz->[0];
 my $fin = $wiz->[-1];

 for($beg, $fin) {
   return "Bad wizard!" unless ref($_) eq 'HASH';
 }

 my $lastwiz = $#$wiz;
 my $lastpage = $CGI->{wizard_page} || 0;
 my $current_page;

 my %opts;
 copyref($beg, \%opts);

 # Get rid of internal stuff
 for(keys %opts) {
   next unless /^_/;
   delete $opts{$_};
 }

 if($CGI->{ui_wizard_action} eq 'Back') {
   $current_page = $lastpage - 1;
 }
 elsif($CGI->{ui_wizard_action} eq 'Cancel') {
   $current_page = 0;
 }
 elsif($CGI->{ui_wizard_action} eq 'Next') {
   $current_page = $lastpage + 1;
 }
 else {
   $current_page = $lastpage;
 }

 my $finished;
 my $condition_done;
 my $optref;
#::logDebug("Getting screens");
 GETSCREEN: {
   $optref = $wiz->[$current_page];
   if(! $condition_done and $optref->{_condition}) {
     $condition_done = 1;
     my $result;
     if($optref->{_condition_type} eq 'itl') {
       eval {
         $result = interpolate_html($optref->{_condition});
       };
       $result =~ s/\s+$//;
       $result =~ s/.*\s//s;
       $result += 0;
       $current_page += $result;
     }
     else {
       eval {
         $result = $ready_safe->reval($optref->{_condition});
       };
       if($@) {
         $Tag->error(
           "error during perl conditional: $@\ncode was:\n%s",
           $@,
           $optref->{_condition},
         );
         $current_page -= 1;
       }
       $result += 0;
#::logDebug("did perl conditional, result=$result");
       $current_page += $result;
     }
     redo GETSCREEN;
   }

   if($current_page <= 0) {
     $current_page = 1;
   }
   elsif ( ($current_page + 1) == $lastwiz ) {
     $opts{next_text} = errmsg('Finish')
       if $survey_auto{$opts{output_type}} or $fin->{auto};
   }
   elsif ($current_page >= $lastwiz) {
     $finished = 1;
   }
   $optref = $wiz->[$current_page];
 }
 
 unless($current_page <= 1) {
   delete $opts{intro_text};
   delete $optref->{intro_text};
 }

 my %modsub = (
     i    => sub {
             my $val = shift;
#              ::logDebug("running interpolate of $val");
             return interpolate_html($val);
           },
     default => sub {
             my $val = shift;
             my $filters = join " ", @_;
             return $Tag->filter($filters, $val);
           },
   );

 $Scratch->{$title_var}  = $optref->{_page_title};
 $Scratch->{$banner_var} = $optref->{_page_title};

 if($finished) {
     my $ref = { %$fin };

     my $mod;
     if( $mod = delete $ref->{_modifier}) {
       for(keys %$ref) {
         next if /^_/;
         if(my $m = $mod->{$_}) {
           my $v = $ref->{$_};
           my $sub = $modsub{$m} || $modsub{default};
           $ref->{$_} = $sub->($ref->{$_}, $m);
         }
       }
     }

     my @vals;
     for my $w (@$wiz) {
       next unless ref($w->{_name}) eq 'ARRAY';
       push @vals, @{$w->{_name}};
     }

     my $otype = $opts{output_type};
     $otype ||= 'auto_bounce' if $ref->{auto};
     my $sub = $survey_action{$otype} || $survey_action{default};
     $$dest = $sub->($wizname, $ref, \%opts, \@vals);
     return $$dest if $opt->{show};
     return;
#Debug("finished, page ref=" . uneval($ref));

 }

#Debug("we have a wiz=$wizname! current_page = $current_page");

#Debug("optref=" . $Tag->uneval(undef, $optref));

#::logDebug("prepping to walk optref");

### TODO: Find bad reference when no section title...

 my $name = $optref->{_name} || die;
#  $Scratch->{page_title} = $optref->{_page_title};

 if($optref->{_breaks} and ref($optref->{_breaks}) eq 'ARRAY') {
   $opts{ui_break_before} = join " ", @{$optref->{_breaks}};
   $opts{ui_break_before_label} = join ",", @{$optref->{_break_labels}};
 }

 if(my $o = $optref->{_options}) {
   for (my $i = 0; $i < @$o; $i += 2) {
     $opts{$o->[$i]} = $o->[$i + 1];
   }
 }

 $opts{form_name} ||= 'wizard';
 $opts{all_errors} = '1';
 $opts{hidden} = {
   wizard_name => $wizname,
   wizard_page => $current_page,
 };

 $opts{wizard} = 1;
 $opts{notable} = 1;
 $opts{no_meta} = 1;
 $opts{defaults} = 1;
 $opts{mv_cancelpage} ||= 'index';
 $opts{row_template} ||= $opt->{row_template} || <<'EOF' unless $opts{display_type};
{HELP?}<td>&nbsp;</td><td>
    <span style="color: blue">{HELP}</span>
  {HELP_URL?}<BR><A HREF="{HELP_URL}">more help</A>{/HELP_URL?}
  </td>
 </tr>
   <tr class=rnorm>
 {/HELP?}
  <td class=cdata width="20%" valign=top> 
    {LABEL}
 </td>
<td class=cdata width=500> 
        $WIDGET$
</td>
</tr>
<tr class=rspacer>
<td colspan=2><img src="bg.gif" height=1 width=1></td>
EOF

$opts{ui_wizard_fields} = join " ", @$name;
$opts{mv_nextpage} = $Global::Variable->{MV_PAGE};
$opts{mv_prevpage} = $Global::Variable->{MV_PAGE} if $current_page != 1;
$opts{bottom_buttons} = 1;

#::logDebug("walking optref");
my $mod = $optref->{_modifier} || '';
 for(keys %$optref) {
   next if /^_/;
   next if $overall_opt{$_};
   next unless ref($optref->{$_}) eq 'HASH';
   $opts{$_} = {} if ref($opts{$_}) ne 'HASH';
   Vend::Util::copyref($optref->{$_}, $opts{$_});
   my $m;
   if($mod and $m = $mod->{$_}) {
     my $r = $opts{$_};
     for my $k (keys %$r) {
       next unless $m->{$k};
       my @subs = split /\s*,\s*/, $m->{$k};
       for(@subs) {
         my $sub = $modsub{$_} || $modsub{default};
         $r->{$k} = $sub->($r->{$k}, $_);
       }
     }
   }
 }

 $opts{widget} ||= {};
 if( my $r = delete $opts{type} ) {
   for(keys %$r) {
     $opts{widget}{$_} = $r->{$_};
   }
 }

 delete $opts{type};
 # Prevent ui_data_fields from parent corrupting wizard
 delete $opts{ui_data_fields};
 delete $opts{extended};
#::logDebug("calling table_editor opts=" . ::uneval(\%opts));
 $$dest = $Tag->table_editor( {all_opts => \%opts });
 if($$dest !~ /<form\s+/i) {
   my $msg = errmsg("Auto wizard failed to run wizard %s.", $name);
   $$dest .= $Tag->error({ show => 1, set => $msg });
 }

 return $$dest if $opt->{show};
 return;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: available_ups_internal.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag available_ups_internal Version $Revision: 1.4 $
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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: available_www_shipping.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag available_www_shipping Order   only
UserTag available_www_shipping Version $Revision: 1.5 $
UserTag available_www_shipping Routine <<EOR
sub {
my ($only) = @_;
my $ups;

if(! $only or $only =~ /ups/i) {
  eval {
    require Business::UPS;
  };
  $ups = $@ ? 0 : 1;
}

my @ups_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 (wantarray) {
  return @ups_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};
  }
  return $out;
}
}
EOR

# Copyright 2002-2016 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag backup-database Order    tables
UserTag backup-database AddAttr
UserTag backup-database Version  1.12
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};

my $xls;

if ($opt->{xls}) {
  eval {
    require Spreadsheet::WriteExcel;
    import Spreadsheet::WriteExcel;
    $xls = Spreadsheet::WriteExcel->new("$backup_dir/DBDOWNLOAD.xls");
  };
  if ($xls) {
    if ($opt->{max_xls_string}) {
      $Max_xls_string = int($opt->{max_xls_string}) || 255;
      $xls->{_xls_strmax} = $Max_xls_string;
    }
  }
  else {
    undef $opt->{xls};
  }
}

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 $fn = $db->config('file');
  $fn =~ s:.*/::;
  my $file = "$backup_dir/$fn";
  my $status;
  local $Vend::Cfg->{NoExportExternal} if $opt->{force};
  eval {
    $status = export(
          $table,
          {
            force => 1,
            table => $table,
            file => $file,
            type => 'TAB',
            where => $opt->{where},
          },
        );
  };

  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])
        if length $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>\n<li>", @errors;
  $::Scratch->{ui_error} .= '</li></ul>';
}
return $opt->{hide} ? "" : $done;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: backup_file.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag backup-file Order     file
UserTag backup-file AddAttr
UserTag backup-file Version   $Revision: 1.5 $
UserTag backup-file Routine   <<EOR
require File::Copy;
require File::Path;
require File::Basename;
sub {
my ($file, $opt) = @_;
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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: banner.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag banner              Order        category
UserTag banner              addAttr
UserTag banner              PosNumber    1
UserTag banner              Version      $Revision: 1.6 $
UserTag banner              Routine      <<EOR
sub {
my ($place, $opt) = @_;


sub initialize_banner_directory {
  my ($dir, $category, $opt) = @_;
  mkdir $dir, 0777 if ! -d $dir;
  my $t = $opt->{table} || 'banner';
  my $c_field;
  my $append = '';
  if($category) {
    $append = ' AND ';
    $append .= ($opt->{c_field} || 'category');
    $category =~ s/'/''/g;
    $append .= " = '$category'";
  }
  my $db = database_exists_ref($t);
  if(! $db) {
    my $weight_file = "$dir/total_weight";
    return undef if -f $weight_file;
    $t = "no banners db $t\n";
    Vend::Util::writefile( $weight_file, $t, $opt);
    ::logError($t);
    return undef;
  }
  my $w_field = $opt->{w_field} || 'weight';
  my $b_field = $opt->{b_field} || 'banner';
  my $q = "select $w_field, $b_field from $t where $w_field >= 1$append";
  my $banners = $db->query({
    query => $q,
    st => 'db',
  });
  my $i = 0;
  for(@$banners) {
    my ($weight, $text) = @$_;
    for(1 .. $weight) {
      Vend::Util::writefile(">$dir/$i", $text, $opt);
      $i++;
    }
  }
  Vend::Util::writefile(">$dir/total_weight", $i, $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

# Copyright 2003-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: bar_button.tag,v 1.5 2007-03-30 23:40:56 pajamian Exp $

UserTag bar-button Order     page current
UserTag bar-button PosNumber 2
UserTag bar-button HasEndTag 1
UserTag bar-button Version   $Revision: 1.5 $
UserTag bar-button Routine   <<EOR
sub {
use strict;
my ($page, $current, $html) = @_;
$current = $Global::Variable->{MV_PAGE}
if ! $current;
$html =~ s!\[selected\]((?s:.)*)\[/selected]!!i;
my $alt = $1;
return $html if $page ne $current;
return $alt;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: base_url.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag base-url Version $Revision: 1.4 $
UserTag base-url Routine sub { return $Vend::Cfg->{VendURL} }

UserTag bootmenu Order        name
UserTag bootmenu hasEndTag
UserTag bootmenu AddAttr
UserTag bootmenu Description  Display menu using jQuery and standard HTML + CSS.
UserTag bootmenu Documentation <<EOD

Returns a menu using an unordered list with associated Bootstrap-recognizable \
 classes (<ul><li>foo</li></ul>). No Javascript is needed for basic functionality.

Call with something like:
[timed-build file="timed/bootmenu" login=1 force=1 minutes=1440][bootmenu \
 name="catalog/menu" timed=1][/bootmenu][/timed-build]
(bootmenu's "name" opt requires a DB menu)
or for simple menu:
[bootmenu file="includes/menus/catalog/menu.txt"][/bootmenu]

You can also put a template inside, and also use "transforms" like "logged_in", e.g.:
[bootmenu file="include/menus/catalog/top.txt" class="nav nav-pills pull-right" logged_in=member]
  <li class="{HELP_NAME}"><a{PAGE?} href="{PAGE}"{/PAGE?} title="{DESCRIPTION}">{NAME}</a>
[/bootmenu]

To be used with Bootstrap and the Javascript plugin for dropdown menus. \
 See http://getbootstrap.com for more.

EOD
UserTag bootmenu Routine      <<EOR

my $indicated;
my $last_line;
my $first_line;
my $logical_field;

my %transform = (
nbsp => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    $row->{$_} =~ s/ /&nbsp;/g;
  }
  return 1;
},
entities => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    $row->{$_} = HTML::Entities::encode_entities($row->{$_});
  }
  return 1;
},
localize => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    $row->{$_} = errmsg($row->{$_});
  }
  return 1;
},
first_line => sub {
  my ($row, $fields) = @_;
  return undef if ref($fields) ne 'ARRAY';
  return 1 if $first_line;
  my $status;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && ! $row->{$_};
    }
    else {
      $status = $status && $row->{$_};
    }
  }
  return $first_line = $status;
},
last_line => sub {
  my ($row, $fields) = @_;
#::logDebug("last_line transform, last_line=$last_line");
  return 1 if ref($fields) ne 'ARRAY';
  return 0 if $last_line;
  my $status;
  for(@$fields) {
#::logDebug("last_line transform checking field $_=$row->{$_}");
    if(s/^!\s*//) {
      $status = ! $row->{$_};
    }
    else {
      $status = $row->{$_};
    }
#::logDebug("last_line transform checked field $_=$row->{$_}, status=$status");
    last if $status;
  }
#::logDebug("last_line transform returning last_line=$status");
  $last_line = $status;
#::logDebug("last_line transform returning status=" . ! $status);
  return ! $status;
},
first_line => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && ! $row->{$_};
    }
    else {
      $status = $status && $row->{$_};
    }
  }
  return $status;
},
inactive => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && $row->{$_};
    }
    else {
      $status = $status && ! $row->{$_};
    }
  }
  return $status;
},
active => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && ! $row->{$_};
    }
    else {
      $status = $status && $row->{$_};
    }
  }
  return $status;
},
ui_security => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    next if ! length($row->{$_});
    $status = $status && Vend::Tags->if_mm('advanced', $row->{$_});
  }
  return $status;
},
full_interpolate => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    next unless $row->{$_} =~ /\[|__[A-Z]\w+__/;
    $row->{$_} = Vend::Interpolate::interpolate_html($row->{$_});
  }
  return 1;
},
page_class => sub {
  my ($row, $fields) = @_;
  return 1 unless $row->{indicated};
  return 1 if $row->{mv_level};
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    my($f, $c) = split /[=~]+/, $_;
    $c ||= $f;
#::logDebug("setting scratch $f to row=$c=$row->{$c}");
    $::Scratch->{$f} = $row->{$c};
  }
  $$indicated = 0;
  return 1;
},
menu_group => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  eval {
    for(@$fields) {
      my($f, $c) = split /[=~]+/, $_;
      $c ||= $f;
      $status = $status && (
              !  $row->{$f}
              or $CGI::values{$c} =~ /$row->{$f}/i
              );
    }
  };
  return $status;
},
superuser => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    $status = $status && (! $row->{$_} or Vend::Tags->if_mm('super'));
  }
  return $status;
},
items  => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  my $nitems = scalar(@{$Vend::Items}) ? 1 : 0;
  for(@$fields) {
    next if ! length($row->{$_});
    $status = $status && (! $nitems ^ $row->{$_});
  }
  return $status;
},
logged_in => sub {
  my ($row, $fields) = @_;
#::logDebug("logged_in... doing:$_, fields=" . ref($fields) . ', ' . uneval($fields));
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    next if ! length($row->{$_});
    $status = $status && (! $::Vend::Session->{logged_in} ^ $row->{$_});
  }
#::logDebug("logged_in... got here. doing:$_, status=$status, row=$row->{$_}");
  return $status;
},
depends_on => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    next if ! $row->{$_};
    $status = $status && $CGI::values{$row->{$_}};
  }
  return $status;
},
exclude_on => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    $status = $status && (! $CGI::values{$row->{$_}});
  }
  return $status;
},
indicator_class => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    my ($indicator,$rev, $last, $status);
    my($s,$r) = split /=/, $_;
    $rev = $indicator =~ s/^\s*!\s*// ? 1 : 0;
    $last = $indicator =~ s/\s*!\s*$// ? 1 : 0;
#::logDebug("checking scratch $s=$::Scratch->{$s} eq row=$r=$row->{$r}");
    $status = $::Scratch->{$s} eq $row->{$r};
    if($rev xor $status) {
      $row->{indicated} = 1;
    }
    last if $last;
  }
  if($row->{indicated}) {
    $indicated = \$row->{indicated};
  }
  return 1;
},
indicator_profile => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    my ($indicator,$rev, $last, $status);
    next unless $indicator = $row->{$_};
    $rev = $indicator =~ s/^\s*!\s*// ? 1 : 0;
    $last = $indicator =~ s/\s*!\s*$// ? 1 : 0;
    $status = Vend::Tags->run_profile($indicator);
    if($rev xor $status) {
      $row->{indicated} = 1;
      next unless $last;
    }
    last if $last;
  }
  return 1;
},
indicator_page => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    if ($::Scratch->{mv_logical_page} eq $row->{$_}) {
      unless(
          $::Scratch->{mv_logical_page_used}
          and $::Scratch->{mv_logical_page_used}
            ne
          $row->{$logical_field}
        )
    {
      $row->{indicated} = 1;
      $::Scratch->{mv_logical_page_used} = $row->{$logical_field};
      last;
    }
  }
  ($row->{indicated} = 1, last)
    if  $Global::Variable->{MV_PAGE} eq $row->{$_}
    and ! defined $row->{indicated};
}
return 1;
},
indicator => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    my ($indicator,$rev, $last, $status);
    next unless $indicator = $row->{$_};
    $rev = $indicator =~ s/^\s*!\s*// ? 1 : 0;
    $last = $indicator =~ s/\s*!\s*$// ? 1 : 0;
    if($indicator =~ /^\s*([-\w.:][-\w.:]+)\s*$/) {
      $status =  $CGI::values{$1};
    }
    elsif ($indicator =~ /^\s*`(.*)`\s*$/s) {
      $status = Vend::Interpolate::tag_calc($1);
    }
    elsif ($indicator =~ /\[/s) {
      $status = Vend::Interpolate::interpolate_html($indicator);
      $status =~ s/\s+//g;
    }
    if($rev xor $status) {
      $row->{indicated} = 1;
    }
    else {
      $row->{indicated} = '';
    }
    last if $last;
  }
  return 1;
},
expand_values_form => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    next unless $row->{$_} =~ /\%5b|\[/i;
    my @parms = split $Global::UrlSplittor, $row->{$_};
    my @out;
    for my $p (@parms) {
      my ($parm, $val) = split /=/, $p, 2;
      $val = unhexify($val);
      $val =~ s/\[cgi\s+([^\[]+)\]/$CGI::values{$1}/g;
      $val =~ s/\[var\s+([^\[]+)\]/$::Variable->{$1}/g;
      $val =~ s/\[value\s+([^\[]+)\]/$::Values->{$1}/g;
      push @out, join('=', $parm, hexify($val));
    }
    $row->{$_} = join $Global::UrlJoiner, @out;
  }
  return 1;
},
expand_values => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    next unless $row->{$_} =~ /\[/;
    $row->{$_} =~ s/\[cgi\s+([^\[]+)\]/$CGI::values{$1}/g;
    $row->{$_} =~ s/\[var\s+([^\[]+)\]/$::Variable->{$1}/g;
    $row->{$_} =~ s/\[value\s+([^\[]+)\]/$::Values->{$1}/g;
  }
  return 1;
},
);

sub reset_transforms {
#::logDebug("resetting transforms");
my $opt = shift;
if($opt) {
  $logical_field = $opt->{logical_page_field} || 'name';
}
undef $last_line;
undef $first_line;
undef $indicated;
}

sub {
my($name, $opt, $template) = @_;

reset_transforms($opt);

my @transform;
my @ordered_transform = qw/full_interpolate indicator_page page_class \
 indicator_class localize entities nbsp/;
my %ordered;
@ordered{@ordered_transform} = @ordered_transform;

for(keys %transform) {
  next if $ordered{$_};
  next unless $opt->{$_};
  my @fields = grep /\S/, split /[\s,\0]+/, $opt->{$_};
  $opt->{$_} = \@fields;
#::logDebug("opt $_ = " . uneval(\@fields));
  push @transform, $_;
}
for(@ordered_transform) {
  next unless $opt->{$_};
  my @fields = grep /\S/, split /[\s,\0]+/, $opt->{$_};
  $opt->{$_} = \@fields;
  push @transform, $_;
}
$opt->{_transform} = \@transform;
#::logDebug("in menu sub main");

my @out;

$template = <<EOF if $template !~ /\S/;
  {INDICATOR?}<li class="{INDICATOR}">{/INDICATOR?}
{INDICATOR:}<li class="{BOOT_LI}">
  <a{PAGE?} href="{PAGE}"{/PAGE?} title="{DESCRIPTION}" class="{LINK_CLASS}" \
 \
 {BOOT_CONTENT}>{ICON?}{ICON} {/ICON?}{NAME}{CARET?} {CARET}{/CARET?}</a>
{/INDICATOR:}
EOF

my $top_timeout = $opt->{timeout} || 1000;

my %o = (
  start       => $opt->{tree_selector} || $opt->{name},
  file    => $opt->{file},
  table       => $opt->{table} || $::Variable->{MV_TREE_TABLE} || 'tree',
  master      => 'parent_fld',
  subordinate => 'code',
  autodetect  => '1',
  sort        => $opt->{sort} || 'code',
    full        => '1',
    timed    => $opt->{timed},
    spacing     => '4',
    _transform   => $opt->{_transform},
  );

for(@{$opt->{_transform} || []}) {
  $o{$_} = $opt->{$_};
}

my $main;
my $rows;
if($opt->{iterator}) {
  $o{iterator} = $opt->{iterator};
  $main =  Vend::Tags->tree(\%o);
  $rows = $o{object}{mv_results};
}
else {
  Vend::Tags->tree(\%o);
#::logDebug("bootmenu: " . uneval({ ref => \%o }) );
  my @o;
  for(@{$o{object}{mv_results}}) {
    next if $_->{deleted};

    for my $tr (@{$o{_transform}}) {
#::logDebug("running transform: $tr, on: " . uneval($_) . ", " . uneval($opt->{$tr}));
      my $status = $transform{$tr}->($_, $opt->{$tr});
#::logDebug("transform... status=$status, did: $tr, result: " . uneval($_));
      $opt->{next_level} = $_->{mv_level}
        if ! $status;
      $_->{deleted} = 1 unless $status;
    }

    if($_->{page} and $_->{page} !~ m{^(\w+:)?/}) {
      my $form = $_->{form};
      if($form and $form !~ /[\r\n]/) {
        $form = join "\n", split $Global::UrlSplittor, $form;
      }

      $_->{page} = "" if $_->{page} eq 'index';

      my $add = ($::Scratch->{mv_add_dot_html} && $_->{page} !~ /\.\w+$/) || 0;

      $_->{page} = Vend::Tags->area({
                  href => $_->{page},
                  form => $form,
                  no_count => $o{timed},
                  add_dot_html => $add,
                  no_session_id => $o{timed},
                  auto_format => 1,
                }) unless $_->{page} =~ /^#/;

    }
    
    push @o, $_ unless $_->{deleted};
  }
  $rows = \@o;
}

$rows->[-1]{mv_last_row} = 1 if @$rows;

#::logDebug("rows = " . ::uneval({ ref => $rows }) );

$name =~ s|/|_|g;
$opt->{ul_id} ||= $name;
$opt->{class} ||= 'nav navbar-nav';

my $id = $opt->{ul_id} ? q{ id="$opt->{ui_id}"} : '';
my $style = $opt->{style} ? q{ style="$opt->{style}"} : '';

push @out, <<EOF;
<ul$id class="$opt->{class}"$style $opt->{extra}>
EOF

#return Vend::Tags->uneval({ ref => $rows });

## Dropdown classes

my $boot_content = qq| data-toggle="dropdown" role="button" data-target="#"|;
my $boot_class = qq|dropdown-toggle|;
my $boot_li = qq|dropdown|;
my $caret = $opt->{caret} || qq|<b class="caret"></b>|;

my $class = $opt->{class};
my $link_class = $opt->{link_class};
my $li_class = $opt->{li_class};

my $z = 0;
my $last_level = 0;

for my $row (@$rows) {
#Debug("mvlevel:$row->{mv_level} last:$last_level lastrow:$row->{mv_last_row} z:$z");
  next if $row->{deleted};
  if($row->{mv_children} > 0){
    $row->{boot_content} = $boot_content;
    $row->{link_class} = "$boot_class $link_class";
    $row->{caret} = $caret;
    $row->{boot_li} = "$boot_li $li_class";
  }
  else{
    $row->{link_class} = $link_class;
    $row->{boot_li} = "$li_class";
  }

  ## Allow for bootstrap icon set

  unless ($row->{img_icon} =~ /\.(jpg|gif|png|jpeg)$/i){
    $row->{icon} = qq|<i class="$row->{img_icon}"></i>| if $row->{img_icon};
  }

  my ($in_template, $list_open, $list_close);
  if($row->{mv_level} > $last_level) {   # new nested list
    $list_open = <<EOF;
<ul class="dropdown dropdown-menu">
EOF

  }
  elsif($row->{mv_level} < $last_level) {   # end of nested list
    $list_close = <<EOF;
  <!-- level:$row->{mv_level} -->
  </li>
</ul>
  </li>
EOF
    my $add_close = <<EOF;
</ul>
EOF
    my $level_diff = $last_level - $row->{mv_level};
    for(2..$level_diff) {
      $list_close .= $add_close;
    }
  }
  elsif ($z) {
    $list_close = <<EOF;
  </li>
EOF
  }
  $in_template = $list_close . $list_open . $template;
  if($row->{mv_last_row}) {

    my $scl = <<EOF;
  </li>
EOF
    my $cl = <<EOF;
  </li>
</ul>
EOF
    if ($row->{mv_level} == 1){
      $in_template .= $cl;
    }
    elsif ($row->{mv_level} > 1) {
      while($last_level >= 0){
        $in_template .= $cl;
        $last_level--;
      }
    }
    $in_template .= $scl;
  }

  push @out, Vend::Tags->uc_attr_list($row, $in_template);
  $last_level = $row->{mv_level};
  $z++;
}

push @out, <<EOF;
</ul>
EOF

return join "", @out;
}

EOR

# Copyright 2004-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: breadcrumbs.tag,v 1.5 2007-08-09 13:40:53 pajamian Exp $

UserTag breadcrumbs Order number
UserTag breadcrumbs addAttr
UserTag breadcrumbs Routine <<EOR
sub {
my ($number, $opt) = @_;

use vars qw/$Tag $Scratch $CGI $Session $Variable/;
my $only_last = $::Variable->{BREADCRUMB_ONLY_LAST} || 'ord/basket login';
my $exclude   = $::Variable->{BREADCRUMB_EXCLUDE};
my $max   = $number || $::Variable->{BREADCRUMB_MAX} || 6;

my %exclude;
my %only_last;

my @exclude = split /[\s,\0]+/, $exclude;
my @only_last = split /[\s,\0]+/, $only_last;
@exclude{@exclude} = @exclude;
@only_last{@only_last} = @only_last;

my $curpage = $Global::Variable->{MV_PAGE};
my $titles = $Scratch->{bc_titles} ||= {};

my %special = (
scan => sub { 
    my $url = shift;
    my @items = split m{/}, $url;

    my $title;
    for(@items) {
      if(s/^se=//) {
        $title = $_;
      }
      elsif(s/^va=banner_text=//) {
        $title = $_;
      }
    }
    return ($title, $title);
  },
);

my $curhist   = $Session->{History}->[-1] || [];
my $curparams = $curhist->[1] || {};

my $keyname;

my $curfull = $curhist->[0];
$curfull =~ s/$Vend::Cfg->{HTMLsuffix}$//;
$curfull =~ s{^/}{};
my ($curaction,$curpath) = split m{/}, $curfull, 2;

my $ptitle = $opt->{title} || $curparams->{short_title};
$ptitle ||= $Scratch->{short_title};

my $db;

my @extra;

if($special{$curaction} and ! $ptitle) {
  ($ptitle, $keyname) = $special{$curaction}->($curpath);
}
elsif(
    $Vend::Flypart
      and
    $db = Vend::Data::product_code_exists_ref($Vend::Flypart)
  )
{
  my $tab = $db->name();
  my $record = tag_data($tab, undef, $Vend::Flypart, { hash => 1});
  $ptitle = $keyname = $record->{$Vend::Cfg->{DescriptionField}};

  if($record and $record->{prod_group}) {
    my @parms;
    push @parms, "fi=$tab";
    push @parms, "co=yes";
    push @parms, "st=db";
    push @parms, "sf=prod_group";
    push @parms, "se=$record->{prod_group}";
    push @parms, "op=eq";
    push @extra, {
      key => $record->{prod_group},
      title => $record->{prod_group},
      description => undef,
      url => $Tag->area({ search => join("\n", @parms) }),
    };
  }
  if($record and $record->{category}) {
    my @parms;
    push @parms, "fi=$tab";
    push @parms, "co=yes";
    push @parms, "st=db";
    if($record->{prod_group}) {
      push @parms, "sf=prod_group";
      push @parms, "se=$record->{prod_group}";
      push @parms, "op=eq";
    }
    push @parms, "sf=category";
    push @parms, "se=$record->{category}";
    push @parms, "op=eq";
    push @extra, {
    key => $record->{category},
    title => $record->{category},
    description => undef,
    url => $Tag->area({ search => join "\n", @parms }),
  };
}
}

if(! $ptitle) {
$ptitle = $Scratch->{page_title};
$ptitle =~ s/(\s*\W+\s*)?$Variable->{COMPANY}(\s*\W+\s*)?//;
}

$ptitle =~ s/^\s+//;
$ptitle =~ s/\s+$//;

$keyname ||= $curpage;

$titles->{$curpage} = $ptitle if $ptitle;

my %exclude_param = qw(
  mv_pc 1
  bread_reset 1
);

if($Scratch->{bread_reset} || $CGI->{bread_reset}) {
  delete $Session->{breadcrumbs};
}

my $crumbs = $Session->{breadcrumbs} ||= [];
my $crumb;

if($opt->{reset_on_product} and @extra) {
#::logDebug("Resetting based on product");
  @$crumbs = ();
}

if(! $exclude{$curpage}) {
  my $form = '';
  if(! $CGI->{bread_no_params}) {
    for(grep !$exclude_param{$_}, keys %$curparams) {
       $form .= "\n$_=";
       $form .= join("\n$_=", split /\0/, $curparams->{$_});
    }
  }
  $crumb = {
    key => $keyname,
    title => HTML::Entities::encode($ptitle),
    description => HTML::Entities::encode($Scratch->{page_description}),
    url => $Tag->area({ href => $curfull, form => $form, secure => $CGI->{secure} }),
  };
}

push @$crumbs, @extra if @extra;
push @$crumbs, $crumb if $crumb;

my %seen;
my @new = grep !$seen{$_->{key}}++, reverse @$crumbs;

my $did_one;
for(@new) {
  ## Kill ones that only are allowed in last position
  if( $did_one and $only_last{$_->{key}}) {
    $_ = undef;
  }
  $did_one = 1;
}

if(@new > $max) {
  splice @new, $max;
}

@$crumbs = grep $_, reverse @new;

my $tpl = $opt->{template} || <<EOF;
<a href="{url}"{description?} title="{description}"{/description?} class=breadlink>{title}</a>
EOF

my @out;
for(@$crumbs) {
  next unless ref($_) eq 'HASH' and $_->{url};
  my $link = tag_attr_list($tpl, $_);
#::logDebug("link=$link from:\ntpl=$tpl\ncrumb=" . ::uneval($_));
  push @out, $link;
}

$opt->{joiner} = '&nbsp;&gt;&nbsp;' unless defined $opt->{joiner};
return join $opt->{joiner}, @out;
}
EOR

# Copyright 2002-2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: button.tag,v 1.25 2008-06-15 19:11:16 jure Exp $

UserTag button Order     name src text
UserTag button addAttr
UserTag button attrAlias value text
UserTag button hasEndTag
UserTag button Version   $Revision: 1.25 $
UserTag button Routine   <<EOR
sub {
my ($name, $src, $text, $opt, $action) = @_;

my $trigger_text;

if($opt->{wait_text}) {
  $trigger_text = $opt->{wait_text};
}
else {
  $trigger_text = $text;
}

my @js;
my $image;

my @from_html = qw/class id style/;

if($src) {
if( $opt->{srcliteral} || $src =~ m{^https?://}i ) {
  $image = $src;
}
else {
  my $dr = $::Variable->{DOCROOT};
  my $id = $Tag->image( { dir_only => 1 } );
  $id =~ s:/+$::;
  $id =~ s:/~[^/]+::;

    if( $dr and $id and $src =~ m{^[^/]} and -f "$dr$id/$src" ) {
      $image = $src;
    }
    elsif( $dr and $src =~ m{^/} and -f "$dr/$src" ) {
      $image = "$id/$src";
    }
    else {
      ::logError("No image file '$src' found or image file name is invalid.");
    }
  }
}
my $onclick = '';
my $onmouseover = '';
my $onmouseout = '';
while($action =~ s! \[
          (
            j (?:ava)? s (?:cript)?
          )
          \]
            (.*?)
          \[ / \1 \]
          !!xis
  )
{
  my $script = $2;
  $script =~ s/\s+$//;
  $script =~ s/^\s+//;
  if($script =~ s/\bonclick\s*=\s*"(.*?)"//is) {
    $onclick = $1;
    next;
  }
  if ($script =~ s/\bonmouse(\w+)\s*=\s*"(.*?)"//is) {
    if (lc($1) eq 'over') {
      $onmouseover .= ($onmouseover ? ';' : '') . $2;
    }
    elsif (lc($1) eq 'out') {
      $onmouseout .= ($onmouseout ? ';' : '') . $2;
    }
    else {
      logError(q{Skipping 'onmouse%s', invalid JavaScript event}, $1);
    }
    next;
  }
  push @js, $script;
}

if(! $name or $name eq 'mv_click') {
  $action =~ s/^\s+//;
  $action =~ s/\s+$//;
  my $set_text = HTML::Entities::decode($trigger_text);
  $::Scratch->{$set_text} = $action;
  $name = 'mv_click' if ! $name;
}

my $out = '';
my $confirm = '';
my $wait = '';
$opt->{extra} = $opt->{extra} ? " $opt->{extra}" : '';
if($opt->{confirm}) {
  $opt->{confirm} =~ s/'/\\'/g;
  $confirm = "confirm('$opt->{confirm}')";
}

if($onclick) {
  $confirm .= ' && ' if $confirm;
  $onclick = qq{ onClick="$confirm$onclick"};
}

# Constructing form button. Will be sent back in all cases,
# either as the primary button or as the <noscript> option
# for JavaScript-challenged browsers.
$text =~ s/"/&quot;/g;
$name =~ s/"/&quot;/g;
$out = qq{<input type="submit" name="$name" value="$text"$onclick$Vend::Xtrailer>};
if (@js) {
  $out =~ s/ /join "\n", '', @js, ''/e;
}

$opt->{extra} ||= '';
for(@from_html) {
  next unless $opt->{$_};
  $opt->{extra} .= qq{ $_="$opt->{$_}"};
}

# return submit button if not an image
if(! $image) {
  $text =~ s/"/&quot;/g;
  $name =~ s/"/&quot;/g;
  if(! $onclick and $confirm) {
    $onclick = qq{ onclick="return $confirm"};
  }
  elsif(! $onclick and $opt->{wait_text}) {
    $opt->{wait_text} = HTML::Entities::encode($trigger_text);
    $onclick  = qq{ onClick="};
    $onclick .= qq{var msg = 'Already submitted.';};
    $onclick .= qq{this.value = '$opt->{wait_text}';};
    $onclick .= qq{this.onclick = 'alert(msg)'; return true;};
    $onclick .= qq{"};
  }

  my $out = $opt->{bold} ? '<b>' : '';
  $out .= qq{<input$opt->{extra} type="submit" name="$name" value="$text"$onclick$Vend::Xtrailer>};
  $out .= '</b>' if $opt->{bold};
  if(@js) {
    $out =~ s/ /join "\n", '', @js, ''/e;
  }
  return $out;
}

# If we got here the button is an image
# Wrap form button code in <noscript>
my $no_script = qq{<noscript>$out</noscript>\n};
$out = '';

my $wstatus = $opt->{alt} || $text;
$wstatus =~ s/'/\\'/g;

my $clickname = $name;
my $clickvar = $name;
if($image and $name eq 'mv_click') {
  $clickvar = $text;
  $clickvar =~ s/\W/_/g;
  $clickname = "mv_click_$clickvar";
  $out = qq{<input type='hidden' name='mv_click_map' value='$clickvar'$Vend::Xtrailer>};
}

$out .= qq{<input type='hidden' name='$clickname' value=''$Vend::Xtrailer>} if $image; 

my $formname;
$opt->{form} = 'forms[0]'
  if ! $opt->{form};

$confirm .= ' && ' if $confirm;
$opt->{border} = 0 if ! $opt->{border};

if($opt->{getsize}) {
  eval {
    require Image::Size;
    ($opt->{width}, $opt->{height}) = Image::Size::imgsize($image);
  };
}

$opt->{align} = 'top' if ! $opt->{align};

my $position = '';
for(qw/height width vspace hspace align/) {
  $position .= " $_='$opt->{$_}'" if $opt->{$_};
}

my $anchor = '';
unless( $opt->{hidetext}) {
  $anchor = $opt->{anchor} || $text;
  $anchor =~ s/ /&nbsp;/g;
  $anchor = "<b>$anchor</b>";
}

my $a_before = '</a>';
my $a_after  = '';
if($opt->{link_text_too}) {
  $a_before = '';
  $a_after = '</a>';
}

$opt->{link_href} ||= 'javascript: void 0';
if ($onclick =~ /^\s*onclick\s*=\s*"(.*?)"/i) {
  $onclick = $1 . ' && ';
}
# QUOTING (fix here too?)
$out .= <<EOF;
<a href="$opt->{link_href}"$opt->{extra} onMouseOver="window.status='$wstatus';$onmouseover"
EOF
$out .= <<EOF if $onmouseout;
onMouseOut="$onmouseout"
EOF
$out .= <<EOF;
onClick="$confirm $onclick mv_click_map_unique(document.$opt->{form}, \
 '$clickname', '$text') && $opt->{form}.submit(); return(false);"
alt="$wstatus"><img alt="$wstatus" src="$src" border='$opt->{border}'$position>$a_before$anchor$a_after
EOF

my $function = '';
unless ($::Instance->{js_functions}{mv_do_click}++) {
  $function = "\n" . <<'EOJS';
function mv_click_map_unique(myform, clickname, clicktext) {
for (var i = 0; i < myform.length; i++) {
  var widget = myform.elements[i];
  if (
    (widget.type == 'hidden')
    && (widget.name != 'mv_click_map')
    && (widget.name.indexOf('mv_click_') == 0)
  )
    widget.value = (widget.name == clickname) ? clicktext : '';
}
return true;
}
EOJS
}

# Must escape backslashes and single quotes for JavaScript write function.
# Also must get rid of newlines and carriage returns.
$out =~ s/(['\\])/\\$1/g;
$out =~ s/[\n\r]+/ /g;
$out = <<EOV;
<script language="javascript1.2" type="text/javascript">
<!--$function
document.write('$out');
// -->
</script>
$no_script
EOV

return $out;
}

EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: calc.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag calc                hasEndTag
UserTag calc                Interpolate
UserTag calc                Version      $Revision: 1.4 $
UserTag calc                MapRoutine   Vend::Interpolate::tag_calc

sub tag_calc {
my($body) = @_;
my $result;
if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
}

$Items = $Vend::Items;

if($MVSAFE::Safe) {
  $result = eval($body);
}
else {
  init_calc() if ! $Vend::Calc_initialized;
  $result = $ready_safe->reval($body);
}

if ($@) {
  my $msg = $@;
  $Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
  logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
  logError("Safe: %s\n%s\n" , $msg, $body);
  return $MVSAFE::Safe ? '' : 0;
}
return $result;
}

sub tag_calc {
my($body) = @_;
my $result;
if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
}

$Items = $Vend::Items;

if($MVSAFE::Safe) {
  $result = eval($body);
}
else {
  init_calc() if ! $Vend::Calc_initialized;
  $result = $ready_safe->reval($body);
}

if ($@) {
  my $msg = $@;
  $Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
  logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
  logError("Safe: %s\n%s\n" , $msg, $body);
  return $MVSAFE::Safe ? '' : 0;
}
return $result;
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: calcn.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag calcn               hasEndTag
UserTag calcn               Version      $Revision: 1.4 $
UserTag calcn               MapRoutine   Vend::Interpolate::tag_calc

sub tag_calc {
my($body) = @_;
my $result;
if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
}

$Items = $Vend::Items;

if($MVSAFE::Safe) {
  $result = eval($body);
}
else {
  init_calc() if ! $Vend::Calc_initialized;
  $result = $ready_safe->reval($body);
}

if ($@) {
  my $msg = $@;
  $Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
  logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
  logError("Safe: %s\n%s\n" , $msg, $body);
  return $MVSAFE::Safe ? '' : 0;
}
return $result;
}

# Copyright 2006-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: captcha.coretag,v 1.4 2007-03-30 23:55:57 pajamian Exp $

UserTag captcha Order    function
UserTag captcha attrAlias  func function
UserTag captcha addAttr
UserTag captcha Description  Generate captcha codes for authentication check
UserTag captcha Version    $Revision: 1.4 $

UserTag captcha Routine    <<EOR
my $Have_Captcha;
eval {
 require Authen::Captcha;
 $Have_Captcha = 1;
};

sub {
 my ($func, $opt) = @_;

 use vars qw/$Tag/;

 if(! $Have_Captcha) {
   ::logError("Use of captcha tag without Authen::Captcha, skipping");
   return '';
 }
 
 $func = lc($func);
$func =~ s/[^a-z]+//g;
my $result = '';
if($func eq 'code') {
 $result = $Vend::Session->{captcha};
}

$opt->{length} ||= 4;
my $en = $opt->{error_name} || 'captcha';

my $subdir = $opt->{image_subdir}
|| $::Variable->{CAPTCHA_IMAGE_SUBDIR}
|| 'captcha';
my $tmpdir = "$Vend::Cfg->{ScratchDir}/$subdir";

mkdir($tmpdir) unless -d $tmpdir;

my $imgdir = $opt->{image_location} || $::Variable->{CAPTCHA_IMAGE_LOCATION};

unless ($imgdir ) {
if(! $Global::NoAbsolute and $::Variable->{DOCROOT}) {
$imgdir = "$::Variable->{DOCROOT}$::Variable->{IMAGE_DIR}/$subdir";
}
else {
$imgdir = "images/$subdir";
}
}

my $imgpath = $opt->{image_path}
      || $::Variable->{CAPTCHA_IMAGE_PATH}
      || "$::Variable->{IMAGE_DIR}/$subdir";


my $captcha = Authen::Captcha->new(
        data_folder => $tmpdir,
         output_folder => $imgdir,
       );

 my $guess   = $opt->{guess} || $CGI::values{mv_captcha_guess};
 my $code    = $opt->{source};

 if($func eq 'check') {

   my $check_against = $code || $Vend::Session->{captcha};
   my $status = $captcha->check_code($guess, $check_against);
   if($status > 0) {
     return $status;
   }
   elsif($status == 0) {
     $Tag->error( { name => $en, set => "Code not checked: error" });
     return 0;
   }
   elsif($status == -1) {
     $Tag->error( { name => $en, set => "Code expired" });
     return 0;
   }
   elsif($status == -2) {
     $Tag->error( { name => $en, set => "Code never generated" });
     return 0;
 }
 elsif($status == -3) {
   $Tag->error( { name => $en, set => "Code doesn't match" });
   return 0;
 }
}
else {
 # Used for [captcha-refresh] if requested
 $::Instance->{last_captcha_build_opt} = { %$opt };

   my $save_u = umask($::Variable->{CAPTCHA_UMASK} || 2);

 if($opt->{reset}) {
   undef $Vend::Captcha;
   delete $Vend::Session->{captcha};
   }

   if($Vend::Captcha) {
     $code ||= $Vend::Session->{captcha};
   }

   if($func eq 'code' and $code) {
     return $code;
   }

    eval {

   unless( Vend::File::allowed_file($imgdir, 1) ) {
     my $msg = errmsg("No permission to write directory '%s'", $imgdir);
     $Tag->error( { name => $en, set => $msg });
     return 0;
   }

   mkdir($imgdir) unless -d $imgdir;

   if(! $code) {
     $code = $Vend::Session->{captcha} = $captcha->generate_code($opt->{length});
     $Vend::Captcha = $code;
   }
   umask $save_u;
    };

   if($@) {
     $Tag->error( { name => $en, set => "Error: $@" });
     return '';
   }

   if($func eq 'code') {
     return $code;
   }
 
   # Now probably an image function.

   unless ($func =~ /ima?ge?/)  {
     $Tag->error({
             name => $en,
             set => errmsg("Unknown function %s", $func),
           });
     return undef;
   }

   my $path = $opt->{relative} ? "$subdir/$code.png" : "$imgpath/$code.png";

   if(! $opt->{name_only}) {
     return   $Tag->image($path);
   }
   else {
     return $path;
   }
 }

}
EOR

UserTag captcha Documentation <<EOD
=head1 NAME

Interchange [captcha] tag

=head1 SYNOPSIS

 [captcha  function="check|code|image|relative_image|image_tag"
           length="4"
           image-subdir="captcha"
           image-location="images/captcha"
           image-path="/standard/images/captcha"
           source="[cgi mv_captcha_source]"
           error-name="captcha"
           guess="[cgi mv_captcha_guess]"
       ]

=head1 DESCRIPTION

This tag generates and/or checks "captcha" images to authenticate user input.
If called for the first time in a page, it generates a code/image pair and
sets the code in the session (at $Vend::Session->{captcha}).

There are several functions.

=over 4

=item check

Checks the captcha source code (presumably from the previous page) against
the guess. If it matches, returns 1. If not, returns 0 and puts error
in $Tag->error.

=item code

Returns the generated code. Generates one if not done previously in session.

=item image

Returns an IMG tag as generated by Interchange's [image] tag. If the
name-only=1 option is passed, no surrounding IMG tag will be generated,
only the image name. If the C<relative=1> option is passed, that name
will not be prefaced with the ImageDir.

=back

The additional options are:

=over 4

=item guess 

The input from the user when the function is C<check>. Default is the
contents of [cgi mv_captcha_guess].

=item image-subdir

The image subdirectory (based in images directory) which will
be used.

=item image-path

The base path for URL generation. Default is the Interchange IMAGE_DIR
variable.

=item image-location

The directory where image files will be generated. Default is the
Interchange IMAGE_DIR variable based in the Interchange DOCROOT
variable, with the subdirectory above, i.e. C<[var DOCROOT][var IMAGE_DIR]/captcha>.

=item length

Length of the input for the captcha. Default is 4 characters.

=item name-only 

When set, tells the image function to not generate an HTML IMG tag.

=item relative 

When set, tells the image function (when in name-only mode) to
return relative path.

=item reset 

Normally only one captcha code / image will be generated per page
transaction. If this is set, you can generate another one -- though
you would have to take care of saving the generated code yourself,
as $Session->{captcha} is overwritten.

=item source 

The captcha base to guess against for the C<check> function. Default is the
contents of the last-generated captcha, or [cgi mv_captcha_source].

=back

=head1 EXAMPLE

 [if cgi mv_captcha_guess]
   [tmp good][captcha check][/tmp]
   [if scratch good]
     You guessed right!
   [else]
     Sorry, try again.
   [/else]
   [/if]
   <br>
 [/if]

 [captcha function=image]

 <form action="[process href="@@MV_PAGE@@"]">
 <input type=text name=mv_captcha_guess size value="">
 <input type=submit value="Guess">
 </form>

 [error auto=1]

=head1 PREREQUISITES

Authen::Captcha

=head1 AUTHOR

Mike Heins, <mike AT THE DOMAIN perusion.com>.

EOD

# Copyright 2003-2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: capture_page.tag,v 1.12 2008-10-01 09:21:45 racke Exp $

UserTag capture_page Order   page file
UserTag capture_page addAttr
UserTag capture_page Version $Revision: 1.12 $
UserTag capture_page Routine <<EOR
sub {
my ($page, $file, $opt) = @_;

# check if we are using a file
if ($file) {
  # check if we are allowed to write the file
  unless (Vend::File::allowed_file($file, 1)) {
    Vend::File::log_file_violation($file, 'capture_page');
    return 0;
  }

  if ($opt->{expiry}) {
    my $stat = (stat($file))[9];

    if ($stat > $opt->{expiry}) {
      if ($opt->{touch}) {
        my $now = time();
        unless (utime ($now, $now, $file)) {
          ::logError ("Error on touching file $file: $!\n");
        }
      }
      return;
    }
  }
}

if ($opt->{scan}) {
  Vend::Page::do_scan($opt->{scan});
}

$::Scratch->{mv_no_count} = 1;

# save mapped output
my (@output, %outptr, %outfilter, %outextended, $multiout, $content, $retval);

@output = @Vend::Output;
%outptr = %Vend::OutPtr;
%outfilter = %Vend::OutFilter;
%outextended = %Vend::OutExtended;
$multiout = $Vend::MultiOutput;

# clear mapped output
@Vend::Output = %Vend::OutPtr = %Vend::OutFilter = %Vend::OutExtended = ();
$Vend::MultiOutput = 0;
  
Vend::Page::display_page($page, {return => 1});

for my $part (@Vend::Output) {
   Vend::Interpolate::substitute_image($part);
  $content .= $$part;
 }

# restore mapped output
@Vend::Output = @output;
%Vend::OutPtr = %outptr;
%Vend::OutFilter = %outfilter;
%Vend::OutExtended = %outextended;
$Vend::MultiOutput = $multiout;

if ($opt->{scratch}) {
  $::Scratch->{$opt->{scratch}} = $content;
  $retval = 1;
}

if ($file) {
   $retval = Vend::File::writefile (">$file", \$content,
         {auto_create_dir => $opt->{auto_create_dir},
         umask => $opt->{umask}});
}

return $retval;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: cart.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag cart                Order        name
UserTag cart                PosNumber    1
UserTag cart                Version      $Revision: 1.6 $
UserTag cart                MapRoutine   Vend::Interpolate::tag_cart

sub tag_cart {
$Vend::CurrentCart = shift;
return '';
}

sub tag_cart {
$Vend::CurrentCart = shift;
return '';
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: catch.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $

UserTag catch               Order        label
UserTag catch               addAttr
UserTag catch               hasEndTag
UserTag catch               Version      $Revision: 1.7 $
UserTag catch               Routine      <<EOR
sub {
my ($label, $opt, $body) = @_;
$label = 'default' unless $label;
my $patt;
my $error;
return pull_else($body) 
  unless $error = $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 = $error;
  $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 $emsg = $2;
  eval {
    $re = qr{$1}
  };
  next if $@;
  if($emsg =~ $patt) {
    push @found, $emsg;
  }
  next unless $error =~ $re;
  push @found, $emsg;
  last;
}

if(@found) {
  $body = join $opt->{joiner} || "\n", @found;
}
else {
  $body =~ s/\$ERROR\$/$error/g;
}

$body =~ s/\s+$//;
$body =~ s/^\s+//;

if($opt->{error_set}) {
  set_error($body, $opt->{error_set});
}
if($opt->{error_scratch}) {
  $::Scratch->{$opt->{error_scratch}} = 1;
}

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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: cgi.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag cgi                 Order        name
UserTag cgi                 addAttr
UserTag cgi                 PosNumber    1
UserTag cgi                 Version      $Revision: 1.6 $
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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: charge.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag charge              Order        route
UserTag charge              addAttr
UserTag charge              PosNumber    1
UserTag charge              Version      $Revision: 1.5 $
UserTag charge              MapRoutine   Vend::Payment::charge

sub charge {
my ($charge_type, $opt) = @_;

my $pay_route;

### We get the payment base information from a route with the
### same name as $charge_type if it is there
if($Vend::Cfg->{Route}) {
  $pay_route = $Vend::Cfg->{Route_repository}{$charge_type} || {};
}
else {
  $pay_route = {};
}

### Then we take any payment options set in &charge, [charge ...],
### or $Tag->charge

# $pay_opt is package-scoped but lexical
$pay_opt = { %$pay_route };
for(keys %$opt) {
  $pay_opt->{$_} = $opt->{$_};
}

# We relocate these to subroutines to standardize

### Maps the form variable names to the names needed by the routine
### Standard names are defined ala Interchange or MV4.0x, b_name, lname,
### etc. with b_varname taking precedence for these. Falls back to lname
### if the b_lname is not set
my (%actual) = map_actual();
$pay_opt->{actual} = \%actual;

# We relocate this to a subroutine to standardize. Uses the payment
# counter if there
my $orderID = gen_order_id($pay_opt);

### Set up the amounts. The {amount} key will have the currency prepended,
### e.g. "usd 19.95". {total_cost} has just the cost.

# Uses the {currency} -> MV_PAYMENT_CURRENCY options if set
my $currency =  charge_param('currency')
        || ($Vend::Cfg->{Locale} && $Vend::Cfg->{Locale}{currency_code})
        || 'usd';

# Uses the {precision} -> MV_PAYMENT_PRECISION options if set
my $precision = charge_param('precision') || 2;
my $penny     = charge_param('penny_pricing') || 0;

my $amount = $pay_opt->{amount} || Vend::Interpolate::total_cost();
$amount = round_to_frac_digits($amount, $precision);
$amount = sprintf "%.${precision}f", $amount;
$amount *= 100 if $penny;

$pay_opt->{total_cost} = $amount;
$pay_opt->{amount} = "$currency $amount";

### 
### Finish setting amounts and currency

# If we have a previous payment amount, delete it but push it on a stack
# 
my $stack = $Vend::Session->{payment_stack} || [];
delete $Vend::Session->{payment_result}; 
delete $Vend::Session->{cybercash_result}; ### Deprecated

#::logDebug("Called charge at " . scalar(localtime));
#::logDebug("Charge caller is " . join(':', caller));

#::logDebug("mode=$pay_opt->{gateway}");
#::logDebug("pay_opt=" . ::uneval($pay_opt));
# Default to the gateway same as charge type if no gateway specified,
# and set the gateway in the session for logging on completion
if(! $opt->{gateway}) {
  $pay_opt->{gateway} = charge_param('gateway') || $charge_type;
}
#$charge_type ||= $pay_opt->{gateway};
$Vend::Session->{payment_mode} = $pay_opt->{gateway};

# See if we are in test mode
$pay_opt->{test} = charge_param('test');

# just convenience
my $gw = $pay_opt->{gateway};

# See if we are calling a defined GlobalSub payment mode
my $sub = $Global::GlobalSub->{$gw};

# Try our predefined modes
if (! $sub and defined &{"Vend::Payment::$gw"} ) {
  $sub = \&{"Vend::Payment::$gw"};
}

# This is the return from all routines
my %result;

if($sub) {
#::logDebug("Charge sub");
  # Calling a defined GlobalSub payment mode
  # Arguments are the passed option hash (if any) and the route hash

      my $pid;
      my $timeout = $pay_opt->{global_timeout} || charge_param('global_timeout');

      %result = eval {
          if ($timeout > 0) {

              my $pipe = IO::Pipe->new;

              unless ($pid = fork) {
                  Vend::Server::child_process_dbi_prep();
                  $pipe->writer;
                  my %rv = $sub->($pay_opt);
                  $pipe->print( ::uneval(\%rv) );
                  exit;
              }

              $pipe->reader;

              my $to_msg = $pay_opt->{global_timeout_msg}
                  || charge_param('global_timeout_msg')
                  || 'Due to technical difficulties, your order could not be processed.';
              local $SIG{ALRM} = sub { die "$to_msg\n" };

              alarm $timeout;
              wait;
              alarm 0;

              $pid = undef;

              my $rv = eval join ('', $pipe->getlines);

              return %$rv;
          }

          return $sub->($pay_opt);
      };

  if($@) {
    my $msg = errmsg(
          "payment routine '%s' returned error: %s",
          $charge_type,
          $@,
    );
          kill (KILL => $pid)
              if $pid && kill (0 => $pid);
    ::logError($msg);
    $result{MStatus} = 'died';
    $result{MErrMsg} = $msg;
  }
}
elsif($charge_type =~ /^\s*custom\s+(\w+)(?:\s+(.*))?/si) {
#::logDebug("Charge custom");
  # MV4 and IC4.6.x methods
  my (@args);
  @args = Text::ParseWords::shellwords($2) if $2;
  if(! defined ($sub = $Global::GlobalSub->{$1}) ) {
    ::logError("bad custom payment GlobalSub: %s", $1);
    return undef;
  }
  eval {
    %result = $sub->(@args);
  };
  if($@) {
    my $msg = errmsg(
          "payment routine '%s' returned error: %s",
          $charge_type,
          $@,
    );
    ::logError($msg);
    $result{MStatus} = $msg;
  }
}
elsif (
    $actual{cyber_mode} =~ /^minivend_test(?:_(.*))?/
      or 
    $charge_type =~ /^internal_test(?:[ _]+(.*))?/
    )
{
#::logDebug("Internal test");

  # Test mode....

  my $status = $1 || charge_param('result') || undef;
  # Interchange test mode
  my %payment = ( %$pay_opt );
  &testSetServer ( %payment );
  %result = testsendmserver(
    $actual{cyber_mode},
    'Order-ID'     => $orderID,
    'Amount'       => $amount,
    'Card-Number'  => $actual{mv_credit_card_number},
    'Card-Name'    => $actual{b_name},
    'Card-Address' => $actual{b_address},
    'Card-City'    => $actual{b_city},
    'Card-State'   => $actual{b_state},
    'Card-Zip'     => $actual{b_zip},
    'Card-Country' => $actual{b_country},
    'Card-Exp'     => $actual{mv_credit_card_exp_all}, 
  );
  $result{MStatus} = $status if defined $status;
}
else {
#::logDebug("Unknown charge type");
  my $msg = errmsg("Unknown charge type: %s", $charge_type);
  ::logError($msg);
  $result{MStatus} = $msg;
}

push @$stack, \%result;
$Vend::Session->{payment_result} = \%result;
$Vend::Session->{payment_stack}  = $stack;

my $svar = charge_param('success_variable') || 'MStatus';
my $evar = charge_param('error_variable')   || 'MErrMsg';

if($result{$svar} !~ /^success/) {
  $Vend::Session->{payment_error} = $result{$evar};
  if ($result{$evar} =~ /\S/) {
    $Vend::Session->{errors}{mv_credit_card_valid} = $result{$evar};
  }
  $result{'invalid-order-id'} = delete $result{'order-id'}
    if $result{'order-id'};
}
elsif($result{$svar} =~ /success-duplicate/) {
  $Vend::Session->{payment_error} = $result{$evar};
  $result{'invalid-order-id'} = delete $result{'order-id'}
    if $result{'order-id'};
}
else {
  delete $Vend::Session->{payment_error};
}

$Vend::Session->{payment_id} = $result{'order-id'};

my $encrypt = charge_param('encrypt');

if($encrypt and $CGI::values{mv_credit_card_number} and $Vend::Cfg->{EncryptKey}) {
  my $prog = charge_param('encrypt_program') || $Vend::Cfg->{EncryptProgram};
  if($prog =~ /pgp|gpg/) {
    $CGI::values{mv_credit_card_force} = 1;
    (
      undef,
      $::Values->{mv_credit_card_info},
      $::Values->{mv_credit_card_exp_month},
      $::Values->{mv_credit_card_exp_year},
      $::Values->{mv_credit_card_exp_all},
      $::Values->{mv_credit_card_type},
      $::Values->{mv_credit_card_error}
    )  = encrypt_standard_cc(\%CGI::values);
  }
}
::logError(
      "Order id for charge type %s: %s",
      $charge_type,
      $Vend::Session->{cybercash_id},
    )
  if $pay_opt->{log_to_error};

# deprecated
for(qw/ id error result /) {
  $Vend::Session->{"cybercash_$_"} = $Vend::Session->{"payment_$_"};
}

return \%result if $pay_opt->{hash};
return $result{'order-id'};
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: check_upload.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag check-upload Order     file same
UserTag check-upload PosNumber 2
UserTag check-upload Version   $Revision: 1.4 $
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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: checked.coretag,v 1.9 2007-03-30 23:40:49 pajamian Exp $

UserTag checked             Order        name value
UserTag checked             addAttr
UserTag checked             Implicit     multiple multiple
UserTag checked             Implicit     default default
UserTag checked             PosNumber    2
UserTag checked             Version      $Revision: 1.9 $
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="checked"' if ! length($ref) and $opt->{default};

if(! $opt->{case}) {
  $ref = lc($ref);
  $value = lc($value);
}

return ' checked="checked"' if $ref eq $value;

if ($opt->{delimiter}) {
  $opt->{multiple} = 1;
}

if ($opt->{multiple}) {
    
    my $be;
    my $ee;
    $opt->{delimiter} = "\0" unless defined $opt->{delimiter};

    if (length $opt->{delimiter}) {
  my $del = Vend::Interpolate::get_joiner($opt->{delimiter}, "\0");
  $be = '(?:^|' . $del . ')'; ;
  $ee = '(?:$|' . $del . ')'; ;
    }
    else {
  $be = '';
  $ee = '';
    }

    my $regex = qr/$be\Q$value\E$ee/;
    return ' checked="checked"' if $ref =~ $regex;
}
return '';
}
EOR

# Copyright 2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: child-process.tag,v 1.3 2009-01-08 12:05:16 markj Exp $

UserTag child-process addAttr
UserTag child-process HasEndTag
UserTag child-process NoReparse 0
UserTag child-process Interpolate 0
UserTag child-process Version $Revision: 1.3 $
UserTag child-process Documentation <<EOD

=head1 NAME

child_process - Execute ITL code in a forked child process

=head1 SYNOPSIS

[child-process] ... ITL ... [/child-process]

=head1 DESCRIPTION

Runs Interchange markup code in a forked child process.
Useful for off-loading processes that take a relatively long time to complete.

Has no effect if the body is empty or contains only whitespace.

Options are:

=over 4

=item filename

File name relative to catalog directory to file where output from forked
process should be stored.

=item label

Optional descriptive label for this process that will be put in the operating
system process list. Default is "child-process tag".

=item notifyname

File name relative to catalog directory where a file of zero length will
be created if the file in option 'filename' is created successfully.

This empty file could be used for notification purposes, e.g. as an
indicator that the child process has delivered its output. When placed
in web docroot space one could poll for the existence of this file and
when it exists bounce to a page that will display the results.

=back

=head1 EXAMPLES

This is the parent process.

Child process starts here.
[child-process filename="tmp/report_[time]%Y%m%d%H%M%S[/time].txt"]
[query
    list=1
    sql="
        ... some long-running SQL query ...
    "
][sql-line]
[/query]
[/child-process]
Child process ends here.

Some more parent stuff....

=head1 AUTHORS

Ton Verhagen <tverhagen@alamerce.nl>

Jon Jensen <jon@endpoint.com>


=cut

EOD
UserTag child-process Routine <<EOR

use POSIX ();

sub {
   my ($opt, $body) = @_;
   use vars qw/ $Tag /;

   return unless defined($body) and $body =~ /\S/;

   defined(my $kid = fork) or die "Cannot fork: $!\n";
   if ($kid) {
       waitpid($kid, 0);
       return;
   }
   else {

       Vend::Server::sever_database();

       defined (my $grandkid = fork) or die "Kid cannot fork: $!\n";
       exit if $grandkid;

       Vend::Server::cleanup_for_exec();

       # Disconnect from parent's terminal
       POSIX::setsid() or die "Can't start a new session: $!\n";

       defined $opt->{label} or $opt->{label} = 'child-process tag';
       Vend::Server::set_process_name($opt->{label});

       my $output = interpolate_html($body, 1);

       my $filename = $opt->{filename};
       if (defined($filename) and length($filename)) {
           $filename = $Tag->filter('filesafe', $filename);
           my $status = $Tag->write_relative_file($filename, $$output);

           my $notifyname = $opt->{notifyname};
           if ($status and defined($notifyname) and length($notifyname)) {
               $notifyname = $Tag->filter('filesafe', $notifyname);
               $Tag->write_relative_file($notifyname, $opt, '');
           }
       }

       exit;
   }
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: comment.coretag,v 1.2 2007-03-30 23:40:49 pajamian Exp $

# This tag exists to strip out any [comment]...[/comment] blocks
# that weren't caught by &Vend::Interpolate::vars_and_comments,
# e.g. in reparsed output from [perl] blocks

UserTag comment Version $Revision: 1.2 $
UserTag comment hasEndTag
UserTag comment Routine <<EOR
sub { '' }
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: component.tag,v 1.10 2009-05-01 13:50:00 pajamian Exp $

UserTag component Order     component
UserTag component addAttr
UserTag component NoReparse 1
UserTag component Version   $Revision: 1.10 $
UserTag component Routine   <<EOR
sub {
my ($name, $opt) = @_;

my %ignore = (
  qw/
    component    1
    comp_table   1
    comp_field   1
    comp_cache   1
    reparse      1
    interpolate  1
  /
);
my @override = grep ! $ignore{$_}, keys %$opt;

my $control = $::Control->[$::Scratch->{control_index}];
for(grep $_ !~ /^comp(?:onent)?_?/, keys %$opt) {
  $control->{$_} = $opt->{$_};
}

$name ||= $control->{component};
$name ||= $opt->{default};

if (! $name or $name eq 'none') {
# Increment control_index so empty component has no side effect
$::Scratch->{control_index}++;
return;
}

my $t = $opt->{comp_table} || $::Variable->{MV_COMPONENT_TABLE} || 'component';
my $ctab = $::Variable->{MV_COMPONENT_CACHE} || 'component_cache';

my $record;
my $db = database_exists_ref($t);
my $nocache;

if($db) {
  if(my $when = $Vend::Session->{teleport}) {
    $nocache = 1;
    my $q = qq{
      SELECT code from $t
      WHERE  base_code = '$name'
      AND    expiration_date < $when
      AND    show_date >= $when
      ORDER BY show_date DESC
    };
    my $ary = $db->query($q);
    if($ary and $ary->[0]) {
      $name = $ary->[0][0];
    }
}
$record = $db->row_hash($name);
}

$record ||= $opt;

my $body = $record->{comptext};

if(! length($body)) {
my $dir = $opt->{comp_dir}
    || $::Variable->{MV_COMPONENT_DIR}
    || 'templates/components';
$body = readfile("$dir/$name",undef,1);
}

# Increment control_index so empty component has no side effect
if (! length $body) {
  $::Scratch->{control_index}++;
  return;
}

my $cache_it;
my $cdb;
my $now;
my $crecord;
if (
  ! $nocache
  and $record->{cache_interval}
  and $cdb = database_exists_ref($ctab)
  )
{
  $cache_it = $name;

  # Cache based not only on name, but control values specified
  if($record->{cache_options}) {
    my @opts = split /[\s,\0]+/, $record->{cache_options};
    $cache_it .= '.';
    $cache_it .= generate_key( join "\0", @{$control}{@opts});
  }

  $crecord = $cdb->row_hash($cache_it) || {};
  $now = time;
  
  my $exp = adjust_time($record->{cache_interval}, $crecord->{cache_time});
  
  if ($exp > $now) {
    # Increment control_index as not done below
    $::Scratch->{control_index}++;
    return $crecord->{compcache};
  }
}

my $result = interpolate_html($body);
$::Scratch->{control_index}++;
if($cache_it) {
  my $thing = {
          compcache => $result,
          cache_time => $now,
        };
  $cdb->set_slice($cache_it, $thing);
}

if($record->{output}) {
  Vend::Interpolate::substitute_image(\$result)
    unless $opt->{no_image_substitute};
  $Tag->output_to($record->{output}, undef, $result);
  return;
}
return $result;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: content_editor.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag content-editor Order      name
UserTag content-editor addAttr
UserTag content-editor hasEndTag
UserTag content-editor Version    $Revision: 1.6 $
UserTag content-editor Routine    <<EOR
use UI::ContentEditor;
sub {
return UI::ContentEditor::editor(@_);
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: content_info.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag content-info Order     dir
UserTag content-info addAttr
UserTag content-info Version   $Revision: 1.5 $
UserTag content-info Routine   <<EOR
use UI::ContentEditor;
sub {
UI::ContentEditor::content_info(@_);
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: content_modify.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag content-modify Order    op name type
UserTag content-modify addAttr
UserTag content-modify Version  $Revision: 1.4 $
UserTag content-modify Routine  <<EOR
use UI::ContentEditor;
sub {
return UI::ContentEditor::content_modify(@_);
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: control.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag control             Order        name default
UserTag control             addAttr
UserTag control             PosNumber    2
UserTag control             Version      $Revision: 1.4 $
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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: control_set.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag control-set         Order        index
UserTag control-set         addAttr
UserTag control-set         hasEndTag
UserTag control-set         PosNumber    1
UserTag control-set         Version      $Revision: 1.4 $
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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: convert_date.tag,v 1.9 2009-05-01 13:50:00 pajamian Exp $

UserTag convert-date Order       adjust
UserTag convert-date PosNumber   1
UserTag convert-date addAttr
UserTag convert-date AttrAlias   fmt format
UserTag convert-date AttrAlias   days adjust
UserTag convert-date HasEndTag
UserTag convert-date Interpolate
UserTag convert-date Version     $Revision: 1.9 $
UserTag convert-date Routine     <<EOR
sub {
  my ($adjust, $opt, $text) = @_;
  my @t;
  my $now;

if(! ref $opt) {
  my $raw = $opt ? 1 : 0;
  $opt = {};
  $opt->{raw} = 1 if $raw;
}

my $fmt = $opt->{format} || '';
if($text =~ /^(\d\d\d\d)-(\d?\d)-(\d?\d)$/) {
  $t[5] = $1 - 1900;
  $t[4] = $2 - 1;
  $t[3] = $3;
} 
elsif($text =~ /\d/) {
        $text =~ s/\D//g;
        $text =~ /(\d\d\d\d)(\d\d)(\d\d)(?:(\d\d)(\d\d))?/;
        $t[2] = $4 || undef;
        $t[1] = $5 || undef;
        $t[3] = $3;
        $t[4] = $2 - 1;
        $t[5] = $1;
        $t[5] -= 1900;
}
elsif (exists $opt->{empty}) {
  return $opt->{empty};
}
else {
        $now = time();
        @t = localtime($now) unless $adjust;
}

if ($adjust) {
  if ($#t < 8) {
    $t[8] = -1;
  }
  $now ||= POSIX::mktime(@t);
  $adjust .= ' days' if $adjust =~ /^[-\s\d]+$/;
  @t = localtime(adjust_time($adjust, $now, $opt->{compensate_dst}));
}

if (defined $opt->{raw} and Vend::Util::is_yes($opt->{raw})) {
        $fmt = $t[2] && $text ?  '%Y%m%d%H%M' : '%Y%m%d';
}

if (! $fmt) {
  if ($t[1] || $t[2]) {
$fmt = '%d-%b-%Y %I:%M%p';
} else {
$fmt = '%d-%b-%Y';
}
}

my ($current, $out);
my $locale = $opt->{locale} || $Scratch->{mv_locale};
if ($locale) {
$current = POSIX::setlocale(&POSIX::LC_TIME);
  if (($::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8})
      && $locale !~ /\.utf-?8$/i) {
      POSIX::setlocale(&POSIX::LC_TIME, "$locale.utf8");
  }
  else {
          POSIX::setlocale(&POSIX::LC_TIME, $locale);
      }
  $out = POSIX::strftime($fmt, @t);
  POSIX::setlocale(&POSIX::LC_TIME, $current);
} else {
  $out = POSIX::strftime($fmt, @t);
}
$out =~ s/\b0(\d)\b/$1/g if $opt->{zerofix};
return $out;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: counter.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag counter             Order        file
UserTag counter             addAttr
UserTag counter             attrAlias    name file
UserTag counter             PosNumber    1
UserTag counter             Version      $Revision: 1.6 $
UserTag counter             MapRoutine   Vend::Interpolate::tag_counter

UserTag fcounter            Alias        counter

sub tag_counter {
  my $file = shift || 'etc/counter';
my $opt = shift;
#::logDebug("counter: file=$file start=$opt->{start} sql=$opt->{sql} routine=$opt->{inc_routine} \
 caller=" . scalar(caller()) );
if($opt->{sql}) {
  my ($tab, $seq) = split /:+/, $opt->{sql}, 2;
  my $db = database_exists_ref($tab);
  my $dbh;
  my $dsn;
  if($opt->{bypass}) {
    $dsn = $opt->{dsn} || $ENV{DBI_DSN};
    $dbh = DBI->connect(
          $dsn,
          $opt->{user},
          $opt->{pass},
          $opt->{attr},
        );
  }
  elsif($db) {
    $dbh = $db->dbh();
    $dsn = $db->config('DSN');
  }

  my $val;

  eval {
    my $diemsg = errmsg(
            "Counter sequence '%s' failed, using file.\n",
            $opt->{sql},
          );
    if(! $dbh) {
      die errmsg(
          "No database handle for counter sequence '%s', using file.",
          $opt->{sql},
        );
    } 
    elsif($seq =~ /^\s*SELECT\W/i) {
#::logDebug("found custom SQL SELECT for sequence: $seq");
      my $sth = $dbh->prepare($seq) or die $diemsg;
      $sth->execute or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:mysql:/i) {
      $seq ||= $tab;
      $dbh->do("INSERT INTO $seq VALUES (0)")    or die $diemsg;
      my $sth = $dbh->prepare("select LAST_INSERT_ID()")
        or die $diemsg;
      $sth->execute()                or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Pg:/i) {
      my $sth = $dbh->prepare("select nextval('$seq')")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Oracle:/i) {
      my $sth = $dbh->prepare("select $seq.nextval from dual")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }

  };

  logOnce('error', $@) if $@;

  return $val if defined $val;
}

unless (allowed_file($file)) {
  log_file_violation ($file, 'counter');
  return undef;
}

  $file = $Vend::Cfg->{VendRoot} . "/$file"
      unless Vend::Util::file_name_is_absolute($file);

for(qw/inc_routine dec_routine/) {
  my $routine = $opt->{$_}
    or next;

  if( ! ref($routine) ) {
    $opt->{$_}   = $Vend::Cfg->{Sub}{$routine};
    $opt->{$_} ||= $Global::GlobalSub->{$routine};
  }
}

  my $ctr = new Vend::CounterFile
        $file,
        $opt->{start} || undef,
        $opt->{date},
        $opt->{inc_routine},
        $opt->{dec_routine};
  return $ctr->value() if $opt->{value};
  return $ctr->dec() if $opt->{decrement};
  return $ctr->inc();
}

sub tag_counter {
  my $file = shift || 'etc/counter';
my $opt = shift;
#::logDebug("counter: file=$file start=$opt->{start} sql=$opt->{sql} routine=$opt->{inc_routine} \
 caller=" . scalar(caller()) );
if($opt->{sql}) {
  my ($tab, $seq) = split /:+/, $opt->{sql}, 2;
  my $db = database_exists_ref($tab);
  my $dbh;
  my $dsn;
  if($opt->{bypass}) {
    $dsn = $opt->{dsn} || $ENV{DBI_DSN};
    $dbh = DBI->connect(
          $dsn,
          $opt->{user},
          $opt->{pass},
          $opt->{attr},
        );
  }
  elsif($db) {
    $dbh = $db->dbh();
    $dsn = $db->config('DSN');
  }

  my $val;

  eval {
    my $diemsg = errmsg(
            "Counter sequence '%s' failed, using file.\n",
            $opt->{sql},
          );
    if(! $dbh) {
      die errmsg(
          "No database handle for counter sequence '%s', using file.",
          $opt->{sql},
        );
    } 
    elsif($seq =~ /^\s*SELECT\W/i) {
#::logDebug("found custom SQL SELECT for sequence: $seq");
      my $sth = $dbh->prepare($seq) or die $diemsg;
      $sth->execute or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:mysql:/i) {
      $seq ||= $tab;
      $dbh->do("INSERT INTO $seq VALUES (0)")    or die $diemsg;
      my $sth = $dbh->prepare("select LAST_INSERT_ID()")
        or die $diemsg;
      $sth->execute()                or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Pg:/i) {
      my $sth = $dbh->prepare("select nextval('$seq')")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Oracle:/i) {
      my $sth = $dbh->prepare("select $seq.nextval from dual")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }

  };

  logOnce('error', $@) if $@;

  return $val if defined $val;
}

unless (allowed_file($file)) {
  log_file_violation ($file, 'counter');
  return undef;
}

  $file = $Vend::Cfg->{VendRoot} . "/$file"
      unless Vend::Util::file_name_is_absolute($file);

for(qw/inc_routine dec_routine/) {
  my $routine = $opt->{$_}
    or next;

  if( ! ref($routine) ) {
    $opt->{$_}   = $Vend::Cfg->{Sub}{$routine};
    $opt->{$_} ||= $Global::GlobalSub->{$routine};
  }
}

  my $ctr = new Vend::CounterFile
        $file,
        $opt->{start} || undef,
        $opt->{date},
        $opt->{inc_routine},
        $opt->{dec_routine};
  return $ctr->value() if $opt->{value};
  return $ctr->dec() if $opt->{decrement};
  return $ctr->inc();
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: cp.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag cp Order      from to
UserTag cp addAttr
UserTag cp Version    $Revision: 1.5 $
UserTag cp Routine    <<EOR
require File::Copy;
sub {
my ($from, $to, $opt) = @_;
#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);

if ($opt->{preserve_times}) {
  my ($atime, $mtime);

  ($atime, $mtime) = (stat $from)[8,9];

  if ($atime) {
    $status = utime($atime, $mtime, $from);
  }
  else {
    $status = 0;
  }
}

umask($save_mask) if defined $save_mask;
return '' if $opt->{hide};
return $status;
}
EOR

# Copyright 2003-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: crypt.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag crypt Order     value salt
UserTag crypt attrAlias password value
UserTag crypt attrAlias crypted salt
UserTag crypt Version   $Revision: 1.6 $
UserTag crypt Routine   <<EOR
sub {
my ($string, $salt) = @_;
return crypt($string, $salt ? $salt : Vend::Util::random_string(2))
}
EOR

# Copyright 2003-2009 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag css Order   name
UserTag css addAttr
UserTag css Version $Revision: 1.9 $
UserTag css Routine <<EOR
sub {
my ($name, $opt) = @_;

use vars qw/$Tag/;

return unless $name;

my $bn = lc $name;
$bn .= '.css';

my $dir = $opt->{output_dir} ||= 'images';

my $id = "";

if (! $opt->{no_imagedir} ) {
$id = $opt->{imagedir} || $Vend::Cfg->{ImageDir};
$id =~ s:/*$:/:;
}

$dir =~ s:/+$::;

if($opt->{relative}) {
my @dirs = split m{/}, $Global::Variable->{MV_PAGE};
pop @dirs;
if(@dirs) {
  $id .= join "/", @dirs, '';
  $dir = join "/", $dir, @dirs;
  }
}

my $sourcetime;
if($opt->{basefile}) {
  $sourcetime = (stat($opt->{basefile}))[9];
#::logDebug("basefile=$opt->{basefile} sourcetime=$sourcetime");
}

my $url = "$id$bn";
my $fn  = "$dir/$bn";


my $write;
my $success;

my @stat = stat($fn);
my $writable;

if(@stat) {
  $writable = -w _;
  if($opt->{basefile}) {
    if($sourcetime > $stat[9]) {
#::logDebug("Found a basefile, out of date at modtime=$stat[9]");
      $write = 1;
    }
    else {
#::logDebug("Found a basefile, in date at modtime=$stat[9]");
      $success = 1;
    }
  }
  elsif($opt->{timed}) {
    my $now = time();
    $opt->{timed} .= ' min' if $opt->{timed} =~ /^\d+$/;
    my $fliptime = adjust_time($opt->{timed}, $stat[9]);
#::logDebug("fliptime=$fliptime now=$now");
    if ($fliptime <= $now) {
      $write = 1;
    }
    else {
      $success = 1;
    }
  }
  else {
    $success = 1;
  }
}
else {
  $writable = -w $dir;
  $write = 1;
}


my $extra = '';
$extra .= qq{ media="$opt->{media}"} if $opt->{media};

my $css;
$css = length($opt->{literal})
      ? $opt->{literal}
      : interpolate_html($Tag->var($name));
$css =~ s/^\s*<style.*?>\s*//si;
$css =~ s:\s*</style>\s*$:\n:i;

WRITE: {
  last WRITE unless $write;
  if(! $writable) {
    if(@stat) {
      logError("CSS file %s has no write permission.", $fn);
    }
    else {
      if ( -d $dir ) {
        logError("CSS dir %s has no write permission.", $dir);
      }
      else {
        logError("CSS dir %s does not exist.", $dir);
      }
    }
    last WRITE;
  }
  my $mode = $opt->{mode} ? oct($opt->{mode}) : 0644;
  $success = $Tag->write_relative_file($fn, $css) && chmod($mode, $fn)
    or logError("Error writing CSS file %s, returning in page", $fn);
}

return qq{<link rel="stylesheet" href="$url"$extra>} if $success;
return qq{<style type="text/css">\n$css</style>};
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: currency.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag currency            Order        convert noformat
UserTag currency            hasEndTag
UserTag currency            Interpolate
UserTag currency            addAttr
UserTag currency            PosNumber    2
UserTag currency            Version      $Revision: 1.5 $
UserTag currency            Routine      <<EOR
sub {
my($convert,$noformat,$opt,$amount) = @_;
return Vend::Util::currency($amount, $noformat, $convert, $opt);
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: data.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

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                Version      $Revision: 1.4 $
UserTag data                MapRoutine   Vend::Interpolate::tag_data

sub tag_data {
my($selector,$field,$key,$opt,$flag) = @_;

local($Safe_data);
$Safe_data = 1 if $opt->{safe_data};

my $db;

if ( not $db = database_exists_ref($selector) ) {
  if($selector eq 'session') {
    if(defined $opt->{value}) {
      $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
        if $opt->{filter};
      if ($opt->{increment}) {
        $Vend::Session->{$field} += (+ $opt->{value} || 1);
      }
      elsif ($opt->{append}) {
        $Vend::Session->{$field} .= $opt->{value};
      }
      else  {
        $Vend::Session->{$field} = $opt->{value};
      }
      return '';
    }
    else {
      my $value = $Vend::Session->{$field} || '';
      $value = filter_value($opt->{filter}, $value, $field)
        if $opt->{filter};
      return $value;
    }
  }
  else {
    logError( "Bad data selector='%s' field='%s' key='%s'",
          $selector,
          $field,
          $key,
    );
    return '';
  }
}
elsif($opt->{increment}) {
#::logDebug("increment_field: key=$key field=$field value=$opt->{value}");
  return increment_field($Vend::Database{$selector},$key,$field,$opt->{value} || 1);
}
elsif (defined $opt->{value}) {
#::logDebug("alter table: table=$selector alter=$opt->{alter} field=$field value=$opt->{value}");
  if ($opt->{alter}) {
    $opt->{alter} =~ s/\W+//g;
    $opt->{alter} = lc($opt->{alter});
    if ($opt->{alter} eq 'change') {
      return $db->change_column($field, $opt->{value});
    }
    elsif($opt->{alter} eq 'add') {
      return $db->add_column($field, $opt->{value});
    }
    elsif ($opt->{alter} eq 'delete') {
      return $db->delete_column($field, $opt->{value});
    }
    else {
      logError("alter function '%s' not found", $opt->{alter});
      return undef;
    }
  }
  else {
    $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
      if $opt->{filter};
#::logDebug("set_field: table=$selector key=$key field=$field foreign=$opt->{foreign} \
 value=$opt->{value}");
    my $orig = $opt->{value};
    if($opt->{serial}) {
      $field =~ s/\.(.*)//;
      my $hk = $1;
      my $current = database_field($selector,$key,$field,$opt->{foreign});
      $opt->{value} = dotted_hash($current, $hk, $orig);
    }
    my $result = set_field(
            $selector,
            $key,
            $field,
            $opt->{value},
            $opt->{append},
            $opt->{foreign},
          );
    return $orig if $opt->{serial};
    return $result
  }
}
elsif ($opt->{serial}) {
  $field =~ s/\.(.*)//;
  my $hk = $1;
  return ed(
        dotted_hash(
          database_field($selector,$key,$field,$opt->{foreign}),
          $hk,
        )
      );
}
elsif ($opt->{hash}) {
  return undef unless $db->record_exists($key);
  return $db->row_hash($key);
}
elsif ($opt->{filter}) {
  return filter_value(
    $opt->{filter},
    ed(database_field($selector,$key,$field,$opt->{foreign})),
    $field,
  );
}

#The most common , don't enter a block, no accoutrements
return ed(database_field($selector,$key,$field,$opt->{foreign}));
}

sub tag_data {
my($selector,$field,$key,$opt,$flag) = @_;

local($Safe_data);
$Safe_data = 1 if $opt->{safe_data};

my $db;

if ( not $db = database_exists_ref($selector) ) {
  if($selector eq 'session') {
    if(defined $opt->{value}) {
      $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
        if $opt->{filter};
      if ($opt->{increment}) {
        $Vend::Session->{$field} += (+ $opt->{value} || 1);
      }
      elsif ($opt->{append}) {
        $Vend::Session->{$field} .= $opt->{value};
      }
      else  {
        $Vend::Session->{$field} = $opt->{value};
      }
      return '';
    }
    else {
      my $value = $Vend::Session->{$field} || '';
      $value = filter_value($opt->{filter}, $value, $field)
        if $opt->{filter};
      return $value;
    }
  }
  else {
    logError( "Bad data selector='%s' field='%s' key='%s'",
          $selector,
          $field,
          $key,
    );
    return '';
  }
}
elsif($opt->{increment}) {
#::logDebug("increment_field: key=$key field=$field value=$opt->{value}");
  return increment_field($Vend::Database{$selector},$key,$field,$opt->{value} || 1);
}
elsif (defined $opt->{value}) {
#::logDebug("alter table: table=$selector alter=$opt->{alter} field=$field value=$opt->{value}");
  if ($opt->{alter}) {
    $opt->{alter} =~ s/\W+//g;
    $opt->{alter} = lc($opt->{alter});
    if ($opt->{alter} eq 'change') {
      return $db->change_column($field, $opt->{value});
    }
    elsif($opt->{alter} eq 'add') {
      return $db->add_column($field, $opt->{value});
    }
    elsif ($opt->{alter} eq 'delete') {
      return $db->delete_column($field, $opt->{value});
    }
    else {
      logError("alter function '%s' not found", $opt->{alter});
      return undef;
    }
  }
  else {
    $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
      if $opt->{filter};
#::logDebug("set_field: table=$selector key=$key field=$field foreign=$opt->{foreign} \
 value=$opt->{value}");
    my $orig = $opt->{value};
    if($opt->{serial}) {
      $field =~ s/\.(.*)//;
      my $hk = $1;
      my $current = database_field($selector,$key,$field,$opt->{foreign});
      $opt->{value} = dotted_hash($current, $hk, $orig);
    }
    my $result = set_field(
            $selector,
            $key,
            $field,
            $opt->{value},
            $opt->{append},
            $opt->{foreign},
          );
    return $orig if $opt->{serial};
    return $result
  }
}
elsif ($opt->{serial}) {
  $field =~ s/\.(.*)//;
  my $hk = $1;
  return ed(
        dotted_hash(
          database_field($selector,$key,$field,$opt->{foreign}),
          $hk,
        )
      );
}
elsif ($opt->{hash}) {
  return undef unless $db->record_exists($key);
  return $db->row_hash($key);
}
elsif ($opt->{filter}) {
  return filter_value(
    $opt->{filter},
    ed(database_field($selector,$key,$field,$opt->{foreign})),
    $field,
  );
}

#The most common , don't enter a block, no accoutrements
return ed(database_field($selector,$key,$field,$opt->{foreign}));
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: db_date.tag,v 1.4 2007-03-30 23:40:56 pajamian Exp $

# [db-date table format]
#
# This tag returns the last-modified time of a database table,
# 'products' by default. Accepts a POSIX strftime value for
# date format; uses '%A %d %b %Y' by default.
#
UserTag  db-date  Order     table format
UserTag  db-date  PosNumber 2
UserTag  db-date  Version   $Revision: 1.4 $
UserTag  db-date  Routine   <<EOF
sub {
  my ($db, $format) = @_;
my ($dbfile, $mtime);

# use defaults if necessary
$db = 'products' unless $db;
  $format = '%A %d %b %Y' unless $format;

# build database file name
$dbfile = $Vend::Cfg->{ProductDir} . '/' 
  . $Vend::Cfg->{Database}{$db}{'file'};

# get last modified time
$mtime = (stat ($dbfile))[9];

if (defined ($mtime)) {
  return POSIX::strftime($format, localtime($mtime));
} else {
  logError ("Couldn't stat $dbfile: $!\n");
}
}
EOF

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: db_hash.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag db-hash Order      table column key
UserTag db-hash PosNumber  3
UserTag db-hash addAttr
UserTag db-hash Version    $Revision: 1.5 $
UserTag db-hash Routine    <<EOR
sub {
my($table, $col, $key, $opt) = @_;
$col =~ s/:+(.*)//s;
my $out;
my $rest = $1;
my $val = ::tag_data($table,$col,$key);

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 .= "\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

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: db_columns.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag db_columns  Order       name columns joiner passed_order
UserTag db_columns  AttrAlias   table name
UserTag db_columns  AttrAlias   fields columns
UserTag db_columns  Version     $Revision: 1.5 $
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 @cols if wantarray;
return join $joiner, @cols;
}
EOR

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: debug.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag debug  hasEndTag
UserTag debug  Interpolate
UserTag debug  Version      $Revision: 1.4 $
UserTag debug  MapRoutine   Vend::Util::logDebug

sub logDebug {
return unless $Global::DebugFile;

if(my $re = $Vend::Cfg->{DebugHost}) {
  return unless
     Net::IP::Match::Regexp::match_ip($CGI::remote_addr, $re);
}

if(my $sub = $Vend::Cfg->{SpecialSub}{debug_qualify}) {
  return unless $sub->();
}

my $msg;

if (my $tpl = $Global::DebugTemplate) {
  my %debug;
  $tpl = POSIX::strftime($tpl, localtime());
  $tpl =~ s/\s*$//;
  $debug{page} = $Global::Variable->{MV_PAGE};
  $debug{tag} = $Vend::CurrentTag;
  $debug{host} = $CGI::host || $CGI::remote_addr;
  $debug{remote_addr} = $CGI::remote_addr;
  $debug{request_method} = $CGI::request_method;
  $debug{request_uri} = $CGI::request_uri;
  $debug{catalog} = $Vend::Cat;
      if($tpl =~ /\{caller\d+\}/i) {
          my @caller = caller();
          for(my $i = 0; $i < @caller; $i++) {
              $debug{"caller$i"} = $caller[$i];
          }
      }
      $tpl =~ s/\{session\.([^}|]+)(.*?)\}/
              $debug{"session_\L$1"} = $Vend::Session->{$1};
              "{SESSION_\U$1$2}"
          /iegx;
  $debug{message} = errmsg(@_);

  $msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
}

# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: default.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag default             Order        name default
UserTag default             addAttr
UserTag default             PosNumber    2
UserTag default             Version      $Revision: 1.5 $
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