Return to cgi-lib.pl CVS log

Up to [LON-CAPA] / capa / capa51 / CapaTools

Big sync, might actually begin using the cvs after this revision.

    1: # Perl Routines to Manipulate CGI input
    2: # cgi-lib@pobox.com
    3: # $Id: cgi-lib.pl,v 1.2 1999/10/13 18:45:28 albertel Exp $
    4: #
    5: # Copyright (c) 1993-1999 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: 1.2 $ =~ /(\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 = "/tmp";    # 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:     $cgi_msg = "Begin multipart/form-data:: CONTENT_TYPE=[$type]\n";
  137: 
  138:     if ($ENV{'REQUEST_METHOD'} ne 'POST') {
  139:       &CgiDie("Invalid request method for  multipart/form-data: $meth\n");
  140:     }
  141: 
  142:     if ($writefiles) {
  143:       local($me);
  144:       stat ($writefiles);
  145:       $writefiles = "/tmp" unless  -d _ && -w _;
  146:       # ($me) = $0 =~ m#([^/]*)$#;
  147:       $writefiles .= "/$cgi_lib'filepre"; 
  148:     }
  149:     
  150:     # read in the data and split into parts:
  151:     # put headers in @in and data in %in
  152:     # General algorithm:
  153:     #   There are two dividers: the border and the '\r\n\r\n' between
  154:     # header and body.  Iterate between searching for these
  155:     #   Retain a buffer of size(bufsize+maxbound); the latter part is
  156:     # to ensure that dividers don't get lost by wrapping between two bufs
  157:     #   Look for a divider in the current batch.  If not found, then
  158:     # save all of bufsize, move the maxbound extra buffer to the front of
  159:     # the buffer, and read in a new bufsize bytes.  If a divider is found,
  160:     # save everything up to the divider.  Then empty the buffer of everything
  161:     # up to the end of the divider.  Refill buffer to bufsize+maxbound
  162:     #   Note slightly odd organization.  Code before BODY: really goes with
  163:     # code following HEAD:, but is put first to 'pre-fill' buffers.  BODY:
  164:     # is placed before HEAD: because we first need to discard any 'preface,'
  165:     # which would be analagous to a body without a preceeding head.
  166: 
  167:     $left = $len;
  168:    PART: # find each part of the multi-part while reading data
  169:     while (1) {
  170:       die $@ if $errflag;
  171: 
  172:       $amt = ($left > $bufsize+$maxbound-length($buf) 
  173: 	      ?  $bufsize+$maxbound-length($buf): $left);
  174:       $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
  175:       die "Short Read: wanted $amt, got $got\n" if $errflag;
  176:       $left -= $amt;
  177: 
  178:       $in{$name} .= "\0" if defined $in{$name}; 
  179:       $in{$name} .= $fn if $fn;
  180: 
  181:       $name=~/([-\w]+)/;  # This allows $insfn{$name} to be untainted
  182:       if (defined $1) {
  183:         $insfn{$1} .= "\0" if defined $insfn{$1}; 
  184:         $insfn{$1} .= $fn if $fn;
  185:       }
  186:       $cgi_msg .= "Before BODY:: in{name}=[$in{$name}], name=[$name], fn=[$fn]\n";
  187:       $cgi_msg .= ":: amt=[$amt],buf(20)=[" . substr($buf,0,20) . "]\n";
  188:       $cgi_msg .= ":: buflen=[" . length($buf) . "]\n";
  189: 
  190:      BODY: 
  191:       while (($bpos = index($buf, $boundary)) == -1) {
  192:         if ($left == 0 && $buf eq '') {
  193: 	  foreach $value (values %insfn) {
  194:             unlink(split("\0",$value));
  195: 	  }
  196: 	  &CgiDie("cgi-lib.pl: reached end of input while seeking boundary " .
  197: 		  "of multipart. Format of CGI input is wrong.\n");
  198:         }
  199:         die $@ if $errflag;
  200:         $cgi_msg .= "WITHIN BODY WHILE():: name = [$name], fn=[$fn]\n";
  201:         if ($name) {  # if no $name, then it's the prologue -- discard
  202:           if ($fn) { print FILE substr($buf, 0, $bufsize); }
  203:           else     { $in{$name} .= substr($buf, 0, $bufsize); }
  204:         }
  205:         $buf = substr($buf, $bufsize);
  206:         $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
  207:         $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
  208: 	die "Short Read: wanted $amt, got $got\n" if $errflag;
  209:         $left -= $amt;
  210:       }
  211:       $cgi_msg .= "WITHIN BODY:: name = [$name], fn=[$fn]\n";
  212:       $cgi_msg .= ":: buf(20)= [" . substr($buf,0,20) . "], bpos=[$bpos]\n";
  213:       if (defined $name) {  # if no $name, then it's the prologue -- discard
  214:         if ($fn) { print FILE substr($buf, 0, $bpos-2); }
  215:         else     { $in {$name} .= substr($buf, 0, $bpos-2); } # kill last \r\n
  216:       }
  217:       close (FILE);
  218:       last PART if substr($buf, $bpos + $blen, 2) eq "--";
  219:       substr($buf, 0, $bpos+$blen+2) = '';
  220:       $amt = ($left > $bufsize+$maxbound-length($buf) 
  221: 	      ? $bufsize+$maxbound-length($buf) : $left);
  222:       $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
  223:       die "Short Read: wanted $amt, got $got\n" if $errflag;
  224:       $left -= $amt;
  225: 
  226:       $cgi_msg .= "before HEAD:: buf(20)= [" . substr($buf,0,20) . "],amt=[$amt]\n";
  227: 
  228:       undef $head;  undef $fn;
  229:      HEAD:
  230:       while (($lpos = index($buf, "\r\n\r\n")) == -1) { 
  231:         if ($left == 0  && $buf eq '') {
  232: 	  foreach $value (values %insfn) {
  233:             unlink(split("\0",$value));
  234: 	  }
  235: 	  &CgiDie("cgi-lib: reached end of input while seeking end of " .
  236: 		  "headers. Format of CGI input is wrong.\n$buf");
  237:         }
  238:         die $@ if $errflag;
  239:         $head .= substr($buf, 0, $bufsize);
  240:         $buf = substr($buf, $bufsize);
  241:         $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
  242:         $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
  243:         die "Short Read: wanted $amt, got $got\n" if $errflag;
  244:         $cgi_msg .= "HEAD WHILE(lpos=-1):: head=[$head],amt=[$amt]\n";
  245:         $left -= $amt;
  246:       }
  247:       $head .= substr($buf, 0, $lpos+2);
  248:       push (@in, $head);
  249:       @heads = split("\r\n", $head);
  250:       ($cd) = grep (/^\s*Content-Disposition:/i, @heads);
  251:       ($ct) = grep (/^\s*Content-Type:/i, @heads);
  252: 
  253:       ($name) = $cd =~ /\bname="([^"]+)"/i; #"; 
  254:       ($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name;  
  255: 
  256:       ($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be null-str
  257:       ($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname;
  258:       $incfn{$name} .= (defined $in{$name} ? "\0" : "") . 
  259:         (defined $fname ? $fname : "");
  260: 
  261:       ($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i;  #";
  262:       ($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless defined $ctype;
  263:       $inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype;
  264: 
  265:       $cgi_msg .= "Before Write:: Content-Type=[$ct]\n";
  266:       $cgi_msg .= "::Content-Disposition=[$cd]\n";
  267:       $cgi_msg .= "::name=[$name],in{name}=[$in{$name}],inct{name}=[$inct{$name}]\n";
  268:       $cgi_msg .= "::writefiles=[$writefiles],fname=[$fname]\n";
  269:       $cgi_msg .= "::head=[$head],heads=[@heads]\n";
  270: 
  271:       if ($writefiles && defined $fname) {
  272:         $ser++;
  273: 	$fn = $writefiles . ".$$.$ser";
  274: 	open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n");
  275:         binmode (FILE);  # write files accurately
  276:       }
  277:       substr($buf, 0, $lpos+4) = '';
  278:       undef $fname;
  279:       undef $ctype;
  280:     }
  281: 
  282: 1;
  283: END_MULTIPART
  284:     if ($errflag) {
  285:       local ($errmsg, $value);
  286:       $errmsg = $@ || $errflag;
  287:       foreach $value (values %insfn) {
  288:         unlink(split("\0",$value));
  289:       }
  290:       &CgiDie($errmsg);
  291:     } else {
  292:       # everything's ok.
  293:     }
  294:   } else {
  295:     &CgiDie("cgi-lib.pl: Unknown Content-type: $ENV{'CONTENT_TYPE'}\n");
  296:   }
  297: 
  298:   # no-ops to avoid warnings
  299:   $insfn = $insfn;
  300:   $incfn = $incfn;
  301:   $inct  = $inct;
  302: 
  303:   $^W = $perlwarn;
  304: 
  305:   return ($errflag ? undef :  scalar(@in)); 
  306: }
  307: 
  308: 
  309: # PrintHeader
  310: # Returns the magic line which tells WWW that we're an HTML document
  311: 
  312: sub PrintHeader {
  313:   return "Content-type: text/html\n\n";
  314: }
  315: 
  316: 
  317: # HtmlTop
  318: # Returns the <head> of a document and the beginning of the body
  319: # with the title and a body <h1> header as specified by the parameter
  320: 
  321: sub HtmlTop
  322: {
  323:   local ($title) = @_;
  324: 
  325:   return <<END_OF_TEXT;
  326: <html>
  327: <head>
  328: <title>$title</title>
  329: </head>
  330: <body>
  331: <h1>$title</h1>
  332: END_OF_TEXT
  333: }
  334: 
  335: 
  336: # HtmlBot
  337: # Returns the </body>, </html> codes for the bottom of every HTML page
  338: 
  339: sub HtmlBot
  340: {
  341:   return "</body>\n</html>\n";
  342: }
  343: 
  344: 
  345: # SplitParam
  346: # Splits a multi-valued parameter into a list of the constituent parameters
  347: 
  348: sub SplitParam
  349: {
  350:   local ($param) = @_;
  351:   local (@params) = split ("\0", $param);
  352:   return (wantarray ? @params : $params[0]);
  353: }
  354: 
  355: 
  356: # MethGet
  357: # Return true if this cgi call was using the GET request, false otherwise
  358: 
  359: sub MethGet {
  360:   return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "GET");
  361: }
  362: 
  363: 
  364: # MethPost
  365: # Return true if this cgi call was using the POST request, false otherwise
  366: 
  367: sub MethPost {
  368:   return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "POST");
  369: }
  370: 
  371: 
  372: # MyBaseUrl
  373: # Returns the base URL to the script (i.e., no extra path or query string)
  374: sub MyBaseUrl {
  375:   local ($ret, $perlwarn);
  376:   $perlwarn = $^W; $^W = 0;
  377:   $ret = 'http://' . $ENV{'SERVER_NAME'} .  
  378:          ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
  379:          $ENV{'SCRIPT_NAME'};
  380:   $^W = $perlwarn;
  381:   return $ret;
  382: }
  383: 
  384: 
  385: # MyFullUrl
  386: # Returns the full URL to the script (i.e., with extra path or query string)
  387: sub MyFullUrl {
  388:   local ($ret, $perlwarn);
  389:   $perlwarn = $^W; $^W = 0;
  390:   $ret = 'http://' . $ENV{'SERVER_NAME'} .  
  391:          ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
  392:          $ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'} .
  393:          (length ($ENV{'QUERY_STRING'}) ? "?$ENV{'QUERY_STRING'}" : '');
  394:   $^W = $perlwarn;
  395:   return $ret;
  396: }
  397: 
  398: 
  399: # MyURL
  400: # Returns the base URL to the script (i.e., no extra path or query string)
  401: # This is obsolete and will be removed in later versions
  402: sub MyURL  {
  403:   return &MyBaseUrl;
  404: }
  405: 
  406: 
  407: # CgiError
  408: # Prints out an error message which which containes appropriate headers,
  409: # markup, etcetera.
  410: # Parameters:
  411: #  If no parameters, gives a generic error message
  412: #  Otherwise, the first parameter will be the title and the rest will 
  413: #  be given as different paragraphs of the body
  414: 
  415: sub CgiError {
  416:   local (@msg) = @_;
  417:   local ($i,$name);
  418: 
  419:   if (!@msg) {
  420:     $name = &MyFullUrl;
  421:     @msg = ("Error: script $name encountered fatal error\n");
  422:   };
  423: 
  424:   if (!$cgi_lib'headerout) { #')
  425:     print &PrintHeader;	
  426:     print "<html>\n<head>\n<title>$msg[0]</title>\n</head>\n<body>\n";
  427:   }
  428:   print "<h1>$msg[0]</h1>\n";
  429:   foreach $i (1 .. $#msg) {
  430:     print "<p>$msg[$i]</p>\n";
  431:   }
  432: 
  433:   $cgi_lib'headerout++;
  434: }
  435: 
  436: 
  437: # CgiDie
  438: # Identical to CgiError, but also quits with the passed error message.
  439: 
  440: sub CgiDie {
  441:   local (@msg) = @_;
  442:   &CgiError (@msg);
  443:   die @msg;
  444: }
  445: 
  446: 
  447: # PrintVariables
  448: # Nicely formats variables.  Three calling options:
  449: # A non-null associative array - prints the items in that array
  450: # A type-glob - prints the items in the associated assoc array
  451: # nothing - defaults to use %in
  452: # Typical use: &PrintVariables()
  453: 
  454: sub PrintVariables {
  455:   local (*in) = @_ if @_ == 1;
  456:   local (%in) = @_ if @_ > 1;
  457:   local ($out, $key, $output);
  458: 
  459:   $output =  "\n<dl compact>\n";
  460:   foreach $key (sort keys(%in)) {
  461:     foreach (split("\0", $in{$key})) {
  462:       ($out = $_) =~ s/\n/<br>\n/g;
  463:       $output .=  "<dt><b>$key</b>\n <dd>:<i>$out</i>:<br>\n";
  464:     }
  465:   }
  466:   $output .=  "</dl>\n";
  467: 
  468:   return $output;
  469: }
  470: 
  471: # PrintEnv
  472: # Nicely formats all environment variables and returns HTML string
  473: sub PrintEnv {
  474:   &PrintVariables(*ENV);
  475: }
  476: 
  477: 
  478: # The following lines exist only to avoid warning messages
  479: $cgi_lib'writefiles =  $cgi_lib'writefiles;
  480: $cgi_lib'bufsize    =  $cgi_lib'bufsize ;
  481: $cgi_lib'maxbound   =  $cgi_lib'maxbound;
  482: $cgi_lib'version    =  $cgi_lib'version;
  483: $cgi_lib'filepre    =  $cgi_lib'filepre;
  484: 
  485: 1; #return true 
  486: