X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=c0cb5fd518a75113f1dae6241becdbf216b0dcac;hb=9bea678f36dc293400ada67aa122ef456a9dcf74;hp=3e339551e7c5454b26a99fb8eab7ca2914b155e1;hpb=71f3e297ff71d9b213ccf3230601eae8b4e9b685;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI.pm b/lib/CGI.pm index 3e33955..c0cb5fd 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -17,8 +17,8 @@ require 5.004; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.5 1998/12/06 10:19:48 lstein Exp $'; -$CGI::VERSION='2.46'; +$CGI::revision = '$Id: CGI.pm,v 1.18 1999/06/09 14:52:45 lstein Exp $'; +$CGI::VERSION='2.53'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -58,6 +58,9 @@ sub initialize_globals { # Change this to 1 to disable uploads entirely: $DISABLE_UPLOADS = 0; + # Automatically determined -- don't change + $EBCDIC = 0; + # Change this to 1 to suppress redundant HTTP headers $HEADERS_ONCE = 0; @@ -89,9 +92,11 @@ unless ($OS) { } } if ($OS=~/Win/i) { - $OS = 'WINDOWS'; + $OS = 'WINDOWS'; } elsif ($OS=~/vms/i) { - $OS = 'VMS'; + $OS = 'VMS'; +} elsif ($OS=~/dos/i) { + $OS = 'DOS'; } elsif ($OS=~/^MacOS$/i) { $OS = 'MACINTOSH'; } elsif ($OS=~/os2/i) { @@ -101,7 +106,7 @@ if ($OS=~/Win/i) { } # Some OS logic. Binary mode enabled on DOS, NT and VMS -$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/; +$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin)/; # This is the default class for the CGI object to use when all else fails. $DefaultClass = 'CGI' unless defined $CGI::DefaultClass; @@ -112,7 +117,7 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; # The path separator is a slash, backslash or semicolon, depending # on the paltform. $SL = { - UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', MACINTOSH=>':', VMS=>'/' + UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/' }->{$OS}; # This no longer seems to be necessary @@ -123,7 +128,7 @@ $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; # Turn on special checking for Doug MacEachern's modperl if (exists $ENV{'GATEWAY_INTERFACE'} && - ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) + ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//)) { $| = 1; require Apache; @@ -139,11 +144,32 @@ $PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ # really annoying. $EBCDIC = "\t" ne "\011"; if ($OS eq 'VMS') { - $CRLF = "\n"; + $CRLF = "\n"; } elsif ($EBCDIC) { - $CRLF= "\r\n"; + $CRLF= "\r\n"; } else { - $CRLF = "\015\012"; + $CRLF = "\015\012"; +} + +if ($EBCDIC) { +@A2E = ( + 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, + 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, +240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, +124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, +215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, +121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, +151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, + 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, + 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, + 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, +144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, +100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, +172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, + 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, +140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 + ); } if ($needs_binmode) { @@ -164,15 +190,16 @@ if ($needs_binmode) { submit reset defaults radio_group popup_menu button autoEscape scrolling_list image_button start_form end_form startform endform start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie Dump - raw_cookie request_method query_string Accept user_agent remote_host + ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump + raw_cookie request_method query_string Accept user_agent remote_host content_type remote_addr referer server_name server_software server_port server_protocol virtual_host remote_ident auth_type http use_named_parameters save_parameters restore_parameters param_fetch - remote_user user_name header redirect import_names put Delete Delete_all url_param/], + remote_user user_name header redirect import_names put + Delete Delete_all url_param cgi_error/], ':ssl' => [qw/https/], ':imagemap' => [qw/Area Map/], - ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], ':html' => [qw/:html2 :html3 :netscape/], ':standard' => [qw/:html2 :html3 :form :cgi/], ':push' => [qw/multipart_init multipart_start multipart_end/], @@ -328,7 +355,7 @@ sub init { # if we get called more than once, we want to initialize # ourselves from the original query (which may be gone # if it was read from STDIN originally.) - if (defined(@QUERY_PARAM) && !defined($initializer)) { + if (@QUERY_PARAM && !defined($initializer)) { foreach (@QUERY_PARAM) { $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); } @@ -337,12 +364,17 @@ sub init { $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; - die "Client attempted to POST $content_length bytes, but POSTs are limited to $POST_MAX" - if ($POST_MAX > 0) && ($content_length > $POST_MAX); + $fh = to_filehandle($initializer) if $initializer; METHOD: { + # avoid unreasonably large postings + if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { + $self->cgi_error("413 Request entity too large"); + last METHOD; + } + # Process multipart postings, but only if the initializer is # not defined. if ($meth eq 'POST' @@ -394,7 +426,11 @@ sub init { # If method is GET or HEAD, fetch the query from # the environment. if ($meth=~/^(GET|HEAD)$/) { - $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + if ($MOD_PERL) { + $query_string = Apache->request->args; + } else { + $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + } last METHOD; } @@ -473,14 +509,25 @@ sub print { CORE::print(@_); } +# get/set last cgi_error +sub cgi_error { + my ($self,$err) = self_or_default(@_); + $self->{'.cgi_error'} = $err if defined $err; + return $self->{'.cgi_error'}; +} + # unescape URL-encoded data sub unescape { - shift() if ref($_[0]); - my $todecode = shift; - return undef unless defined($todecode); - $todecode =~ tr/+/ /; # pluses become spaces - $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; - return $todecode; + shift() if ref($_[0]) || $_[0] eq $DefaultClass; + my $todecode = shift; + return undef unless defined($todecode); + $todecode =~ tr/+/ /; # pluses become spaces + if ($EBCDIC) { + $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge; + } else { + $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; + } + return $todecode; } # URL-encode data @@ -488,7 +535,8 @@ sub escape { shift() if ref($_[0]) || $_[0] eq $DefaultClass; my $toencode = shift; return undef unless defined($toencode); - $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; + $toencode=~s/ /+/g; + $toencode=~s/([^a-zA-Z0-9_.+-])/uc sprintf("%%%02x",ord($1))/eg; return $toencode; } @@ -536,10 +584,10 @@ sub binmode { sub _make_tag_func { my ($self,$tagname) = @_; - my $func = qq# + my $func = qq( sub $tagname { shift if \$_[0] && - (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || +# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || (ref(\$_[0]) && (substr(ref(\$_[0]),0,3) eq 'CGI' || UNIVERSAL::isa(\$_[0],'CGI'))); @@ -549,7 +597,7 @@ sub _make_tag_func { my(\@attr) = make_attributes( '',shift() ); \$attr = " \@attr" if \@attr; } - #; + ); if ($tagname=~/start_(\w+)/i) { $func .= qq! return "<\U$1\E\$attr>";} !; } elsif ($tagname=~/end_(\w+)/i) { @@ -650,7 +698,7 @@ sub _compile { die $@; } } - delete($sub->{$func_name}); #free storage + CORE::delete($sub->{$func_name}); #free storage return "$pack\:\:$func_name"; } @@ -746,8 +794,8 @@ END_OF_FUNC #### sub delete { my($self,$name) = self_or_default(@_); - delete $self->{$name}; - delete $self->{'.fieldnames'}->{$name}; + CORE::delete $self->{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); return wantarray ? () : undef; } @@ -762,7 +810,7 @@ sub import_names { my($self,$namespace,$delete) = self_or_default(@_); $namespace = 'Q' unless defined($namespace); die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; - if ($delete || $MOD_PERL) { + if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { # can anyone find an easier way to do this? foreach (keys %{"${namespace}::"}) { local *symbol = "${namespace}::${_}"; @@ -793,7 +841,7 @@ END_OF_FUNC sub keywords { my($self,@values) = self_or_default(@_); # If values is provided, then we set it. - $self->{'keywords'}=[@values] if defined(@values); + $self->{'keywords'}=[@values] if @values; my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); @result; } @@ -801,6 +849,17 @@ END_OF_FUNC # These are some tie() interfaces for compatibility # with Steve Brenner's cgi-lib.pl routines +'Vars' => <<'END_OF_FUNC', +sub Vars { + my %in; + tie(%in,CGI); + return %in if wantarray; + return \%in; +} +END_OF_FUNC + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines 'ReadParse' => <<'END_OF_FUNC', sub ReadParse { local(*in); @@ -1031,6 +1090,7 @@ sub dump { push(@result,"
$_ | "; } for ($row=0;$row<$rows;$row++) { $result .= "||
---|---|---|
$rowheaders->[$row] | " if defined(@$rowheaders); + $result .= "$rowheaders->[$row] | " if @$rowheaders; for ($column=0;$column<$columns;$column++) { $result .= "" . $elements[$column*$rows + $row] . " | " if defined($elements[$column*$rows + $row]); @@ -2135,6 +2192,19 @@ sub url { my $url; $full++ if !($relative || $absolute); + my $path = $self->path_info; + my $script_name; + if (exists($ENV{REQUEST_URI})) { + my $index; + $script_name = $ENV{REQUEST_URI}; + # strip query string + substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0; + # and path + substr($script_name,$index) = '' if $path and ($index = rindex($script_name,$path)) >= 0; + } else { + $script_name = $self->script_name; + } + if ($full) { my $protocol = $self->protocol(); $url = "$protocol://"; @@ -2148,13 +2218,13 @@ sub url { unless (lc($protocol) eq 'http' && $port == 80) || (lc($protocol) eq 'https' && $port == 443); } - $url .= $self->script_name; + $url .= $script_name; } elsif ($relative) { - ($url) = $self->script_name =~ m!([^/]+)$!; + ($url) = $script_name =~ m!([^/]+)$!; } elsif ($absolute) { - $url = $self->script_name; + $url = $script_name; } - $url .= $self->path_info if $path_info and $self->path_info; + $url .= $path if $path_info and defined $path; $url .= "?" . $self->query_string if $query and $self->query_string; return $url; } @@ -2236,6 +2306,8 @@ sub expire_calc { my($offset); if (!$time || (lc($time) eq 'now')) { $offset = 0; + } elsif ($time=~/^\d+/) { + return $time; } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { $offset = ($mult{$2} || 1)*$1; } else { @@ -2247,7 +2319,7 @@ END_OF_FUNC # This internal routine creates date strings suitable for use in # cookies and HTTP headers. (They differ, unfortunately.) -# Thanks to Fisher Mark for this. +# Thanks to Mark Fisher for this. 'expires' => <<'END_OF_FUNC', sub expires { my($time,$format) = @_; @@ -2330,6 +2402,15 @@ sub request_method { } END_OF_FUNC +#### Method: content_type +# Returns the content_type string +#### +'content_type' => <<'END_OF_FUNC', +sub content_type { + return $ENV{'CONTENT_TYPE'}; +} +END_OF_FUNC + #### Method: path_translated # Return the physical path information provided # by the URL (if any) @@ -2353,6 +2434,7 @@ sub query_string { my($eparam) = escape($param); foreach $value ($self->param($param)) { $value = escape($value); + next unless defined $value; push(@pairs,"$eparam=$value"); } } @@ -2556,6 +2638,7 @@ END_OF_FUNC sub http { my ($self,$parameter) = self_or_CGI(@_); return $ENV{$parameter} if $parameter=~/^HTTP/; + $parameter =~ tr/-/_/; return $ENV{"HTTP_\U$parameter\E"} if $parameter; my(@p); foreach (keys %ENV) { @@ -2574,6 +2657,7 @@ sub https { my ($self,$parameter) = self_or_CGI(@_); return $ENV{HTTPS} unless $parameter; return $ENV{$parameter} if $parameter=~/^HTTPS/; + $parameter =~ tr/-/_/; return $ENV{"HTTPS_\U$parameter\E"} if $parameter; my(@p); foreach (keys %ENV) { @@ -2754,7 +2838,11 @@ sub read_multipart { my $filenumber = 0; while (!$buffer->eof) { %header = $buffer->readHeader; - die "Malformed multipart POST\n" unless %header; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/; @@ -2784,13 +2872,16 @@ sub read_multipart { last UPLOADS; } - $tmpfile = new TempFile; - $tmp = $tmpfile->as_string; - - $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES); - + # choose a relatively unpredictable tmpfile sequence number + my $seqno = unpack("%16C*",join('',localtime,values %ENV)); + for (my $cnt=10;$cnt>0;$cnt--) { + next unless $tmpfile = new TempFile($seqno); + $tmp = $tmpfile->as_string; + last if $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES); + $seqno += int rand(100); + } + die "CGI open of tmpfile: $!\n" unless $filehandle; $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; - chmod 0600,$tmp; # only the owner can tamper with it my ($data); local($\) = ''; @@ -2814,6 +2905,16 @@ sub read_multipart { } END_OF_FUNC +'upload' =><<'END_OF_FUNC', +sub upload { + my($self,$param_name) = self_or_default(@_); + my $param = $self->param($param_name); + return unless $param; + return unless ref($param) && fileno($param); + return $param; +} +END_OF_FUNC + 'tmpFileName' => <<'END_OF_FUNC', sub tmpFileName { my($self,$filename) = self_or_default(@_); @@ -2906,10 +3007,9 @@ sub new { require Fcntl unless defined &Fcntl::O_RDWR; ++$FH; my $ref = \*{'Fh::' . quotemeta($name)}; - sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL()) - || die "CGI open of $file: $!\n"; + sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; unlink($file) if $delete; - delete $Fh::{$FH}; + CORE::delete $Fh::{$FH}; return bless $ref,$pack; } END_OF_FUNC @@ -2976,7 +3076,7 @@ sub new { # BUG: IE 3.01 on the Macintosh uses just the boundary -- not # the two extra hyphens. We do a special case here on the user-agent!!!! - $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; ?Mac'); + $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac'); } else { # otherwise we find it ourselves my($old); @@ -3175,15 +3275,25 @@ $MAC = $CGI::OS eq 'MACINTOSH'; my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; unless ($TMPDIRECTORY) { @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", - "C:${SL}temp","${SL}tmp","${SL}temp","${vol}${SL}Temporary Items", + "C:${SL}temp","${SL}tmp","${SL}temp", + "${vol}${SL}Temporary Items", "${SL}WWW_ROOT"); + unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'}; + + # + # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX'; + # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this + # : can generate a 'getpwuid() not implemented' exception, even though + # : it's never called. Found under DOS/Win with the DJGPP perl port. + # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX. + unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX'; + foreach (@TEMP) { do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; } } $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; -$SEQUENCE=0; $MAXTRIES = 5000; # cute feature, but overload implementation broke it @@ -3199,14 +3309,15 @@ $AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; 'new' => <<'END_OF_FUNC', sub new { - my($package) = @_; - my $directory; - my $i; - for ($i = 0; $i < $MAXTRIES; $i++) { - $directory = sprintf("${TMPDIRECTORY}${SL}CGItemp%d%04d",${$},++$SEQUENCE); - last if ! -f $directory; + my($package,$sequence) = @_; + my $filename; + for (my $i = 0; $i < $MAXTRIES; $i++) { + last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); } - return bless \$directory; + # untaint the darn thing + return unless $filename =~ m!^([a-zA-Z0-9_ '":/\\]+)$!; + $filename = $1; + return bless \$filename; } END_OF_FUNC @@ -3240,7 +3351,6 @@ if ($^W) { $MultipartBuffer::CRLF; $MultipartBuffer::TIMEOUT; $MultipartBuffer::INITIAL_FILLUNIT; - $TempFile::SEQUENCE; EOF ; } @@ -3322,7 +3432,7 @@ script and restore it later. For example, using the object oriented style, here is how you create a simple "Hello World" HTML page: - #!/usr/local/bin/perl + #!/usr/local/bin/perl -w use CGI; # load CGI routines $q = new CGI; # create new CGI object print $q->header, # create the HTTP header @@ -3640,6 +3750,36 @@ can manipulate in any way you like. You can also use a named argument style using the B<-name> argument. +=head2 FETCHING THE PARAMETER LIST AS A HASH: + + $params = $q->Vars; + print $params->{'address'}; + @foo = split("\0",$params->{'foo'}); + %params = $q->Vars; + + use CGI ':cgi-lib'; + $params = Vars; + +Many people want to fetch the entire parameter list as a hash in which +the keys are the names of the CGI parameters, and the values are the +parameters' values. The Vars() method does this. Called in a scalar +context, it returns the parameter list as a tied hash reference. +Changing a key changes the value of the parameter in the underlying +CGI parameter list. Called in an array context, it returns the +parameter list as an ordinary hash. This allows you to read the +contents of the parameter list, but not to change it. + +When using this, the thing you must watch out for are multivalued CGI +parameters. Because a hash cannot distinguish between scalar and +array context, multivalued parameters will be returned as a packed +string, separated by the "\0" (null) character. You must split this +packed string in order to get at the individual values. This is the +convention introduced long ago by Steve Brenner in his cgi-lib.pl +module for Perl version 4. + +If you wish to use Vars() as a function, import the I<:cgi-lib> set of +function calls (also see the section on CGI-LIB compatibility). + =head2 SAVING THE STATE OF THE SCRIPT TO A FILE: $query->save(FILEHANDLE) @@ -3687,13 +3827,36 @@ The file format used for save/restore is identical to that used by the Whitehead Genome Center's data exchange format "Boulderio", and can be manipulated and even databased using Boulderio utilities. See - http://www.genome.wi.mit.edu/genome_software/other/boulder.html + http://stein.cshl.org/boulder/ for further details. If you wish to use this method from the function-oriented (non-OO) interface, the exported name for this method is B