# 
#!/usr/local/bin/perl
#
#
use FileHandle;
use CGI qw(all);
use CGI::State;
use CGI::Carp qw(fatalsToBrowser);
use CGI "shortcuts";
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Response;
use URI::URL;
use Data::Dumper;
use Time::CTime;
no strict ; #"refs";

$CGI::State::globaldefault = 'DEFAULT';   # name of default config file to read
$CGI::State::defaultsuffix = '.CFG';
$CGI::State::perlsuffix    = '.pl';
$CGI::State::htmlsuffix    = '.html';
$CGI::State::helpsuffix    = '.help';
$CGI::State::MONITOR       = 1;
$CGI::State::defaultstub   = 'default';   # name of default perl file to do{}
$CGI::State::popup_undef   = 'Please select';   # value of an unset popup menu

$MAIN::logfilename         = 'logfile';   # name of file to log results to
$MAIN::bgcolor             = "#FFFF00";
$MAIN::debugstring         = '<HIDDEN NAME="DEBUG" VALUE="1">';

#General purpose CGI skeleton for state-tracking applications
#
#This is a skeleton CGI script. What it does is entirely dependent on
#external configuration files.
#
#When invoked with no arguments, via method GET, it looks for a 
#configuration file called DEFAULT.CFG. (More on the details of this
#later.) DEFAULT.CFG specifies:
#
#* the data type and names of some persistent data stores to initialize
#* a boilerplate pre-HTML file to read
#* a perl logic module to execute
#* a set of control variables (which are also stored in a persistent store)
#
#A new CGI::State object is created, and the data stores are initialized.
#
#The perl logic module is then loaded and executed, and may make 
#changes to the program's state control variables. (It uses the do{}
#mechanism, and there is probably no logic to speak of required by the
#first DEFAULT state.)
#
#Next, the pre-HTML file is fed to the macro processor, which does various
#things (including inserting links for %next% and %previous%, in accordance
#with the control variables, and writing the persistent stores out into the
#CGI object's HTML output stream).
#
#Once the user hits the %next% or %previous% links, they're in the state
#machine. What they see is entirely controlled by the control variables
#declared in DEFAULT.CFG, unless they've been modified since then by an
#intermediate CGI.
#
#Note: the CGI object, and the perl code, correspond to the current state
#the program is in. But the HTML form that is produced corresponds to the
#NEXT state that the program is to enter -- it builds the dialog. In this
#way, there's no 'submit' button; just forward and back. 
#
#THE only exceptions to this model are the START state (probably no perl code
#to execute) and the FINISH state (maybe no HTML to produce).
#
#The control data structure looks like this:
#
# store (control) {
#     scalar STATE  -- the current state to process
#     scalar NEXT   -- the next state to enter
#     scalar TERM   -- a special terminal state (end-point)
#     scalar GLOBALERR  -- any current state warning messages
#     array HELPTXT -- an array of help texts, corresponding to states
#     array SEQ     -- an array of states to traverse, in order
#     hash ST_HTML  -- a hash of states => pre-HTML files (macro files/state)
#     hash ST_PERL  -- a hash of states => perl logic files to do{}
#     hash STORE    -- a hash that will be used to store any persisent vars 
#                      programmer needs the current application; these are
#                      used in the macro processing back-end for interpolating
#                      form contents (i.e. it is assumed that items in STORE
#                      are fields in an HTML form)
# }
#
# See the comments under 'initialize' for a discussion of the file format.
# NB: all variables stored under control are refs to the relevent structure;
# e.g. $control->{ST_HTML}->{'START'}. Only exception is scalars, stored as
# themselves.
# 
#=cut
#
#------- main program ---------
#

my ($c) = new CGI::State;

# print $c->header('text/html');

if ($c->request_method() eq 'GET') {
   # we don't use GET, so this is our first time round the block
   $CGI::State::MONITOR && warn "received GET request\n";
   initialize($c, $CGI::State::globaldefault);
   $MAIN::MS && notify_microsoft_of_session($c);
   exec_script($c);
   do_results($c);
} elsif ($c->request_method() eq 'POST') {
   # we're processing a form
   # loadconfig($c);
   $CGI::State::MONITOR && warn "----- RUNNING -----\n";
   exec_script($c);
   do_results($c);
} else {
   # something REALLY flakey is going on -- unidentified HTTP method?
   dump_error($c);
}
$CGI::State::MONITOR && warn "----- FINISHED -----\n";

#undef $c; -- as CGI app under CGI.pm
#exit 0;   -- ditto
#
#------- main subroutines, called in order by the program -----
#

