# ============ CGI SUPPORT ROUTINES ====================
# EIW-CGI library V2.0
#
# The subroutines provided here are:
#  GetQuery();     # gets the query and returns name/value pairs 
#  http_header();  # sends the browser an HTTP header 
#  fatal_error():  # send an error message to the browser and quits
#  send_file();    # reads in a file and sends to the browser
#  GetCookies();   # get all cookies and returns name/value pairs


# -----------------------------------------------------
# GetQuery is a subroutine that gets the query 
# (can handle both POST and GET methods) and returns an 
# associative array holding the url-decoded name/value pairs
# 
# For Multivalued fields, the field values are all packed in
# to a single string with ":" used as a delimiter.

# Example usage:
#
# %fields = GetQuery();
#

sub GetQuery {
   local($query,$size,$method,$name,$value);
   local(%fields);

   # First get the request method
   $method = $ENV{'REQUEST_METHOD'};

   if ($method EQ "GET" ) {        # NOTICE I USE "eq" NOT "==" !!!!!!
       $query = $ENV{'QUERY_STRING'};
   } elsif ($method eq "POST") {
       # method is POST
       $size = $ENV{'CONTENT_LENGTH'};
       read(STDIN,$query,$size);    # read $size bytes in to $query
   } else {
       # DEBUGGING SUPPORT - SOMETIMES WE WOULD LIKE TO RUN
       # AS A NORMAL PERL PROGRAM (NOT as a CGI) - this allows
       # US TO GET THE QUERY FROM STDIN

       print "NO REQUEST METHOD DETECTED - ENTER QUERY ON SINGLE LINE\n";
       chomp($query = <>);
   }

   #  $query holds the query string - split on "&"
   @pairs = split("&",$query);

   # @pairs is now an array that holds a string like "name=value" in each
   # array location.

   foreach $i (@pairs) {
      ($name,$value) = split("=",$i);

      #url-decode each string
      $name = urldecode($name);
      $value = urldecode($value);
      # add to the associative array named %fields
      # if this is a multivalued field - seperate with a delimeter
      if ($fields{$name}) {
	  $fields{$name} .= ":$value";
      } else {
	  $fields{$name} = $value;
      }
   }

   # Here is a neat trick you can do in perl. We can create
   # a global variable whose name is the same as the
   # field name (for each field found in the query).
   # So if the form that was used to submit the query
   # has fields named "color", "weight" and "age" we end
   # up with global variables names $color, $weight and $age.

   # I leave this commented - uncomment if you want to do things
   # this way (instead of using the associative array)

   # foreach $i (keys %fields) {
   #   $$i = $fields{$i};
   # }

   # return the associative array
   return %fields;
}


# ============================================
# subroutine that does URL decoding
# urldecode expects a single string parameter and returns
# the same string after url-decoding.
# example usage:
#
#  $string = urldecode($string);
#
sub urldecode {
    my($string) = $_[0];

    # convert all '+' to ' '
    $string =~ s/\+/ /g;    

    # Convert %XX from hex numbers to ASCII 
    # The "e" modifier at the end of the substitute command tells
    # perl that the substitution text is really a perl command
    # that should be evaluated! In this case the pack command
    # is used to convert from 2 ASCII HEX characters to a single
    # character.

    $string =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("c",hex($1))/eg; 


    return($string);  # don't really need this return with perl!
                      # by default the subroutine will return the
                      # value of the last expression.
}

# --------------------------------------------
# http header generation
# this subroutine should be called before the perl CGI program
# prints anything!
# The extra logic in this subroutine just makes sure that the 
# header is never sent twice
#
# example usage:
#  http_header();

sub http_header {
    if (! $http_header ) {
	print "Content-type: text/html\r\n\r\n";
	$http_header=1;
    }
}


# --------------------------------------------
# fatal_error generates an HTML error message and quits.
# This subroutine should only be called when a fatal
# error condition occurs, something like the query didn't
# include expected fields. 
# Any parameters to this subroutine are treated as strings that
# should be sent back as part of the error message.
#
# a back button is created that the user can press to go back to
# the refering page (typically the form that was sent here) if the
# environment variable REFERER is found (otherwise no back button
# is created).
# 
# Example usage:
#   fatal_error("You must fill in all fields in the form!\n");

sub fatal_error {

    # send the HTTP header 
    http_header();

    # and make this a real HTML document
    print "<HEAD><TITLE>Error!</TITLE></HEAD>\n";
    print "<BODY><HTML>\n";

    # send a generic error message back to the browser
    print "<H2>ERROR - YOUR QUERY COULD NOT BE PROCESSED</H2>\n";

    local($line);

    # now send back any parameters passed to this subroutine
    print @_;

    # now create the back button
    local($referer) = $ENV{'HTTP_REFERER'};
    if ($referer) {
	print "<P>\n";
	print "Press <A HREF=$referer>here</A> to return\n";
    }
    # and close out the HTML document
    print "</HTML></BODY>\n";

    # terminate this program
    exit;
}


# --------------------------------------------
#
# send_file will read in a file and send the contents of the
# file to the browser. This is useful when part of the HTML
# you want to generate is always the same - just put it in
# a file instead of coding it in print statements
#
# example usage:
#   send_file("header.html");


sub send_file {
    local($filename) = $_[0];

    # attempt to open the file
    if (! open(F,$filename) ) {
	# Can't open the file - this is a fatal error!
	fatal_error("Can't find the file $filename\n");
    }

    # the file is open - read everything and send to
    # the browser
    local(@lines) = <F>;    # reads the whole file
    print @lines;           # sends all the lines to the browser
    close(F);               # close the file
}

# --------------------------------------------
#
# GetCookies subroutine
#
# This subroutine gets all cookies sent with the request and
# puts them in to an associate array. 
#
# Example usage:
#
#  %cookies = GetCookies();

sub GetCookies {
    local($cookies) = $ENV{"HTTP_COOKIE"};
    local(@pairs);
    local($name,$value);
    local($i);
    local(%cookies);

    # The cookie string is a sequence of "name=value;name=value;..."
    # Split on the semicolons and gobble up and stray whitespace
    # following the semicolon

    $cookies =~ s/;\s*/;/g;

    @pairs = split(";",$cookies);

    foreach $i (@pairs) {
	# split on "=" 
	($name,$value) = split("=",$i);
	# add to the associative array
	$cookies{$name} = $value;
    }
    return(%cookies);
}



# this last line is needed ! (the return value of this file is used
# by the "require" statement, and the return value is the last 
# statement in the file).
1;