- use a better BuildRoot - drop a redundant mkdir in %%install - call patchlevel.h only once; rm patchlevel.bak - update modules Sys::Syslog, Module::Load::Conditional, Module::CoreList, Test::Harness, Test::Simple, CGI.pm (dropping the upstreamed patch), File::Path (that includes our perl-5.10.0-CVE-2008-2827.patch), constant, Pod::Simple, Archive::Tar, Archive::Extract, File::Fetch, File::Temp, IPC::Cmd, Time::HiRes, Module::Build, ExtUtils::CBuilder - standardize the patches for updating embedded modules - work around a bug in Module::Build tests bu setting TMPDIR to a directory inside the source tree
1237 lines
44 KiB
Diff
1237 lines
44 KiB
Diff
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 <http-equiv> 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(<meta name="$_" content="$meta->{$_}">)); }
|
|
}
|
|
|
|
- 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,<<END) if $noscript;
|
|
@@ -1699,6 +1712,7 @@
|
|
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 +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{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
|
|
+ return $XHTML ? CGI::label($labelattributes,
|
|
+ qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
|
|
: qq{<input type="checkbox" name="$name" value="$value"$checked$other>$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(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
|
|
} else {
|
|
push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${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/<select name="$name" $tabindex$other>\n/;
|
|
foreach (@values) {
|
|
if (/<optgroup/) {
|
|
- foreach (split(/\n/)) {
|
|
+ for my $v (split(/\n/)) {
|
|
my $selectit = $XHTML ? 'selected="selected"' : 'selected';
|
|
- s/(value="$selected")/$selectit $1/ if defined $selected;
|
|
- $result .= "$_\n";
|
|
+ for my $selected (keys %selected) {
|
|
+ $v =~ s/(value="$selected")/$selectit $1/;
|
|
+ }
|
|
+ $result .= "$v\n";
|
|
}
|
|
}
|
|
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 .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
|
|
+ my $attribs = $self->_set_attributes($_, $attributes);
|
|
+ my($selectit) = $self->_selected($selected{$_});
|
|
+ my($label) = $_;
|
|
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
|
|
+ my($value) = $self->escapeHTML($_);
|
|
+ $label = $self->escapeHTML($label,1);
|
|
+ $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
|
|
}
|
|
}
|
|
|
|
@@ -2560,6 +2583,7 @@
|
|
$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,12 +2716,13 @@
|
|
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;
|
|
- $uri =~ s/\?.*$//; # remove query string
|
|
- $uri =~ s/\Q$path\E$// if defined $path; # remove path
|
|
+ $uri =~ s/\?.*$//s; # remove query string
|
|
+ $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
|
|
+# $uri =~ s/\Q$path\E$// if defined $path; # remove path
|
|
|
|
if ($full) {
|
|
my $protocol = $self->protocol();
|
|
@@ -2723,6 +2748,7 @@
|
|
|
|
$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;
|
|
}
|
|
@@ -2793,12 +2819,12 @@
|
|
sub param_fetch {
|
|
my($self,@p) = self_or_default(@_);
|
|
my($name) = rearrange([NAME],@p);
|
|
- unless (exists($self->{$name})) {
|
|
+ unless (exists($self->{param}{$name})) {
|
|
$self->add_parameter($name);
|
|
- $self->{$name} = [];
|
|
+ $self->{param}{$name} = [];
|
|
}
|
|
|
|
- return $self->{$name};
|
|
+ return $self->{param}{$name};
|
|
}
|
|
END_OF_FUNC
|
|
|
|
@@ -2824,30 +2850,58 @@
|
|
}
|
|
END_OF_FUNC
|
|
|
|
-# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54
|
|
+# This function returns a potentially modified version of SCRIPT_NAME
|
|
+# and PATH_INFO. Some HTTP servers do sanitise the paths in those
|
|
+# variables. It is the case of at least Apache 2. If for instance the
|
|
+# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
|
|
+# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
|
|
+# SCRIPT_NAME=/path/to/env.cgi
|
|
+# PATH_INFO=/x/y/x
|
|
+#
|
|
+# This is all fine except that some bogus CGI scripts expect
|
|
+# PATH_INFO=/http://foo when the user requests
|
|
+# http://xxx/script.cgi/http://foo
|
|
+#
|
|
+# Old versions of this module used to accomodate with those scripts, so
|
|
+# this is why we do this here to keep those scripts backward compatible.
|
|
+# Basically, we accomodate with those scripts but within limits, that is
|
|
+# we only try to preserve the number of / that were provided by the user
|
|
+# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
|
|
+# of consecutive /.
|
|
+#
|
|
+# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
|
|
+# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
|
|
+# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
|
|
+# possibly sanitised by the HTTP server, so in the case of Apache 2:
|
|
+# script_name == /foo/x/z/script.cgi and path_info == /b/c.
|
|
+#
|
|
+# Future versions of this module may no longer do that, so one should
|
|
+# avoid relying on the browser, proxy, server, and CGI.pm preserving the
|
|
+# number of consecutive slashes as no guarantee can be made there.
|
|
'_name_and_path_from_env' => <<'END_OF_FUNC',
|
|
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 = unescape($self->request_uri) || '';
|
|
-
|
|
- 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;
|
|
-
|
|
- my $apache_bug = @uri_double_slashes != @path_double_slashes;
|
|
- return ($raw_script_name,$raw_path_info) unless $apache_bug;
|
|
-
|
|
- my $path_info_search = quotemeta($raw_path_info);
|
|
- $path_info_search =~ s!/!/+!g;
|
|
- if ($uri =~ m/^(.+)($path_info_search)/) {
|
|
- return ($1,$2);
|
|
- } else {
|
|
- return ($raw_script_name,$raw_path_info);
|
|
- }
|
|
+ my $self = shift;
|
|
+ my $script_name = $ENV{SCRIPT_NAME} || '';
|
|
+ my $path_info = $ENV{PATH_INFO} || '';
|
|
+ my $uri = $self->request_uri || '';
|
|
+
|
|
+ $uri =~ s/\?.*//s;
|
|
+ $uri = unescape($uri);
|
|
+
|
|
+ if ($uri ne "$script_name$path_info") {
|
|
+ my $script_name_pattern = quotemeta($script_name);
|
|
+ my $path_info_pattern = quotemeta($path_info);
|
|
+ $script_name_pattern =~ s{(?:\\/)+}{/+}g;
|
|
+ $path_info_pattern =~ s{(?:\\/)+}{/+}g;
|
|
+
|
|
+ if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
|
|
+ # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
|
|
+ # numer of consecutive slashes, so we can extract the info from
|
|
+ # REQUEST_URI:
|
|
+ ($script_name, $path_info) = ($1, $2);
|
|
+ }
|
|
+ }
|
|
+ return ($script_name,$path_info);
|
|
}
|
|
END_OF_FUNC
|
|
|
|
@@ -2931,7 +2985,9 @@
|
|
my($self,$search) = self_or_CGI(@_);
|
|
my(%prefs,$type,$pref,$pat);
|
|
|
|
- my(@accept) = split(',',$self->http('accept'));
|
|
+ my(@accept) = defined $self->http('accept')
|
|
+ ? split(',',$self->http('accept'))
|
|
+ : ();
|
|
|
|
foreach (@accept) {
|
|
($pref) = /q=(\d\.\d+|\d+)/;
|
|
@@ -3284,10 +3340,10 @@
|
|
|
|
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);
|
|
}
|
|
@@ -3368,11 +3424,20 @@
|
|
return;
|
|
}
|
|
|
|
+ $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
|
|
+
|
|
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 ||= ''; # quench uninit variable warning
|
|
+
|
|
+ $filename =~ s/^"([^"]*)"$/$1/;
|
|
# Test for Opera's multiple upload feature
|
|
my($multipart) = ( defined( $header{'Content-Type'} ) &&
|
|
$header{'Content-Type'} =~ /multipart\/mixed/ ) ?
|
|
@@ -3386,7 +3451,7 @@
|
|
if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
|
|
my($value) = $buffer->readBody;
|
|
$value .= $TAINTED;
|
|
- push(@{$self->{$param}},$value);
|
|
+ push(@{$self->{param}{$param}},$value);
|
|
next;
|
|
}
|
|
|
|
@@ -3431,7 +3496,7 @@
|
|
|
|
my ($data);
|
|
local($\) = '';
|
|
- my $totalbytes;
|
|
+ my $totalbytes = 0;
|
|
while (defined($data = $buffer->read)) {
|
|
if (defined $self->{'.upload_hook'})
|
|
{
|
|
@@ -3462,7 +3527,7 @@
|
|
name => $tmpfile,
|
|
info => {%header},
|
|
};
|
|
- push(@{$self->{$param}},$filehandle);
|
|
+ push(@{$self->{param}{$param}},$filehandle);
|
|
}
|
|
}
|
|
}
|
|
@@ -3564,7 +3629,7 @@
|
|
name => $tmpfile,
|
|
info => {%header},
|
|
};
|
|
- push(@{$self->{$param}},$filehandle);
|
|
+ push(@{$self->{param}{$param}},$filehandle);
|
|
}
|
|
}
|
|
return $returnvalue;
|
|
@@ -3645,6 +3710,7 @@
|
|
|
|
################### Fh -- lightweight filehandle ###############
|
|
package Fh;
|
|
+
|
|
use overload
|
|
'""' => \&asString,
|
|
'cmp' => \&compare,
|
|
@@ -3696,7 +3762,7 @@
|
|
(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;
|
|
@@ -3705,6 +3771,14 @@
|
|
}
|
|
END_OF_FUNC
|
|
|
|
+'handle' => <<'END_OF_FUNC',
|
|
+sub handle {
|
|
+ my $self = shift;
|
|
+ eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
|
|
+ return IO::Handle->new_from_fd(fileno $self,"<");
|
|
+}
|
|
+END_OF_FUNC
|
|
+
|
|
);
|
|
END_OF_AUTOLOAD
|
|
|
|
@@ -3768,7 +3842,7 @@
|
|
}
|
|
|
|
my $self = {LENGTH=>$length,
|
|
- CHUNKED=>!defined $length,
|
|
+ CHUNKED=>!$length,
|
|
BOUNDARY=>$boundary,
|
|
INTERFACE=>$interface,
|
|
BUFFER=>'',
|
|
@@ -3986,6 +4060,14 @@
|
|
"${vol}${SL}Temporary Items",
|
|
"${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
|
|
"C:${SL}system${SL}temp");
|
|
+
|
|
+ if( $CGI::OS eq 'WINDOWS' ){
|
|
+ unshift @TEMP,
|
|
+ $ENV{TEMP},
|
|
+ $ENV{TMP},
|
|
+ $ENV{WINDIR} . $SL . 'TEMP';
|
|
+ }
|
|
+
|
|
unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
|
|
|
|
# this feature was supposed to provide per-user tmpfiles, but
|
|
@@ -4014,7 +4096,7 @@
|
|
|
|
sub DESTROY {
|
|
my($self) = @_;
|
|
- $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return;
|
|
+ $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
|
|
my $safe = $1; # untaint operation
|
|
unlink $safe; # get rid of the file
|
|
}
|
|
@@ -4032,10 +4114,10 @@
|
|
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 +4191,8 @@
|
|
hr;
|
|
}
|
|
|
|
+ print end_html;
|
|
+
|
|
=head1 ABSTRACT
|
|
|
|
This perl library uses perl5 objects to make it easy to create Web
|
|
@@ -4392,8 +4476,7 @@
|
|
the method will return a single value.
|
|
|
|
If a value is not given in the query string, as in the queries
|
|
-"name1=&name2=" or "name1&name2", it will be returned as an empty
|
|
-string. This feature is new in 2.63.
|
|
+"name1=&name2=", it will be returned as an empty string.
|
|
|
|
|
|
If the parameter does not exist at all, then param() will return undef
|
|
@@ -4477,6 +4560,10 @@
|
|
|
|
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 +4899,16 @@
|
|
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 +5485,7 @@
|
|
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.
|
|
@@ -5987,24 +6084,27 @@
|
|
|
|
To be safe, use the I<upload()> function (new in version 2.47). When
|
|
called with the name of an upload field, I<upload()> returns a
|
|
-filehandle, or undef if the parameter is not a valid filehandle.
|
|
+filehandle-like object, or undef if the parameter is not a valid
|
|
+filehandle.
|
|
|
|
$fh = upload('uploaded_file');
|
|
while (<$fh>) {
|
|
print;
|
|
}
|
|
|
|
-In an list context, upload() will return an array of filehandles.
|
|
+In a list context, upload() will return an array of filehandles.
|
|
This makes it possible to create forms that use the same name for
|
|
multiple upload fields.
|
|
|
|
This is the recommended idiom.
|
|
|
|
-For robust code, consider reseting the file handle position to beginning of the
|
|
-file. Inside of larger frameworks, other code may have already used the query
|
|
-object and changed the filehandle postion:
|
|
+The lightweight filehandle returned by CGI.pm is not compatible with
|
|
+IO::Handle; for example, it does not have read() or getline()
|
|
+functions, but instead must be manipulated using read($fh) or
|
|
+<$fh>. To get a compatible IO::Handle object, call the handle's
|
|
+handle() method:
|
|
|
|
- seek($fh,0,0); # reset postion to beginning of file.
|
|
+ my $real_io_handle = upload('uploaded_file')->handle;
|
|
|
|
When a file is uploaded the browser usually sends along some
|
|
information along with it in the format of headers. The information
|
|
@@ -6102,7 +6202,7 @@
|
|
|
|
print popup_menu(-name=>'menu_name',
|
|
-values=>['eenie','meenie','minie'],
|
|
- -default=>'meenie',
|
|
+ -default=>['meenie','minie'],
|
|
-labels=>\%labels,
|
|
-attributes=>\%attributes);
|
|
|
|
@@ -6125,7 +6225,8 @@
|
|
|
|
The optional third parameter (-default) is the name of the default
|
|
menu choice. If not specified, the first item will be the default.
|
|
-The values of the previous choice will be maintained across queries.
|
|
+The values of the previous choice will be maintained across
|
|
+queries. Pass an array reference to select multiple defaults.
|
|
|
|
=item 4.
|
|
|
|
@@ -6389,6 +6490,9 @@
|
|
-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 <label> element that surrounds each button.
|
|
+
|
|
When the form is processed, all checked boxes will be returned as
|
|
a list under the parameter name 'group_name'. The values of the
|
|
"on" checkboxes can be retrieved with:
|
|
@@ -6546,6 +6650,9 @@
|
|
with the attribute's name as the key and the attribute's value as the
|
|
value.
|
|
|
|
+The optional B<-labelattributes> argument will contain attributes
|
|
+attached to the <label> element that surrounds each button.
|
|
+
|
|
When the form is processed, the selected radio button can
|
|
be retrieved using:
|
|
|
|
@@ -7658,10 +7765,8 @@
|
|
|
|
=head1 AUTHOR INFORMATION
|
|
|
|
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
|
|
-
|
|
-This library is free software; you can redistribute it and/or modify
|
|
-it under the same terms as Perl itself.
|
|
+The GD.pm interface is copyright 1995-2007, Lincoln D. Stein. It is
|
|
+distributed under GPL and the Artistic License 2.0.
|
|
|
|
Address bug reports and comments to: lstein@cshl.org. When sending
|
|
bug reports, please provide the version of CGI.pm, the version of
|