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,""); @@ -1065,7 +1125,7 @@ sub save { my($escaped_param) = escape($param); my($value); foreach $value ($self->param($param)) { - print $filehandle "$escaped_param=",escape($value),"\n"; + print $filehandle "$escaped_param=",escape("$value"),"\n"; } } print $filehandle "=\n"; # end of record @@ -1327,7 +1387,7 @@ sub _style { '-foo'=>'bar', # a trick to allow the '-' to be omitted ref($style) eq 'ARRAY' ? @$style : %$style); $type = $stype if $stype; - push(@result,qq//) if $src; + push(@result,qq//) if $src; push(@result,style({'type'=>$type},"")) if $code; } else { push(@result,style({'type'=>$type},"")); @@ -1348,7 +1408,7 @@ sub _script { ($src,$code,$language) = $self->rearrange([SRC,CODE,LANGUAGE], '-foo'=>'bar', # a trick to allow the '-' to be omitted - ref($style) eq 'ARRAY' ? @$script : %$script); + ref($script) eq 'ARRAY' ? @$script : %$script); } else { ($src,$code,$language) = ('',$script,'JavaScript'); @@ -1360,7 +1420,7 @@ sub _script { if $code && $language=~/javascript/i; $code = "" if $code && $language=~/perl/i; - push(@result,script({@satts},$code)); + push(@result,script({@satts},$code || '')); } @result; } @@ -1727,9 +1787,7 @@ sub checkbox { $the_label = $self->escapeHTML($the_label); my($other) = @other ? " @other" : ''; $self->register_parameter($name); - return <$the_label -END + return qq{$the_label}; } END_OF_FUNC @@ -1800,8 +1858,7 @@ END_OF_FUNC # Escape HTML -- used internally 'escapeHTML' => <<'END_OF_FUNC', sub escapeHTML { - my($self,$toencode) = @_; - $toencode = $self unless ref($self); + my ($self,$toencode) = self_or_default(@_); return undef unless defined($toencode); return $toencode if ref($self) && $self->{'dontescape'}; @@ -1849,14 +1906,14 @@ sub _tableize { # rearrange into a pretty table $result = ""; my($row,$column); - unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders); - $result .= "" if defined(@{$colheaders}); + unshift(@$colheaders,'') if @$colheaders && @$rowheaders; + $result .= "" if @$colheaders; foreach (@{$colheaders}) { $result .= ""; } for ($row=0;$row<$rows;$row++) { $result .= ""; - $result .= "" if defined(@$rowheaders); + $result .= "" if @$rowheaders; for ($column=0;$column<$columns;$column++) { $result .= "" 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. +=head2 RETRIEVING CGI ERRORS + +Errors can occur while processing user input, particularly when +processing uploaded files. When these errors occur, CGI will stop +processing and return an empty parameter list. You can test for +the existence and nature of errors using the I function. +The error messages are formatted as HTTP status codes. You can either +incorporate the error text into an HTML page, or use it as the value +of the HTTP status: + + my $error = $q->cgi_error; + if ($error) { + print $q->header(-status=>$error), + $q->start_html('Problems'), + $q->h2('Request not processed'), + $q->strong($error); + exit 0; + } + +When using the function-oriented interface (see the next section), +errors may only occur the first time you call I. Be ready +for this! + =head2 USING THE FUNCTION-ORIENTED INTERFACE To use the function-oriented interface, you must specify which CGI.pm @@ -3754,7 +3917,7 @@ Import "standard" features, 'html2', 'html3', 'form' and 'cgi'. =item B<:all> Import all the available methods. For the full list, see the CGI.pm -code, where the variable %TAGS is defined. +code, where the variable %EXPORT_TAGS is defined. =back @@ -3765,7 +3928,7 @@ provide for the rapidly-evolving HTML "standard." For example, say Microsoft comes out with a new tag called (which causes the user's desktop to be flooded with a rotating gradient fill until his machine reboots). You don't need to wait for a new version of CGI.pm -to start using it immeidately: +to start using it immediately: use CGI qw/:standard :html3 gradient/; print gradient({-start=>'red',-end=>'blue'}); @@ -3907,15 +4070,35 @@ See the section on debugging for more details. =item -private_tempfiles -CGI.pm can process uploaded file. Ordinarily it spools the -uploaded file to a temporary directory, then deletes the file -when done. However, this opens the risk of eavesdropping as -described in the file upload section. -Another CGI script author could peek at this data during the -upload, even if it is confidential information. On Unix systems, -the -private_tempfiles pragma will cause the temporary file to be unlinked as soon -as it is opened and before any data is written into it, -eliminating the risk of eavesdropping. +CGI.pm can process uploaded file. Ordinarily it spools the uploaded +file to a temporary directory, then deletes the file when done. +However, this opens the risk of eavesdropping as described in the file +upload section. Another CGI script author could peek at this data +during the upload, even if it is confidential information. On Unix +systems, the -private_tempfiles pragma will cause the temporary file +to be unlinked as soon as it is opened and before any data is written +into it, reducing, but not eliminating the risk of eavesdropping +(there is still a potential race condition). To make life harder for +the attacker, the program chooses tempfile names by calculating a 32 +bit checksum of the incoming HTTP headers. + +To ensure that the temporary file cannot be read by other CGI scripts, +use suEXEC or a CGI wrapper program to run your script. The temporary +file is created with mode 0600 (neither world nor group readable). + +The temporary directory is selected using the following algorithm: + + 1. if the current user (e.g. "nobody") has a directory named + "tmp" in its home directory, use that (Unix systems only). + + 2. if the environment variable TMPDIR exists, use the location + indicated. + + 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp, + /tmp, /temp, ::Temporary Items, and \WWW_ROOT. + +Each of these locations is checked that it is a directory and is +writable. If not, the algorithm tries the next choice. =back @@ -4135,17 +4318,17 @@ You can place other arbitrary HTML elements to the section with the B<-head> tag. For example, to place the rarely-used element in the head section, use this: - print $q->start_html(-head=>Link({-rel=>'next', - -href=>'http://www.capricorn.com/s2.html'})); + print start_html(-head=>Link({-rel=>'next', + -href=>'http://www.capricorn.com/s2.html'})); To incorporate multiple HTML elements into the section, just pass an array reference: - print $q->start_html(-head=>[ - Link({-rel=>'next', - -href=>'http://www.capricorn.com/s2.html'}), - Link({-rel=>'previous', - -href=>'http://www.capricorn.com/s1.html'}) + print start_html(-head=>[ + Link({-rel=>'next', + -href=>'http://www.capricorn.com/s2.html'}), + Link({-rel=>'previous', + -href=>'http://www.capricorn.com/s1.html'}) ] ); @@ -4205,8 +4388,8 @@ one or more of -language, -src, or -code: ); print $q->(-title=>'The Riddle of the Sphinx', - -script=>{-language=>'PERLSCRIPT'}, - -code=>'print "hello world!\n;"' + -script=>{-language=>'PERLSCRIPT', + -code=>'print "hello world!\n;"'} ); @@ -4215,19 +4398,19 @@ header. Just pass the list of script sections as an array reference. this allows you to specify different source files for different dialects of JavaScript. Example: - print $q->start_html(-title=>'The Riddle of the Sphinx', - -script=>[ - { -language => 'JavaScript1.0', - -src => '/javascript/utilities10.js' + print $q->start_html(-title=>'The Riddle of the Sphinx', + -script=>[ + { -language => 'JavaScript1.0', + -src => '/javascript/utilities10.js' }, - { -language => 'JavaScript1.1', - -src => '/javascript/utilities11.js' + { -language => 'JavaScript1.1', + -src => '/javascript/utilities11.js' }, - { -language => 'JavaScript1.2', - -src => '/javascript/utilities12.js' + { -language => 'JavaScript1.2', + -src => '/javascript/utilities12.js' }, - { -language => 'JavaScript28.2', - -src => '/javascript/utilities219.js' + { -language => 'JavaScript28.2', + -src => '/javascript/utilities219.js' } ] ); @@ -4382,7 +4565,7 @@ This example shows how to use the HTML methods: print $q->blockquote( "Many years ago on the island of", $q->a({href=>"http://crete.org/"},"Crete"), - "there lived a minotaur named", + "there lived a Minotaur named", $q->strong("Fred."), ), $q->hr; @@ -4820,23 +5003,16 @@ field will accept (-maxlength). =back When the form is processed, you can retrieve the entered filename -by calling param(). +by calling param(): $filename = $query->param('uploaded_file'); -In Netscape Navigator 2.0, the filename that gets returned is the full -local filename on the B machine. If the remote user is -on a Unix machine, the filename will follow Unix conventions: - - /path/to/the/file - -On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions: - - C:\PATH\TO\THE\FILE.MSW - -On a Macintosh machine, the filename will follow Mac conventions: - - HD 40:Desktop Folder:Sort Through:Reminders +Different browsers will return slightly different things for the +name. Some browsers return the filename only. Others return the full +path to the file, using the path conventions of the user's machine. +Regardless, the name returned is always the name of the file on the +I machine, and is unrelated to the name of the temporary file +that CGI.pm creates during upload spooling (see below). The filename returned is also a file handle. You can read the contents of the file using standard Perl file reading calls: @@ -4852,6 +5028,25 @@ of the file using standard Perl file reading calls: print OUTFILE $buffer; } +However, there are problems with the dual nature of the upload fields. +If you C, then Perl will complain when you try to use a +string as a filehandle. You can get around this by placing the file +reading code in a block containing the C pragma. More +seriously, it is possible for the remote user to type garbage into the +upload field, in which case what you get from param() is not a +filehandle at all, but a string. + +To be safe, use the I function (new in version 2.47). When +called with the name of an upload field, I returns a +filehandle, or undef if the parameter is not a valid filehandle. + + $fh = $query->upload('uploaded_file'); + while (<$fh>) { + print; + } + +This is the recommended idiom. + When a file is uploaded the browser usually sends along some information along with it in the format of headers. The information usually includes the MIME content type. Future browsers may send @@ -4867,7 +5062,25 @@ an associative array containing all the document headers. If you are using a machine that recognizes "text" and "binary" data modes, be sure to understand when and how to use them (see the Camel book). -Otherwise you may find that binary files are corrupted during file uploads. +Otherwise you may find that binary files are corrupted during file +uploads. + +There are occasionally problems involving parsing the uploaded file. +This usually happens when the user presses "Stop" before the upload is +finished. In this case, CGI.pm will return undef for the name of the +uploaded file and set I to the string "400 Bad request +(malformed multipart POST)". This error message is designed so that +you can incorporate it into a status code to be sent to the browser. +Example: + + $file = $query->upload('uploaded_file'); + if (!$file && $query->cgi_error) { + print $query->header(-status->$query->cgi_error); + exit 0; + } + +You are free to create a custom HTML page to complain about the error, +if you wish. JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are @@ -5838,6 +6051,32 @@ Newer browsers do not report the user name for privacy reasons! Returns the method used to access your script, usually one of 'POST', 'GET' or 'HEAD'. +=item B + +Returns the content_type of data submitted in a POST, generally +multipart/form-data or application/x-www-form-urlencoded + +=item B + +Called with no arguments returns the list of HTTP environment +variables, including such things as HTTP_USER_AGENT, +HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the +like-named HTTP header fields in the request. Called with the name of +an HTTP header field, returns its value. Capitalization and the use +of hyphens versus underscores are not significant. + +For example, all three of these examples are equivalent: + + $requested_language = $q->http('Accept-language'); + $requested_language = $q->http('Accept_language'); + $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE'); + +=item B + +The same as I, but operates on the HTTPS environment variables +present when the SSL protocol is in effect. Can be used to determine +whether SSL is turned on. + =back =head1 USING NPH SCRIPTS @@ -6014,18 +6253,31 @@ initialize_globals(). =back -Since an attempt to send a POST larger than $POST_MAX bytes -will cause a fatal error, you might want to use CGI::Carp to echo the -fatal error message to the browser window as shown in the example -above. Otherwise the remote user will see only a generic "Internal -Server" error message. See the L manual page for more -details. +An attempt to send a POST larger than $POST_MAX bytes will cause +I to return an empty CGI parameter list. You can test for +this event by checking I, either after you create the CGI +object or, if you are using the function-oriented interface, call + for the first time. If the POST was intercepted, then +cgi_error() will return the message "413 POST too large". + +This error message is actually defined by the HTTP protocol, and is +designed to be returned to the browser as the CGI script's status + code. For example: + + $uploaded_file = param('upload'); + if (!$uploaded_file && cgi_error()) { + print header(-status=>cgi_error()); + exit 0; + } + +However it isn't clear that any browser currently knows what to do +with this status code. It might be better just to create an +HTML page that warns the user of the problem. =head1 COMPATIBILITY WITH CGI-LIB.PL -To make it easier to port existing programs that use cgi-lib.pl -the compatibility routine "ReadParse" is provided. Porting is -simple: +To make it easier to port existing programs that use cgi-lib.pl the +compatibility routine "ReadParse" is provided. Porting is simple: OLD VERSION require "cgi-lib.pl";
$_
$rowheaders->[$row]$rowheaders->[$row]" . $elements[$column*$rows + $row] . "