sub initialize ($$) {
    # initialize a CGI::State session within the application.
    # 
    my ($c) = shift @_;   # CGI::State object
    my ($g) = shift @_;   # globaldefault -- filename. (Specified here so that
                          # if necessary we can support multiple default files.)

    # open the default filename. Read in the data in it. Data is specified
    # in records where field #1 = data type, field #2 = variable name, and
    # following fields are data to be stored in the named field. fields are
    # tab-delimited; literal tabs are represented by \t
    # 
    # Records are grouped into a block named <thingy>, like this:
    # 
    # store (thingy) {
    #     scalar  fred  "this is stored in fred"
    #     array   numbers  1  2  3  "element four" "something\twith a tab in it"
    # }
    # 
    # Once variables are initialized, they are stashed in a CGI::State
    # persistent store named for their block.
    # 
    $CGI::State::MONITOR && warn "entering initialize(", ref($c), ", $g) ...\n";
    my ($i) = 0;                          # line counter
    my ($fname) = $g . $CGI::State::defaultsuffix;
    open(IN, "<$fname") || die "open($fname) failed\n";
    $CGI::State::MONITOR && warn "opened $fname\n";
    my ($l) = "";
    while (defined($l = <IN>)) {
        $i++;
        chomp $l;
        $l =~ s/^(.*?)#(.*?)$/$1/;        # strip comments following first '#'
        $CGI::State::MONITOR && warn "$i: $l\n";
        next if ($l =~ /^\s*$/);          # skip whitespace lines
        if ($l =~ /^\s*?store\s*?\((\S+)\)\s*?{/) {
            my ($storename) = $l;
            $storename =~s/^\s*?store\s*?\((\S+)\)\s*?{/$1/;
            $CGI::State::MONITOR && warn "initialize(): line $i: block $storename\n";
            $i = _process_block(IN, $c, $storename, $i);
        }
    }
    $CGI::State::MONITOR && warn "finished looping on $fname -- read $i lines\n";
    close(IN);
    $c->init_store("STATE", "SCALAR");
    $c->put_store("STATE", "START");
    # kludge to add session ID to store "control"
    my ($s) = $c->fetch_store('control');
    my ($sess_id) = $$ . '_' . time;
    $s->{'SESS_ID'} = $sess_id;
    $c->put_store("control", $s);  
    return;
}

sub _process_block($$$$) {
    # this is ONLY called by initialize()'s parser, and is used to return
    # a storage block's contents
    my ($IN)    = shift @_;   # file handle we're parsing
    my ($c)     = shift @_;   # CGI::State object we're storing stuff under
    my ($s)     = shift @_;   # store name we're populating in $c
    my ($i)     = shift @_;   # line counter
    my ($l)     = "";         # read buffer
    my (%tmp)   = ();         # hash to hang temporary variables off
    
    $CGI::State::MONITOR && warn "entering _process_block() at line $i\n";
    while (defined($l = <IN>)) {
        $i++;
        $l =~ s/^(.*?)#(.*?)$/$1/;        # strip comments following first '#'
        next if ($l =~ /^\s*$/);          # skip whitespace lines
        chomp $l;                         # strip end of line marker
        if ($l =~ /^\s*?}/) {             # return if this is a block-end marker
            return ($l, $i);
        }
        $CGI::State::MONITOR && warn "_process_block(): line $i: \n$l\n";
        #
        # let's do some error trapping
        # 
        if ($l =~ /^\s*?store\s*?\((\S+)\)\s*?{/) {
            $CGI::State::MONITOR && warn "_process_block(): line $i: error: recursive block ",
                 "declaration forbidden.";
            next;
        }
        my (@l) = split(/\t/, $l);        # split tab-delim record into @l
        if ($l[0] !~ /array|scalar|hash/i) {
            $CGI::State::MONITOR && warn "_process_block(): line $i: unrecognized data type $l[0]\n";
            next;
        }
        if (scalar(@l) < 3) {
            $CGI::State::MONITOR && warn "_process_block(): line $i: not enough parameters for $l[0]\n";
            next;
        }
        if (($l[0] =~ /hash/) && ((scalar (@l) % 2) != 0 )) {
            $CGI::State::MONITOR && warn "_process_block(): line $i: hash declared with odd number ",
                 "of parameters!\n";
            next;
        }
        #
        # error conditions trapped -- now let's store variables below %tmp
        # 
        if ($l[0] =~ /scalar/) {
            $tmp->{$l[1]} = join("\t", @l[2..$#l]);  # scalar-ify contents
            $CGI::State::MONITOR && warn "created $l[1] as SCALAR ($tmp->{$l[1]}";
        } elsif ($l[0] =~ /array/) {
            $tmp->{$l[1]} = [ @l[2..$#l] ];          # array-ify contents
            $CGI::State::MONITOR && warn "created $l[1] as ARRAY";
        } elsif ($l[0] =~ /hash/) {
            $tmp->{$l[1]} = { @l[2..$#l] };          # hash-ify contents
            $CGI::State::MONITOR && warn "created $l[1] as HASH";
        } else {
            $CGI::State::MONITOR && warn "_process_block(): line $i: I am confused!\n";
            next;
        } 
        #
        # now let's put everything below %tmp into our store
        #
        $c->init_store($s, 'HASH');
        $c->put_store($s, $tmp);    
    }
    return $i;
}

sub exec_script ($) {
    my ($c) = shift;
    $CGI::State::MONITOR && warn "entering exec_script(", ref($c), ") ...\n";
    my ($i) = 0;                          # line counter
    my ($fname) = "";
    my ($code) = "";
    my ($s) = $c->fetch_store('control');
    $CGI::State::MONITOR && warn "exec_script(), state is ", ($s->{'STATE'} || 'unknown'), "\n" ;
    if (($s->{'STATE'} ne '') &&
        ($s->{'STATE'} ne 'START') ) {
        $fname = $s->{'ST_PERL'}->{$s->{'STATE'}} . $CGI::State::perlsuffix;
        $CGI::State::MONITOR && warn "setting fname to $fname\n";
    } else {
        # if our state is undefined, or we're in state START, execute
        # the default.pl file
        $CGI::State::MONITOR && warn "CGI::State::defaultstub is $CGI::State::defaultstub\n";
        $CGI::State::MONITOR && warn "CGI::State::perlsuffix is $CGI::State::perlsuffix\n";
        $fname = $CGI::State::defaultstub . $CGI::State::perlsuffix;
    }
    $CGI::State::MONITOR && warn "executing $fname\n";
    # do $fname || die "Failed to do $fname\n";
    open (STUB, "<$fname") ||
    $CGI::State::MONITOR && warn "Error: failed to import $fname\n";
    $code = join (" ", (<STUB>));
    $CGI::State::MONITOR && warn "eval(code): ";
    close STUB;
    my ($result) = eval $code;
    $CGI::State::MONITOR && warn "exec_script() returned $result \n";
    $c->put_store('control', $s);
}

sub do_results ($) {
    my ($c) = shift @_; # cgi object
    #
    print $c->header('text/html');  
    #
    # This is the routine that prints the HTML forms out

    $CGI::State::MONITOR && warn "entering do_results(", ref($c), ") ...\n";
    my ($i) = 0;                          # line counter
    my ($s) = $c->fetch_store('control');
    my ($fname) = $s->{'ST_HTML'}->{$s->{'STATE'}} . $CGI::State::htmlsuffix;
    $CGI::State::MONITOR && warn "state is ", $s->{'STATE'}, " and file is ", $fname, "\n";
    open(IN, "<$fname") || die "open($fname) failed\n";
    $CGI::State::MONITOR && warn "opened $fname\n";
    my ($l) = "";
    while (defined($l = <IN>)) {
        $i++;
        # warn "do_results(): line $i: $l\n";
        $l = macro_sub($l, $c, $s);
        print $l; 
    }
   log_transaction($c,$s);
   return;
}

sub dump_error ($) {
    my ($c) = shift @_;   # cgi object
    print $c->header(),
    $c->start_html("Something is wrong"),
    $c->h1("Something is wrong"),
    $c->hr(),
    $c->p("I can't process that request. Please copy the ",
    "following mumbo-jumbo and email it to ",
    "cstross\@demon.net, along with the time and date ",
    "at which it occured, the name and version of your web ",
    "browser and operating system, and any other information ",
    "you think may help him to fix it."),
    $c->dump(),
    $c->hr(),
    $c->dl( 
    $c->dt('accept'),
    $c->dd(join(' ', $c->accept())||'n/a'),
    $c->dt('raw_cookie'),
    $c->dd(join(' ', $c->raw_cookie())||'n/a'),
    $c->dt('user_agent'),
    $c->dd($c->user_agent()||'n/a'),
    $c->dt('path_info'),
    $c->dd($c->path_info()||'n/a'),
    $c->dt('path_translated'),
    $c->dd($c->path_translated()||'n/a'),
    $c->dt('remote_host'),
    $c->dd($c->remote_host()||'n/a'),
    $c->dt('script_name'),
    $c->dd($c->script_name()||'n/a'),
    $c->dt('referer'),
    $c->dd($c->referer()||'n/a'),
    $c->dt('auth_type'),
    $c->dd($c->auth_type()||'n/a'),
    $c->dt('server_name'),
    $c->dd($c->server_name()||'n/a'),
    $c->dt('virtual_host'),
    $c->dd($c->virtual_host()||'n/a'),
    $c->dt('server_software'),
    $c->dd(join(' ', $c->server_software())||'n/a'),
    $c->dt('remote_user'),
    $c->dd($c->remote_user()||'n/a'),
    $c->dt('user_name'),
    $c->dd($c->user_name()||'n/a'),
    $c->dt('request_method'),
    $c->dd($c->request_method()||'n/a'),
    ),
    $c->hr();
    foreach (@{ $c->param()} ) {
       print $c->dt($_),
             $c->dd($c->param($_));
       if ($_ =~ /XXfreezestore/) {
           my ($tmp) = $c->param($_);
           my ($thawed) = thaw($tmp);
           print $c->dd(Dumper $thawed);
       }
    }
    print $c->end_html();
}


sub macro_sub ($$$) {
    my ($l) = shift @_;
    my ($c) = shift @_;
    my ($s) = shift @_;
    my (%mac) =  (
                    '%date%'      => sub { return ctime(time); },
                    '%bgcolor%'   => sub { return $MAIN::bgcolor ;  },
                    '%debugger%'  => sub { return $MAIN::debugstring; },
                    '%startform%' => sub { return $c->startform(); },
                    '%endform%'   => sub { 
                                           my ($buff) = "";
                                           # allow persistent state changes 
                                           # made inside macros to persist
                                           $c->put_store('control', $s);
                                           $buff .= join("\n", $c->commit());
                                           $buff .= $c->end_form();
                                           return $buff; 
                                         },
                    '%next(.*?)%'  => sub { 
                                           my ($arg) = $1;
                                           $arg =~  s/\((.*)\)/$1/;
                                           return $c->submit(-name => "Next",
                                                             -value => $arg);
                                         },
                    '%prev(.*?)%'  => sub { 
                                          my ($arg) = $1;
                                           $arg =~  s/\((.*)\)/$1/;
                                           return $c->submit(-name => "Back",
                                                      -value => "$arg"
                                                  ) ; 
                                         },
                    '%sub(.*?)%'   => sub { 
                                          my ($arg) = $1;
                                          $arg =~  s/\((.*)\)/$1/;
                                          if ($arg !~ /,/) {
                                              return "%sub($arg)% ERROR";
                                          }
                                          my ($name, $cap) = split(/,/, $arg);
                                          return $c->submit(-name =>  $name,
                                                      -value => $cap
                                                  ) ; 
                                         },
                    '%do_warns%'  => sub { 
                                          warn 's->{GLOBALERR} is ', 
                                               $s->{'GLOBALERR'};
                                          return $s->{'GLOBALERR'} ; 
                                         },
                    #
                    # Now let's define the macro hooks for HTML form fields                     
                    #
                    '%input(.*?)%' => sub { return html_input($1, $c, $s); },
                    '%area(.*?)%'  => sub { return html_textarea($1, $c, $s); },
                    '%popup(.*?)%' => sub { return html_popup($1, $c, $s); },
                    '%fupld(.*?)%' => sub { return html_upload($1, $c, $s); },
                    '%ckbox(.*?)%' => sub { return html_checkbox($1, $c, $s); },
                    '%pass(.*?)%'  => sub { return html_password($1, $c, $s); },
                    '%scroll(.*?)%'=> sub { return html_scroll($1, $c, $s); },
                    '%radio(.*?)%' => sub { return html_radio($1, $c, $s); },
                    '%ckgrp(.*?)%' => sub { return html_ckgroup($1, $c, $s); },
                    #
                    # Variable interpolator from $s
                    #
                    '%var(.*?)%'   => sub { return var_interp($1, $c, $s); },
                    #
                    # Variable dereferencing interpolator from $s
                    #
                    '%val(.*?)%'   => sub { return val_interp($1, $c, $s); },
                    #
                    # Only-if-exists variable interpolator from $s 
                    #
                    '%ifdef_var(.*?)%' => sub { return var_ifdef($1, $c, $s); },
                    #
                    # Only-if-another-var-exists variable interpolator from $s 
                    #
                    '%if_other_var(.*?)%' => sub { return var_o($1, $c, $s); },
                    #
                    # String interpolators (based on var/value [in]equivalence)
                    #
                    '%if_var_ne_val(.*?)%' => sub { return var_ne($1, $c, $s); },
                    '%if_var_eq_val(.*?)%' => sub { return var_eq($1, $c, $s); },
                 );
   my ($k) = ""; 
   foreach $k (keys %mac) {
       my($v) = $mac{$k};
        if ($l =~ /$k/) { 
           if ($CGI::State::MONITOR != 0) {
               if (defined ($1)) {
                   warn "FOUND: $k [$1]\n"; 
		 } else {
                   warn "FOUND: $l";
                 }
           }
	 }
        $l =~  s/$k/&$v/eg;
   }   
   return $l ;
}

# let's define the html_* subs here. These are local shells around
# the appropriate CGI.pm subs, designed to take their parameters from a macro

sub html_input ($$$) {
    # provide shell around CGI::textfield()
    # 
    # macro syntax: %input(x[,y[,z]])%
    # where <x> is the name of the field
    #       <y> is the width of the field
    #       <z> is the maximum width of the field
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    my ($raw, $c, $s) = @_;
    $CGI::State::MONITOR &&  warn "In html_input($raw)";
    $raw =~  s/\((.*)\)/$1/;
    my (@raw) = split(',', $raw);
    my ($val) = $s->{'STORE'}->{$raw[0]} || "";
    $CGI::State::MONITOR &&  warn "value of $raw[0] is [$val]";
    # $CGI::State::MONITOR &&  warn Dumper $s;
    if (scalar(@raw) == 1) {
        return $c->textfield($raw[0],$val);
    } elsif(scalar(@raw) == 2) {
        return $c->textfield($raw[0],$val,$raw[1]);
    } elsif (scalar(@raw) == 3) {
        return $c->textfield($raw[0],$val,$raw[1],$raw[2]);
    }
    if ($CGI::State::MONITOR) {
        return "Error: textfield($raw) failed";
    } else {
        return "";
    }
}

sub html_textarea ($$$) {
    # provide shell around CGI::textarea()
    # 
    # macro syntax: %area(x[,y[,z]])%
    # where <x> is the name of the field
    #       <y> is the number of rows
    #       <z> is the number of columns
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw) = split(',', $raw);
    my ($val) = $s->{'STORE'}->{$raw[0]} || "";
    $val = unescape($val);
warn "value for $raw[0] is $val\n";
    if (scalar(@raw) == 1) {
        return $c->textarea(-name=>$raw[0],-default=>$val);
    } elsif(scalar(@raw) == 2) {
        return $c->textarea(-name=>$raw[0],-default=>$val,-rows=>$raw[1]);
    } elsif (scalar(@raw) == 3) {
        return $c->textarea(-name=>$raw[0],-default=>$val,
                            -rows=>$raw[1],-columns=>$raw[2]);
    }
    if ($CGI::State::MONITOR) {
        return "Error: textarea($raw) failed";
    } else {
        return "";
    }
}

sub html_password ($$$) {
    # provide shell around CGI::password_field()
    # 
    # macro syntax: %pass(x[,y[,z]])%
    # where <x> is the name of the field
    #       <y> is the width of the field
    #       <z> is the maximum width of the field
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw) = split(',', $raw);
    my ($val) = $s->{'STORE'}->{$raw[0]} || "";
    if (scalar(@raw) == 1) {
        return $c->password_field($raw[0],$val);
    } elsif(scalar(@raw) == 2) {
        return $c->password_field($raw[0],$val,$raw[1]);
    } elsif (scalar(@raw) == 3) {
        return $c->password_field($raw[0],$val,$raw[1],$raw[2]);
    }
    if ($CGI::State::MONITOR) {
        return "Error: password($raw) failed";
    } else {
        return "";
    }
}

sub html_upload ($$$) {
    # provide shell around CGI::filefield()
    # 
    # macro syntax: %fupld(x[,y[,z]])%
    # where <x> is the name of the field
    #       <y> is the width of the field
    #       <z> is the maximum width of the field
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw) = split(',', $raw);
    my ($val) = $s->{'STORE'}->{$raw[0]} || "";
    if (scalar(@raw) == 1) {
        return $c->filefield($raw[0],$val);
    } elsif(scalar(@raw) == 2) {
        return $c->filefield($raw[0],$val,$raw[1]);
    } elsif (scalar(@raw) == 3) {
        return $c->filefield($raw[0],$val,$raw[1],$raw[2]);
    }
    if ($CGI::State::MONITOR) {
        return "Error: filefield($raw) failed";
    } else {
        return "";
    }
}

sub html_popup ($$$) {
    # provide shell around CGI::popup_menu()
    # 
    # macro syntax: %popup(x,y[,z])%
    # where <x> is the name of the field
    #       <y> is a series of values, pipe-separated ( a|b|c )
    #       <z> is a hash of values => labels, pipe-separated pairs ( a|b|c|d )
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    # e.g: %popup(color,1|2|3,red|blue|green);
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw) = split(',', $raw);
    my ($selected) = $s->{'STORE'}->{$raw[0]} || $CGI::State::popup_undef;
    @vals = ();
    if (scalar(@raw) > 1) {
       @vals = split(/\|/, $raw[1]) ;
    } else {
       @vals = @{ $s->{'STORE'}->{$raw[0]} };
    }
    if ($selected eq $CGI::State::popup_undef) {
       push(@vals, $CGI::State::popup_undef);
    }
#   @vals = unique(@vals);
 warn "current values are [", join('][', @vals), "]\n";
    my (%labels) = ();
    if (scalar (@raw) < 3) {
        my (@tmp_labels) = map {($_, $_)} @vals;
        warn "labels [", join("][", @tmp_labels), "]\n";
        %labels = @tmp_labels;
    } elsif (scalar(@raw) == 3) {
        %labels = split(/\|/, $raw[2]);
    } else {
        if ($CGI::State::MONITOR) {
            return "Error: popup($raw): wrong paramenters";
        } else {
            return "";
        }   
    }
    if ($selected) {
        return $c->popup_menu(-name    => $raw[0],
                              "-values"  => \@vals,
                              -default => $selected,
                              -labels  => \%labels);
    } else {
        return $c->popup_menu(-name    => $raw[0],
                              "-values"  => \@vals,
                              -labels  => \%labels);
    }
}


sub html_scroll ($$$) {
    # provide shell around CGI::scrolling_list()
    # 
    # macro syntax: %scroll(v,w,x,y[,z])%
    # where <v> is the name of the field
    #       <w> is the size of the field
    #       <x> 1 if multiselect is true, 0 otherwise
    #       <y> is a series of values, pipe-separated ( a|b|c )
    #       <z> is a series of labels, pipe-separated pairs ( a|b|c|d )
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    # e.g: %scroll(cities,2,1|2|3,1|London|2|Paris|3|New York)%;
    # 
    # puts up a two-line selection box called 'cities', with 'London',
    # 'Paris' and 'New York' visible, returning values 1, 2, and 3
    # respectively.
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw)     = split(',', $raw);
    my ($name)    = $raw[0];                           # fieldname
    my (@default) = @{ $s->{'STORE'}->{$name} } || (); # default selections
    my ($size)    = $raw[1];                           # visible list height
    my ($multi)   = "";                                # multiple (boolean)
    if ($raw[2] == 1) {
        $multi = 'true';
    } else {
        $multi = '';
    }
    my (@vals) = split(/\|/, $raw[3]);
    my (%labels) = ();
    if (scalar (@raw) == 4) {
        map {$labels{$_} = $_ } @vals;
    } elsif (scalar(@raw) == 5) {
        my (@tmp) = split(/\|/, $raw[2]);
        if ($CGI::State::MONITOR) {
            return "Error: popup(raw): wrong num of hash paramenters";
        } else {
            return "";
        }   
        %labels = @tmp;
    } else {
        if ($CGI::State::MONITOR) {
            return "Error: popup(raw): wrong paramenters";
        } else {
            return "";
        }   
    }
    if ($multi eq 'true') {
        return $c->scrolling_list(-name     => $name,
                                  "-values"   => \@vals,
                                  -default  => \@default,
                                  -multiple => $multi,
                                  -size     => $size,
                                  -labels   => \%labels);
    } else {
        return $c->scrolling_list(-name     => $name,
                                  "-values"   => \@vals,
                                  -default  => \@default,
                                  -size     => $size,
                                  -labels   => \%labels);
    }
}


sub html_checkbox ($$$) {
    # provide shell around CGI::checkbox()
    # 
    # macro syntax: %ckbox(x,y)%
    # where <x> is the name of the field
    #       <y> is the value of the checkbox
    #       
    # -- -checked comes from $s->{STORE}->{x}
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw) = split(',', $raw);
    my ($val) = $s->{'STORE'}->{$raw[0]} || "";
    if (scalar(@raw) == 1) {
        return $c->checkbox(-name    => $raw[0],
                            -checked => $val,
                            -label   => "");
    } elsif (scalar(@raw) == 2) {
        return $c->checkbox(-name    => $raw[0],
                            -checked => $val,
                            -value   => $raw[1],
                            -label   => "");
    }
    if ($CGI::State::MONITOR) {
        return "Error: checkbox($raw) failed";
    } else {
        return "";
    }
}


sub html_radio ($$$) {
    # provide shell around CGI::radio_group()
    # 
    # macro syntax: %radio(v,w[,x[,y[,z]]])%
    # where <v> is the name of the group
    #       <w> is a set of values, pipe-separated ( a|b|c )
    #       <x> is the number of rows to display
    #       <y> is the number of columns to display
    #       <z> is a flattened hash of labels to print by the buttons
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    # e.g: %radio(numbers,1|2|3|4|5|6,2,3,1|one|2|two|3|three|4|four|5|five|6|six)%;
    # 
    # puts up a two row by three column grid containing buttons
    # with the values 1..6, and the field name 'numbers'. Next to each
    # button is printed the text of the value associated with it. A default
    # value is pulled from $s->{STORE]->{numbers}, if set.
    # 
    # Note: You CANNOT print labels next to buttons without defining a 2D grid!
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw)     = split(',', $raw);
    my ($name)    = $raw[0];                           # fieldname
    my ($default) = $s->{'STORE'}->{$name}  || '-';    # default selection
    my (@vals) = split(/\|/, $raw[1]);
    my ($table_on) = 0;
    my ($rows) = 1;
    my ($cols) = 1;
    if (scalar(@raw) == 3) {
        $table_on = 1;
        $rows =   $raw[2];          
    } elsif (scalar(@raw) >= 4) {
        $table_on = 1;
        $rows = $raw[2];
        $cols = $raw[3];
    }
    my ($nolabels) = 1;   # flag; indicates -nolabel option is set (default)
    my (%labels) = ();
    if (scalar(@raw) == 5) {
        $nolabels = 0;
        %labels = split(/\|/, $raw[4]);
    }   
    my ($labpar) = "";   # parameter to pass to radio_group()
    my ($labval) = "";   # value of that parameter
    
    if ($nolabels == 1) {
        $labpar = '-nolabels';
        $labval = 1;
    } else {
        $labpar = '-labels';
        $labval = \%labels;
    }
        
    if ($table_on == 1) {
        return $c->radio_group(-name     => $name,
                               "-values"   => \@vals,
                               -default  => $default,
                               $labpar   => $labval,
                               -rows     => $rows,
                               -cols     => $cols
                              );
    } else {
        return $c->radio_group(-name     => $name,
                               "-values"   => \@vals,
                               -default  => $default,
                               $labpar   => $labval,
                              );
    }
}

sub html_ckgroup ($$$) {
    # provide shell around CGI::checkbox_group()
    # 
    # macro syntax: %ckgrp(v,w[,x[,y[,z]]])%
    # where <v> is the name of the group
    #       <w> is a set of values, pipe-separated ( a|b|c )
    #       <x> is the number of rows to display
    #       <y> is the number of columns to display
    #       <z> is a flattened hash of labels to print by the buttons
    #       
    # -- default contents come from $s->{STORE}->{x}
    # 
    # e.g: %ckgrp(numbers,1|2|3|4|5|6,2,3,1|one|2|two|3|three|4|four|5|five|6|six)%;
    # 
    # puts up a two row by three column grid containing buttons
    # with the values 1..6, and the field name 'numbers'. Next to each
    # button is printed the text of the value associated with it. A default
    # value is pulled from $s->{STORE]->{numbers}, if set.
    # 
    # Note: You CANNOT print labels next to buttons without defining a 2D grid!
    # 
    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw)     = split(',', $raw);
    my ($name)    = $raw[0];                           # fieldname
    my (@default) = @{ $s->{'STORE'}->{$name}}  || (); # default selection
    my (@vals) = split(/\|/, $raw[1]);
    my ($table_on) = 0;
    my ($rows) = 1;
    my ($cols) = 1;
    if (scalar(@raw) == 3) {
        $table_on = 1;
        $rows =   $raw[2];          
    } elsif (scalar(@raw) >= 4) {
        $table_on = 1;
        $rows = $raw[2];
        $cols = $raw[3];
    }
    my ($nolabels) = 1;   # flag; indicates -nolabel option is set (default)
    my (%labels) = ();
    if (scalar(@raw) == 5) {
        $nolabels = 0;
        %labels = split(/\|/, $raw[4]);
    }   
    my ($labpar) = "";   # parameter to pass to radio_group()
    my ($labval) = "";   # value of that parameter
    
    if ($nolabels == 1) {
        $labpar = '-nolabels';
        $labval = 1;
    } else {
        $labpar = '-labels';
        $labval = \%labels;
    }
        
    if ($table_on == 1) {
        return $c->radio_group(-name     => $name,
                               "-values"   => \@vals,
                               -default  => \@default,
                               $labpar   => $labval,
                               -rows     => $rows,
                               -cols     => $cols
                              );
    } else {
        return $c->radio_group(-name     => $name,
                               "-values"   => \@vals,
                               -default  => \@default,
                               $labpar   => $labval,
                              );
    }
}

