# 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. UserTag auto-wizard Order name UserTag auto-wizard AddAttr UserTag auto-wizard HasEndTag UserTag auto-wizard Version 1.20 UserTag auto-wizard Routine <{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} .= "

$tm

" 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: <{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} .= '

' . thanks_title($opt, 1) . '

'; } # 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 = <{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: <{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: <{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} || <{TITLE} {PROMPT}

{ANCHOR}
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/,/)/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?}  {HELP} {HELP_URL?}
more help{/HELP_URL?} {/HELP?} {LABEL} $WIDGET$ 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 !~ /error({ show => 1, set => $msg }); } return $$dest if $opt->{show}; return; } EOR