#!/usr/bin/perl -- -*- C -*-

# Perl Routines to Manipulate CGI input
# S.E.Brenner@bioc.cam.ac.uk
# $Header: /cys/people/seb1005/http/cgi-bin/RCS/cgi-lib.pl,v 1.7 1994/11/04 00:17:17 seb1005 Exp $
#
# Copyright 1994 Steven E. Brenner  
# Unpublished work.
# Permission granted to use and modify this library so long as the
# copyright above is maintained, modifications are documented, and
# credit is given for any use of the library.
#
# Thanks are due to many people for reporting bugs and suggestions
# especially Meng Weng Wong, Maki Watanabe, Bo Frese Rasmussen,
# Andrew Dalke, Mark-Jason Dominus and Dave Dittrich.

# see http://www.seas.upenn.edu/~mengwong/forms/   or
#     http://www.bio.cam.ac.uk/web/                for more information

# Additions by Karl Auer, The Internet Project.
# Pruned by Lawrie Brown, for general use, once placed in perl library area

# Minimalist http form and script (http://www.bio.cam.ac.uk/web/minimal.cgi):
# if (&MethGet) {
#   print &PrintHeader,
#       '<form method=POST><input type="submit">Data: <input name="myfield">';
# } else {
#   &ReadParse(*input);
#   print &PrintHeader, &PrintVariables(%input);
# }

#
# Configurable parameters
#
$mailprog = '/usr/lib/sendmail';	# mail program used on this system

# make stdout unbuffered so error messages are in place in users scripts
$| = 1;

# MethGet
# Return true if this cgi call was using the GET request, false otherwise
# Now that cgi scripts can be put in the normal file space, it is useful
# to combine both the form and the script in one place with GET used to
# retrieve the form, and POST used to get the result.

sub MethGet {
  return ($ENV{'REQUEST_METHOD'} eq "GET");
}

# ReadParse
# Reads in GET or POST data, converts it to unescaped text, and puts
# one key=value in each member of the list "@in"
# Also creates key/value pairs in %in, using '\0' to separate multiple
# selections

# If a variable-glob parameter (e.g., *cgi_input) is passed to ReadParse,
# information is stored there, rather than in $in, @in, and %in.

sub ReadParse {
    local (*in) = @_ if @_;


  local ($i, $loc, $key, $val);

  # Read in text
  if ($ENV{'REQUEST_METHOD'} eq "GET") {
    $in = $ENV{'QUERY_STRING'};
  } elsif ($ENV{'REQUEST_METHOD'} eq "POST") {
    read(STDIN,$in,$ENV{'CONTENT_LENGTH'});
  }

  @in = split(/&/,$in);

  foreach $i (0 .. $#in) {
    # Convert plus's to spaces
    $in[$i] =~ s/\+/ /g;

    # Split into key and value.  
    ($key, $val) = split(/=/,$in[$i],2); # splits on the first =.

    # Convert %XX from hex numbers to alphanumeric
    $key =~ s/%(..)/pack("c",hex($1))/ge;
    $val =~ s/%(..)/pack("c",hex($1))/ge;

    # Associate key and value
    $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
    $in{$key} .= $val;

  }

  return 1; # just for fun
}

# PrintHeader
# Returns the magic line which tells WWW that we're an HTML document

sub PrintHeader {
  return "Content-type: text/html\n\n";
}

# PrintVariables
# Nicely formats variables in an associative array passed as a parameter
# And returns the HTML string.

sub PrintVariables {
  local (%in) = @_;
  local ($old, $out, $output);
  $old = $*;  $* =1;
  $output .=  "<DL>";
  foreach $key (sort keys(%in)) {
    foreach (split("\0", $in{$key})) {
      ($out = $_) =~ s/\n/<BR>/g;
      $output .=  "<DT><B>$key</B><DD><I>$out</I><BR>";
    }
  }
  $output .=  "</DL>";
  $* = $old;

  return $output;
}