sub var_interp ($$$) {
    # for a given variable name, return whatever is stored against 
    # that name in $s->{'STORE'}. 
    # 
    # Note: this is stuff stored from a cgi script. It's being pumped
    # out into HTML. So we expect it to be a scalar or a list -- it
    # would be _really_ silly to do this to a hash or a ref!

    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    if ( ref($s->{'STORE'}->{$raw}) =~ /ARRAY/i) {
        return join(' ', $s->{'STORE'}->{$raw});
    }  else {
        return $s->{'STORE'}->{$raw} || return $s->{$raw};
    }
}

sub var_ifdef ($$$) {
    # for a given variable name, return whatever is stored against 
    # that name in $s->{'STORE'} -- IF AND ONLY IF it is defined. 
    # Otherwise, return an empty string.

    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    if (defined ($s->{'STORE'}->{$raw})) {
        if ( ref($s->{'STORE'}->{$raw}) =~ /ARRAY/i) {
            return join(' ', $s->{'STORE'}->{$raw});
        }  else {
            return $s->{'STORE'}->{$raw};
        }
    } else {
        return "";
    }
}

sub var_o ($$$) {
    # takes three args. If arg1 is a defined variable, and its value is arg2,
    # return whatever is stored in the named variable arg3.
    # Otherwise, return an empty string.
    #
    # e.g. %if_other_var(poot,corge)%
    # returns the contents of corge if poot is defined

    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my ($switch, $val, $target) = split(/,/, $raw);
    if ((defined ($s->{'STORE'}->{$switch})) &&
        ($s->{'STORE'}->{$switch} eq $val)) {
        if (defined ($s->{'STORE'}->{$target})) {
            if ( ref($s->{'STORE'}->{$target}) =~ /ARRAY/i) {
                return join(' ', $s->{'STORE'}->{$target});
            }  else {
                return $s->{'STORE'}->{$target};
            }
        }
    } else {
        return "";
    }
}

