Change 34331 by [EMAIL PROTECTED] on 2008/09/10 10:02:05
Integrate:
[ 34208]
Subject: Re: Re: [perl #30524] [PATCH] CGI.pm has poor list of temp
directories on Windows
From: [EMAIL PROTECTED]
Date: Wed, 20 Aug 2008 11:26:02 +0200 (CEST)
Message-Id: <[EMAIL PROTECTED]>
[ 34278]
Fix a couple of failing CGI.pm tests on Win32
(My temporary directory is C:\DOCUME~1\shay\LOCALS~1\Temp, so we need
to allow ~ characters.)
[ 34302]
Upgrade to CGI.pm 3.41
Local change 34208, 34278 remain.
[ 34320]
Upgrade to CGI.pm 3.42
Affected files ...
... //depot/maint-5.10/perl/lib/CGI.pm#6 integrate
... //depot/maint-5.10/perl/lib/CGI/Changes#3 integrate
... //depot/maint-5.10/perl/lib/CGI/Pretty.pm#2 integrate
... //depot/maint-5.10/perl/lib/CGI/Util.pm#4 integrate
... //depot/maint-5.10/perl/lib/CGI/t/upload.t#3 integrate
... //depot/maint-5.10/perl/lib/CGI/t/uploadInfo.t#2 integrate
Differences ...
==== //depot/maint-5.10/perl/lib/CGI.pm#6 (text) ====
Index: perl/lib/CGI.pm
--- perl/lib/CGI.pm#5~34257~ 2008-09-03 14:46:38.000000000 -0700
+++ perl/lib/CGI.pm 2008-09-10 03:02:05.000000000 -0700
@@ -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.257 2008/08/06 14:01:06 lstein Exp $';
-$CGI::VERSION='3.40';
+$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'];
@@ -1381,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";
@@ -2720,8 +2720,9 @@
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();
@@ -3709,6 +3710,7 @@
################### Fh -- lightweight filehandle ###############
package Fh;
+
use overload
'""' => \&asString,
'cmp' => \&compare,
@@ -3760,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;
@@ -3769,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
@@ -4050,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
@@ -4078,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
}
@@ -4099,7 +4117,7 @@
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;
@@ -6066,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
==== //depot/maint-5.10/perl/lib/CGI/Changes#3 (text) ====
Index: perl/lib/CGI/Changes
--- perl/lib/CGI/Changes#2~33582~ 2008-03-27 04:35:31.000000000 -0700
+++ perl/lib/CGI/Changes 2008-09-10 03:02:05.000000000 -0700
@@ -1,3 +1,46 @@
+
+ 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.
==== //depot/maint-5.10/perl/lib/CGI/Pretty.pm#2 (text) ====
Index: perl/lib/CGI/Pretty.pm
--- perl/lib/CGI/Pretty.pm#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/lib/CGI/Pretty.pm 2008-09-10 03:02:05.000000000 -0700
@@ -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
==== //depot/maint-5.10/perl/lib/CGI/Util.pm#4 (text) ====
Index: perl/lib/CGI/Util.pm
--- perl/lib/CGI/Util.pm#3~33582~ 2008-03-27 04:35:31.000000000 -0700
+++ perl/lib/CGI/Util.pm 2008-09-10 03:02:05.000000000 -0700
@@ -4,7 +4,7 @@
use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A);
require Exporter;
@ISA = qw(Exporter);
[EMAIL PROTECTED] = qw(rearrange make_attributes unescape escape
[EMAIL PROTECTED] = 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 [EMAIL PROTECTED]
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 [EMAIL PROTECTED], \%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;
}
==== //depot/maint-5.10/perl/lib/CGI/t/upload.t#3 (text) ====
Index: perl/lib/CGI/t/upload.t
--- perl/lib/CGI/t/upload.t#2~33810~ 2008-05-10 09:07:19.000000000 -0700
+++ perl/lib/CGI/t/upload.t 2008-09-10 03:02:05.000000000 -0700
@@ -29,32 +29,45 @@
# %ENV setup.
#-----------------------------------------------------------------------------
-%ENV = (
- %ENV,
- 'SCRIPT_NAME' => '/test.cgi',
- 'SERVER_NAME' => 'perl.org',
- 'HTTP_CONNECTION' => 'TE, close',
- 'REQUEST_METHOD' => 'POST',
- 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
- 'CONTENT_LENGTH' => 3285,
- 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
- 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
- 'HTTP_TE' => 'deflate,gzip;q=0.3',
- 'QUERY_STRING' => '',
- 'REMOTE_PORT' => '1855',
- 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
- 'SERVER_PORT' => '80',
- 'REMOTE_ADDR' => '127.0.0.1',
- 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
- 'SERVER_PROTOCOL' => 'HTTP/1.1',
- 'PATH' => '/usr/local/bin:/usr/bin:/bin',
- 'REQUEST_URI' => '/test.cgi',
- 'GATEWAY_INTERFACE' => 'CGI/1.1',
- 'SCRIPT_URL' => '/test.cgi',
- 'SERVER_ADDR' => '127.0.0.1',
- 'DOCUMENT_ROOT' => '/home/develop',
- 'HTTP_HOST' => 'www.perl.org'
-);
+my %myenv;
+
+BEGIN {
+ %myenv = (
+ 'SCRIPT_NAME' => '/test.cgi',
+ 'SERVER_NAME' => 'perl.org',
+ 'HTTP_CONNECTION' => 'TE, close',
+ 'REQUEST_METHOD' => 'POST',
+ 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
+ 'CONTENT_LENGTH' => 3285,
+ 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
+ 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
+ 'HTTP_TE' => 'deflate,gzip;q=0.3',
+ 'QUERY_STRING' => '',
+ 'REMOTE_PORT' => '1855',
+ 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1;
X11)',
+ 'SERVER_PORT' => '80',
+ 'REMOTE_ADDR' => '127.0.0.1',
+ 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
+ 'SERVER_PROTOCOL' => 'HTTP/1.1',
+ 'PATH' => '/usr/local/bin:/usr/bin:/bin',
+ 'REQUEST_URI' => '/test.cgi',
+ 'GATEWAY_INTERFACE' => 'CGI/1.1',
+ 'SCRIPT_URL' => '/test.cgi',
+ 'SERVER_ADDR' => '127.0.0.1',
+ 'DOCUMENT_ROOT' => '/home/develop',
+ 'HTTP_HOST' => 'www.perl.org'
+ );
+
+ for my $key (keys %myenv) {
+ $ENV{$key} = $myenv{$key};
+ }
+}
+
+END {
+ for my $key (keys %myenv) {
+ delete $ENV{$key};
+ }
+}
#-----------------------------------------------------------------------------
# Simulate the upload (really, multiple uploads contained in a single stream).
==== //depot/maint-5.10/perl/lib/CGI/t/uploadInfo.t#2 (text) ====
Index: perl/lib/CGI/t/uploadInfo.t
--- perl/lib/CGI/t/uploadInfo.t#1~33801~ 2008-05-10 06:34:11.000000000
-0700
+++ perl/lib/CGI/t/uploadInfo.t 2008-09-10 03:02:05.000000000 -0700
@@ -29,32 +29,46 @@
# %ENV setup.
#-----------------------------------------------------------------------------
-%ENV = (
- %ENV,
- 'SCRIPT_NAME' => '/test.cgi',
- 'SERVER_NAME' => 'perl.org',
- 'HTTP_CONNECTION' => 'TE, close',
- 'REQUEST_METHOD' => 'POST',
- 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
- 'CONTENT_LENGTH' => 3285,
- 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
- 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
- 'HTTP_TE' => 'deflate,gzip;q=0.3',
- 'QUERY_STRING' => '',
- 'REMOTE_PORT' => '1855',
- 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
- 'SERVER_PORT' => '80',
- 'REMOTE_ADDR' => '127.0.0.1',
- 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
- 'SERVER_PROTOCOL' => 'HTTP/1.1',
- 'PATH' => '/usr/local/bin:/usr/bin:/bin',
- 'REQUEST_URI' => '/test.cgi',
- 'GATEWAY_INTERFACE' => 'CGI/1.1',
- 'SCRIPT_URL' => '/test.cgi',
- 'SERVER_ADDR' => '127.0.0.1',
- 'DOCUMENT_ROOT' => '/home/develop',
- 'HTTP_HOST' => 'www.perl.org'
-);
+my %myenv;
+
+BEGIN {
+ %myenv = (
+ 'SCRIPT_NAME' => '/test.cgi',
+ 'SERVER_NAME' => 'perl.org',
+ 'HTTP_CONNECTION' => 'TE, close',
+ 'REQUEST_METHOD' => 'POST',
+ 'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
+ 'CONTENT_LENGTH' => 3285,
+ 'SCRIPT_FILENAME' => '/home/usr/test.cgi',
+ 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
+ 'HTTP_TE' => 'deflate,gzip;q=0.3',
+ 'QUERY_STRING' => '',
+ 'REMOTE_PORT' => '1855',
+ 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1;
X11)',
+ 'SERVER_PORT' => '80',
+ 'REMOTE_ADDR' => '127.0.0.1',
+ 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
+ 'SERVER_PROTOCOL' => 'HTTP/1.1',
+ 'PATH' => '/usr/local/bin:/usr/bin:/bin',
+ 'REQUEST_URI' => '/test.cgi',
+ 'GATEWAY_INTERFACE' => 'CGI/1.1',
+ 'SCRIPT_URL' => '/test.cgi',
+ 'SERVER_ADDR' => '127.0.0.1',
+ 'DOCUMENT_ROOT' => '/home/develop',
+ 'HTTP_HOST' => 'www.perl.org'
+ );
+
+ for my $key (keys %myenv) {
+ $ENV{$key} = $myenv{$key};
+ }
+}
+
+END {
+ for my $key (keys %myenv) {
+ delete $ENV{$key};
+ }
+}
+
#-----------------------------------------------------------------------------
# Simulate the upload (really, multiple uploads contained in a single stream).
End of Patch.
