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