From: Gurusamy Sarathy Date: Mon, 28 Jun 1999 18:22:26 +0000 (+0000) Subject: upgrade CGI.pm to v2.53 (CGI/{Apache,Switch}.pm NOT deleted) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3538e1d594b84483ebd9da2f46446c3f5afac4b5;p=p5sagit%2Fp5-mst-13.2.git upgrade CGI.pm to v2.53 (CGI/{Apache,Switch}.pm NOT deleted) p4raw-id: //depot/perl@3559 --- diff --git a/eg/cgi/file_upload.cgi b/eg/cgi/file_upload.cgi index 38f8547..3037de7 100644 --- a/eg/cgi/file_upload.cgi +++ b/eg/cgi/file_upload.cgi @@ -12,7 +12,7 @@ print strong("Version "),$CGI::VERSION,p; print h1("File Upload Example"), 'This example demonstrates how to prompt the remote user to select a remote file for uploading. ', - strong("This feature only works with Netscape 2.0 browsers."), + strong("This feature only works with Netscape 2.0 or greater, or IE 4.0 or greater."), p, 'Select the ',cite('browser'),' button to choose a text file to upload. When you press the submit button, this script diff --git a/lib/CGI.pm b/lib/CGI.pm index f5615f2..b131926 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/], @@ -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}::${_}"; @@ -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'}; @@ -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 @@ -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"; diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm index dfae1a6..8425fa0 100644 --- a/lib/CGI/Carp.pm +++ b/lib/CGI/Carp.pm @@ -192,9 +192,16 @@ use Carp; @EXPORT = qw(confess croak carp); @EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck); +BEGIN { + $] >= 5.005 + ? eval q#sub ineval { $^S }# + : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#; + $@ and die; +} + $main::SIG{__WARN__}=\&CGI::Carp::warn; $main::SIG{__DIE__}=\&CGI::Carp::die; -$CGI::Carp::VERSION = '1.13'; +$CGI::Carp::VERSION = '1.14'; $CGI::Carp::CUSTOM_MSG = undef; # fancy import routine detects and handles 'errorWrap' specially. @@ -251,14 +258,15 @@ sub _longmess { } sub die { - my $message = shift; - my $time = scalar(localtime); - my($file,$line,$id) = id(1); - $message .= " at $file line $line." unless $message=~/\n$/; - &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m; - my $stamp = stamp; - $message=~s/^/$stamp/gm; - realdie $message; + realdie @_ if ineval; + my $message = shift; + my $time = scalar(localtime); + my($file,$line,$id) = id(1); + $message .= " at $file line $line." unless $message=~/\n$/; + &fatalsToBrowser($message) if $WRAP; + my $stamp = stamp; + $message=~s/^/$stamp/gm; + realdie $message; } sub set_message { diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm index 204d67b..433df49 100644 --- a/lib/CGI/Cookie.pm +++ b/lib/CGI/Cookie.pm @@ -7,17 +7,13 @@ package CGI::Cookie; # documentation in manual or html file format (these utilities are part of the # Perl 5 distribution). -# Copyright 1995,1996, Lincoln D. Stein. All rights reserved. +# Copyright 1995-1999, Lincoln D. Stein. All rights reserved. # It may be used and modified freely, but I do request that this copyright # notice remain attached to the file. You may modify this module as you # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. -# The most recent version and complete docs are available at: -# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html -# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ - -$CGI::Cookie::VERSION='1.06'; +$CGI::Cookie::VERSION='1.10'; use CGI; use overload '""' => \&as_string, @@ -100,8 +96,9 @@ sub new { 'value'=>[@values], },$class; - # IE requires the path to be present for some reason. - ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path; + # IE requires the path and domain to be present for some reason. + $path ||= CGI::url(-absolute=>1); + $domain ||= CGI::virtual_host(); $self->path($path) if defined $path; $self->domain($domain) if defined $domain; @@ -251,10 +248,10 @@ cookie originated from. If you provide a cookie path attribute, the browser will check it against your script's URL before returning the cookie. For example, if you specify the path "/cgi-bin", then the cookie will be returned -to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", -and "/cgi-bin/customer_service/complain.pl", but not to the script -"/cgi-private/site_admin.pl". By default, path is set to "/", which -causes the cookie to be sent to any CGI script on your site. +to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and +"/cgi-bin/customer_service/complain.pl", but not to the script +"/cgi-private/site_admin.pl". By default, the path is set to the +directory that contains your script. =item B<4. secure flag> diff --git a/lib/CGI/Fast.pm b/lib/CGI/Fast.pm index a39fe05..968bb1f 100644 --- a/lib/CGI/Fast.pm +++ b/lib/CGI/Fast.pm @@ -16,7 +16,7 @@ package CGI::Fast; # The most recent version and complete docs are available at: # http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html # ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ -$CGI::Fast::VERSION='1.01'; +$CGI::Fast::VERSION='1.02'; use CGI; use FCGI; diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm new file mode 100644 index 0000000..f8931fb --- /dev/null +++ b/lib/CGI/Pretty.pm @@ -0,0 +1,175 @@ +package CGI::Pretty; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +# You can run this file through either pod2man or pod2html to produce pretty +# documentation in manual or html file format (these utilities are part of the +# Perl 5 distribution). + +use CGI (); + +$VERSION = '1.0'; +$CGI::DefaultClass = __PACKAGE__; +$AutoloadClass = 'CGI'; +@ISA = 'CGI'; + +# These tags should not be prettify'd. If we did prettify them, the +# browser would output text that would have extraneous spaces +@AS_IS = qw( A PRE ); +my $NON_PRETTIFY_ENDTAGS = join "", map { "" } @AS_IS; + +sub _make_tag_func { + my ($self,$tagname) = @_; + return $self->SUPER::_make_tag_func($tagname) if $tagname=~/^(start|end)_/; + + return qq{ + sub $tagname { + # handle various cases in which we're called + # most of this bizarre stuff is to avoid -w errors + shift if \$_[0] && +# (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) || + (ref(\$_[0]) && + (substr(ref(\$_[0]),0,3) eq 'CGI' || + UNIVERSAL::isa(\$_[0],'CGI'))); + + my(\$attr) = ''; + if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') { + my(\@attr) = make_attributes('',shift); + \$attr = " \@attr" if \@attr; + } + + my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E"); + return \$tag unless \@_; + + my \@result; + if ( "$NON_PRETTIFY_ENDTAGS" =~ /\$untag/ ) { + \@result = map { "\$tag\$_\$untag\\n" } + (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + } + else { + \@result = map { + chomp; + if ( \$_ !~ /<\\// ) { + s/\\n/\\n /g; + } + else { + my \$text = ""; + my ( \$pretag, \$thistag, \$posttag ); + while ( /<\\/.*>/si ) { + if ( (\$pretag, \$thistag, \$posttag ) = + /(.*?)<(.*?)>(.*)/si ) { + \$pretag =~ s/\\n/\\n /g; + \$text .= "\$pretag<\$thistag>"; + + ( \$thistag ) = split ' ', \$thistag; + my \$endtag = ""; + if ( "$NON_PRETTIFY_ENDTAGS" =~ /\$endtag/ ) { + if ( ( \$pretag, \$posttag ) = + \$posttag =~ /(.*?)\$endtag(.*)/si ) { + \$text .= "\$pretag\$endtag"; + } + } + + \$_ = \$posttag; + } + } + \$_ = \$text; + if ( defined \$posttag ) { + \$posttag =~ s/\\n/\\n /g; + \$_ .= \$posttag; + } + } + "\$tag\\n \$_\\n\$untag\\n" } + (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_"; + } + return "\@result"; + } + }; +} + +sub new { + my $class = shift; + my $this = $class->SUPER::new( @_ ); + + return bless $this, $class; +} + +1; + +=head1 NAME + +CGI::Pretty - module to produce nicely formatted HTML code + +=head1 SYNOPSIS + + use CGI::Pretty qw( :html3 ); + + # Print a table with a single data element + print table( TR( td( "foo" ) ) ); + +=head1 DESCRIPTION + +CGI::Pretty is a module that derives from CGI. It's sole function is to +allow users of CGI to output nicely formatted HTML code. + +When using the CGI module, the following code: + print table( TR( td( "foo" ) ) ); + +produces the following output: +
foo
+ +If a user were to create a table consisting of many rows and many columns, +the resultant HTML code would be quite difficult to read since it has no +carriage returns or indentation. + +CGI::Pretty fixes this problem. What it does is add a carriage +return and indentation to the HTML code so that one can easily read +it. + + print table( TR( td( "foo" ) ) ); + +now produces the following output: + + + + +
+ foo +
+ + +=head2 Tags that won't be formatted + +The and
 tags are not formatted.  If these tags were formatted, the
