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