#--------#---------#---------#---------#---------#---------#---------#---------#
# subroutine collection
#
# author: larg 24/03/00
# last updated: larg 05/04/00
#
# A collection of subroutines
# These are being created initially for plugin email scripts
# They are all using %ha array, the address of which is passed to most
# of these routines. All warnings and errors are collected in
# elements of this array to be printed later.
#--------#---------#---------#---------#---------#---------#---------#---------#
#
# PARAMETERS AND HASH
#
#--------#---------#---------#---------#---------#---------#---------#---------#
#--------#---------#---------#---------#---------#---------#---------#---------#
# chech a list of parameters are present
# required parameters is a list contained in the supplied hash
# existing parameters is a hash contained in the supplied hash
# returns false (ok) or true (error message)
#
sub check_params {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "check_params \n";
# read in every parameter
   my $key = '';
   my $success       = 1;  # boolean flag. true if sub is OK, false if screwed
   my @list    = @{$ha->{params_required}}; # dereferencing: any clearer? erm..
   foreach $item ( @list ) {
      if ( ! $ha->{params_supplied}->{$item} ) {
         $ha->{info_warning}  .= "The field '$item' was not filled in. \n";
         $success    = 0;
      }
      $ha->{info_debug}         .=  "missing \$item: $item \n";
   }
# fill in missing default parameters
   unless ( $ha->{params_supplied}->{page} ) {
      $ha->{params_supplied}->{page}   = 'html';
    }
# translate parameters
        $ha->{file_success}     = $ha->{params_supplied}->{success};
    $ha->{file_msg_body}= $ha->{params_supplied}->{template};

# finish
   $ha->{info_debug}    .=  "\$success: $success \n";
   return $success;
}
#--------#---------#---------#---------#---------#---------#---------#---------#
# store all variables passed to this program
# takes a pointer to the CGI hash
# stores a hash of parameter keys and values
# All keys are converted to lower case
# returns true if paramters were found, and false if none provided
#
sub read_params {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "read_params \n";

   # pointer to the object containing parameters
   my $cgi_ptr        = $ha->{cgi_ptr};
   # list the names of all parameters passed in
   my @array      = $cgi_ptr->param;
   # array in a scalar context gives number of elements
   my $total      = @array;
   # were any values supplied?
   if ( $total eq 0 ) {
      $ha->{info_debug} .=  "no values to read. \n";
      return 0;
   }

    my %params    = ();    # hash for parameter keys and values
   my $key        = '';

   foreach $key ( @array ) {
          # convert to lower case
      my $lckey         = lc($key);
      $params{$lckey} = $cgi_ptr->param("$key");

#      $ha->{info_debug} .=  "\$key              : $key \n";
      $ha->{info_debug} .=  "\$cgi_ptr->param($key) : ".$cgi_ptr->param($key)." \n";

   }
   $ha->{params_supplied}  = { %params };

# happy ending
        my $success = 1;        # hey, can't go wrong, trust me
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;
}

#--------#---------#---------#---------#---------#---------#---------#---------#
# store the cgi hash in a file
# one field per line, each record datestamped in GMT
# This works for all forms as
# whatever is returned is copied into the file with no checks
# or tidying up
# as long as the file is writable.
# return true if nobody gets hurt. Return false for a file bloodbath.
#
sub write_params {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "write_params \n";

# bit of cosmetic dereferencing
   my $cgi_ptr    = $ha->{cgi_ptr};
   my $log        = $ha->{file_log};
   $ha->{info_debug} .=  "\$cgi_ptr: $cgi_ptr \n";
   $ha->{info_debug} .=  "\$log    : $log \n";

   my $success = 1;
# open, lock, print to and close the file
   if       ( ! open (LOG, ">>$log") ) {
      $ha->{info_warning} .= "warning: can't open $log: $!";
      $success  = 0;
   } elsif  ( ! flock(LOG, 2) ) {
      $ha->{info_warning} .= "warning: can't flock $log: $!";
      $success  = 0;
   } else {
      my $date = gmtime( time() );
      print LOG  "#--------# $date #--------# \n";
      $cgi_ptr->save(*LOG);
      if ( ! close (LOG) ) {
         $ha->{info_warning} .= "warning: can't close $log: $!";
         $success  = 0;
      };
   }

# happy ending
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;
}

