Annotation of capa/capa51/CapaTools/cgi-lib.pl, revision 1.1
1.1 ! albertel 1: # Perl Routines to Manipulate CGI input
! 2: # cgi-lib@pobox.com
! 3: # $Id: cgi-lib.pl,v 2.18 1999/02/23 08:16:43 brenner 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: 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 = "/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:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to cgi-lib.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / capa / capa51 / CapaTools