cgi-lib.pl

   1 #!/usr/local/bin/perl
   2
   3 # Perl Routines to Manipulate CGI input
   4 #
   5 # Copyright (c) 1995 Steven E. Brenner
   6 # Permission granted to use and modify this library so long as the
   7 # copyright above is maintained, modifications are documented, and
   8 # credit is given for any use of the library.
   9 #
  10 # Thanks are due to many people for reporting bugs and suggestions
  11 # especially Meng Weng Wong, Maki Watanabe, Bo Frese Rasmussen,
  12 # Andrew Dalke, Mark-Jason Dominus, Dave Dittrich, Jason Mathews
  13
  14 # For more information, see:
  15 #     http://www.bio.cam.ac.uk/web/form.html
  16 #     http://www.seas.upenn.edu/~mengwong/forms/
  17
  18 # Minimalist http form and script (http://www.bio.cam.ac.uk/web/minimal.cgi):
  19 #
  20 # require "cgi-lib.pl";
  21 # if (&ReadParse(*input)) {
  22 #    print &PrintHeader, &PrintVariables(%input);
  23 # } else {
  24 #   print &PrintHeader,'<form><input type="submit"> Data: <input name="myfield">';
  25 #}
  26
  27 # ReadParse
  28 # Reads in GET or POST data, converts it to unescaped text,
  29 # creates key/value pairs in %in, using '\0' to separate multiple
  30 # selections
  31
  32 # Returns TRUE if there was input, FALSE if there was no input
  33 # UNDEF may be used in the future to indicate some failure.
  34
  35 # Now that cgi scripts can be put in the normal file space, it is useful
  36 # to combine both the form and the script in one place.  If no parameters
  37 # are given (i.e., ReadParse returns FALSE), then a form could be output.
  38
  39 # If a variable-glob parameter (e.g., *cgi_input) is passed to ReadParse,
  40 # information is stored there, rather than in $in, @in, and %in.
  41
  42 sub ReadParse {
  43   local (*in) = @_ if @_;
  44   local ($i, $key, $val, $cl, $rd);
  45
  46   # Read in text
  47   if (&MethGet) {
  48     $in = $ENV{'QUERY_STRING'};
  49   } elsif (&MethPost) {
  50     $cl = $ENV{'CONTENT_LENGTH'};
  51     $rd= read(STDIN,$in,$cl);
  52     $rd == $cl or CgiDie("unable to read POST data ($cl, $rd, $!)");
  53   }
  54
  55   @in = split(/[&;]/,$in);
  56
  57   foreach $i (0 .. $#in) {
  58     # Convert plus's to spaces
  59     $in[$i] =~ s/\+/ /g;
  60
  61     # Split into key and value.
  62     ($key, $val) = split(/=/,$in[$i],2); # splits on the first =.
  63
  64     # Convert %XX from hex numbers to alphanumeric
  65     $key =~ s/%(..)/pack("c",hex($1))/ge;
  66     $val =~ s/%(..)/pack("c",hex($1))/ge;
  67
  68     # Associate key and value
  69     $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
  70     $in{$key} .= $val;
  71
  72   }
  73
  74   return scalar(@in);
  75 }
  76
  77
  78 # PrintHeader
  79 # Returns the magic line which tells WWW that we're an HTML document
  80
  81 sub PrintHeader {
  82   return "Content-type: text/html\n\n";
  83 }
  84
  85
  86 # HtmlTop
  87 # Returns the <head> of a document and the beginning of the body
  88 # with the title and a body <h1> header as specified by the parameter
  89
  90 sub HtmlTop
  91 {
  92   local ($title) = @_;
  93
  94   return <<END_OF_TEXT;
  95 <html>
  96 <head>
  97 <title>$title</title>
  98 </head>
  99 <body>
 100 <h1>$title</h1>
 101 END_OF_TEXT
 102 }
 103
 104 # Html Bot
 105 # Returns the </body>, </html> codes for the bottom of every HTML page
 106
 107 sub HtmlBot
 108 {
 109    return "</body>\n</html>\n";
 110  }
 111
 112
 113 # MethGet
 114 # Return true if this cgi call was using the GET request, false otherwise
 115
 116 sub MethGet {
 117   return ($ENV{'REQUEST_METHOD'} eq "GET");
 118 }
 119
 120
 121 # MethPost
 122 # Return true if this cgi call was using the POST request, false otherwise
 123
 124 sub MethPost {
 125   return ($ENV{'REQUEST_METHOD'} eq "POST");
 126 }
 127
 128
 129 # MyURL
 130 # Returns a URL to the script
 131
 132 sub MyURL  {
 133   local ($port);
 134   $port = ":" . $ENV{'SERVER_PORT'} if  $ENV{'SERVER_PORT'} != 80;
 135   return  'http://' . $ENV{'SERVER_NAME'} .  $port . $ENV{'SCRIPT_NAME'};
 136 }
 137
 138
 139 # CgiError
 140 # Prints out an error message which which containes appropriate headers,
 141 # markup, etcetera.
 142 # Parameters:
 143 #  If no parameters, gives a generic error message
 144 #  Otherwise, the first parameter will be the title and the rest will
 145 #  be given as different paragraphs of the body
 146
 147 sub CgiError {
 148   local (@msg) = @_;
 149   local ($i,$name);
 150
 151   if (!@msg) {
 152     $name = &MyURL;
 153     @msg = ("Error: script $name encountered fatal error");
 154   };
 155
 156   print &PrintHeader;
 157   print "<html><head><title>$msg[0]</title></head>\n";
 158   print "<body><h1>$msg[0]</h1>\n";
 159   foreach $i (1 .. $#msg) {
 160     print "<p>$msg[$i]</p>\n";
 161   }
 162   print "</body></html>\n";
 163 }
 164
 165
 166 # CgiDie
 167 # Identical to CgiError, but also quits with the passed error message.
 168
 169 sub CgiDie {
 170   local (@msg) = @_;
 171   &CgiError (@msg);
 172   die @msg;
 173 }
 174
 175
 176 # PrintVariables
 177 # Nicely formats variables in an associative array passed as a parameter
 178 # And returns the HTML string.
 179 sub PrintVariables {
 180   local (%in) = @_;
 181   local ($old, $out, $output);
 182   $old = $*;  $* =1;
 183   $output .=  "\n<dl compact>\n";
 184   foreach $key (sort keys(%in)) {
 185     foreach (split("\0", $in{$key})) {
 186       ($out = $_) =~ s/\n/<br>\n/g;
 187       $output .=  "<dt><b>$key</b>\n <dd><i>$out</i><br>\n";
 188     }
 189   }
 190   $output .=  "</dl>\n";
 191   $* = $old;
 192
 193   return $output;
 194 }
 195
 196 # PrintVariablesShort
 197 # Now obsolete; just calls PrintVariables
 198
 199 sub PrintVariablesShort {
 200   return &PrintVariables(@_);
 201 }
 202
 203 1; #return true
 204
 205