home *** CD-ROM | disk | FTP | other *** search
/ Web Designer 98 (Professional) / WebDesigner 1.0.iso / tutorials / tutorial / cgi-lib.txt < prev    next >
Encoding:
Text File  |  1997-06-15  |  13.4 KB  |  430 lines
  1. # Perl Routines to Manipulate CGI input
  2. # S.E.Brenner@bioc.cam.ac.uk
  3. # $Id: cgi-lib.pl,v 2.8 1996/03/30 01:36:33 brenner Rel $
  4. #
  5. # Copyright (c) 1996 Steven E. Brenner  
  6. # Unpublished work.
  7. # Permission granted to use and modify this library so long as the
  8. # copyright above is maintained, modifications are documented, and
  9. # credit is given for any use of the library.
  10. #
  11. # Thanks are due to many people for reporting bugs and suggestions
  12. # especially Meng Weng Wong, Maki Watanabe, Bo Frese Rasmussen,
  13. # Andrew Dalke, Mark-Jason Dominus, Dave Dittrich, Jason Mathews
  14.  
  15. # For more information, see:
  16. #     http://www.bio.cam.ac.uk/cgi-lib/
  17.  
  18. ($cgi_lib'version = '$Revision: 2.8 $') =~ s/[^.\d]//g;
  19.  
  20.  
  21. # Parameters affecting cgi-lib behavior
  22. # User-configurable parameters affecting file upload.
  23. $cgi_lib'maxdata    = 131072;    # maximum bytes to accept via POST - 2^17
  24. $cgi_lib'writefiles =      0;    # directory to which to write files, or
  25.                                  # 0 if files should not be written
  26. $cgi_lib'filepre    = "cgi-lib"; # Prefix of file names, in directory above
  27.  
  28. # Do not change the following parameters unless you have special reasons
  29. $cgi_lib'bufsize  =  8192;    # default buffer size when reading multipart
  30. $cgi_lib'maxbound =   100;    # maximum boundary length to be encounterd
  31. $cgi_lib'headerout =    0;    # indicates whether the header has been printed
  32.  
  33.  
  34. # ReadParse
  35. # Reads in GET or POST data, converts it to unescaped text, and puts
  36. # key/value pairs in %in, using "\0" to separate multiple selections
  37.  
  38. # Returns >0 if there was input, 0 if there was no input 
  39. # undef indicates some failure.
  40.  
  41. # Now that cgi scripts can be put in the normal file space, it is useful
  42. # to combine both the form and the script in one place.  If no parameters
  43. # are given (i.e., ReadParse returns FALSE), then a form could be output.
  44.  
  45. # If a reference to a hash is given, then the data will be stored in that
  46. # hash, but the data from $in and @in will become inaccessable.
  47. # If a variable-glob (e.g., *cgi_input) is the first parameter to ReadParse,
  48. # information is stored there, rather than in $in, @in, and %in.
  49. # Second, third, and fourth parameters fill associative arrays analagous to
  50. # %in with data relevant to file uploads. 
  51.  
  52. # If no method is given, the script will process both command-line arguments
  53. # of the form: name=value and any text that is in $ENV{'QUERY_STRING'}
  54. # This is intended to aid debugging and may be changed in future releases
  55.  
  56. sub ReadParse {
  57.   local (*in) = shift if @_;    # CGI input
  58.   local (*incfn,                # Client's filename (may not be provided)
  59.      *inct,                 # Client's content-type (may not be provided)
  60.      *insfn) = @_;          # Server's filename (for spooled files)
  61.   local ($len, $type, $meth, $errflag, $cmdflag, $perlwarn);
  62.     
  63.   # Disable warnings as this code deliberately uses local and environment
  64.   # variables which are preset to undef (i.e., not explicitly initialized)
  65.   $perlwarn = $^W;
  66.   $^W = 0;
  67.     
  68.   # Get several useful env variables
  69.   $type = $ENV{'CONTENT_TYPE'};
  70.   $len  = $ENV{'CONTENT_LENGTH'};
  71.   $meth = $ENV{'REQUEST_METHOD'};
  72.   
  73.   if ($len > $cgi_lib'maxdata) { #'
  74.       &CgiDie("cgi-lib.pl: Request to receive too much data: $len bytes\n");
  75.   }
  76.   
  77.   if (!defined $meth || $meth eq '' || $meth eq 'GET' || 
  78.       $type eq 'application/x-www-form-urlencoded') {
  79.     local ($key, $val, $i);
  80.     
  81.     # Read in text
  82.     if (!defined $meth || $meth eq '') {
  83.       $in = $ENV{'QUERY_STRING'};
  84.       $cmdflag = 1;  # also use command-line options
  85.     } elsif($meth eq 'GET' || $meth eq 'HEAD') {
  86.       $in = $ENV{'QUERY_STRING'};
  87.     } elsif ($meth eq 'POST') {
  88.         $errflag = (read(STDIN, $in, $len) != $len);
  89.     } else {
  90.       &CgiDie("cgi-lib.pl: Unknown request method: $meth\n");
  91.     }
  92.  
  93.     @in = split(/[&;]/,$in); 
  94.     push(@in, @ARGV) if $cmdflag; # add command-line parameters
  95.  
  96.     foreach $i (0 .. $#in) {
  97.       # Convert plus to space
  98.       $in[$i] =~ s/\+/ /g;
  99.  
  100.       # Split into key and value.  
  101.       ($key, $val) = split(/=/,$in[$i],2); # splits on the first =.
  102.  
  103.       # Convert %XX from hex numbers to alphanumeric
  104.       $key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
  105.       $val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
  106.  
  107.       # Associate key and value
  108.       $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
  109.       $in{$key} .= $val;
  110.     }
  111.  
  112.   } elsif ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) {
  113.     # for efficiency, compile multipart code only if needed
  114. $errflag = !(eval <<'END_MULTIPART');
  115.  
  116.     local ($buf, $boundary, $head, @heads, $cd, $ct, $fname, $ctype, $blen);
  117.     local ($bpos, $lpos, $left, $amt, $fn, $ser);
  118.     local ($bufsize, $maxbound, $writefiles) = 
  119.       ($cgi_lib'bufsize, $cgi_lib'maxbound, $cgi_lib'writefiles);
  120.  
  121.  
  122.     # The following lines exist solely to eliminate spurious warning messages
  123.     $buf = ''; 
  124.  
  125.     ($boundary) = $type =~ /boundary="([^"]+)"/; #";   # find boundary
  126.     ($boundary) = $type =~ /boundary=(\S+)/ unless $boundary;
  127.     &CgiDie ("Boundary not provided") unless $boundary;
  128.     $boundary =  "--" . $boundary;
  129.     $blen = length ($boundary);
  130.  
  131.     if ($ENV{'REQUEST_METHOD'} ne 'POST') {
  132.       &CgiDie("Invalid request method for  multipart/form-data: $meth\n");
  133.     }
  134.  
  135.     if ($writefiles) {
  136.       local($me);
  137.       stat ($writefiles);
  138.       $writefiles = "/tmp" unless  -d _ && -r _ && -w _;
  139.       # ($me) = $0 =~ m#([^/]*)$#;
  140.       $writefiles .= "/$cgi_lib'filepre"; 
  141.     }
  142.  
  143.     # read in the data and split into parts:
  144.     # put headers in @in and data in %in
  145.     # General algorithm:
  146.     #   There are two dividers: the border and the '\r\n\r\n' between
  147.     # header and body.  Iterate between searching for these
  148.     #   Retain a buffer of size(bufsize+maxbound); the latter part is
  149.     # to ensure that dividers don't get lost by wrapping between two bufs
  150.     #   Look for a divider in the current batch.  If not found, then
  151.     # save all of bufsize, move the maxbound extra buffer to the front of
  152.     # the buffer, and read in a new bufsize bytes.  If a divider is found,
  153.     # save everything up to the divider.  Then empty the buffer of everything
  154.     # up to the end of the divider.  Refill buffer to bufsize+maxbound
  155.     #   Note slightly odd organization.  Code before BODY: really goes with
  156.     # code following HEAD:, but is put first to 'pre-fill' buffers.  BODY:
  157.     # is placed before HEAD: because we first need to discard any 'preface,'
  158.     # which would be analagous to a body without a preceeding head.
  159.  
  160.     $left = $len;
  161.    PART: # find each part of the multi-part while reading data
  162.     while (1) {
  163.       last PART if $errflag;
  164.  
  165.       $amt = ($left > $bufsize+$maxbound-length($buf) 
  166.           ?  $bufsize+$maxbound-length($buf): $left);
  167.       $errflag = (read(STDIN, $buf, $amt, length($buf)) != $amt);
  168.       $left -= $amt;
  169.  
  170.       $in{$name} .= "\0" if defined $in{$name}; 
  171.       $in{$name} .= $fn if $fn;
  172.  
  173.       $name=~/([-\w]+)/;  # This allows $insfn{$name} to be untainted
  174.       if (defined $1) {
  175.         $insfn{$1} .= "\0" if defined $insfn{$1}; 
  176.         $insfn{$1} .= $fn if $fn;
  177.       }
  178.  
  179.      BODY: 
  180.       while (($bpos = index($buf, $boundary)) == -1) {
  181.         if ($name) {  # if no $name, then it's the prologue -- discard
  182.           if ($fn) { print FILE substr($buf, 0, $bufsize); }
  183.           else     { $in{$name} .= substr($buf, 0, $bufsize); }
  184.         }
  185.         $buf = substr($buf, $bufsize);
  186.         $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
  187.         $errflag = (read(STDIN, $buf, $amt, $maxbound) != $amt);  
  188.         $left -= $amt;
  189.       }
  190.       if (defined $name) {  # if no $name, then it's the prologue -- discard
  191.         if ($fn) { print FILE substr($buf, 0, $bpos-2); }
  192.         else     { $in {$name} .= substr($buf, 0, $bpos-2); } # kill last \r\n
  193.       }
  194.       close (FILE);
  195.       last PART if substr($buf, $bpos + $blen, 4) eq "--\r\n";
  196.       substr($buf, 0, $bpos+$blen+2) = '';
  197.       $amt = ($left > $bufsize+$maxbound-length($buf) 
  198.           ? $bufsize+$maxbound-length($buf) : $left);
  199.       $errflag = (read(STDIN, $buf, $amt, length($buf)) != $amt);
  200.       $left -= $amt;
  201.  
  202.  
  203.       undef $head;  undef $fn;
  204.      HEAD:
  205.       while (($lpos = index($buf, "\r\n\r\n")) == -1) { 
  206.         $head .= substr($buf, 0, $bufsize);
  207.         $buf = substr($buf, $bufsize);
  208.         $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
  209.         $errflag = (read(STDIN, $buf, $amt, $maxbound) != $amt);  
  210.         $left -= $amt;
  211.       }
  212.       $head .= substr($buf, 0, $lpos+2);
  213.       push (@in, $head);
  214.       @heads = split("\r\n", $head);
  215.       ($cd) = grep (/^\s*Content-Disposition:/i, @heads);
  216.       ($ct) = grep (/^\s*Content-Type:/i, @heads);
  217.  
  218.       ($name) = $cd =~ /\bname="([^"]+)"/i; #"; 
  219.       ($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name;  
  220.  
  221.       ($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be null-str
  222.       ($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname;
  223.       $incfn{$name} .= (defined $in{$name} ? "\0" : "") . $fname;
  224.  
  225.       ($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i;  #";
  226.       ($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless defined $ctype;
  227.       $inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype;
  228.  
  229.       if ($writefiles && defined $fname) {
  230.         $ser++;
  231.     $fn = $writefiles . ".$$.$ser";
  232.     open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n");
  233.       }
  234.       substr($buf, 0, $lpos+4) = '';
  235.       undef $fname;
  236.       undef $ctype;
  237.     }
  238.  
  239. 1;
  240. END_MULTIPART
  241.   &CgiDie($@) if $errflag;
  242.   } else {
  243.     &CgiDie("cgi-lib.pl: Unknown Content-type: $ENV{'CONTENT_TYPE'}\n");
  244.   }
  245.  
  246.  
  247.   $^W = $perlwarn;
  248.  
  249.   return ($errflag ? undef :  scalar(@in)); 
  250. }
  251.  
  252.  
  253. # PrintHeader
  254. # Returns the magic line which tells WWW that we're an HTML document
  255.  
  256. sub PrintHeader {
  257.   return "Content-type: text/html\n\n";
  258. }
  259.  
  260.  
  261. # HtmlTop
  262. # Returns the <head> of a document and the beginning of the body
  263. # with the title and a body <h1> header as specified by the parameter
  264.  
  265. sub HtmlTop
  266. {
  267.   local ($title) = @_;
  268.  
  269.   return <<END_OF_TEXT;
  270. <html>
  271. <head>
  272. <title>$title</title>
  273. </head>
  274. <body>
  275. <h1>$title</h1>
  276. END_OF_TEXT
  277. }
  278.  
  279.  
  280. # HtmlBot
  281. # Returns the </body>, </html> codes for the bottom of every HTML page
  282.  
  283. sub HtmlBot
  284. {
  285.   return "</body>\n</html>\n";
  286. }
  287.  
  288.  
  289. # SplitParam
  290. # Splits a multi-valued parameter into a list of the constituent parameters
  291.  
  292. sub SplitParam
  293. {
  294.   local ($param) = @_;
  295.   local (@params) = split ("\0", $param);
  296.   return (wantarray ? @params : $params[0]);
  297. }
  298.  
  299.  
  300. # MethGet
  301. # Return true if this cgi call was using the GET request, false otherwise
  302.  
  303. sub MethGet {
  304.   return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "GET");
  305. }
  306.  
  307.  
  308. # MethPost
  309. # Return true if this cgi call was using the POST request, false otherwise
  310.  
  311. sub MethPost {
  312.   return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "POST");
  313. }
  314.  
  315.  
  316. # MyBaseUrl
  317. # Returns the base URL to the script (i.e., no extra path or query string)
  318. sub MyBaseUrl {
  319.   local ($ret, $perlwarn);
  320.   $perlwarn = $^W; $^W = 0;
  321.   $ret = 'http://' . $ENV{'SERVER_NAME'} .  
  322.          ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
  323.          $ENV{'SCRIPT_NAME'};
  324.   $^W = $perlwarn;
  325.   return $ret;
  326. }
  327.  
  328.  
  329. # MyFullUrl
  330. # Returns the full URL to the script (i.e., with extra path or query string)
  331. sub MyFullUrl {
  332.   local ($ret, $perlwarn);
  333.   $perlwarn = $^W; $^W = 0;
  334.   $ret = 'http://' . $ENV{'SERVER_NAME'} .  
  335.          ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
  336.          $ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'} .
  337.          (length ($ENV{'QUERY_STRING'}) ? "?$ENV{'QUERY_STRING'}" : '');
  338.   $^W = $perlwarn;
  339.   return $ret;
  340. }
  341.  
  342.  
  343. # MyURL
  344. # Returns the base URL to the script (i.e., no extra path or query string)
  345. # This is obsolete and will be removed in later versions
  346. sub MyURL  {
  347.   return &MyBaseUrl;
  348. }
  349.  
  350.  
  351. # CgiError
  352. # Prints out an error message which which containes appropriate headers,
  353. # markup, etcetera.
  354. # Parameters:
  355. #  If no parameters, gives a generic error message
  356. #  Otherwise, the first parameter will be the title and the rest will 
  357. #  be given as different paragraphs of the body
  358.  
  359. sub CgiError {
  360.   local (@msg) = @_;
  361.   local ($i,$name);
  362.  
  363.   if (!@msg) {
  364.     $name = &MyFullUrl;
  365.     @msg = ("Error: script $name encountered fatal error\n");
  366.   };
  367.  
  368.   if (!$cgi_lib'headerout) { #')
  369.     print &PrintHeader;    
  370.     print "<html>\n<head>\n<title>$msg[0]</title>\n</head>\n<body>\n";
  371.   }
  372.   print "<h1>$msg[0]</h1>\n";
  373.   foreach $i (1 .. $#msg) {
  374.     print "<p>$msg[$i]</p>\n";
  375.   }
  376.  
  377.   $cgi_lib'headerout++;
  378. }
  379.  
  380.  
  381. # CgiDie
  382. # Identical to CgiError, but also quits with the passed error message.
  383.  
  384. sub CgiDie {
  385.   local (@msg) = @_;
  386.   &CgiError (@msg);
  387.   die @msg;
  388. }
  389.  
  390.  
  391. # PrintVariables
  392. # Nicely formats variables.  Three calling options:
  393. # A non-null associative array - prints the items in that array
  394. # A type-glob - prints the items in the associated assoc array
  395. # nothing - defaults to use %in
  396. # Typical use: &PrintVariables()
  397.  
  398. sub PrintVariables {
  399.   local (*in) = @_ if @_ == 1;
  400.   local (%in) = @_ if @_ > 1;
  401.   local ($out, $key, $output);
  402.  
  403.   $output =  "\n<dl compact>\n";
  404.   foreach $key (sort keys(%in)) {
  405.     foreach (split("\0", $in{$key})) {
  406.       ($out = $_) =~ s/\n/<br>\n/g;
  407.       $output .=  "<dt><b>$key</b>\n <dd>:<i>$out</i>:<br>\n";
  408.     }
  409.   }
  410.   $output .=  "</dl>\n";
  411.  
  412.   return $output;
  413. }
  414.  
  415. # PrintEnv
  416. # Nicely formats all environment variables and returns HTML string
  417. sub PrintEnv {
  418.   &PrintVariables(*ENV);
  419. }
  420.  
  421.  
  422. # The following lines exist only to avoid warning messages
  423. $cgi_lib'writefiles =  $cgi_lib'writefiles;
  424. $cgi_lib'bufsize    =  $cgi_lib'bufsize ;
  425. $cgi_lib'maxbound   =  $cgi_lib'maxbound;
  426. $cgi_lib'version    =  $cgi_lib'version;
  427.  
  428. 1; #return true 
  429.  
  430.