#--------#---------#---------#---------#---------#---------#---------#---------#
# store the cgi hash in a file
# one field per line, each record datestamped in GMT
# This works for all forms as
# whatever is returned is copied into the file with no checks
# or tidying up
# as long as the file is writable.
# return true if nobody gets hurt. Return false for a file bloodbath.
#
sub write_debug {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "write_debug \n";

# bit of cosmetic dereferencing
   my $cgi_ptr    = $ha->{cgi_ptr};
   my $log        = $ha->{file_debug};
   $ha->{info_debug} .=  "\$cgi_ptr: $cgi_ptr \n";
   $ha->{info_debug} .=  "\$log    : $log \n";

   my $success = 1;
# open
   if       ( ! open (LOG, ">>$log") ) {
      $ha->{info_warning} .= "warning: can't open $log: $!";
      $success  = 0;
# lock
   } elsif  ( ! flock(LOG, 2) ) {
      $ha->{info_warning} .= "warning: can't flock $log: $!";
      $success  = 0;
   } else {
      my $date = gmtime( time() );
# print
      print LOG  "#--------# $date #--------# \n";
      print LOG "\n\nwarnings \n\n";
      print LOG $ha->{info_warning};
      print LOG "\n\ndebug \n\n";
      print LOG $ha->{info_debug};
# close
      if ( ! close (LOG) ) {
         $ha->{info_warning} .= "warning: can't close $log: $!";
         $success  = 0;
      };
   }

# happy ending
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;
}

#--------#---------#---------#---------#---------#---------#---------#---------#
# iitialise the hash
# belt and braces approach to avoiding memory leaks in mod_perl
#
sub init_email_hash {

# create the empty hash
   my %ha = (
        cgi_ptr            => '', # pointer to the hash used by the CGI module
        info_warning       => '', # warnings generated by subs
        info_debug         => '', # extra debugging info from subs
        file_success       => '', # HTML page to display if lifeis rosy
        file_fail          => '', # HTML page to display if all is ruin
        file_msg_body      => '', # email text body
        file_html_body     => '', # html page text body
        file_log           => '', # file to store parameters in
        file_debug         => '', # file to store debugging info in
        msg_ptr            => '', # pointer to the hash used by the MIME::Lite module
        msg_subject        => '', # subject (title) of email
        msg_body           => '', # body text of email, including any substitutions
        params_supplied    => {}, # variable/value pairs that are passed to this program
#                                { field01 => value, field02 => value, ... },
        params_required    => [], # variable/value pairs that must be passed in
        html_body          => '', # body text of html page, including any substitutions
        success            => 0   # boolean true if everything went smoothly
#                                (also see info_debug)
   );
# start the debug section
   $ha{info_debug}   .=  "---------*---------* \n";
   $ha{info_debug}   .=  "init_email_hash \n";
#   $ha{info_debug}   .=  "\%ha: ", %ha, "\n";

   return %ha;
}

#--------#---------#---------#---------#---------#---------#---------#---------#
#
# EMAIL
#
#--------#---------#---------#---------#---------#---------#---------#---------#
# slurp in the file named in $ha->{file_msg_body}
# append the contents to whatever is stored in $ha->{msg_body}
# check the file size first
#
sub read_msg_file {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "read_msg_file \n";

   my $success = 1;
# bit of cosmetic dereferencing
   my $file = $ha->{file_msg_body};
   $ha->{info_debug} .=  "\$file: $file \n";

# check the file size
   my $max        = 1024 * 1024;  # 1 Meg size limit
   if (&file_too_fat ("$file", $max)) {
       $ha->{info_warning} .= "warning: file is too fat ";
       $ha->{info_debug}   .= "file size greater than $max bytes \n";
       $success  = 0;
       return $success;
   }

# open, read and close the file
   if       ( ! open (FILE, "<$file") ) {
      $ha->{info_warning} .= "warning: can't open $file: $!";
      $success  = 0;
   } else {
      my @file = <FILE>;
      $ha->{msg_body}  .= join( '', @file ); # append text to existing string
   }

# happy ending
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;
}
#--------#---------#---------#---------#---------#---------#---------#---------#
# subroutine
#   file_too_fat
# description
#   file size check. how big is it?
#   A huge file causes an error.
#   return true if too big, false otherwise.
#
sub file_too_fat {

   my $file = shift;
   my $max  = shift;
   my (
               $dev, $ino, $mode, $nlink, $uid, $gid, $rdev,
               $size, $atime, $mtime, $ctime, $blksize, $blocks
   ) = stat "$file";
#   print STDERR "   \$size   \t$size  \n" if $DEBUG;
#   print STDERR "   \$max    \t$max   \n" if $DEBUG;
   return 1 if $size > $max;
   return 0;
}


