[interchange-cvs] interchange - heins modified
eg/usertag/survey_wizard.coretag
interchange-cvs at icdevgroup.org
interchange-cvs at icdevgroup.org
Sun Apr 10 01:25:37 EDT 2005
User: heins
Date: 2005-04-10 05:25:37 GMT
Added: eg/usertag survey_wizard.coretag
Log:
* Temporary commit before remove of duplicate
Revision Changes Path
1.1 interchange/eg/usertag/survey_wizard.coretag
rev 1.1, prev_rev 1.0
Index: survey_wizard.coretag
===================================================================
# Copyright 2002 Interchange Development Group (http://www.icdevgroup.org/)
# Licensed under the GNU GPL v2. See file LICENSE for details.
# $Id: survey_wizard.coretag,v 1.1 2005/04/10 05:25:37 mheins Exp $
UserTag survey-wizard Order name
UserTag survey-wizard AddAttr
UserTag survey-wizard HasEndTag
UserTag survey-wizard Version $Revision: 1.1 $
UserTag survey-wizard Routine <<EOR
use vars qw/$Session $Tag $CGI $Tmp $Scratch $Values $ready_safe/;
my @wanted_opts = qw/
already_message
already_title
attach_fields
bottom_buttons
break_row_class
combo_row_class
data_cell_class
data_row_class
page_template_1
page_template_2
page_template_3
page_template_4
page_template_5
page_template_6
page_template_7
page_template_8
page_template_9
page_template_10
page_template_11
page_template_12
page_template_13
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 sw_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 sw_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 sw_title_and_message {
my ($opt, $already) = @_;
my $tt = sw_thanks_title($opt, $already);
my $tm = sw_thanks_message($opt, $already);
return (
'',
"final: $tt",
'template: <<EOF',
$tm,
'EOF',
);
}
sub sw_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 sw_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 = sw_already($wizname);
push @$ary, sw_title_and_message($opt, $done);
if ( $done ) {
$opt->{intro_text} .= '<h1>' . sw_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 sw_find_attachments {
my ($ref, $opt) = @_;
my @fields = @$ref;
my @attachments;
if($opt->{file_upload} and $opt->{attach_fields}) {
@attachments = grep /\S/, split /[\s,\0]/, $opt->{attach_fields};
my %att;
@att{@attachments} = @attachments;
@$ref = grep ! $att{$_}, @$ref;
@fields = grep ! $att{$_}, @fields;
}
return wantarray ? @attachments : \@attachments;
}
sub sw_non_attachments {
my ($ref, $opt) = @_;
my @fields = @$ref;
my @attachments;
if($opt->{file_upload} and $opt->{attach_fields}) {
@attachments = grep /\S/, split /[\s,\0]/, $opt->{attach_fields};
my %att;
@att{@attachments} = @attachments;
@fields = grep ! $att{$_}, @fields;
}
return wantarray ? @fields : \@fields;
}
sub sw_gen_email_template {
my ($wizname, $ref, $opt, $fnames) = @_;
my $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;
}
@fields = sw_non_attachments(\@fields, $opt);
for(@fields) {
$tpl .= "$_: {$_}\n";
}
$tpl .= "--------------------------------------------\n";
return $tpl;
}
sub sw_email_output {
my ($wizname, $ref, $opt, $fnames) = @_;
#::logDebug("Called sw_email_output");
return unless $opt->{output_email};
#::logDebug("sw_email_output has an address of $opt->{output_email}");
## Check and see if already sent
if(! $opt->{output_repeated} and sw_already($wizname)) {
#::logDebug("sw_email_output already done, repeated=$opt->{output_repeated} already=" . ::uneval($Vend::Session->{surveys}));
return;
}
#::logDebug("sw_email_output is continuing");
my $tpl = $opt->{email_template};
if(! $tpl or $tpl !~ /\S/) {
$tpl = sw_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};
}
}
my $subject = errmsg($opt->{email_subject} || "Response to %s", $wizname);
my $from_addr = $opt->{email_from};
my $cc_addr = $opt->{email_cc};
if(! $from_addr) {
for(qw/ EMAIL_SURVEY EMAIL_INFO EMAIL_SERVICE /) {
next unless $from_addr = $::Variable->{$_};
last;
}
}
$from_addr ||= $Vend::Cfg->{MailOrderFrom} || $Vend::Cfg->{MailOrderTo};
#::logDebug("sw_email_output tpl=$tpl");
my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
if(! @fields) {
@fields = @$fnames;
}
my @attachments = sw_find_attachments(\@fields, $opt);
#::logDebug("Found (in=$opt->{attach_fields}) attachments: " . join(",", @attachments));
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());
my $attach;
my $ul = $::Scratch->{user_uploads};
for my $afield (@attachments) {
next unless $ul->{$afield};
$attach ||= [];
my %a = (
path => $ul->{$afield},
);
if($Vend::Session->{logged_in}) {
my $dn = $::Variable->{SURVEY_LOG_DIR} || 'logs/survey';
$dn .= "/user_upload/$Vend::username";
$dn = Vend::Util::escape_chars($dn);
File::Path::mkpath($dn) unless -e $dn;
File::Copy::copy($ul->{$afield}, $dn);
}
push @$attach, \%a;
}
for(@fields) {
$outref->{$_} = $Values->{$_};
}
my $out = tag_attr_list($tpl, $outref);
my %email = (
from => $from_addr,
to => $opt->{output_email},
subject => $subject,
cc => $cc_addr,
attach => $attach,
);
my $status;
$status = $Tag->email(\%email, $out)
or ::logError("Failed to send survey email output:\n$out");
#::logDebug("sw_email_output status=$status");
return $status;
}
sub sw_survey_log_to_file {
my ($wizname, $ref, $opt, $fnames) = @_;
if(! $opt->{output_repeated} and sw_already($wizname)) {
return sw_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);
sw_email_output($wizname, $ref, $opt, $fnames);
sw_already($wizname => 1) unless $opt->{output_repeated};
return sw_template_attr($wizname, $ref, $opt, $fnames);
}
my %survey_genfinal = (
survey_log => \&sw_survey_log_generate_final,
email_only => sub {
my ($wizname, $opt, $ary) = @_;
push @$ary, sw_title_and_message($opt, sw_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 .= sw_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 sw_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} = sw_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 sw_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 => \&sw_survey_log_to_file,
auto_bounce => sub {
my ($wizname, $ref, $opt, $fnames) = @_;
my $url = sw_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;
sw_email_output($wizname, $ref, $opt, $fnames);
return sw_template_attr($wizname, $ref, $opt, $fnames);
},
);
sub sw_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]+$//;
my @pic = grep /\S/, split /[\r\n]+/, $string;
#Debug("pic=" . ::uneval(\@pic) );
$string =~ s/[,\0\s]+/ /g;
my @fields = split /\s+/, $string;
my @out = "$k: $met->{label}";
my $i = 1;
for my $sf (@fields) {
if($break{$sf}) {
my @flines;
push @out, "$i: $break{$sf}";
my $start = 0;
for my $nf (@pic) {
my @f = split /[,\0\s]+/, $nf;
if($start) {
if($break{$f[0]}) {
last;
}
else {
push @flines, $nf;
}
}
elsif($sf eq $f[0]) {
$start = 1;
push @flines, $nf;
}
}
push @out, "layout: " . join "|", @flines;
#Debug("layout: " . join "|", @flines);
$i++;
}
push @out, "\tdb_id: $ids$sf";
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(/^layout:\s*(.*)/) {
my @lines = split /\|/, $1;
$ref->{wizard_layout} = join "\n", @lines;
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/,/)/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 = sw_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> </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
if($optref->{wizard_layout} =~ / /) {
$opts{ui_wizard_fields} = $optref->{wizard_layout};
$opts{display_type} = $opts{multi_display_type} || '3';
}
else {
$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}, $_);
}
}
}
}
if(my $tpl = $opts{"page_template_$current_page"}) {
#::logDebug("yup, found a template=$tpl");
$opts{row_template} = '';
$opts{display_type} = 'default';
$opts{fields_template_only} = 1;
$opts{overall_template} = $tpl;
}
$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
More information about the interchange-cvs
mailing list