sub var_ne ($$$) {
    # takes three parameters; a variable name, a value, and a string.
    # if the contents of the named variable != the value, return the
    # string; otherwise return the empty string.
    #
    # e.g. %if_var_ne_val(CISS,1,"CISS not defined")% returns the
    # string 'CISS not defined', if CISS != 1.

    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my ($varname, $value, $retvar) = split(',', $raw);
warn "varname: $varname\nvalue: $value\nretvar: $retvar\n\n";
warn "stored variable s->{STORE}->{$varname} is ",
     $s->{'STORE'}->{$varname}, "\n";
    if ((defined($s->{'STORE'}->{$varname})) &&
        ($s->{'STORE'}->{$varname} eq $value)) {
warn "returning []\n";
        return "";
    } else {
warn "returning $retvar\n";
        return $retvar;
    }
}

sub var_eq ($$$) {
    # takes three parameters; a variable name, a value, and a string.
    # if the contents of the named variable == the value, return the
    # string; otherwise return the empty string.
    #
    # e.g. %if_var_eq_val(CISS,1,"CISS is defined")% returns the
    # string 'CISS is defined', if CISS == 1.

    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my ($varname, $value, $retvar) = split(',', $raw);
    if ((defined($s->{'STORE'}->{$varname})) &&
        ($s->{'STORE'}->{$varname} eq $value)) {
        return $retvar;
    } else {
        return "";
    }
}
sub val_interp ($$$) {
    # for a given variable name, locate whatever is stored against 
    # that name in $s->{'STORE'}. Then use the hash (second param in
    # the macro) to replace it with some other value. e.g.:
    # 
    # %val(FOO,1|red|2|blue|3|green)%
    # 
    # is replaced by 'red' (if FOO is '1'), 'blue' (if FOO is '2'), or
    # 'green' (if FOO is '3').
    # 
    # Note: This ONLY ONLY ONLY works for scalar values!!!

    my ($raw, $c, $s) = @_;
    $raw =~  s/\((.*)\)/$1/;
    my (@raw) = split(/,/, $raw);
    my ($key) = $s->{'STORE'}->{$raw[0]};
    my (@hash) = split(/\|/, $raw[1]);
    my (%hash) = @hash;
    return $hash{$key};
}