#--------#---------#---------#---------#---------#---------#---------#---------#
# substitute values for variables in the message body
# variables in the text are words that are surrounded by square brackets [ ]
# they are substituted with anything that matches in the parameter hash
#
sub parse_msg_body {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "parse_msg_body \n";

   my $success    = 1;
   my $text       = $ha->{msg_body};
   my %params     = %{$ha->{params_supplied}}; # dereference for king and country
   my $key        = '';

# replace
   # variable tokens eg. [recipient]
   foreach $key ( keys %params ) {
       $text    =~      s/\[$key\]/$params{$key}/mig;
       # mig - multiline; ignore case; global;
       $ha->{info_debug} .=  "searching for \$params{$key}: ".$params{$key}."\n";
   }
   # special tokens eg. [*date-time*]
   my $date = scalar localtime;
   $text    =~ s/\[\*date-time\*]/$date/mig; # these flags might be bollocks
   my $remote_host  = $ha->{cgi_ptr}->remote_host();
   $text    =~ s/\[\$REMOTE_ADDR]/$remote_host/mig; # these flags might be bollocks

# the finished string
   $ha->{msg_body}   = $text;

# happy ending
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;

}

#--------#---------#---------#---------#---------#---------#---------#---------#
# post an email with attachment
#   use sendmail as a command line interface to send a message.
#   headers and message are assumed to be in $ha->{msg_body}
#   errors are stored in a hash to be reported later, and a flag is set for
#   failure or success.

sub send_text {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "send_text \n";

# make sure sendmail is in the path!
   $ENV{'PATH'}="/bin:/usr/bin:/usr/sbin";
   delete @ENV{'IFS','CDPATH','ENV','BASH_ENV'};

# Send the message
    my $success = 0;
    my $body    = $ha->{msg_body};         # headers and message
    my $sender  = $ha->{sender};           # from address
    $ha->{info_debug} .=  "\$body: \n$body \n";
    if (open ( MAIL, "| /usr/lib/sendmail -f $sender -t -i")) {
       print MAIL<<END_MESSAGE;
$body
END_MESSAGE
   $ha->{info_debug} .=  "\$body: \n$body \n";
       if (close MAIL) {
           $ha->{info_debug} .=  "passed to sendmail. \n";
           $success = 1;
       } else {
          $ha->{info_warning} .= "warning: can't close sendmail: $!";
       }
    } else {
          $ha->{info_warning} .= "warning: can't open sendmail: $!";
    } # if open

   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;
}

#--------#---------#---------#---------#---------#---------#---------#---------#
#
# HTML AND PRINTING
#
#--------#---------#---------#---------#---------#---------#---------#---------#
#--------#---------#---------#---------#---------#---------#---------#---------#
sub read_html_file {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "read_html_file \n";

   my $success = 1;
# bit of cosmetic dereferencing
   my $file = $ha->{file_html_body};
   $ha->{info_debug} .=  "\$file: $file \n";

# open, read and close the file
   if       ( ! open (FILE, "<$file") ) {
      $ha->{info_warning} .= "warning: can't open $file: $!";
      $success  = 0;
   } else {
      my @file = <FILE>;
      $ha->{html_body}  = join( '', @file );
   }

# happy ending?
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;
}
#--------#---------#---------#---------#---------#---------#---------#---------#
# substitute values for variables in the message body
# variables in the text are any words that start with "$"
# they are substituted with anything that matches in the parameter hash
#
sub parse_html_body {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "parse_html_body \n";

   my $success    = 1;
   my $text       = $ha->{html_body};
   my %params     = %{$ha->{params_supplied}}; # dereference for king and country
   my $key        = '';
   foreach $key ( keys %params ) {
      $text   =~ s/\[$key\]/$params{$key}/mig; # these flags might be bollocks
      $ha->{info_debug} .=  "\$params{$key}: ".$params{$key}."\n";
   }
   $ha->{html_body}   = $text;

# happy ending
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;

}

