PERL   8

cgi-lib.pl

Guest on 12th May 2021 06:11:53 PM

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

Raw Paste


Login or Register to edit or fork this paste. It's free.