# now let's do some misc support subs

sub lnext ($$) {
   # given a scalar and a list ref, 
   # returns the successor to the scalar in the list - undef on error or if
   # successor falls off the end of the list
   # 
   my ($scalar) = shift @_;
   my ($listref) = shift @_;
   my (@list) = @$listref;
   my ($cnt) = 0;
   my (%map) = ();
   return undef if (ref($listref) !~ /array/i);
   map {$map{$_} = $cnt++ } @list;
   if ($map{$scalar} >= $#list) {
       return undef ;
   } else {
       return $list[($map{$scalar}+1)];
   }
}

sub lprev ($$) {
   # given a scalar and a list ref, 
   # returns the predecessor of the scalar in the list - undef on error or if
   # predecessor falls off the start of the list
   # 
   my ($scalar) = shift @_;
   my ($listref) = shift @_;
   my (@list) = @$listref;
   my ($cnt) = 0;
   my (%map) = ();
   return undef if (ref($listref) !~ /array/i);
   map {$map{$_} = $cnt++ } @list;
   if ($map{$scalar} <= 0) {
       return undef ;
   } else {
       return $list[($map{$scalar}-1)];
   }
}

sub forward ($) {
   # advance the CGI-processor state one notch
   my ($s) = shift @_;
   $s->{'STATE'} = $s->{'NEXT'};
   $s->{'NEXT'} = (lnext($s->{'STATE'}, $s->{'SEQ'}) || 'FINISH');
   $CGI::State::MONITOR && warn 'lnext(', $s->{'STATE'}, "...) is ", 
                                $s->{'NEXT'}, "\n";
   return $s;
}

