summaryrefslogtreecommitdiff
path: root/contrib/webcscope/cgi-lib.pl
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/webcscope/cgi-lib.pl')
-rw-r--r--contrib/webcscope/cgi-lib.pl471
1 files changed, 471 insertions, 0 deletions
diff --git a/contrib/webcscope/cgi-lib.pl b/contrib/webcscope/cgi-lib.pl
new file mode 100644
index 0000000..97d0caa
--- /dev/null
+++ b/contrib/webcscope/cgi-lib.pl
@@ -0,0 +1,471 @@
+# Perl Routines to Manipulate CGI input
+# cgi-lib@pobox.com
+# $Id: cgi-lib.pl,v 1.1 2001/06/29 14:20:16 petr Exp $
+#
+# Copyright (c) 1993-1999 Steven E. Brenner
+# Unpublished work.
+# Permission granted to use and modify this library so long as the
+# copyright above is maintained, modifications are documented, and
+# credit is given for any use of the library.
+#
+# Thanks are due to many people for reporting bugs and suggestions
+
+# For more information, see:
+# http://cgi-lib.stanford.edu/cgi-lib/
+
+$cgi_lib'version = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
+
+
+# Parameters affecting cgi-lib behavior
+# User-configurable parameters affecting file upload.
+$cgi_lib'maxdata = 131072; # maximum bytes to accept via POST - 2^17
+$cgi_lib'writefiles = 0; # directory to which to write files, or
+ # 0 if files should not be written
+$cgi_lib'filepre = "cgi-lib"; # Prefix of file names, in directory above
+
+# Do not change the following parameters unless you have special reasons
+$cgi_lib'bufsize = 8192; # default buffer size when reading multipart
+$cgi_lib'maxbound = 100; # maximum boundary length to be encounterd
+$cgi_lib'headerout = 0; # indicates whether the header has been printed
+
+
+# ReadParse
+# Reads in GET or POST data, converts it to unescaped text, and puts
+# key/value pairs in %in, using "\0" to separate multiple selections
+
+# Returns >0 if there was input, 0 if there was no input
+# undef indicates some failure.
+
+# Now that cgi scripts can be put in the normal file space, it is useful
+# to combine both the form and the script in one place. If no parameters
+# are given (i.e., ReadParse returns FALSE), then a form could be output.
+
+# If a reference to a hash is given, then the data will be stored in that
+# hash, but the data from $in and @in will become inaccessable.
+# If a variable-glob (e.g., *cgi_input) is the first parameter to ReadParse,
+# information is stored there, rather than in $in, @in, and %in.
+# Second, third, and fourth parameters fill associative arrays analagous to
+# %in with data relevant to file uploads.
+
+# If no method is given, the script will process both command-line arguments
+# of the form: name=value and any text that is in $ENV{'QUERY_STRING'}
+# This is intended to aid debugging and may be changed in future releases
+
+sub ReadParse {
+ # Disable warnings as this code deliberately uses local and environment
+ # variables which are preset to undef (i.e., not explicitly initialized)
+ local ($perlwarn);
+ $perlwarn = $^W;
+ $^W = 0;
+
+ local (*in) = shift if @_; # CGI input
+ local (*incfn, # Client's filename (may not be provided)
+ *inct, # Client's content-type (may not be provided)
+ *insfn) = @_; # Server's filename (for spooled files)
+ local ($len, $type, $meth, $errflag, $cmdflag, $got, $name);
+
+ binmode(STDIN); # we need these for DOS-based systems
+ binmode(STDOUT); # and they shouldn't hurt anything else
+ binmode(STDERR);
+
+ # Get several useful env variables
+ $type = $ENV{'CONTENT_TYPE'};
+ $len = $ENV{'CONTENT_LENGTH'};
+ $meth = $ENV{'REQUEST_METHOD'};
+
+ if ($len > $cgi_lib'maxdata) { #'
+ &CgiDie("cgi-lib.pl: Request to receive too much data: $len bytes\n");
+ }
+
+ if (!defined $meth || $meth eq '' || $meth eq 'GET' ||
+ $meth eq 'HEAD' ||
+ $type eq 'application/x-www-form-urlencoded') {
+ local ($key, $val, $i);
+
+ # Read in text
+ if (!defined $meth || $meth eq '') {
+ $in = $ENV{'QUERY_STRING'};
+ $cmdflag = 1; # also use command-line options
+ } elsif($meth eq 'GET' || $meth eq 'HEAD') {
+ $in = $ENV{'QUERY_STRING'};
+ } elsif ($meth eq 'POST') {
+ if (($got = read(STDIN, $in, $len) != $len))
+ {$errflag="Short Read: wanted $len, got $got\n";};
+ } else {
+ &CgiDie("cgi-lib.pl: Unknown request method: $meth\n");
+ }
+
+ @in = split(/[&;]/,$in);
+ push(@in, @ARGV) if $cmdflag; # add command-line parameters
+
+ foreach $i (0 .. $#in) {
+ # Convert plus to space
+ $in[$i] =~ s/\+/ /g;
+
+ # Split into key and value.
+ ($key, $val) = split(/=/,$in[$i],2); # splits on the first =.
+
+ # Convert %XX from hex numbers to alphanumeric
+ $key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
+ $val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
+
+ # Associate key and value
+ $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
+ $in{$key} .= $val;
+ }
+
+ } elsif ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) {
+ # for efficiency, compile multipart code only if needed
+$errflag = !(eval <<'END_MULTIPART');
+
+ local ($buf, $boundary, $head, @heads, $cd, $ct, $fname, $ctype, $blen);
+ local ($bpos, $lpos, $left, $amt, $fn, $ser);
+ local ($bufsize, $maxbound, $writefiles) =
+ ($cgi_lib'bufsize, $cgi_lib'maxbound, $cgi_lib'writefiles);
+
+
+ # The following lines exist solely to eliminate spurious warning messages
+ $buf = '';
+
+ ($boundary) = $type =~ /boundary="([^"]+)"/; #"; # find boundary
+ ($boundary) = $type =~ /boundary=(\S+)/ unless $boundary;
+ &CgiDie ("Boundary not provided: probably a bug in your server")
+ unless $boundary;
+ $boundary = "--" . $boundary;
+ $blen = length ($boundary);
+
+ if ($ENV{'REQUEST_METHOD'} ne 'POST') {
+ &CgiDie("Invalid request method for multipart/form-data: $meth\n");
+ }
+
+ if ($writefiles) {
+ local($me);
+ stat ($writefiles);
+ $writefiles = "/tmp" unless -d _ && -w _;
+ # ($me) = $0 =~ m#([^/]*)$#;
+ $writefiles .= "/$cgi_lib'filepre";
+ }
+
+ # read in the data and split into parts:
+ # put headers in @in and data in %in
+ # General algorithm:
+ # There are two dividers: the border and the '\r\n\r\n' between
+ # header and body. Iterate between searching for these
+ # Retain a buffer of size(bufsize+maxbound); the latter part is
+ # to ensure that dividers don't get lost by wrapping between two bufs
+ # Look for a divider in the current batch. If not found, then
+ # save all of bufsize, move the maxbound extra buffer to the front of
+ # the buffer, and read in a new bufsize bytes. If a divider is found,
+ # save everything up to the divider. Then empty the buffer of everything
+ # up to the end of the divider. Refill buffer to bufsize+maxbound
+ # Note slightly odd organization. Code before BODY: really goes with
+ # code following HEAD:, but is put first to 'pre-fill' buffers. BODY:
+ # is placed before HEAD: because we first need to discard any 'preface,'
+ # which would be analagous to a body without a preceeding head.
+
+ $left = $len;
+ PART: # find each part of the multi-part while reading data
+ while (1) {
+ die $@ if $errflag;
+
+ $amt = ($left > $bufsize+$maxbound-length($buf)
+ ? $bufsize+$maxbound-length($buf): $left);
+ $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
+ die "Short Read: wanted $amt, got $got\n" if $errflag;
+ $left -= $amt;
+
+ $in{$name} .= "\0" if defined $in{$name};
+ $in{$name} .= $fn if $fn;
+
+ $name=~/([-\w]+)/; # This allows $insfn{$name} to be untainted
+ if (defined $1) {
+ $insfn{$1} .= "\0" if defined $insfn{$1};
+ $insfn{$1} .= $fn if $fn;
+ }
+
+ BODY:
+ while (($bpos = index($buf, $boundary)) == -1) {
+ if ($left == 0 && $buf eq '') {
+ foreach $value (values %insfn) {
+ unlink(split("\0",$value));
+ }
+ &CgiDie("cgi-lib.pl: reached end of input while seeking boundary " .
+ "of multipart. Format of CGI input is wrong.\n");
+ }
+ die $@ if $errflag;
+ if ($name) { # if no $name, then it's the prologue -- discard
+ if ($fn) { print FILE substr($buf, 0, $bufsize); }
+ else { $in{$name} .= substr($buf, 0, $bufsize); }
+ }
+ $buf = substr($buf, $bufsize);
+ $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
+ $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
+ die "Short Read: wanted $amt, got $got\n" if $errflag;
+ $left -= $amt;
+ }
+ if (defined $name) { # if no $name, then it's the prologue -- discard
+ if ($fn) { print FILE substr($buf, 0, $bpos-2); }
+ else { $in {$name} .= substr($buf, 0, $bpos-2); } # kill last \r\n
+ }
+ close (FILE);
+ last PART if substr($buf, $bpos + $blen, 2) eq "--";
+ substr($buf, 0, $bpos+$blen+2) = '';
+ $amt = ($left > $bufsize+$maxbound-length($buf)
+ ? $bufsize+$maxbound-length($buf) : $left);
+ $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
+ die "Short Read: wanted $amt, got $got\n" if $errflag;
+ $left -= $amt;
+
+
+ undef $head; undef $fn;
+ HEAD:
+ while (($lpos = index($buf, "\r\n\r\n")) == -1) {
+ if ($left == 0 && $buf eq '') {
+ foreach $value (values %insfn) {
+ unlink(split("\0",$value));
+ }
+ &CgiDie("cgi-lib: reached end of input while seeking end of " .
+ "headers. Format of CGI input is wrong.\n$buf");
+ }
+ die $@ if $errflag;
+ $head .= substr($buf, 0, $bufsize);
+ $buf = substr($buf, $bufsize);
+ $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf);
+ $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt);
+ die "Short Read: wanted $amt, got $got\n" if $errflag;
+ $left -= $amt;
+ }
+ $head .= substr($buf, 0, $lpos+2);
+ push (@in, $head);
+ @heads = split("\r\n", $head);
+ ($cd) = grep (/^\s*Content-Disposition:/i, @heads);
+ ($ct) = grep (/^\s*Content-Type:/i, @heads);
+
+ ($name) = $cd =~ /\bname="([^"]+)"/i; #";
+ ($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name;
+
+ ($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be null-str
+ ($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname;
+ $incfn{$name} .= (defined $in{$name} ? "\0" : "") .
+ (defined $fname ? $fname : "");
+
+ ($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i; #";
+ ($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless defined $ctype;
+ $inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype;
+
+ if ($writefiles && defined $fname) {
+ $ser++;
+ $fn = $writefiles . ".$$.$ser";
+ open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n");
+ binmode (FILE); # write files accurately
+ }
+ substr($buf, 0, $lpos+4) = '';
+ undef $fname;
+ undef $ctype;
+ }
+
+1;
+END_MULTIPART
+ if ($errflag) {
+ local ($errmsg, $value);
+ $errmsg = $@ || $errflag;
+ foreach $value (values %insfn) {
+ unlink(split("\0",$value));
+ }
+ &CgiDie($errmsg);
+ } else {
+ # everything's ok.
+ }
+ } else {
+ &CgiDie("cgi-lib.pl: Unknown Content-type: $ENV{'CONTENT_TYPE'}\n");
+ }
+
+ # no-ops to avoid warnings
+ $insfn = $insfn;
+ $incfn = $incfn;
+ $inct = $inct;
+
+ $^W = $perlwarn;
+
+ return ($errflag ? undef : scalar(@in));
+}
+
+
+# PrintHeader
+# Returns the magic line which tells WWW that we're an HTML document
+
+sub PrintHeader {
+ return "Content-type: text/html\n\n";
+}
+
+
+# HtmlTop
+# Returns the <head> of a document and the beginning of the body
+# with the title and a body <h1> header as specified by the parameter
+
+sub HtmlTop
+{
+ local ($title) = @_;
+
+ return <<END_OF_TEXT;
+<html>
+<head>
+<title>$title</title>
+</head>
+<body>
+<h1>$title</h1>
+END_OF_TEXT
+}
+
+
+# HtmlBot
+# Returns the </body>, </html> codes for the bottom of every HTML page
+
+sub HtmlBot
+{
+ return "</body>\n</html>\n";
+}
+
+
+# SplitParam
+# Splits a multi-valued parameter into a list of the constituent parameters
+
+sub SplitParam
+{
+ local ($param) = @_;
+ local (@params) = split ("\0", $param);
+ return (wantarray ? @params : $params[0]);
+}
+
+
+# MethGet
+# Return true if this cgi call was using the GET request, false otherwise
+
+sub MethGet {
+ return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "GET");
+}
+
+
+# MethPost
+# Return true if this cgi call was using the POST request, false otherwise
+
+sub MethPost {
+ return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "POST");
+}
+
+
+# MyBaseUrl
+# Returns the base URL to the script (i.e., no extra path or query string)
+sub MyBaseUrl {
+ local ($ret, $perlwarn);
+ $perlwarn = $^W; $^W = 0;
+ $ret = 'http://' . $ENV{'SERVER_NAME'} .
+ ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
+ $ENV{'SCRIPT_NAME'};
+ $^W = $perlwarn;
+ return $ret;
+}
+
+
+# MyFullUrl
+# Returns the full URL to the script (i.e., with extra path or query string)
+sub MyFullUrl {
+ local ($ret, $perlwarn);
+ $perlwarn = $^W; $^W = 0;
+ $ret = 'http://' . $ENV{'SERVER_NAME'} .
+ ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') .
+ $ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'} .
+ (length ($ENV{'QUERY_STRING'}) ? "?$ENV{'QUERY_STRING'}" : '');
+ $^W = $perlwarn;
+ return $ret;
+}
+
+
+# MyURL
+# Returns the base URL to the script (i.e., no extra path or query string)
+# This is obsolete and will be removed in later versions
+sub MyURL {
+ return &MyBaseUrl;
+}
+
+
+# CgiError
+# Prints out an error message which which containes appropriate headers,
+# markup, etcetera.
+# Parameters:
+# If no parameters, gives a generic error message
+# Otherwise, the first parameter will be the title and the rest will
+# be given as different paragraphs of the body
+
+sub CgiError {
+ local (@msg) = @_;
+ local ($i,$name);
+
+ if (!@msg) {
+ $name = &MyFullUrl;
+ @msg = ("Error: script $name encountered fatal error\n");
+ };
+
+ if (!$cgi_lib'headerout) { #')
+ print &PrintHeader;
+ print "<html>\n<head>\n<title>$msg[0]</title>\n</head>\n<body>\n";
+ }
+ print "<h1>$msg[0]</h1>\n";
+ foreach $i (1 .. $#msg) {
+ print "<p>$msg[$i]</p>\n";
+ }
+
+ $cgi_lib'headerout++;
+}
+
+
+# CgiDie
+# Identical to CgiError, but also quits with the passed error message.
+
+sub CgiDie {
+ local (@msg) = @_;
+ &CgiError (@msg);
+ die @msg;
+}
+
+
+# PrintVariables
+# Nicely formats variables. Three calling options:
+# A non-null associative array - prints the items in that array
+# A type-glob - prints the items in the associated assoc array
+# nothing - defaults to use %in
+# Typical use: &PrintVariables()
+
+sub PrintVariables {
+ local (*in) = @_ if @_ == 1;
+ local (%in) = @_ if @_ > 1;
+ local ($out, $key, $output);
+
+ $output = "\n<dl compact>\n";
+ foreach $key (sort keys(%in)) {
+ foreach (split("\0", $in{$key})) {
+ ($out = $_) =~ s/\n/<br>\n/g;
+ $output .= "<dt><b>$key</b>\n <dd>:<i>$out</i>:<br>\n";
+ }
+ }
+ $output .= "</dl>\n";
+
+ return $output;
+}
+
+# PrintEnv
+# Nicely formats all environment variables and returns HTML string
+sub PrintEnv {
+ &PrintVariables(*ENV);
+}
+
+
+# The following lines exist only to avoid warning messages
+$cgi_lib'writefiles = $cgi_lib'writefiles;
+$cgi_lib'bufsize = $cgi_lib'bufsize ;
+$cgi_lib'maxbound = $cgi_lib'maxbound;
+$cgi_lib'version = $cgi_lib'version;
+$cgi_lib'filepre = $cgi_lib'filepre;
+
+1; #return true
+