Correct [log type=error|debug] final newline behavior
[interchange.git] / code / UI_Tag / auto_wizard.coretag
1 # Copyright 2002-2007 Interchange Development Group and others
2
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 2 of the License, or
6 # (at your option) any later version.  See the LICENSE file for details.
7
8 # $Id: auto_wizard.coretag,v 1.20 2007-03-30 23:40:54 pajamian Exp $
9
10 UserTag  auto-wizard  Order     name
11 UserTag  auto-wizard  AddAttr
12 UserTag  auto-wizard  HasEndTag
13 UserTag  auto-wizard  Version   $Revision: 1.20 $
14 UserTag  auto-wizard  Routine   <<EOR
15
16 use vars qw/$Session $Tag $CGI $Tmp $Scratch $Values $ready_safe/;
17         
18 my @wanted_opts = qw/
19         already_message
20         already_title
21         bottom_buttons
22         break_row_class
23         combo_row_class
24         data_cell_class
25         data_row_class
26         display_type
27         help_cell_class
28         intro_text
29         label_cell_class
30         left_width
31         output_type
32         spacer_row_class
33         table_width
34         thanks_message
35         thanks_title
36         top_buttons
37         widget_cell_class
38         email_from
39         email_cc
40         email_subject
41         email_template
42         continue_template
43         row_template
44         output_email
45         output_fields
46         output_repeated
47 /;
48
49 my %overall_opt;
50 @overall_opt{@wanted_opts} = @wanted_opts;
51
52 sub thanks_title {
53         my ($opt, $already, $default) = @_;
54         my $tt = $already
55                         ?  ($opt->{already_title} ||= "You already did that survey!" )
56                         :  ($opt->{thanks_title} ||= $default || "Thanks for completing the survey!");
57         return errmsg($tt);
58 }
59
60 sub thanks_message {
61         my ($opt, $already) = @_;
62         my $tm;
63         if($already) {
64                 $opt->{already_message} ||=
65                         "We only want to collect information once from each person. Thank you.";
66                 $tm = $opt->{already_message};
67         }
68         else {
69                 $opt->{thanks_message} ||= "Your survey is complete. Thank you.";
70                 $tm = $opt->{thanks_message};
71         }
72         return errmsg($tm);
73         $opt->{intro_text} .= "<h1>$tm</h1>" if $already;
74 }
75
76 sub title_and_message {
77         my ($opt, $already) = @_;
78         my $tt = thanks_title($opt, $already);
79         my $tm = thanks_message($opt, $already);
80         return (
81                                 '',
82                                 "final: $tt",
83                                 'template: <<EOF',
84                                 $tm,
85                                 'EOF',
86                         );
87 }
88
89 sub already {
90         my ($wizname, $set) = @_;
91         my $surv = $Vend::Session->{surveys} ||= {};
92         if(defined $set) {
93                 $surv->{$wizname} = $set;
94         }
95
96         if ($Vend::Session->{logged_in} and ! $Vend::admin) {
97                 if (! defined $surv->{$wizname}) {
98                         my $o = {
99                                 function => 'check_file_acl',
100                                 location => "survey/$wizname",
101                         };
102                         $surv->{$wizname} = $Tag->userdb($o);
103                 }
104                 else {
105                         my $o = {
106                                 function => 'set_file_acl',
107                                 location => "survey/$wizname",
108                                 mode => $surv->{$wizname},
109                         };
110                         $Tag->userdb($o);
111                 }
112         }
113
114         return $surv->{$wizname};
115 }
116
117 sub survey_log_generate_final {
118         my ($wizname, $opt, $ary) = @_;
119
120         ref($opt) eq 'HASH'
121                 or die "bad call to generate_final routine, output options not hash ref ($opt)";
122         ref($ary) eq 'ARRAY'
123                 or die "bad call to generate_final routine, output not array ref ($ary)";
124
125         my $done = already($wizname);
126
127         push @$ary, title_and_message($opt, $done);
128
129         if ( $done ) {
130                 $opt->{intro_text} .= '<h1>' . thanks_title($opt, 1) . '</h1>';
131         }
132 #       else {
133 #               $opt->{survey_counter}  ||= "logs/survey/$wizname.cnt";
134 #               $opt->{survey_file}             ||= "logs/survey/$wizname.txt";
135 #               push @$ary, "\tsurvey_file: $opt->{survey_file}";
136 #               push @$ary, "\tsurvey_counter: $opt->{survey_counter}";
137 #       }
138         return;
139 }
140
141 sub gen_email_header {
142         my ($wizname, $ref, $opt, $fnames) = @_;
143         my $subject = errmsg($opt->{email_subject} || "Response to %s", $wizname);
144         my $from_addr = $opt->{email_from};
145         my $cc_addr = $opt->{email_cc};
146         for(qw/ EMAIL_SURVEY EMAIL_INFO EMAIL_SERVICE /) {
147                 next unless $from_addr = $::Variable->{$_};
148                 last;
149         }
150         $from_addr ||= $Vend::Cfg->{MailOrderFrom} || $Vend::Cfg->{MailOrderTo};
151         my $tpl = <<EOF;
152 From: $from_addr
153 Subject: $subject
154 To: {output_email}
155 EOF
156         $tpl .= "Cc: $cc_addr\n" if $cc_addr;
157         return $tpl;
158 }
159
160 sub gen_email_template {
161         my ($wizname, $ref, $opt, $fnames) = @_;
162         my $tpl = gen_email_header($wizname, $ref, $opt, $fnames);
163         $tpl .= <<EOF;
164
165 {code?}Sequence: {code}
166 {/code?}Username: {username}
167 IP Address: $CGI::remote_addr
168 Host: $CGI::remote_host
169 Date: {date}
170 --------------------------------------------
171 EOF
172
173         my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
174         if(! @fields) {
175                 @fields = @$fnames;
176         }
177
178         for(@fields) {
179                 $tpl .= "$_: {$_}\n";
180         }
181         $tpl .= "--------------------------------------------\n";
182         return $tpl;
183 }
184
185 sub email_output {
186         my ($wizname, $ref, $opt, $fnames) = @_;
187 #::logDebug("Called email_output");
188         return unless  $opt->{output_email};
189
190 #::logDebug("email_output has an address of $opt->{output_email}");
191         ## Check and see if already sent
192         if(! $opt->{output_repeated} and already($wizname)) {
193 #::logDebug("email_output already done, repeated=$opt->{output_repeated} already=" . ::uneval($Vend::Session->{surveys}));
194                 return;
195         }
196
197 #::logDebug("email_output is continuing");
198         my $tpl  = $opt->{email_template};
199         if(! $tpl or $tpl !~ /\S/) {
200                 $tpl = gen_email_template($wizname, $ref, $opt, $fnames);
201         }
202         else {
203                 $opt->{email_template} =~ s/\s+$//;
204                 $opt->{email_template} =~ s/^\s+//;
205                 if($opt->{email_template} !~ /[\r\n]/) {
206                         $tpl = interpolate_html(Vend::Util::readfile($opt->{email_template}));
207                 }
208                 else {
209                         $tpl = $opt->{email_template};
210                 }
211                 if($tpl !~ /^[-\w]+:/) {
212                         $tpl = join "\n", gen_email_header($wizname, $ref, $opt, $fnames), $tpl;
213                 }
214         }
215
216 #::logDebug("email_output tpl=$tpl");
217
218         my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
219         if(! @fields) {
220                 @fields = @$fnames;
221         }
222         
223         my $outref = { %$opt };
224
225         $outref->{ip_address} = $CGI::remote_addr;
226         $outref->{host_name} = $CGI::remote_host;
227         $outref->{username} = $Vend::username || 'anonymous';
228         $outref->{date} = POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime());
229
230         for(@fields) {
231                 $outref->{$_} = $Values->{$_};
232         }
233         my $out = tag_attr_list($tpl, $outref);
234
235         my $status;
236         $status = $Tag->email_raw({}, $out)
237                 or ::logError("Failed to send survey email output:\n$out");
238 #::logDebug("email_output status=$status");
239         return $status;
240 }
241
242 sub survey_log_to_file {
243         my ($wizname, $ref, $opt, $fnames) = @_;
244
245         if(! $opt->{output_repeated} and already($wizname)) {
246                 return template_attr($wizname, $ref, $opt, $fnames);
247         }
248
249         my $fn   = $ref->{survey_file};
250         my $cfn  = $ref->{survey_counter};
251         my $sqlc = $ref->{survey_counter_sql};
252
253         if(! $fn) {
254                 $fn = $::Variable->{SURVEY_LOG_DIR} || 'logs/survey';
255                 $fn .= "/$wizname.txt";
256         }
257
258         if(! $cfn and ! $sqlc) {
259                 $cfn = $fn;
260                 $cfn =~ s/\.txt$//;
261                 $cfn .= '.cnt';
262                 $cfn =~ s:(.*/):$1.:;
263         }
264
265         my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
266         if(! @fields) {
267                 @fields = @$fnames;
268         }
269         if(! -f $fn) {
270                 my $string = join "\t",
271                                                 'code', 'ip_address', 'username', 'date', @fields;
272                 $string .= "\n";
273                 $Tag->write_relative_file($fn, $string);
274         }
275
276         my @o = $Tag->counter({file => $cfn, sql => $sqlc});
277         push @o, $CGI::remote_addr;
278         push @o, $Vend::username || 'anonymous';
279         push @o, POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime());
280
281         for(@fields) {
282                 my $result = $Values->{$_};
283                 $result =~ s/\r?\n/\r/g;
284                 $result =~ s/\t/  /g;
285                 push @o, $result;
286         }
287
288         ::logData($fn, @o);
289         email_output($wizname, $ref, $opt, $fnames);
290         already($wizname => 1) unless $opt->{output_repeated};
291         return template_attr($wizname, $ref, $opt, $fnames);
292 }
293
294 my %survey_genfinal = (
295         survey_log => \&survey_log_generate_final,
296         email_only => sub {
297                 my ($wizname, $opt, $ary) = @_;
298                 push @$ary, title_and_message($opt, already($wizname));
299                 if($opt->{continue_template}) {
300                         push @$ary, "template: <<EOF";
301                         push @$ary, $opt->{continue_template};
302                         push @$ary, 'EOF';
303                 }
304                 return;
305         },
306         default => sub {
307                 my ($wizname, $opt, $ary) = @_;
308                 my $line = "final: ";
309                 $line .= thanks_title(
310                                                 $opt,
311                                                 $Vend::Session->{surveys}{$wizname},
312                                                 errmsg("Finished with %s", $wizname),
313                                         );
314                 push @$ary, '';
315                 push @$ary, $line;
316                 if($opt->{continue_template}) {
317                         push @$ary, "template: <<EOF";
318                         push @$ary, $opt->{continue_template};
319                         push @$ary, 'EOF';
320                 }
321                 return;
322         },
323 );
324
325 sub template_attr {
326         my ($wizname, $ref, $opt, $fields) = @_; 
327         my %attr;
328
329         if(ref($fields) eq 'hash') {
330                 %attr = { %$fields };
331         }
332
333         $attr{TITLE} = $ref->{_page_title} || "Finished with $wizname...";
334         $attr{PROMPT} = $ref->{prompt};
335         $attr{ANCHOR} = $ref->{anchor} || 'Go';
336         $attr{EXTRA} = $ref->{extra} || '';
337         $attr{EXTRA} = " $attr{EXTRA}" if $attr{EXTRA};
338         $attr{URL} = wizard_url($ref, $opt, $fields);
339 #::logDebug("generated ATTR is: " . uneval(\%attr));
340         my $template = $ref->{template} || <<EOF;
341 <H1>{TITLE}</h1>
342 {PROMPT}
343 <p>
344 <blockquote>
345 <A HREF="{URL}"{EXTRA}>{ANCHOR}</A>
346 </blockquote>
347 EOF
348         return tag_attr_list($template, \%attr);
349 }
350
351 sub wizard_url {
352         my ($ref, $opt, $fields) = @_; 
353         my %attr;
354         my %ignore = qw/
355                                         page 
356                                         href
357                                         template
358                                         remap
359                                         /;
360                                 
361         my $form = { };
362         for(keys %$ref) {
363                 next if /^_/;
364                 next if $ignore{$_};
365                 $form->{$_} = $ref->{$_};
366         }
367
368         $form->{href} = $opt->{output_href} || $ref->{href} || $ref->{page};
369         if($opt->{output_parm}) {
370                 my $ref = Vend::Util::scalar_to_hash($opt->{output_parm}) || {};
371                 for (keys %$ref) {
372                         $form->{$_} = $ref->{$_};
373                 }
374         }
375         $form->{form} = 'auto';
376         for(@$fields) {
377                 $form->{$_} = $Values->{$_};
378         }
379
380         my $save = { };
381         if($ref->{remap}) {
382                 my @pairs = split /[\s,\0]+/, $ref->{remap};
383                 for(@pairs) {
384                         my ($k, $v) = split /=/, $_;
385                         next unless $k and $v;
386                         my $val = delete($form->{$k}) || $save->{$k};
387                         $save->{$k} = $val;
388                         $form->{$v} = $val;
389                 }
390         }
391
392         return $Tag->area($form);
393 }
394
395 my %survey_auto = qw/
396                                                 survey_log   1
397                                                 email_only   1
398                                                 auto_bounce  1
399                                         /;
400 ## Called with:
401 ##
402 ##      $$dest = $sub->($wizname, $ref, $opt, \@vals);
403 ##
404 ##       $wizname name of wizard/survey
405 ##       $ref     copy of final stanza of auto_wizard, hash ref with keys, can modify
406 ##       %opts    Options auto_wizard was created with, can modify
407 ##       @vals    Fields names collected in the wizard, can modify
408
409 my %survey_action = (
410         survey_log => \&survey_log_to_file,
411         auto_bounce => sub {
412                 my ($wizname, $ref, $opt, $fnames) = @_;
413                 my $url = wizard_url($ref, $opt, $fnames);
414                 email_output($wizname, $ref, $opt, $fnames);
415                 my $status = $Tag->deliver( { type => 'text/html', location => $url });
416                 return $status;
417         },
418         default => sub {
419                 my ($wizname, $ref, $opt, $fnames) = @_;
420                 $ref->{wizard_name} = $wizname;
421                 email_output($wizname, $ref, $opt, $fnames);
422                 return template_attr($wizname, $ref, $opt, $fnames);
423         },
424 );
425
426 sub compile_wizard {
427         my ($wizname, $opt, $script) = @_;
428 #Debug("script in: $script");
429         $script =~ s/^\s+//;
430         $script =~ s/\r\n/\n/g;
431         $script =~ s/\r/\n/g;
432         my @lines = split /\n/, $script;
433         my $ref;
434
435         my @pages;
436
437         my $qip; # question in progress
438         my $iip; # item in progress
439         my $fip; # final in progress
440         my $bip; # breaks in progress
441         my $blip; # break labels in progress
442         my $began; # We have begun
443
444         my $sip;
445         my $vip;
446         my $mark;
447         my $break;
448         my %opts;
449
450         if($opt->{db_id}) {
451 #Debug("found db_id=$opt->{db_id}");
452                 my ($t, $k) = split /:+/, $opt->{db_id}, 2;
453                 BUILDWIZ: {
454                         my $met = $Tag->meta_record($k, undef, $t)
455                                 or last BUILDWIZ;
456                         my($structure) = delete $met->{ui_data_fields};
457                         delete $met->{extended};
458                         %opts = %$met;
459 #Debug("display type=$opts{display_type} met=" . ::uneval($met) );
460                         $met->{row_template} = $opt->{row_template}
461                                 if $opt->{row_template};
462                         my $ids = $t . '::' . $k . '::';
463                         $structure =~ s/\r\n?/\n/g;
464                         my $string = "\n\n$structure";
465                         my %break;
466                         while ($string =~ s/\n+(?:\n[ \t]*=(.*))?\n+[ \t]*(\w[:.\w]+)/\n$2/) {
467                                 $break{$2} = $1;
468                         }
469                         $string =~ s/^[\s,\0]+//;
470                         $string =~ s/[\s,\0]+$//;
471                         $string =~ s/[,\0\s]+/ /g;
472                         my @fields = split /\s+/, $string;
473                         my @out = "$k: $met->{label}";
474                         my $i = 1;
475                         my $fields_line = join "\t", @fields;
476                         for(@fields) {
477                                 if($break{$_}) {
478                                         push @out, "$i: $break{$_}";
479                                         $i++;
480                                 }
481                                 push @out, "\tdb_id: $ids$_";
482                                 push @out, '';
483                         }
484                         $opts{output_fields} ||= join " ", @fields;
485                         my $otype = $opts{output_type} || 'default';
486                         my $sub = $survey_genfinal{$otype} || $survey_genfinal{default};
487                         $sub->($k, \%opts, \@out);
488                         @lines = @out;
489                 }
490         }
491
492 #Debug("Found some lines, number=" . scalar @lines);
493 #Debug("display type=$opts{display_type}");
494         for(@lines) {
495                 if($mark) {
496                         $sip .= "$_\n", next
497                                 unless $_ eq $mark;
498                         $_ = $sip;
499                         undef $mark;
500                         undef $sip;
501                 }
502
503                 if (s/<<(\w+)$//) {
504                         $mark = $1;
505                         $sip = $_;
506                         next;
507                 }
508
509                 s/\s+$//;
510
511                 if(! $_) {
512                         undef $iip;
513                         next;
514                 }
515
516                 if(! $ref) {
517                         if(/^(\w+):\s*(.*)/) {
518                                 $began = 1;
519                                 $wizname ||= $1;
520                                 my $title = $2;
521                                 $ref = {
522                                                 _page_name => 'begin',
523                                                 _name => [],
524                                                 title => $title,
525                                                 %opts,
526                                         };
527                         }
528                         next;
529                 }
530
531                 if(/^(\d+)[:.]\s*(.*)/) {
532                         my $pn = $1; my $title = $2;
533                         push @pages, $ref;
534                         my $lastpage = $ref->{_page_name};
535                         $qip = [];
536                         undef $bip;
537                         undef $blip;
538                         $ref = {        
539                                                 _page_name              => $pn,
540                                                 _name                   => $qip,
541                                                 _breaks                 => $bip,
542                                                 _break_labels   => $blip,
543                                                 _page_title             => $title,
544                                                 };
545                         next;
546                 }
547                 if(/^final[:.]\s*(.*)/) {
548                         undef $qip;
549                         undef $iip;
550                         $fip = 1;
551                         my $title = $1;
552                         push @pages, $ref;
553                         my $lastpage = $ref->{_page_name};
554                         $ref = { _page_name => 'final', _page_title => $title};
555                         next;
556                 }
557
558
559                 if($fip) {
560                         s/^\s+//;
561                         unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
562                                 $Tag->warnings(qq{Unrecognized "$_" in middle of script.});
563                                 next;
564                         }
565                         my $thing    = $1;
566                         my $modifier = $2;
567                         my $value    = $3;
568                         if($modifier) {
569                                 $ref->{_modifier} ||= {};
570                                 $ref->{_modifier}{$thing} = $modifier;
571                         }
572                         $ref->{$thing} = $value;
573                         next;
574                 }
575
576                 if($qip) {
577                         if(/^(itl|perl)(?:_condition)?:\s*(.*)$/s) {
578                                 if(! $ref->{_condition}) {
579                                         $ref->{_condition_type} = $1;
580                                         $ref->{_condition} = $2;
581                                 }
582                                 else {
583                                         $Tag->error(
584                                                 "%s_condition: cannot set twice in wizard %s screen %s",
585                                                 $1,
586                                                 $pages[0]->{_title},
587                                                 $ref->{_page_name},
588                                         );
589                                         return;
590                                 }
591                                 next;
592                         }
593                         elsif(/^opt:\s*(.*)$/s) {
594                                 my $option = $1;
595                                 $option =~ s/\s+$//;
596                                 my ($n, $v) = split /=/, $option, 2;
597                                 my $o = $ref->{_options} ||= [];
598                                 push @$o, $n, $v;
599                                 next;
600                         }
601
602                         s/^\s+//;
603                         unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
604                                 $Tag->warnings(qq{Unrecognized "$_" in middle of script.});
605                                 next;
606                         }
607                         my $thing = $1;
608                         my $modifier = $2;
609                         my $value = $3;
610
611                         if(! $iip) {
612
613                                 ## This redoes the loop
614                                 if($thing eq 'name') {
615                                         $thing = $value;
616                                         undef $value;
617                                 }
618                                 elsif($thing eq 'break') {
619                                         $break = $value;
620                                         $break =~ s/,/&#41;/g;
621                                         $ref->{_breaks} ||= ($bip = []);
622                                         $ref->{_break_labels} ||= ($blip = []);
623                                         next;
624                                 }
625                                 elsif($thing eq 'db_id') {
626                                         my ($t, $survey, $name) = split /:+/, $value, 3;
627                                         $thing = $name;
628                                         my $key = $survey . '::' . $name;
629                                         my $meta = $Tag->meta_record($key, undef, $t);
630                                         if($meta) {
631                                                 for(keys %$meta) {
632                                                         $ref->{$_} ||= {};
633                                                         $ref->{$_}{$thing} = $meta->{$_};
634                                                 }
635                                         }
636                                         $ref->{name}{$thing} = $thing;
637 #::logDebug("meta record is " . ::uneval($meta));
638
639                                         undef $value;
640                                 }
641
642                                 $iip = $thing;
643                                 push @$qip, $iip;
644                                 if($break) {
645                                         push @$bip, $iip;
646                                         push @$blip, "$iip=$break";
647                                         undef $break;
648                                 }
649                                 $ref->{label}{$iip} = $value if $value;
650                                 next;
651                         }
652
653                         if($modifier) {
654                                 $ref->{_modifier} ||= {};
655                                 $ref->{_modifier}{$thing} ||= {};
656                                 $ref->{_modifier}{$thing}{$iip} = $modifier;
657                         }
658                         $ref->{$thing} ||= {};
659                         $ref->{$thing}{$iip} = $value;
660                 }
661                 else {
662                         unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
663                                 $Tag->warnings(qq{Unrecognized "$_" in beginning section of script.});
664                                 next;
665                         }
666                         my $thing = $1;
667                         my $modifier = $2;
668                         my $value = $3;
669                         $ref->{$thing} = $value;
670                 }
671         }
672         push @pages, $ref;
673         $wizname ||= 'default';
674         my $wiz_ary = $Session->{auto_wizard} ||= {};
675         $wiz_ary->{$wizname} = \@pages;
676 #Debug("Wizard $wizname=" . ::uneval(\@pages));
677         return $wizname;
678 }
679
680 sub {
681         my ($wizname, $opt, $body) = @_;
682
683         my $dest;
684         $wizname ||= $CGI->{wizard_name};
685
686         if($opt->{scratch}) {
687                 $Tag->tmp($opt->{scratch});
688                 $::Scratch->{$opt->{scratch}} ||= '';
689                 $dest = \$::Scratch->{$opt->{scratch}};
690         }
691         else {
692                 $Tmp->{auto_wizard} ||= '';
693                 $dest = \$Tmp->{auto_wizard};
694         }
695         return $$dest if $opt->{show} and ! $opt->{run};
696
697         if($opt->{compile} eq 'auto') {
698                 $Session->{auto_wizard} ||= {};
699                 undef $opt->{compile} if $wizname && $Session->{auto_wizard}{$wizname};
700                 $opt->{show} = 1 unless defined $opt->{show};
701                 $opt->{run} = 1;
702         }
703
704         if($opt->{compile}) {
705                 my $n;
706                 $n = compile_wizard(@_)
707                         or do {
708                                 ::logError(
709                                         $$dest = errmsg(
710                                                                                         "Wizard %s failed to compile.",
711                                                                                         $wizname,
712                                                                                 )
713                                                         );
714                                 return;
715                                 };
716 #Debug("compiler returned wizname=$n");
717                 $wizname = $n;
718                 undef $body;
719         }
720
721         if(! defined $opt->{run}) {
722                 $opt->{run} = 1;
723                 $opt->{show} = 0 if ! defined $opt->{show};
724         }
725
726         my $title_var = $opt->{title_scratch}   || 'page_title';
727         my $banner_var = $opt->{banner_scratch} || 'page_banner';
728         my $wiz;
729
730         $wizname ||= $CGI->{wizard_name} || 'default';
731 #Debug("wizname=$wizname");
732
733         return unless $wiz = $Vend::Session->{auto_wizard}{$wizname};
734 #Debug("we have a wiz! wizname=$wizname");
735
736         my $beg = $wiz->[0];
737         my $fin = $wiz->[-1];
738
739         for($beg, $fin) {
740                 return "Bad wizard!" unless ref($_) eq 'HASH';
741         }
742
743         my $lastwiz = $#$wiz;
744         my $lastpage = $CGI->{wizard_page} || 0;
745         my $current_page;
746
747         my %opts;
748         copyref($beg, \%opts);
749
750         # Get rid of internal stuff
751         for(keys %opts) {
752                 next unless /^_/;
753                 delete $opts{$_};
754         }
755
756         if($CGI->{ui_wizard_action} eq 'Back') {
757                 $current_page = $lastpage - 1;
758         }
759         elsif($CGI->{ui_wizard_action} eq 'Cancel') {
760                 $current_page = 0;
761         }
762         elsif($CGI->{ui_wizard_action} eq 'Next') {
763                 $current_page = $lastpage + 1;
764         }
765         else {
766                 $current_page = $lastpage;
767         }
768
769         my $finished;
770         my $condition_done;
771         my $optref;
772 #::logDebug("Getting screens");
773         GETSCREEN: {
774                 $optref = $wiz->[$current_page];
775                 if(! $condition_done and $optref->{_condition}) {
776                         $condition_done = 1;
777                         my $result;
778                         if($optref->{_condition_type} eq 'itl') {
779                                 eval {
780                                         $result = interpolate_html($optref->{_condition});
781                                 };
782                                 $result =~ s/\s+$//;
783                                 $result =~ s/.*\s//s;
784                                 $result += 0;
785                                 $current_page += $result;
786                         }
787                         else {
788                                 eval {
789                                         $result = $ready_safe->reval($optref->{_condition});
790                                 };
791                                 if($@) {
792                                         $Tag->error(
793                                                 "error during perl conditional: $@\ncode was:\n%s",
794                                                 $@,
795                                                 $optref->{_condition},
796                                         );
797                                         $current_page -= 1;
798                                 }
799                                 $result += 0;
800 #::logDebug("did perl conditional, result=$result");
801                                 $current_page += $result;
802                         }
803                         redo GETSCREEN;
804                 }
805
806                 if($current_page <= 0) {
807                         $current_page = 1;
808                 }
809                 elsif ( ($current_page + 1) == $lastwiz ) {
810                         $opts{next_text} = errmsg('Finish')
811                                 if $survey_auto{$opts{output_type}} or $fin->{auto};
812                 }
813                 elsif ($current_page >= $lastwiz) {
814                         $finished = 1;
815                 }
816                 $optref = $wiz->[$current_page];
817         }
818         
819         unless($current_page <= 1) {
820                 delete $opts{intro_text};
821                 delete $optref->{intro_text};
822         }
823
824         my %modsub = (
825                         i               => sub {
826                                                         my $val = shift;
827 #                                                       ::logDebug("running interpolate of $val");
828                                                         return interpolate_html($val);
829                                                 },
830                         default => sub {
831                                                         my $val = shift;
832                                                         my $filters = join " ", @_;
833                                                         return $Tag->filter($filters, $val);
834                                                 },
835                 );
836
837         $Scratch->{$title_var}  = $optref->{_page_title};
838         $Scratch->{$banner_var} = $optref->{_page_title};
839
840         if($finished) {
841                         my $ref = { %$fin };
842
843                         my $mod;
844                         if( $mod = delete $ref->{_modifier}) {
845                                 for(keys %$ref) {
846                                         next if /^_/;
847                                         if(my $m = $mod->{$_}) {
848                                                 my $v = $ref->{$_};
849                                                 my $sub = $modsub{$m} || $modsub{default};
850                                                 $ref->{$_} = $sub->($ref->{$_}, $m);
851                                         }
852                                 }
853                         }
854
855                         my @vals;
856                         for my $w (@$wiz) {
857                                 next unless ref($w->{_name}) eq 'ARRAY';
858                                 push @vals, @{$w->{_name}};
859                         }
860
861                         my $otype = $opts{output_type};
862                         $otype ||= 'auto_bounce' if $ref->{auto};
863                         my $sub = $survey_action{$otype} || $survey_action{default};
864                         $$dest = $sub->($wizname, $ref, \%opts, \@vals);
865                         return $$dest if $opt->{show};
866                         return;
867 #Debug("finished, page ref=" . uneval($ref));
868
869         }
870
871 #Debug("we have a wiz=$wizname! current_page = $current_page");
872
873 #Debug("optref=" . $Tag->uneval(undef, $optref));
874
875 #::logDebug("prepping to walk optref");
876
877 ### TODO: Find bad reference when no section title...
878
879         my $name = $optref->{_name} || die;
880 #       $Scratch->{page_title} = $optref->{_page_title};
881
882         if($optref->{_breaks} and ref($optref->{_breaks}) eq 'ARRAY') {
883                 $opts{ui_break_before} = join " ", @{$optref->{_breaks}};
884                 $opts{ui_break_before_label} = join ",", @{$optref->{_break_labels}};
885         }
886
887         if(my $o = $optref->{_options}) {
888                 for (my $i = 0; $i < @$o; $i += 2) {
889                         $opts{$o->[$i]} = $o->[$i + 1];
890                 }
891         }
892
893         $opts{form_name} ||= 'wizard';
894         $opts{all_errors} = '1';
895         $opts{hidden} = {
896                 wizard_name => $wizname,
897                 wizard_page => $current_page,
898         };
899
900         $opts{wizard} = 1;
901         $opts{notable} = 1;
902         $opts{no_meta} = 1;
903         $opts{defaults} = 1;
904         $opts{mv_cancelpage} ||= 'index';
905         $opts{row_template} ||= $opt->{row_template} || <<'EOF' unless $opts{display_type};
906 {HELP?}<td>&nbsp;</td><td>
907      <span style="color: blue">{HELP}</span>
908          {HELP_URL?}<BR><A HREF="{HELP_URL}">more help</A>{/HELP_URL?}
909          </td>
910         </tr>
911     <tr class=rnorm>
912         {/HELP?}
913    <td class=cdata width="20%" valign=top> 
914      {LABEL}
915    </td>
916    <td class=cdata width=500> 
917            $WIDGET$
918    </td>
919  </tr>
920  <tr class=rspacer>
921    <td colspan=2><img src="bg.gif" height=1 width=1></td>
922 EOF
923
924         $opts{ui_wizard_fields} = join " ", @$name;
925         $opts{mv_nextpage} = $Global::Variable->{MV_PAGE};
926         $opts{mv_prevpage} = $Global::Variable->{MV_PAGE} if $current_page != 1;
927         $opts{bottom_buttons} = 1;
928
929 #::logDebug("walking optref");
930         my $mod = $optref->{_modifier} || '';
931         for(keys %$optref) {
932                 next if /^_/;
933                 next if $overall_opt{$_};
934                 next unless ref($optref->{$_}) eq 'HASH';
935                 $opts{$_} = {} if ref($opts{$_}) ne 'HASH';
936                 Vend::Util::copyref($optref->{$_}, $opts{$_});
937                 my $m;
938                 if($mod and $m = $mod->{$_}) {
939                         my $r = $opts{$_};
940                         for my $k (keys %$r) {
941                                 next unless $m->{$k};
942                                 my @subs = split /\s*,\s*/, $m->{$k};
943                                 for(@subs) {
944                                         my $sub = $modsub{$_} || $modsub{default};
945                                         $r->{$k} = $sub->($r->{$k}, $_);
946                                 }
947                         }
948                 }
949         }
950
951         $opts{widget} ||= {};
952         if( my $r = delete $opts{type} ) {
953                 for(keys %$r) {
954                         $opts{widget}{$_} = $r->{$_};
955                 }
956         }
957
958         delete $opts{type};
959         # Prevent ui_data_fields from parent corrupting wizard
960         delete $opts{ui_data_fields};
961         delete $opts{extended};
962 #::logDebug("calling table_editor opts=" . ::uneval(\%opts));
963         $$dest = $Tag->table_editor( {all_opts => \%opts });
964         if($$dest !~ /<form\s+/i) {
965                 my $msg = errmsg("Auto wizard failed to run wizard %s.", $name);
966                 $$dest .= $Tag->error({ show => 1, set => $msg });
967         }
968
969         return $$dest if $opt->{show};
970         return;
971 }
972 EOR