+user would see the extra indentation on the web browser causing the page to
+look different than what would be expected.  If you wish to add more tags to
+the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
+
+    push @CGI::Pretty::AS_IS,qw(CODE XMP);
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 AUTHOR
+
+Brian Paulsen , with minor modifications by
+Lincoln Stein  for incorporation into the CGI.pm
+distribution.
+
+Copyright 1998, Brian Paulsen.  All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Bug reports and comments to bpaulsen@lehman.com.  You can also write
+to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
+sure I understand it!
+
+=head1 SEE ALSO
+
+L
+
+=cut
+
diff --git a/t/lib/cgi-form.t b/t/lib/cgi-form.t
index 83217a2..e3cba5f 100755
--- a/t/lib/cgi-form.t
+++ b/t/lib/cgi-form.t
@@ -44,16 +44,16 @@ test(6,textfield(-name=>'weather') eq qq('weather',-value=>'nice') eq qq(),"textfield({-name,-value})");
 test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(),
      "textfield({-name,-value,-override})");
-test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(weather\n),
+test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(weather),
      "checkbox()");
 test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq 
-     qq(forecast\n),
+     qq(forecast),
      "checkbox()");
 test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq 
-     qq(forecast\n),
+     qq(forecast),
      "checkbox()");
 test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq 
