CGI.pm-3.42 diff -urN perl-5.10.0.orig/lib/CGI/Carp.pm perl-5.10.0/lib/CGI/Carp.pm --- perl-5.10.0.orig/lib/CGI/Carp.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Carp.pm 2009-02-13 18:08:50.000000000 +0100 @@ -323,7 +323,7 @@ $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 @@ print STDOUT $mess; } else { + print STDOUT "Status: 500\n"; print STDOUT "Content-type: text/html\n\n"; print STDOUT $mess; } diff -urN perl-5.10.0.orig/lib/CGI/Changes perl-5.10.0/lib/CGI/Changes --- perl-5.10.0.orig/lib/CGI/Changes 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Changes 2009-02-13 18:09:15.000000000 +0100 @@ -1,3 +1,70 @@ + + Version 3.42 + 1. Added patch from Renee Baecker that makes it possible to subclass + CGI::Pretty. + 2. Added patch from Nicholas Clark to allow ~ characters in temporary directories. + 3. Added patch from Renee Baecker that fixes the inappropriate escaping of fields + in multipart headers. + + Version 3.41 + 1. Fix url() returning incorrect path when query string contains escaped newline. + 2. Added additional windows temporary directories and environment variables, courtesy patch from Renee Baecker + 3. Added a handle() method to the lightweight upload + filehandles. This method returns a real IO::Handle object. + 4. Added patch from Tony Vanlingen to fix deep recursion warnings in CGI::Pretty. + + Version 3.40 + 1. Fixed CGI::Fast docs to eliminate references to a "special" + version of Perl. + 2. Makefile.PL now depends on FCGI so that CGI::Fast installs properly. + 3. Fix script_name() call from Stephane Chazelas. + + Version 3.39 + 1. Fixed regression in "exists" function when using tied interface to CGI via $q->Vars. + + Version 3.38 + 1. Fix annoying warning in http://rt.cpan.org/Ticket/Display.html?id=34551 + 2. Added nobr() function http://rt.cpan.org/Ticket/Display.html?id=35377 + 3. popup_menu() allows multiple items to be selected by default, satisfying + http://rt.cpan.org/Ticket/Display.html?id=35376 + 4. Patch from Renee Backer to avoid doubled headers. + 5. Fixed documentation bug that describes what happens when a + parameter is empty (e.g. "?test1="). + 6. Fixed minor warning described at http://rt.cpan.org/Public/Bug/Display.html?id=36435 + 7. Fixed overlap of attribute and parameter space described in http://rt.perl.org/rt3//Ticket/Display.html?id=24294 + + 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 -urN perl-5.10.0.orig/lib/CGI/Cookie.pm perl-5.10.0/lib/CGI/Cookie.pm --- perl-5.10.0.orig/lib/CGI/Cookie.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Cookie.pm 2009-02-13 18:08:50.000000000 +0100 @@ -13,7 +13,7 @@ # 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 @@ 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 @@ 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 -urN perl-5.10.0.orig/lib/CGI/Fast.pm perl-5.10.0/lib/CGI/Fast.pm --- perl-5.10.0.orig/lib/CGI/Fast.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Fast.pm 2009-02-13 18:08:50.000000000 +0100 @@ -55,6 +55,7 @@ } } CGI->_reset_globals; + $self->_setup_symbols(@SAVED_SYMBOLS) if @CGI::SAVED_SYMBOLS; return $CGI::Q = $self->SUPER::new($initializer, @param); } @@ -81,18 +82,17 @@ =head1 DESCRIPTION -CGI::Fast is a subclass of the CGI object created by -CGI.pm. It is specialized to work well with the Open Market -FastCGI standard, which greatly speeds up CGI scripts by -turning them into persistently running server processes. Scripts -that perform time-consuming initialization processes, such as -loading large modules or opening persistent database connections, -will see large performance improvements. +CGI::Fast is a subclass of the CGI object created by CGI.pm. It is +specialized to work well FCGI module, which greatly speeds up CGI +scripts by turning them into persistently running server processes. +Scripts that perform time-consuming initialization processes, such as +loading large modules or opening persistent database connections, will +see large performance improvements. =head1 OTHER PIECES OF THE PUZZLE -In order to use CGI::Fast you'll need a FastCGI-enabled Web -server. See http://www.fastcgi.com/ for details. +In order to use CGI::Fast you'll need the FCGI module. See +http://www.cpan.org/ for details. =head1 WRITING FASTCGI PERL SCRIPTS @@ -105,7 +105,7 @@ A typical FastCGI script will look like this: - #!/usr/local/bin/perl # must be a FastCGI version of perl! + #!/usr/bin/perl use CGI::Fast; &do_some_initialization(); while ($q = new CGI::Fast) { diff -urN perl-5.10.0.orig/lib/CGI/Pretty.pm perl-5.10.0/lib/CGI/Pretty.pm --- perl-5.10.0.orig/lib/CGI/Pretty.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Pretty.pm 2009-02-13 18:08:50.000000000 +0100 @@ -176,6 +176,35 @@ } sub _reset_globals { initialize_globals(); } +# ugly, but quick fix +sub import { + my $self = shift; + no strict 'refs'; + ${ "$self\::AutoloadClass" } = 'CGI'; + + # This causes modules to clash. + undef %CGI::EXPORT; + undef %CGI::EXPORT; + + $self->_setup_symbols(@_); + my ($callpack, $callfile, $callline) = caller; + + # To allow overriding, search through the packages + # Till we find one in which the correct subroutine is defined. + my @packages = ($self,@{"$self\:\:ISA"}); + foreach my $sym (keys %CGI::EXPORT) { + my $pck; + my $def = ${"$self\:\:AutoloadClass"} || $CGI::DefaultClass; + foreach $pck (@packages) { + if (defined(&{"$pck\:\:$sym"})) { + $def = $pck; + last; + } + } + *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; + } +} + 1; =head1 NAME diff -urN perl-5.10.0.orig/lib/CGI/t/request.t perl-5.10.0/lib/CGI/t/request.t --- perl-5.10.0.orig/lib/CGI/t/request.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/t/request.t 2009-02-13 18:09:57.000000000 +0100 @@ -4,7 +4,7 @@ ######################### We start with some black magic to print on failure. use lib '.','../blib/lib','../blib/arch'; -BEGIN {$| = 1; print "1..33\n"; } +BEGIN {$| = 1; print "1..34\n"; } END {print "not ok 1\n" unless $loaded;} use CGI (); use Config; @@ -74,6 +74,7 @@ test(29,$p->{bar} eq 'froz',"tied interface fetch"); $p->{bar} = join("\0",qw(foo bar baz)); test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); +test(31,exists $p->{bar}); # test posting $q->_reset_globals; @@ -88,11 +89,11 @@ exit 0; } # at this point, we're in a new (child) process - test(31,$q=new CGI,"CGI::new() from POST"); - test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); - test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); + test(32,$q=new CGI,"CGI::new() from POST"); + test(33,$q->param('weather') eq 'nice',"CGI::param() from POST"); + test(34,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); } else { - print "ok 31 # Skip\n"; print "ok 32 # Skip\n"; print "ok 33 # Skip\n"; + print "ok 34 # Skip\n"; } diff -urN perl-5.10.0.orig/lib/CGI/Util.pm perl-5.10.0/lib/CGI/Util.pm --- perl-5.10.0.orig/lib/CGI/Util.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI/Util.pm 2009-02-13 18:08:50.000000000 +0100 @@ -4,7 +4,7 @@ use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A); require Exporter; @ISA = qw(Exporter); -@EXPORT_OK = qw(rearrange make_attributes unescape escape +@EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); $VERSION = '1.5_01'; @@ -70,16 +70,34 @@ } # Smart rearrangement of parameters to allow named parameter -# calling. We do the rearangement if: +# calling. We do the rearrangement if: # the first parameter begins with a - + sub rearrange { + my ($order,@param) = @_; + my ($result, $leftover) = _rearrange_params( $order, @param ); + push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 ) + if keys %$leftover; + @$result; +} + +sub rearrange_header { + my ($order,@param) = @_; + + my ($result,$leftover) = _rearrange_params( $order, @param ); + push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover; + + @$result; +} + +sub _rearrange_params { my($order,@param) = @_; - return () unless @param; + return [] unless @param; if (ref($param[0]) eq 'HASH') { @param = %{$param[0]}; } else { - return @param + return \@param unless (defined($param[0]) && substr($param[0],0,1) eq '-'); } @@ -103,14 +121,17 @@ } } - push (@result,make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover; - @result; + return \@result, \%leftover; } sub make_attributes { my $attr = shift; return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; my $escape = shift || 0; + my $do_not_quote = shift; + + my $quote = $do_not_quote ? '' : '"'; + my(@att); foreach (keys %{$attr}) { my($key) = $_; @@ -122,7 +143,7 @@ ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_}; - push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/); + push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/); } return @att; } @@ -141,8 +162,12 @@ sub utf8_chr { my $c = shift(@_); - return chr($c) if $] >= 5.006; - + if ($] >= 5.006){ + require utf8; + my $u = chr($c); + utf8::encode($u); # drop utf8 flag + return $u; + } if ($c < 0x80) { return sprintf("%c", $c); } elsif ($c < 0x800) { @@ -189,6 +214,17 @@ if ($EBCDIC) { $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; } else { + # handle surrogate pairs first -- dankogai + $todecode =~ s{ + %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi + %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo + }{ + utf8_chr( + 0x10000 + + (hex($1) - 0xD800) * 0x400 + + (hex($2) - 0xDC00) + ) + }gex; $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/ defined($1)? chr hex($1) : utf8_chr(hex($2))/ge; } @@ -200,8 +236,12 @@ shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); my $toencode = shift; return undef unless defined($toencode); + $toencode = eval { pack("C*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode)); + # force bytes while preserving backward compatibility -- dankogai - $toencode = pack("C*", unpack("U0C*", $toencode)); + # but commented out because it was breaking CGI::Compress -- lstein + # $toencode = eval { pack("U*", unpack("U0C*", $toencode))} || pack("C*", unpack("C*", $toencode)); + if ($EBCDIC) { $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg; } else { diff -urN perl-5.10.0.orig/lib/CGI.pm perl-5.10.0/lib/CGI.pm --- perl-5.10.0.orig/lib/CGI.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/CGI.pm 2009-02-13 18:08:55.000000000 +0100 @@ -18,13 +18,13 @@ # 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.260 2008/09/08 14:13:23 lstein Exp $'; +$CGI::VERSION='3.42'; # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. # $CGITempFile::TMPDIRECTORY = '/usr/tmp'; -use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); +use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); #use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', # 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; @@ -37,7 +37,12 @@ $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 @@ # 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 @@ # 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; @@ -226,7 +227,7 @@ tt u i b blockquote pre img a address cite samp dfn html head base body Link nextid title meta kbd start_html end_html input Select option comment charset escapeHTML/], - ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param + ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr embed basefont style span layer ilayer font frameset frame script small big Area Map/], ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe ins label legend noframes noscript object optgroup Q @@ -352,6 +353,7 @@ $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 @@ 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; } @@ -437,23 +440,22 @@ # If values is provided, then we set it. if (@values or defined $value) { $self->add_parameter($name); - $self->{$name}=[@values]; + $self->{param}{$name}=[@values]; } } else { $name = $p[0]; } - return unless defined($name) && $self->{$name}; + return unless defined($name) && $self->{param}{$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->{param}{$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 { @@ -574,14 +576,14 @@ $self->add_parameter($param); $self->read_from_client(\$value,$content_length,0) if $content_length > 0; - push (@{$self->{$param}},$value); + push (@{$self->{param}{$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); + push (@{$self->{param}{$param}},$value); if ($MOD_PERL) { $query_string = $self->r->args; } else { @@ -641,7 +643,7 @@ 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,13 +669,13 @@ } # 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); + push (@{$self->{param}{$param}},$query_string); undef $query_string ; } # YL: End Change for XML handler 10/19/2001 @@ -685,7 +687,7 @@ $self->parse_params($query_string); } else { $self->add_parameter('keywords'); - $self->{'keywords'} = [$self->parse_keywordlist($query_string)]; + $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)]; } } @@ -752,7 +754,7 @@ @QUERY_PARAM = $self->param; # save list of parameters foreach (@QUERY_PARAM) { next unless defined $_; - $QUERY_PARAM{$_}=$self->{$_}; + $QUERY_PARAM{$_}=$self->{param}{$_}; } $QUERY_CHARSET = $self->charset; %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; @@ -771,7 +773,7 @@ $param = unescape($param); $value = unescape($value); $self->add_parameter($param); - push (@{$self->{$param}},$value); + push (@{$self->{param}{$param}},$value); } } @@ -779,7 +781,7 @@ my($self,$param)=@_; return unless defined $param; push (@{$self->{'.parameters'}},$param) - unless defined($self->{$param}); + unless defined($self->{param}{$param}); } sub all_parameters { @@ -904,6 +906,7 @@ $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$/; @@ -1005,7 +1008,7 @@ my %to_delete; foreach my $name (@to_delete) { - CORE::delete $self->{$name}; + CORE::delete $self->{param}{$name}; CORE::delete $self->{'.fieldnames'}->{$name}; $to_delete{$name}++; } @@ -1054,8 +1057,8 @@ sub keywords { my($self,@values) = self_or_default(@_); # If values is provided, then we set it. - $self->{'keywords'}=[@values] if @values; - my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); + $self->{param}{'keywords'}=[@values] if @values; + my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); @result; } END_OF_FUNC @@ -1173,7 +1176,7 @@ 'EXISTS' => <<'END_OF_FUNC', sub EXISTS { - exists $_[0]->{$_[1]}; + exists $_[0]->{param}{$_[1]}; } END_OF_FUNC @@ -1200,7 +1203,7 @@ my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); if (@values) { $self->add_parameter($name); - push(@{$self->{$name}},@values); + push(@{$self->{param}{$name}},@values); } return $self->param($name); } @@ -1378,7 +1381,7 @@ 'multipart_init' => <<'END_OF_FUNC', sub multipart_init { my($self,@p) = self_or_default(@_); - my($boundary,@other) = rearrange([BOUNDARY],@p); + my($boundary,@other) = rearrange_header([BOUNDARY],@p); $boundary = $boundary || '------- =_aaaaaaaaaa0'; $self->{'separator'} = "$CRLF--$boundary$CRLF"; $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; @@ -1519,7 +1522,7 @@ 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 ''; } @@ -1663,12 +1666,22 @@ : qq()); } } - push(@result,ref($head) ? @$head : $head) if $head; + my $meta_bits_set = 0; + if( $head ) { + if( ref $head ) { + push @result, @$head; + $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head; + } + else { + push @result, $head; + $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i; + } + } # handle the infrequently-used -style and -script parameters push(@result,$self->_style($style)) if defined $style; push(@result,$self->_script($script)) if defined $script; - push(@result,$meta_bits) if defined $meta_bits; + push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set; # handle -noscript parameter push(@result,< */-->\n" : " -->\n"; my @s = ref($style) eq 'ARRAY' ? @$style : $style; + my $other = ''; for my $s (@s) { if (ref($s)) { @@ -1708,7 +1722,7 @@ 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 +1845,7 @@ 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 +2161,9 @@ 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 +2180,8 @@ 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 +2208,11 @@ 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 +2345,14 @@ 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 +2412,7 @@ if ($XHTML) { push @elements, - CGI::label( + CGI::label($labelattributes, qq($label)).${break}; } else { push(@elements,qq/${label}${break}/); @@ -2428,12 +2447,14 @@ my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); - my($result,$selected); + my($result,%selected); if (!$override && defined($self->param($name))) { - $selected = $self->param($name); - } else { - $selected = $default; + $selected{$self->param($name)}++; + } elsif ($default) { + %selected = map {$_=>1} ref($default) eq 'ARRAY' + ? @$default + : $default; } $name=$self->escapeHTML($name); my($other) = @other ? " @other" : ''; @@ -2444,20 +2465,22 @@ $result = qq/