diff -up perl-5.10.0/lib/CGI/Apache.pm.eee perl-5.10.0/lib/CGI/Apache.pm diff -up perl-5.10.0/lib/CGI/Carp.pm.eee perl-5.10.0/lib/CGI/Carp.pm --- perl-5.10.0/lib/CGI/Carp.pm.eee 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Carp.pm 2008-03-27 15:23:36.000000000 +0100 @@ -323,7 +323,7 @@ use File::Spec; $main::SIG{__WARN__}=\&CGI::Carp::warn; -$CGI::Carp::VERSION = '1.29'; +$CGI::Carp::VERSION = '1.30_01'; $CGI::Carp::CUSTOM_MSG = undef; $CGI::Carp::DIE_HANDLER = undef; @@ -575,6 +575,7 @@ END print STDOUT $mess; } else { + print STDOUT "Status: 500\n"; print STDOUT "Content-type: text/html\n\n"; print STDOUT $mess; } diff -up perl-5.10.0/lib/CGI/Changes.eee perl-5.10.0/lib/CGI/Changes --- perl-5.10.0/lib/CGI/Changes.eee 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Changes 2008-04-23 15:08:05.000000000 +0200 @@ -1,3 +1,35 @@ + Version 3.37 + 1. Fix pragmas so that they persist over modperl invocations (e.g. RT 34761) + 2. Fixed handling of chunked multipart uploads; thanks to Michael Bernhardt + who reported and fixed the problem. + + Version 3.36 + 1. Fix CGI::Cookie to support cookies that are separated by "," instead of ";". + + Version 3.35 + 1. Resync with bleadperl, primarily fixing a bug in parsing semicolons in uploaded filenames. + + Version 3.34 + 1. Handle Unicode %uXXXX escapes properly -- patch from DANKOGAI@cpan.org + 2. Fix url() method to not choke on path names that contain regex characters. + + Version 3.33 + 1. Remove uninit variable warning when calling url(-relative=>1) + 2. Fix uninit variable warnings for two lc calls + 3. Fixed failure of tempfile upload due to sprintf() taint failure in perl 5.10 + + Version 3.32 + 1. Patch from Miguel Santinho to prevent sending premature headers under mod_perl 2.0 + + Version 3.31 + 1. Patch from Xavier Robin so that CGI::Carp issues a 500 Status code rather than a 200 status code. + 2. Patch from Alexander Klink to select correct temporary directory in OSX Leopard so that upload works. + 3. Possibly fixed "wrapped pack" error on 5.10 and higher. + + Version 3.30 + 1. Patch from Mike Barry to handle POSTDATA in the same way as PUT. + 2. Patch from Rafael Garcia-Suarez to correctly reencode unicode values as byte values. + Version 3.29 1. The position of file handles is now reset to zero when CGI->new is called. (Mark Stosberg) diff -up perl-5.10.0/lib/CGI/Cookie.pm.eee perl-5.10.0/lib/CGI/Cookie.pm --- perl-5.10.0/lib/CGI/Cookie.pm.eee 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Cookie.pm 2008-03-28 18:15:51.000000000 +0100 @@ -13,7 +13,7 @@ package CGI::Cookie; # wish, but if you redistribute a modified version, please attach a note # listing the modifications you have made. -$CGI::Cookie::VERSION='1.28'; +$CGI::Cookie::VERSION='1.29'; use CGI::Util qw(rearrange unescape escape); use CGI; @@ -51,7 +51,7 @@ sub fetch { my %results; my($key,$value); - my(@pairs) = split("[;,] ?",$raw_cookie); + my @pairs = split("[;,] ?",$raw_cookie); foreach (@pairs) { s/\s*(.*?)\s*/$1/; if (/^([^=]+)=(.*)/) { @@ -88,7 +88,7 @@ sub parse { my ($self,$raw_cookie) = @_; my %results; - my(@pairs) = split("; ?",$raw_cookie); + my @pairs = split("[;,] ?",$raw_cookie); foreach (@pairs) { s/\s*(.*?)\s*/$1/; my($key,$value) = split("=",$_,2); diff -up perl-5.10.0/lib/CGI/Fast.pm.eee perl-5.10.0/lib/CGI/Fast.pm --- perl-5.10.0/lib/CGI/Fast.pm.eee 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Fast.pm 2008-04-14 19:53:12.000000000 +0200 @@ -55,6 +55,7 @@ sub new { } } CGI->_reset_globals; + $self->_setup_symbols(@SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS; return $CGI::Q = $self->SUPER::new($initializer, @param); } diff -up perl-5.10.0/lib/CGI.pm.eee perl-5.10.0/lib/CGI.pm --- perl-5.10.0/lib/CGI.pm.eee 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI.pm 2008-04-23 15:08:23.000000000 +0200 @@ -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.234 2007/04/16 16:58:46 lstein Exp $'; -$CGI::VERSION='3.29'; +$CGI::revision = '$Id: CGI.pm,v 1.251 2008/04/23 13:08:23 lstein Exp $'; +$CGI::VERSION='3.37'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. @@ -37,7 +37,12 @@ use constant XHTML_DTD => ['-//W3C//DTD $TAINTED = substr("$0$^X",0,0); } -$MOD_PERL = 0; # no mod_perl by default +$MOD_PERL = 0; # no mod_perl by default + +#global settings +$POST_MAX = -1; # no limit to uploaded files +$DISABLE_UPLOADS = 0; + @SAVED_SYMBOLS = (); @@ -91,13 +96,6 @@ sub initialize_globals { # it can just be renamed, instead of read and written. $CLOSE_UPLOAD_FILES = 0; - # Set this to a positive value to limit the size of a POSTing - # to a certain number of bytes: - $POST_MAX = -1; - - # Change this to 1 to disable uploads entirely: - $DISABLE_UPLOADS = 0; - # Automatically determined -- don't change $EBCDIC = 0; @@ -111,6 +109,9 @@ sub initialize_globals { # use CGI qw(-no_undef_params); $NO_UNDEF_PARAMS = 0; + # return everything as utf-8 + $PARAM_UTF8 = 0; + # Other globals that you shouldn't worry about. undef $Q; $BEEN_THERE = 0; @@ -352,6 +353,7 @@ sub new { $self->r(Apache->request) unless $self->r; my $r = $self->r; $r->register_cleanup(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; } else { # XXX: once we have the new API @@ -360,6 +362,7 @@ sub new { my $r = $self->r; $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; $r->pool->cleanup_register(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; } undef $NPH; } @@ -445,15 +448,14 @@ sub param { return unless defined($name) && $self->{$name}; - 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]; + my @result = @{$self->{$name}}; + + if ($PARAM_UTF8) { + eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions + @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result; } + + return wantarray ? @result : $result[0]; } sub self_or_default { @@ -641,7 +643,7 @@ sub init { last METHOD; } - if ($meth eq 'POST') { + if ($meth eq 'POST' || $meth eq 'PUT') { $self->read_from_client(\$query_string,$content_length,0) if $content_length > 0; # Some people want to have their cake and eat it too! @@ -667,11 +669,11 @@ sub init { } # YL: Begin Change for XML handler 10/19/2001 - if (!$is_xforms && $meth eq 'POST' + if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') && defined($ENV{'CONTENT_TYPE'}) && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { - my($param) = 'POSTDATA' ; + my($param) = $meth . 'DATA' ; $self->add_parameter($param) ; push (@{$self->{$param}},$query_string); undef $query_string ; @@ -904,6 +906,7 @@ sub _setup_symbols { $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; $DEBUG=2, next if /^[:-][Dd]ebug$/; $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PARAM_UTF8++, next if /^[:-]utf8$/; $XHTML++, next if /^[:-]xhtml$/; $XHTML=0, next if /^[:-]no_?xhtml$/; $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; @@ -1519,7 +1522,7 @@ sub header { push(@header,map {ucfirst $_} @other); push(@header,"Content-Type: $type") if $type ne ''; my $header = join($CRLF,@header)."${CRLF}${CRLF}"; - if ($MOD_PERL and not $nph) { + if (($MOD_PERL >= 1) && !$nph) { $self->r->send_cgi_header($header); return ''; } @@ -1699,6 +1702,7 @@ sub _style { my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n"; my @s = ref($style) eq 'ARRAY' ? @$style : $style; + my $other = ''; for my $s (@s) { if (ref($s)) { @@ -1708,7 +1712,7 @@ sub _style { ref($s) eq 'ARRAY' ? @$s : %$s)); my $type = defined $stype ? $stype : 'text/css'; my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; - my $other = @other ? join ' ',@other : ''; + $other = "@other" if @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 @@ -1831,7 +1835,7 @@ sub startform { my($method,$action,$enctype,@other) = rearrange([METHOD,ACTION,ENCTYPE],@p); - $method = $self->escapeHTML(lc($method) || 'post'); + $method = $self->escapeHTML(lc($method || 'post')); $enctype = $self->escapeHTML($enctype || &URL_ENCODED); if (defined $action) { $action = $self->escapeHTML($action); @@ -2147,8 +2151,9 @@ END_OF_FUNC sub checkbox { my($self,@p) = self_or_default(@_); - my($name,$checked,$value,$label,$override,$tabindex,@other) = - rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE],TABINDEX],@p); + my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) = + rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES, + [OVERRIDE,FORCE],TABINDEX],@p); $value = defined $value ? $value : 'on'; @@ -2165,7 +2170,8 @@ sub checkbox { my($other) = @other ? "@other " : ''; $tabindex = $self->element_tab($tabindex); $self->register_parameter($name); - return $XHTML ? CGI::label(qq{$the_label}) + return $XHTML ? CGI::label($labelattributes, + qq{$the_label}) : qq{$the_label}; } END_OF_FUNC @@ -2192,9 +2198,11 @@ sub escapeHTML { else { $toencode =~ s{"}{"}gso; } - my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' || - uc $self->{'.charset'} eq 'WINDOWS-1252'; - if ($latin) { # bug in some browsers + # Handle bug in some browsers with Latin charsets + if ($self->{'.charset'} && + (uc($self->{'.charset'}) eq 'ISO-8859-1' || + uc($self->{'.charset'}) eq 'WINDOWS-1252')) + { $toencode =~ s{'}{'}gso; $toencode =~ s{\x8b}{‹}gso; $toencode =~ s{\x9b}{›}gso; @@ -2327,13 +2335,14 @@ sub _box_group { my $self = shift; my $box_type = shift; - my($name,$values,$defaults,$linebreak,$labels,$attributes, - $rows,$columns,$rowheaders,$colheaders, + my($name,$values,$defaults,$linebreak,$labels,$labelattributes, + $attributes,$rows,$columns,$rowheaders,$colheaders, $override,$nolabels,$tabindex,$disabled,@other) = - rearrange([ NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,ATTRIBUTES, - ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], - [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED - ],@_); + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES, + ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], + [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED + ],@_); + my($result,$checked,@elements,@values); @@ -2393,7 +2402,7 @@ sub _box_group { if ($XHTML) { push @elements, - CGI::label( + CGI::label($labelattributes, qq($label)).${break}; } else { push(@elements,qq/${label}${break}/); @@ -2560,6 +2569,7 @@ sub scrolling_list { $size = $size || scalar(@values); my(%selected) = $self->previous_or_default($name,$defaults,$override); + my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; my($has_size) = $size ? qq/ size="$size"/: ''; my($other) = @other ? " @other" : ''; @@ -2692,7 +2702,7 @@ sub url { my $request_uri = unescape($self->request_uri) || ''; my $query_str = $self->query_string; - my $rewrite_in_use = $request_uri && $request_uri !~ /^$script_name/; + my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/; undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active my $uri = $rewrite && $request_uri ? $request_uri : $script_name; @@ -2723,6 +2733,7 @@ sub url { $url .= $path if $path_info and defined $path; $url .= "?$query_str" if $query and $query_str ne ''; + $url ||= ''; $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; return $url; } @@ -3284,10 +3295,10 @@ sub previous_or_default { if (!$override && ($self->{'.fieldnames'}->{$name} || defined($self->param($name)) ) ) { - grep($selected{$_}++,$self->param($name)); + $selected{$_}++ for $self->param($name); } elsif (defined($defaults) && ref($defaults) && (ref($defaults) eq 'ARRAY')) { - grep($selected{$_}++,@{$defaults}); + $selected{$_}++ for @{$defaults}; } else { $selected{$defaults}++ if defined($defaults); } @@ -3371,8 +3382,12 @@ sub read_multipart { my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/; $param .= $TAINTED; - # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="([^"]*)"/; + # See RFC 1867, 2183, 2045 + # NB: File content will be loaded into memory should + # content-disposition parsing fail. + my ($filename) = $header{'Content-Disposition'} + =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i; + $filename =~ s/^"([^"]*)"$/$1/; # Test for Opera's multiple upload feature my($multipart) = ( defined( $header{'Content-Type'} ) && $header{'Content-Type'} =~ /multipart\/mixed/ ) ? @@ -3431,7 +3446,7 @@ sub read_multipart { my ($data); local($\) = ''; - my $totalbytes; + my $totalbytes = 0; while (defined($data = $buffer->read)) { if (defined $self->{'.upload_hook'}) { @@ -3696,7 +3711,7 @@ sub new { (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg; my $fv = ++$FH . $safename; my $ref = \*{"Fh::$fv"}; - $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return; + $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$! || return; my $safe = $1; sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; unlink($safe) if $delete; @@ -3768,7 +3783,7 @@ sub new { } my $self = {LENGTH=>$length, - CHUNKED=>!defined $length, + CHUNKED=>!$length, BOUNDARY=>$boundary, INTERFACE=>$interface, BUFFER=>'', @@ -4032,10 +4047,10 @@ sub new { my $filename; find_tempdir() unless -w $TMPDIRECTORY; for (my $i = 0; $i < $MAXTRIES; $i++) { - last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); + last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++)); } # check that it is a more-or-less valid filename - return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!; + return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\-]+)$!; # this used to untaint, now it doesn't # $filename = $1; return bless \$filename; @@ -4109,6 +4124,8 @@ CGI - Simple Common Gateway Interface Cl hr; } + print end_html; + =head1 ABSTRACT This perl library uses perl5 objects to make it easy to create Web @@ -4477,6 +4494,10 @@ it, use code like this: my $data = $query->param('POSTDATA'); +Likewise if PUTed data can be retrieved with code like this: + + my $data = $query->param('PUTDATA'); + (If you don't know what the preceding means, don't worry about it. It only affects people trying to use CGI for XML processing and other specialized tasks.) @@ -4812,6 +4833,16 @@ If start_html()'s -dtd parameter specifi XHTML will automatically be disabled without needing to use this pragma. +=item -utf8 + +This makes CGI.pm treat all parameters as UTF-8 strings. Use this with +care, as it will interfere with the processing of binary uploads. It +is better to manually select which fields are expected to return utf-8 +strings and convert them using code like this: + + use Encode; + my $arg = decode utf8=>param('foo'); + =item -nph This makes CGI.pm produce a header appropriate for an NPH (no @@ -5388,7 +5419,7 @@ Generate just the protocol and net locat If Apache's mod_rewrite is turned on, then the script name and path info probably won't match the request that the user sent. Set -rewrite=>1 (default) to return URLs that match what the user sent -(the original request URI). Set -rewrite->0 to return URLs that match +(the original request URI). Set -rewrite=>0 to return URLs that match the URL after mod_rewrite's rules have run. Because the additional path information only makes sense in the context of the rewritten URL, -rewrite is set to false when you request path info in the URL. @@ -6389,6 +6420,9 @@ are the tab indexes of each button. Exa -tabindex => ['moe','minie','eenie','meenie'] # tab in this order -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order +The optional B<-labelattributes> argument will contain attributes +attached to the