#--------#---------#---------#---------#---------#---------#---------#---------#
# write a MIME form.
# This is meant for collection by Macromedia Flash when
# it is acting as a browser
# The information written is assumed to be escaped already
# eg my+hands=dirty&my+penis=warty
#
sub mime_form {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "mime_form \n";

   my $info = '';
   $info    .= $ha->{cgi_ptr}->header('application/x-www-urlformencoded');
   $info    .= shift;
   return "$info\n";
}
#--------#---------#---------#---------#---------#---------#---------#---------#
# display an HTML page with loadsa lovely state information
# no HTTP headers are defined here
#
sub page_debug {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "page_debug \n";

# dereference  yourself before the one true god
   my $cgi  = $ha->{cgi_ptr};

   my $page;
   $page  .= $cgi->start_html("debug: $0");
   $page  .= $cgi->hr();
   $page  .= $cgi->h1("debug");
   $page  .= "this program is $0";
   $page  .= $cgi->h3("warning messages");
   $page  .= $cgi->pre( $ha->{info_warning} );
   $page  .= $cgi->h3("debug messages");
   $page  .= $cgi->pre( $ha->{info_debug} );
   $page  .= $cgi->hr();

   $page .= $cgi->end_html();
   $page .= " \n";
   return $page;
}
#--------#---------#---------#---------#---------#---------#---------#---------#
# display a page
# which one depends on...
# is this a test?
# is all display handled by a Macromedia Flash movie?
# did everything go well?
# are the pages in fact on a totally different server?
#
sub display_result {

   my $ha   = shift;
   $ha->{info_debug} .=  "---------*---------* \n";
   $ha->{info_debug} .=  "display_result \n";

   my $page = '';
# redirect ending
   # no page parsing is available, so any debug
   # information is written to a file
   if  ( $ha->{params_supplied}{page}  eq 'redirect' ) {
      if ( $ha->{success} ) {
         my $file_success  = $ha->{file_success};
         print $ha->{cgi_ptr}->redirect("$file_success");
      } else {
         my $file_fail     = $ha->{file_fail};
         print $ha->{cgi_ptr}->redirect("$file_fail");
      };
      # debugging information
      $ha->{info_debug} .=  "redirect. $ha->{success} = ".$ha->{success}."\n";
      if ( $ha->{params_supplied}{debug} ) {
         &write_debug( $ha );
      }

      return 1;
   }


# flash ending
   if  ( $ha->{params_supplied}{page}  eq 'flash' ) {
      $ha->{info_debug} .=  "flash ending \n";
      $ha->{html_body}  = &mime_form( $ha, 'status=true' );

# html ending
   # read the success file or the fail file
   # if it is not there, create a placeholder page (NOT the debug page,
   # because punters may see this).
   # replace any variables in the page
   # print it
   } else {
      if ( $ha->{success} ) {
         $ha->{file_html_body}   = $ha->{file_success};
      } else {
         $ha->{file_html_body}   = $ha->{file_fail};
      };
      $ha->{info_debug} .=  "\$ha->{file_html_body} = ".$ha->{file_html_body}."\n";
      # cheat and add any warnings to the parameter list
      # for substitution into the html page
      $ha->{params_supplied}->{info_warning} = $ha->{info_warning};
      # read the template page and insert variable values
      if ( &read_html_file( $ha ) ) {
         &parse_html_body( $ha );
      } else {
         $ha->{html_body}  .= $ha->{cgi_ptr}->start_html("missing file")." \n";
         $ha->{html_body}  .= $ha->{cgi_ptr}->h1("missing file")." \n";
         $ha->{html_body}  .= "The file ".$ha->{file_html_body}." is missing.\n";
         $ha->{html_body}  .= $ha->{cgi_ptr}->end_html()." \n";
      }
      # add the http header for an html page to the start of the text
      $ha->{html_body}  = $ha->{cgi_ptr}->header().$ha->{html_body} ;
   }
# debug ending...as well. possibly maybe.
   if       ( $ha->{params_supplied}{debug} ) {
      $ha->{html_body}  .=  &page_debug( $ha );
      &write_debug( $ha );

# WARNING TESTING
# undocumented perl routine. Don't rely on it being around anywhere else.
#      print $ha->{cgi_ptr}->h3("dumpValue");
#      print $page;
#      print "<PRE> \n";
#      require 'dumpvar.pl'; # pretty array dump. I can't catch the print.
#      dumpValue( $ha );
#      print "<\PRE> \n";
# TESTING WARNING

   }

# print the final page
   print $ha->{html_body};

# happy ending
        my $success = 1;        # hey, can't go wrong, trust me
   $ha->{info_debug} .=  "\$success: $success \n";
   return $success;
}
#--------#---------#---------#---------#---------#---------#---------#---------#
#
1; # this is the required exit code for a perl "include" or "require" library