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;

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

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

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

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

$page = '' if ! defined $page;

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

my $r;

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

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

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

# 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 {
    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.7 2007-03-30 23:40:49 pajamian Exp $

UserTag attr-list           addAttr
UserTag attr-list           hasEndTag
UserTag attr-list           PosNumber    0
UserTag attr-list           noRearrange
UserTag attr-list           Version      $Revision: 1.7 $
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

# 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::Variabl