X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI.pm;h=0d5ef00548c4b90f3abdf390bf8f1bcd26796d65;hb=5108dc18037af131227ae095719eaab3a8fd54cb;hp=27ca5bbe88d6d040bf4a3d2b3655b3ccc8e7fe08;hpb=0a9bdad46b06555ba154417c5a8961c69cfa8b21;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CGI.pm b/lib/CGI.pm index 27ca5bb..0d5ef00 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -18,8 +18,8 @@ use Carp 'croak'; # The most recent version and complete docs are available at: # http://stein.cshl.org/WWW/software/CGI/ -$CGI::revision = '$Id: CGI.pm,v 1.193 2005/12/05 13:52:24 lstein Exp $'; -$CGI::VERSION='3.13_01'; +$CGI::revision = '$Id: CGI.pm,v 1.234 2007/04/16 16:58:46 lstein Exp $'; +$CGI::VERSION='3.29'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -40,6 +40,7 @@ use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', $MOD_PERL = 0; # no mod_perl by default @SAVED_SYMBOLS = (); + # >>>>> Here are some globals that you might want to adjust <<<<<< sub initialize_globals { # Set this to 1 to enable copious autoloader debugging messages @@ -118,6 +119,7 @@ sub initialize_globals { undef %EXPORT; undef $QUERY_CHARSET; undef %QUERY_FIELDNAMES; + undef %QUERY_TMPFILES; # prevent complaints by mod_perl 1; @@ -329,6 +331,10 @@ sub new { my $self = {}; bless $self,ref $class || $class || $DefaultClass; + + # always use a tempfile + $self->{'use_tempfile'} = 1; + if (ref($initializer[0]) && (UNIVERSAL::isa($initializer[0],'Apache') || @@ -339,6 +345,7 @@ sub new { if (ref($initializer[0]) && (UNIVERSAL::isa($initializer[0],'CODE'))) { $self->upload_hook(shift @initializer, shift @initializer); + $self->{'use_tempfile'} = shift @initializer if (@initializer > 0); } if ($MOD_PERL) { if ($MOD_PERL == 1) { @@ -392,9 +399,10 @@ sub upload_hook { } else { $self = shift; } - my ($hook,$data) = @_; + my ($hook,$data,$use_tempfile) = @_; $self->{'.upload_hook'} = $hook; $self->{'.upload_data'} = $data; + $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile; } #### Method: param @@ -427,7 +435,7 @@ sub param { } } # If values is provided, then we set it. - if (@values) { + if (@values or defined $value) { $self->add_parameter($name); $self->{$name}=[@values]; } @@ -436,7 +444,16 @@ sub param { } return unless defined($name) && $self->{$name}; - return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; + + my $charset = $self->charset || ''; + my $utf8 = $charset eq 'utf-8'; + if ($utf8) { + eval "require Encode; 1;" if $utf8 && !Encode->can('decode'); # bring in these functions + return wantarray ? map {Encode::decode(utf8=>$_) } @{$self->{$name}} + : Encode::decode(utf8=>$self->{$name}->[0]); + } else { + return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; + } } sub self_or_default { @@ -478,6 +495,8 @@ sub init { my $self = shift; my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + my $is_xforms; + my $initializer = shift; # for backward compatibility local($/) = "\n"; @@ -488,12 +507,20 @@ sub init { # ourselves from the original query (which may be gone # if it was read from STDIN originally.) if (defined(@QUERY_PARAM) && !defined($initializer)) { - foreach (@QUERY_PARAM) { - $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); - } - $self->charset($QUERY_CHARSET); - $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; - return; + for my $name (@QUERY_PARAM) { + my $val = $QUERY_PARAM{$name}; # always an arrayref; + $self->param('-name'=>$name,'-value'=> $val); + if (defined $val and ref $val eq 'ARRAY') { + for my $fh (grep {defined(fileno($_))} @$val) { + seek($fh,0,0); # reset the filehandle. + } + + } + } + $self->charset($QUERY_CHARSET); + $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; + $self->{'.tmpfiles'} = {%QUERY_TMPFILES}; + return; } $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); @@ -508,17 +535,10 @@ sub init { # avoid unreasonably large postings if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { - # quietly read and discard the post - my $buffer; - my $tmplength = $content_length; - while($tmplength > 0) { - my $maxbuffer = ($tmplength < 10000)?$tmplength:10000; - my $bytesread = $MOD_PERL ? $self->r->read($buffer,$maxbuffer) : read(STDIN,$buffer,$maxbuffer); - $tmplength -= $bytesread; - } - $self->cgi_error("413 Request entity too large"); - last METHOD; - } + #discard the post, unread + $self->cgi_error("413 Request entity too large"); + last METHOD; + } # Process multipart postings, but only if the initializer is # not defined. @@ -532,9 +552,50 @@ sub init { last METHOD; } + # Process XForms postings. We know that we have XForms in the + # following cases: + # method eq 'POST' && content-type eq 'application/xml' + # method eq 'POST' && content-type =~ /multipart\/related.+start=/ + # There are more cases, actually, but for now, we don't support other + # methods for XForm posts. + # In a XForm POST, the QUERY_STRING is parsed normally. + # If the content-type is 'application/xml', we just set the param + # XForms:Model (referring to the xml syntax) param containing the + # unparsed XML data. + # In the case of multipart/related we set XForms:Model as above, but + # the other parts are available as uploads with the Content-ID as the + # the key. + # See the URL below for XForms specs on this issue. + # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options + if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) { + if ($ENV{'CONTENT_TYPE'} eq 'application/xml') { + my($param) = 'XForms:Model'; + my($value) = ''; + $self->add_parameter($param); + $self->read_from_client(\$value,$content_length,0) + if $content_length > 0; + push (@{$self->{$param}},$value); + $is_xforms = 1; + } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\]+)\>?\"?/) { + my($boundary,$start) = ($1,$2); + my($param) = 'XForms:Model'; + $self->add_parameter($param); + my($value) = $self->read_multipart_related($start,$boundary,$content_length,0); + push (@{$self->{$param}},$value); + if ($MOD_PERL) { + $query_string = $self->r->args; + } else { + $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'}; + } + $is_xforms = 1; + } + } + + # If initializer is defined, then read parameters # from it. - if (defined($initializer)) { + if (!$is_xforms && defined($initializer)) { if (UNIVERSAL::isa($initializer,'CGI')) { $query_string = $initializer->query_string; last METHOD; @@ -545,21 +606,6 @@ sub init { } last METHOD; } - - if (defined($fh) && ($fh ne '')) { - while (<$fh>) { - chomp; - last if /^=/; - push(@lines,$_); - } - # massage back into standard format - if ("@lines" =~ /=/) { - $query_string=join("&",@lines); - } else { - $query_string=join("+",@lines); - } - last METHOD; - } if (defined($fh) && ($fh ne '')) { while (<$fh>) { @@ -585,7 +631,7 @@ sub init { # If method is GET or HEAD, fetch the query from # the environment. - if ($meth=~/^(GET|HEAD)$/) { + if ($is_xforms || $meth=~/^(GET|HEAD)$/) { if ($MOD_PERL) { $query_string = $self->r->args; } else { @@ -621,7 +667,7 @@ sub init { } # YL: Begin Change for XML handler 10/19/2001 - if ($meth eq 'POST' + if (!$is_xforms && $meth eq 'POST' && defined($ENV{'CONTENT_TYPE'}) && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { @@ -710,6 +756,7 @@ sub save_request { } $QUERY_CHARSET = $self->charset; %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; + %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; } sub parse_params { @@ -1418,11 +1465,15 @@ sub header { 'ATTACHMENT','P3P'],@p); $nph ||= $NPH; + + $type ||= 'text/html' unless defined($type); + if (defined $charset) { $self->charset($charset); } else { - $charset = $self->charset; + $charset = $self->charset if $type =~ /^text\//; } + $charset ||= ''; # rearrange() was designed for the HTML portion, so we # need to fix it up a little. @@ -1432,8 +1483,11 @@ sub header { ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; } - $type ||= 'text/html' unless defined($type); - $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne ''; + $type .= "; charset=$charset" + if $type ne '' + and $type !~ /\bcharset\b/ + and defined $charset + and $charset ne ''; # Maybe future compatibility. Maybe not. my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; @@ -1499,7 +1553,7 @@ sub redirect { my($self,@p) = self_or_default(@_); my($url,$target,$status,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p); - $status = '302 Moved' unless defined $status; + $status = '302 Found' unless defined $status; $url ||= $self->self_url; my(@o); foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } @@ -1546,7 +1600,7 @@ sub start_html { $self->element_id(0); $self->element_tab(0); - $encoding = 'iso-8859-1' unless defined $encoding; + $encoding = lc($self->charset) unless defined $encoding; # Need to sort out the DTD before it's okay to call escapeHTML(). my(@result,$xml_dtd); @@ -1636,7 +1690,10 @@ END_OF_FUNC sub _style { my ($self,$style) = @_; my (@result); + my $type = 'text/css'; + my $rel = 'stylesheet'; + my $cdata_start = $XHTML ? "\n\n" : " -->\n"; @@ -1645,25 +1702,26 @@ sub _style { for my $s (@s) { if (ref($s)) { - my($src,$code,$verbatim,$stype,$foo,@other) = - rearrange([qw(SRC CODE VERBATIM TYPE FOO)], + my($src,$code,$verbatim,$stype,$alternate,$foo,@other) = + rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], ('-foo'=>'bar', ref($s) eq 'ARRAY' ? @$s : %$s)); - $type = $stype if $stype; + my $type = defined $stype ? $stype : 'text/css'; + my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; my $other = @other ? join ' ',@other : ''; if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference { # If it is, push a LINK tag for each one foreach $src (@$src) { - push(@result,$XHTML ? qq() - : qq()) if $src; + push(@result,$XHTML ? qq() + : qq()) if $src; } } else { # Otherwise, push the single -src, if it exists. - push(@result,$XHTML ? qq() - : qq() + push(@result,$XHTML ? qq() + : qq() ) if $src; } if ($verbatim) { @@ -1675,8 +1733,8 @@ sub _style { } else { my $src = $s; - push(@result,$XHTML ? qq() - : qq()); + push(@result,$XHTML ? qq() + : qq()); } } @result; @@ -1692,19 +1750,17 @@ sub _script { foreach $script (@scripts) { my($src,$code,$language); if (ref($script)) { # script is a hash - ($src,$code,$language, $type) = - rearrange([SRC,CODE,LANGUAGE,TYPE], + ($src,$code,$type) = + rearrange(['SRC','CODE',['LANGUAGE','TYPE']], '-foo'=>'bar', # a trick to allow the '-' to be omitted ref($script) eq 'ARRAY' ? @$script : %$script); - # User may not have specified language - $language ||= 'JavaScript'; - unless (defined $type) { - $type = lc $language; - # strip '1.2' from 'javascript1.2' - $type =~ s/^(\D+).*$/text\/$1/; + $type ||= 'text/javascript'; + unless ($type =~ m!\w+/\w+!) { + $type =~ s/[\d.]+$//; + $type = "text/$type"; } } else { - ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript'); + ($src,$code,$type) = ('',$script, 'text/javascript'); } my $comment = '//'; # javascript by default @@ -1722,7 +1778,6 @@ sub _script { } my(@satts); push(@satts,'src'=>$src) if $src; - push(@satts,'language'=>$language) unless defined $type; push(@satts,'type'=>$type); $code = $cdata_start . $code . $cdata_end if defined $code; push(@result,$self->script({@satts},$code || '')); @@ -1782,7 +1837,7 @@ sub startform { $action = $self->escapeHTML($action); } else { - $action = $self->escapeHTML($self->request_uri); + $action = $self->escapeHTML($self->request_uri || $self->self_url); } $action = qq(action="$action"); my($other) = @other ? " @other" : ''; @@ -1812,9 +1867,7 @@ END_OF_FUNC sub start_multipart_form { my($self,@p) = self_or_default(@_); if (defined($p[0]) && substr($p[0],0,1) eq '-') { - my(%p) = @p; - $p{'-enctype'}=&MULTIPART; - return $self->startform(%p); + return $self->startform(-enctype=>&MULTIPART,@p); } else { my($method,$action,@other) = rearrange([METHOD,ACTION],@p); @@ -2276,15 +2329,14 @@ sub _box_group { my($name,$values,$defaults,$linebreak,$labels,$attributes, $rows,$columns,$rowheaders,$colheaders, - $override,$nolabels,$tabindex,@other) = + $override,$nolabels,$tabindex,$disabled,@other) = rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES, - ROWS,[COLUMNS,COLS],ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS,TABINDEX + ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], + [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED ],@_); - my($result,$checked); + my($result,$checked,@elements,@values); - my(@elements,@values); @values = $self->_set_values_and_labels($values,\$labels,$name); my %checked = $self->previous_or_default($name,$defaults,$override); @@ -2304,10 +2356,21 @@ sub _box_group { } } %tabs = map {$_=>$self->element_tab} @values unless %tabs; - my $other = @other ? "@other " : ''; my $radio_checked; + + # for disabling groups of radio/checkbox buttons + my %disabled; + foreach (@{$disabled}) { + $disabled{$_}=1; + } + foreach (@values) { + my $disable=""; + if ($disabled{$_}) { + $disable="disabled='1'"; + } + my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) : $checked{$_}); my($break); @@ -2322,16 +2385,18 @@ sub _box_group { $label = $_; $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); $label = $self->escapeHTML($label,1); + $label = "$label" if $disabled{$_}; } my $attribs = $self->_set_attributes($_, $attributes); my $tab = $tabs{$_}; $_=$self->escapeHTML($_); + if ($XHTML) { push @elements, CGI::label( - qq($label)).${break}; + qq($label)).${break}; } else { - push(@elements,qq/${label}${break}/); + push(@elements,qq/${label}${break}/); } } $self->register_parameter($name); @@ -2386,13 +2451,13 @@ sub popup_menu { } } else { - my $attribs = $self->_set_attributes($_, $attributes); - my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : ''; - my($label) = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - my($value) = $self->escapeHTML($_); - $label=$self->escapeHTML($label,1); - $result .= "\n"; + my $attribs = $self->_set_attributes($_, $attributes); + my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : ''; + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + my($value) = $self->escapeHTML($_); + $label=$self->escapeHTML($label,1); + $result .= "$label\n"; } } @@ -2509,7 +2574,7 @@ sub scrolling_list { $label=$self->escapeHTML($label); my($value)=$self->escapeHTML($_,1); my $attribs = $self->_set_attributes($_, $attributes); - $result .= "$label\n"; + $result .= "\n"; } $result .= ""; $self->register_parameter($name); @@ -2577,7 +2642,7 @@ sub image_button { my($name,$src,$alignment,@other) = rearrange([NAME,SRC,ALIGN],@p); - my($align) = $alignment ? " align=\U\"$alignment\"" : ''; + my($align) = $alignment ? " align=\L\"$alignment\"" : ''; my($other) = @other ? " @other" : ''; $name=$self->escapeHTML($name); return $XHTML ? qq() @@ -2624,33 +2689,34 @@ sub url { my $path = $self->path_info; my $script_name = $self->script_name; - my $request_uri = $self->request_uri || ''; + my $request_uri = unescape($self->request_uri) || ''; my $query_str = $self->query_string; my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/; undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active my $uri = $rewrite && $request_uri ? $request_uri : $script_name; - $uri =~ s/\?.+$// if defined $query_str; - $uri =~ s/$path$// if defined $path; # remove path from URI + $uri =~ s/\?.*$//; # remove query string + $uri =~ s/\Q$path\E$// if defined $path; # remove path if ($full) { my $protocol = $self->protocol(); $url = "$protocol://"; - my $vh = http('x_forwarded_host') || http('host'); + my $vh = http('x_forwarded_host') || http('host') || ''; + $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. if ($vh) { $url .= $vh; } else { $url .= server_name(); - my $port = $self->server_port; - $url .= ":" . $port - unless (lc($protocol) eq 'http' && $port == 80) - || (lc($protocol) eq 'https' && $port == 443); } + my $port = $self->server_port; + $url .= ":" . $port + unless (lc($protocol) eq 'http' && $port == 80) + || (lc($protocol) eq 'https' && $port == 443); return $url if $base; $url .= $uri; } elsif ($relative) { - ($url) = $script_name =~ m!([^/]+)$!; + ($url) = $uri =~ m!([^/]+)$!; } elsif ($absolute) { $url = $uri; } @@ -2678,8 +2744,8 @@ END_OF_FUNC 'cookie' => <<'END_OF_FUNC', sub cookie { my($self,@p) = self_or_default(@_); - my($name,$value,$path,$domain,$secure,$expires) = - rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); + my($name,$value,$path,$domain,$secure,$expires,$httponly) = + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p); require CGI::Cookie; @@ -2707,6 +2773,7 @@ sub cookie { push(@param,'-path'=>$path) if $path; push(@param,'-expires'=>$expires) if $expires; push(@param,'-secure'=>$secure) if $secure; + push(@param,'-httponly'=>$httponly) if $httponly; return new CGI::Cookie(@param); } @@ -2752,9 +2819,6 @@ sub path_info { } elsif (! defined($self->{'.path_info'}) ) { my (undef,$path_info) = $self->_name_and_path_from_env; $self->{'.path_info'} = $path_info || ''; - # hack to fix broken path info in IIS - $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS; - } return $self->{'.path_info'}; } @@ -2766,11 +2830,10 @@ sub _name_and_path_from_env { my $self = shift; my $raw_script_name = $ENV{SCRIPT_NAME} || ''; my $raw_path_info = $ENV{PATH_INFO} || ''; - my $uri = $ENV{REQUEST_URI} || ''; + my $uri = unescape($self->request_uri) || ''; - if ($raw_script_name =~ m/$raw_path_info$/) { - $raw_script_name =~ s/$raw_path_info$//; - } + my $protected = quotemeta($raw_path_info); + $raw_script_name =~ s/$protected$//; my @uri_double_slashes = $uri =~ m^(/{2,}?)^g; my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g; @@ -2778,10 +2841,7 @@ sub _name_and_path_from_env { my $apache_bug = @uri_double_slashes != @path_double_slashes; return ($raw_script_name,$raw_path_info) unless $apache_bug; - my $path_info_search = $raw_path_info; - # these characters will not (necessarily) be escaped - $path_info_search =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg; - $path_info_search = quotemeta($path_info_search); + my $path_info_search = quotemeta($raw_path_info); $path_info_search =~ s!/!/+!g; if ($uri =~ m/^(.+)($path_info_search)/) { return ($1,$2); @@ -2988,7 +3048,7 @@ END_OF_FUNC sub script_name { my ($self,@p) = self_or_default(@_); if (@p) { - $self->{'.script_name'} = shift; + $self->{'.script_name'} = shift @p; } elsif (!exists $self->{'.script_name'}) { my ($script_name,$path_info) = $self->_name_and_path_from_env(); $self->{'.script_name'} = $script_name; @@ -3308,11 +3368,11 @@ sub read_multipart { return; } - my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/; + my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/; $param .= $TAINTED; # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/; + my($filename) = $header{'Content-Disposition'}=~/ filename="([^"]*)"/; # Test for Opera's multiple upload feature my($multipart) = ( defined( $header{'Content-Type'} ) && $header{'Content-Type'} =~ /multipart\/mixed/ ) ? @@ -3378,7 +3438,109 @@ sub read_multipart { $totalbytes += length($data); &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); } - print $filehandle $data; + print $filehandle $data if ($self->{'use_tempfile'}); + } + + # back up to beginning of file + seek($filehandle,0,0); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle}= { + hndl => $filehandle, + name => $tmpfile, + info => {%header}, + }; + push(@{$self->{$param}},$filehandle); + } + } +} +END_OF_FUNC + +##### +# subroutine: read_multipart_related +# +# Read multipart/related data and store it into our parameters. The +# first parameter sets the start of the data. The part identified by +# this Content-ID will not be stored as a file upload, but will be +# returned by this method. All other parts will be available as file +# uploads accessible by their Content-ID +##### +'read_multipart_related' => <<'END_OF_FUNC', +sub read_multipart_related { + my($self,$start,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + my $filenumber = 0; + my $returnvalue; + while (!$buffer->eof) { + %header = $buffer->readHeader; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/; + $param .= $TAINTED; + + # If this is the start part, then just read the data and assign it + # to our return variable. + if ( $param eq $start ) { + $returnvalue = $buffer->readBody; + $returnvalue .= $TAINTED; + next; + } + + # add this parameter to our list + $self->add_parameter($param); + + my ($tmpfile,$tmp,$filehandle); + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } + + # choose a relatively unpredictable tmpfile sequence number + my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV)); + for (my $cnt=10;$cnt>0;$cnt--) { + next unless $tmpfile = new CGITempFile($seqno); + $tmp = $tmpfile->as_string; + last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES)); + $seqno += int rand(100); + } + die "CGI open of tmpfile: $!\n" unless defined $filehandle; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); + + my ($data); + local($\) = ''; + my $totalbytes; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'}); + } + print $filehandle $data if ($self->{'use_tempfile'}); } # back up to beginning of file @@ -3405,13 +3567,15 @@ sub read_multipart { push(@{$self->{$param}},$filehandle); } } + return $returnvalue; } END_OF_FUNC + 'upload' =><<'END_OF_FUNC', sub upload { my($self,$param_name) = self_or_default(@_); - my @param = grep(ref && fileno($_), $self->param($param_name)); + my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name); return unless @param; return wantarray ? @param : $param[0]; } @@ -4129,7 +4293,10 @@ HTML "standards". $query = new CGI; This will parse the input (from both POST and GET methods) and store -it into a perl5 object called $query. +it into a perl5 object called $query. + +Any filehandles from file uploads will have their position reset to +the beginning of the file. =head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE @@ -4590,7 +4757,7 @@ all. This causes the indicated autoloaded methods to be compiled up front, rather than deferred to later. This is useful for scripts that run for an extended period of time under FastCGI or mod_perl, and for -those destined to be crunched by Malcom Beattie's Perl compiler. Use +those destined to be crunched by Malcolm Beattie's Perl compiler. Use it in conjunction with the methods or method families you plan to use. use CGI qw(-compile :standard :html3); @@ -5063,20 +5230,20 @@ Use the B<-noScript> parameter to pass some HTML text that will be displayed on browsers that do not have JavaScript (or browsers where JavaScript is turned off). -Netscape 3.0 recognizes several attributes of the