-     qq(forecast\n),
+     qq(forecast),
      "checkbox()");
 
 test(13,radio_group(-name=>'game') eq 
diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t
index 3fe41d1..d4c9c1b 100755
--- a/t/lib/cgi-html.t
+++ b/t/lib/cgi-html.t
@@ -10,9 +10,6 @@ BEGIN {
 }
 
 BEGIN {$| = 1; print "1..20\n"; }
-BEGIN {$eol = "\n"   if $^O eq 'VMS';
-       $eol = "\r\n" if $Config{ebcdic} eq 'define';
-       $eol = "\cM\cJ" unless defined $eol; }
 END {print "not ok 1\n" unless $loaded;}
 use CGI (':standard','-no_debug','*h3','start_table');
 $loaded = 1;
@@ -40,10 +37,10 @@ test(7,h1({-align=>'CENTER'},['fred','agnes']) eq
     local($") = '-'; 
     test(8,h1('fred','agnes','maura') eq '

fred-agnes-maura

',"open/close tag \$\" interpolation"); } -test(9,header() eq "Content-Type: text/html${eol}${eol}","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${eol}${eol}","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${eol}Content-Type: image/gif${eol}${eol}","header()"); -test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${eol}Content-Type: text/html${eol}${eol}","header()"); +test(9,header() eq "Content-Type: text/html\015\012\015\012","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif\015\012\015\012","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks\015\012Content-Type: image/gif\015\012\015\012","header()"); +test(12,header(-nph=>1) eq "HTTP/1.0 200 OK\015\012Content-Type: text/html\015\012\015\012","header()"); test(13,start_html() ."\n" eq < Untitled Document @@ -63,8 +60,8 @@ test(15,start_html(-Title=>'The world of foo') ."\n" eq <'fred',-value=>['chocolate','chip'],-path=>'/')) eq - 'fred=chocolate&chip; path=/',"cookie()"); -test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${eol}Date:.*${eol}Content-Type: text/html${eol}${eol}!s, + 'fred=chocolate&chip; domain=localhost; path=/',"cookie()"); +test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; domain=localhost; path=/\015\012Date:.*\015\012Content-Type: text/html\015\012\015\012!s, "header(-cookie)"); test(18,start_h3 eq '

'); test(19,end_h3 eq '

'); diff --git a/t/lib/cgi-request.t b/t/lib/cgi-request.t index 2a6f3fb..9e8cdc2 100755 --- a/t/lib/cgi-request.t +++ b/t/lib/cgi-request.t @@ -25,15 +25,16 @@ sub test { } # Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} ='/somewhere/else'; -$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; $ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -$ENV{HTTP_LOVE} = 'true'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; +$ENV{HTTP_LOVE} = 'true'; $q = new CGI; test(2,$q,"CGI::new()");