sub rewind ($) {
   # rewind the CGI-processor state one notch
   my ($s) = shift @_;
   $s->{'NEXT'} = $s->{'STATE'};
   $s->{'STATE'} = lprev($s->{'STATE'}, $s->{'SEQ'}) || 'START'; 
   $CGI::State::MONITOR && warn 'lprev(', $s->{'NEXT'}, "...) is ", 
                                $s->{'STATE'}, "\n";
   return $s;
}

sub unique (@) {
    # return a list of unique items from @_
    my (@items) = @_;
    my (%list) = ();
    my (@buffer) = ();
    foreach (@items) {
        if (! defined($list{$_})) {
            push(@buffer, $_);
            $list{$_}++;
        }
    }
    return @buffer;    
}

sub get_ip_addr ($) {
    my ($q) = shift @_ || die "get_ip_addr(): no CGI object passed\n";
    my ($raw) = $q->remote_host();
    my ($addr) = "";
    if ($raw !~ /^(\d{1,3}\.){3}\d{1,3}$/) {
        $addr = join(".", unpack('C4', (gethostbyname($raw))[4])); 
    } else {
        $addr = $raw;
    }
    return $addr;
}

sub log_transaction($$) {
    # log whatever we just did 
    my ($c) = shift @_;                     # CGI object
    my ($s) = shift @_;                     # store of control vars
##############################################################
# commented out, for no obvious reason except to make like
# easier for me -- Charlie
#############################################################
#    my ($f) = new FileHandle ">>$MAIN::logfilename"
#             || die "Could not open [$MAIN::logfilename]\n";
#   my ($sess_id) = $s->{'SESS_ID'};
#   my ($state) = $s->{'STATE'};
#   my ($next)  = $s->{'NEXT'};
#   my ($tx) = ctime(time);
#   chomp $tx;
#   $f->print("$tx:Session:$sess_id:State:$state:Next:$next\n");
#   if ($next =~ /FINISH/) {
#       $f->print("$tx:Session:$sess_id:DUMP\n\n");
#       $f->print(Dumper $s);
#       $f->print("\nEND DUMP\n");
#   }
}

# unescape URL-encoded data
sub unescape {
    my($todecode) = @_;
    $todecode =~ tr/+/ /;       # pluses become spaces
    $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
    return $todecode;
}

# URL-encode data
sub escape {
    my($toencode) = @_;
    $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
    return $toencode;
}