Added patch from Nicholas Clark to allow ~ characters in temporary di…

…rectories; fixed broken functionality introduced by Renee Baeckers recent patches
markstos · Sep 8, 2008 · f2bd172 · f2bd172
1 parent 523ba49
commit f2bd172
Show file tree

Hide file tree

Showing 5 changed files with 119 additions and 40 deletions.
diff --git a/CGI.pm b/CGI.pm
@@ -18,13 +18,13 @@ 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.259 2008-08-20 13:45:25 lstein Exp $';
-$CGI::VERSION='3.41';
+$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 @@ END_OF_FUNC
 '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";
@@ -3762,7 +3762,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;
@@ -4060,6 +4060,14 @@ sub find_tempdir {
 	   "${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
@@ -4088,7 +4096,7 @@ $MAXTRIES = 5000;
 
 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
 }
@@ -4109,7 +4117,7 @@ sub new {
 	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;

diff --git a/CGI/Pretty.pm b/CGI/Pretty.pm
@@ -176,6 +176,35 @@ sub initialize_globals {
 }
 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 --git a/CGI/Util.pm b/CGI/Util.pm
@@ -4,7 +4,7 @@ use strict;
 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 @@ elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400
 }
 
 # 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 @@ sub rearrange {
 	}
     }
 
-    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 @@ sub make_attributes {
 	($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;
 }

diff --git a/Changes b/Changes
@@ -1,3 +1,11 @@
+
+  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

diff --git a/t/upload.t b/t/upload.t
@@ -19,32 +19,45 @@ use CGI;
 # %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).