# PrintVariablesShort
# Nicely formats variables in an associative array passed as a parameter
# Using one line per pair (unless value is multiline)
# And returns the HTML string.

sub PrintVariablesShort {
  local (%in) = @_;
  local ($old, $out, $output);
  $old = $*;  $* =1;
  foreach $key (sort keys(%in)) {
    foreach (split("\0", $in{$key})) {
      ($out = $_) =~ s/\n/<BR>/g;
      $output .= "<B>$key</B> is <I>$out</I><BR>";
    }
  }
  $* = $old;

  return $output;
}

# DumpVariablesShort
# Nicely formats variables in an associative array passed as a parameter
# Using one line per pair (unless value is multiline)
# Returns an ordinary string (not HTML).

sub DumpVariablesShort {
  local (%in) = @_;
  local ($old, $out, $output);
  $old = $*;  $* =1;
  foreach $key (sort keys(%in)) {
    foreach $out (split("\0", $in{$key})) {
      $output .= "$key = $out\n";
    }
  }
  $* = $old;

  return $output;
}

# Sendmail
# Sends email to $recip with specified details below using $mailprog
#	(usually sendmail - if /bin/mail MUST filter out ~ from variables)
#
# Expects the following parameters from the html form response:
#	$sender	 - the email address of the sender (must be non-blank)
#	$recip	 - recipient email (must be non-blank)
#	$subject - the subject of the message (may be blank)
#	$msg	 - the comment to be sent (must be non-blank)
# Note - does NOT generate output - the calling function must deal
#        with responding to the user (if any response needed).
#
# ------------------------------------------------------------
# subroutine SendMail
sub SendMail {
    local($sender) = @_[0];
    local($recip) = @_[1];
    local($subject) = @_[2];
    local($msg) = @_[3];
 
    # do some sanity checks on the parameters, just to be sure
    die "Error (cgi-lib.pl) - Invalid sender email address ($sender)\n" unless
	&IsValidEmailAddress($sender);	# valid full email address wanted
    die "Error (cgi-lib.pl) - Invalid recipient address ($recip)\n" unless
	&IsValidShortEmail($recip);	# valid email address wanted
    die "Error (cgi-lib.pl) - Invalid subject ($subject)\n" if
	$subject =~ /[\r\n]/;		# has a single line subject only

    # open MAIL for content of email and build mail message
    open (MAIL, "|$mailprog $recip") || die "Error - Can't open $mailprog!\n";
    print MAIL "To: $recip\n";
    print MAIL "Reply-to: $sender\n";
    print MAIL "Subject: $subject\n\n";
    print MAIL "$sender sent the following message:\n";
    print MAIL "\n---------------------------------------------------------\n";
    print MAIL "$msg";
    print MAIL "\n---------------------------------------------------------\n";
    print MAIL "Server protocol: $ENV{'REQUEST_METHOD'} $ENV{'SERVER_PROTOCOL'}\n";
    print MAIL "Remote host: $ENV{'REMOTE_HOST'} [$ENV{'REMOTE_ADDR'}]\n";
    close (MAIL);
}

# IsValidEmailAddress
# Returns non-zero if the passed email address is a valid looking
#	fully qualified type email address. ie xxx@hhh.yyy.zzz
#
sub IsValidEmailAddress
{
   local($address) = @_[0] ;

   return $address =~
      m:^[-A-Za-z0-9_.=/][-A-Za-z0-9_.=%!/@ ]*@[-A-Za-z0-9_.]+$:;
}

# IsValidShortEmail
# Returns non-zero if the passed email address is a valid looking
#	partial or fully qualified type email address.
#
sub IsValidShortEmail
{
   local($address) = @_[0] ;

   return $address =~
      m:^[-A-Za-z0-9_.=/][-A-Za-z0-9_.=%!/@ ]*$:;
}
