# whc_web - standrd Perl / Web routines for Well House Consultants applications
# For use on our own web site (www.wellho.net) and on training courses

# You are welcome to use these routines but they come "as is" and it's up to you
# to check that they're suitable and secure for your needs.

###################################################################################

use strict;

sub webify {
       $_ = $_[0];
       s/&/&/g;
       s/</&lt;/g;
       s/>/&gt;/g;
       s/"/&quot;/g;
       return $_;
       }

########################

# Code to translate form inputs (GET or POST) into a hash

sub collect_form {

my $buffer;
our %form;

if ($ENV{"REQUEST_METHOD"} eq "POST") {
        read(STDIN,$buffer,$ENV{"CONTENT_LENGTH"});
        $form{"method"} = "POST";
} else {
        $buffer = $ENV{QUERY_STRING};
        $form{"method"} = "GET";
}

my @fof = split(/&/,$buffer);
my $field;
foreach $field(@fof) {
        my ($name,$value) = split(/=/,$field);
        $value =~ tr/+/ /;
        $value =~ s/%([a-fA-F0-9]{2})/pack("C",hex($1))/eg;
        if ($form{$name}) {
                $form{$name} .= "\n$value";
        } else {
                $form{$name} = $value;
                }
        }
}

########################

# Read in a session (by given name or create a new session).

sub read_session {
my ($which) = @_;

our %session;
our $sessdir;
our $sesslife;

my $sessname;

# Read an existing session

if ($which) {
      $sessname = $which;
      open (FHS,"$sessdir/$sessname.ses") or webdie(701,"Session has expired");
    while (<FHS>) {
         chop;
           my ($name,$val) = split;
           $val =~ tr/+/ /;
           $val =~ s/%(..)/pack("C",hex($1))/eg;
           $session{$name} = $val;
 }
} else {

# Create a new session. Do bookkeeping while we're at it.

       $sessname = $$.time();
if (! -e $sessdir) {
        mkdir $sessdir,0700 or webdie(500,"Cannot create session directory");
        }
  # Take the opportunity of a new session to clean up stale ones
  opendir (DH,$sessdir);
  my $fname;
  while ($fname = readdir DH) {
           next if ($fname =~ /^\./);
              if (-M "$sessdir/$fname" > $sesslife/24) {
                  unlink "$sessdir/$fname";
               }
       }
}
return $sessname;
}

########################

sub save_session {

our %session;
our $sessdir;

my ($which) = @_;

   open (FHS,">$sessdir/$which.ses") or webdie (702,"Cannot write session file");
   foreach my $name (keys %session) {
         my $val = $session{$name};
         $val =~ s/%/%25/g;
              $val =~ s/\+/%2b/g;
             $val =~ s/\n/%0a/g;
             $val =~ s/ /+/g;
             print FHS "$name $val\n";
               }
       close FHS;

}

########################

sub archive_session {

our %session;
our $sessdir;
our $archivedir;

my ($which) = @_;

   open (FHS,">$archivedir/$which.ses") or webdie (707,"Cannot archive session");
   foreach my $name (keys %session) {
         my $val = $session{$name};
         $val =~ s/%/%25/g;
              $val =~ s/\+/%2b/g;
             $val =~ s/\n/%0a/g;
             $val =~ s/ /+/g;
             print FHS "$name $val\n";
               }
       close FHS;

if (! -e $archivedir) {
        mkdir $archivedir,0700 or webdie(509,"Cannot create session directory");
        }
        unlink "$sessdir/$which.ses";

}

########################

sub send_response {

my ($template) = @_;

our %fill;
our $headersent;
send_header() if (! $headersent);

open (FH,$template) or webdie (703,"Cannot read template file");
while (<FH>) {
       s/%(\w+)%/$fill{$1}/g;
  print;
  }

}

########################

sub send_header {

our $headersent = 1;

print "Content-type: text/html\n\n";
}

########################

# Code to generate a table row that includes a prompt and an input box
# Adds error messages and old ("sticky") values in

sub formbox {
       our %form;
       our %errtab;
       my ($text,$fieldname) = @_;
       my $add = "";
       if ($errtab{$fieldname}) {
              $add="<br><font color=red>$errtab{$fieldname}</font>";
       }
       $text = "<tr><td>".webify($text)."$add</td><td><input name=$fieldname ".
                "value=\"".webify($form{$fieldname})."\"></td></tr>";
       return $text;
   }

sub radioset {
       our %form;
       our %errtab;
       my ($text,$fieldname,@options) = @_;
       my $add = "";
       if ($errtab{$fieldname}) {
              $add="<br><font color=red>$errtab{$fieldname}</font>";
        }
       # $text = "<tr><td>".webify($text)."$add</td><td>";
       $text = "<tr><td>".$text."$add</td><td>";
       my $k;
       for ($k=0; $k<@options; $k+=2) {
             my $extra = "";
             if ($form{$fieldname} eq $options[$k+1][0]) { $extra = " CHECKED";}
             $text .= "<input type=radio name=$fieldname value=".$options[$k+1][0]." $extra>".
                    " $options[$k]<br>";
             }
       $text .= "</td></tr>";
       return $text;
       }

########################

# Validate a form input against a regular expression

sub checkinput {
       my ($fieldname,$sessname,$rematch,$errmsg) = @_;
       our %form;
       our %session;
       my $good = 1;
       our $errstr;
       our %errtab;
       if ($form{$fieldname} !~ /$rematch/) {
            $good = 0;
            $errtab{$fieldname} = $errmsg;
            $errstr = "Please correct the errors noted and resubmit";
       } else {
            $session{$sessname} = $form{$fieldname};
       }
       return $good;
}
sub checkradio {
       my ($fieldname,$sessname,$errmsg) = @_;
       our %form;
       our %session;
       my $good = 1;
       our $errstr;
       our %errtab;
       if (! $form{$fieldname}) {
            $good = 0;
            $errtab{$fieldname} = $errmsg;
            $errstr = "Please correct the errors noted and resubmit";
       } else {
            $session{$sessname} = $form{$fieldname};
       }
       return $good;
}
##################################################################

# Error handler

sub webdie {
       my ($number,$message) = @_;
       our $title;
       our $email;

our $headersent;
our $homesite;

send_header() if (! $headersent);

       print <<"OOPS";
<html><head><title>ERROR - $title</title></head>
<body bgcolor=#FF9999><h2>$title</h2>
<b>Error $number - $message</b><br><br>
This is an error message from $title. If you need support and
assistance, or if you think this message should not have been
generated, please contact <a href=mailto:$email>$email</a>.<br><br>
Select <a href="?">here</a> to restart the quiz or
<a href=$homesite>here</a> to go to our home page.
</body>
</html>
OOPS
       exit();
       }

1;