Upgrade to CGI.pm 3.49

9 files changed, 268 insertions, 80 deletions

diff --git a/cpan/CGI/Changes b/cpan/CGI/Changes
index e7acabd0fa..fb1644ff64 100644
--- a/cpan/CGI/Changes
+++ b/cpan/CGI/Changes
@@ -1,3 +1,23 @@
+Version 3.49
+
+  [BUG FIXES]
+  1. Fix a regression since 3.44 involving a case when the header includes "Content-Length: 0". 
+     Thanks to Alex Vandiver (RT#51109)
+  2. Suppress uninitialized warnings under -w. Thanks to burak.  (RT#50301)
+  3. url() now uses virtual_port() instead of server_port(). Thanks to MKANAT and Yanick Champoux. (RT#51562)
+
+  [SECURITY]
+  1. embedded newlines are now filtered out of header values in header(). 
+     Thanks to Mark Stosberg and Yanick Champoux.
+
+  [DOCUMENTATION]
+  1. README was updated to reflect that CGI.pm was moved under ./lib. 
+     Thanks to Alex Vandiver.
+
+  [INTERNALS]
+  1. More tests were added for autoescape, thanks to Bob Kuo. (RT#25485)
+  2. Attempt to avoid test failures with t/fast, thanks to Steve Hay. (RT#49599)
+
 Version 3.48
 
   [BUG FIXES]
diff --git a/cpan/CGI/lib/CGI.pm b/cpan/CGI/lib/CGI.pm
index 0cba88172c..355b8d1805 100644
--- a/cpan/CGI/lib/CGI.pm
+++ b/cpan/CGI/lib/CGI.pm
@@ -19,7 +19,7 @@ use Carp 'croak';
 #   http://stein.cshl.org/WWW/software/CGI/
 
 $CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
-$CGI::VERSION='3.48';
+$CGI::VERSION='3.49';
 
 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -663,7 +663,7 @@ sub init {
 	  if ( $content_length > 0 ) {
 	    $self->read_from_client(\$query_string,$content_length,0);
 	  }
-	  else {
+	  elsif (not defined $ENV{CONTENT_LENGTH}) {
 	    $self->read_from_stdin(\$query_string);
 	    # should this be PUTDATA in case of PUT ?
 	    my($param) = $meth . 'DATA' ;
@@ -1542,6 +1542,16 @@ sub header {
                             'EXPIRES','NPH','CHARSET',
                             'ATTACHMENT','P3P'],@p);
 
+    # CR escaping for values, per RFC 822
+    for my $header ($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
+        if (defined $header) {
+            $header =~ s/
+                (?<=\n)    # For any character proceeded by a newline
+                (?=\S)     # ... that is not whitespace
+            / /xg;         # ... inject a leading space in the new line
+        }
+    }
+
     $nph     ||= $NPH;
 
     $type ||= 'text/html' unless defined($type);
@@ -1557,7 +1567,7 @@ sub header {
     # need to fix it up a little.
     for (@other) {
         # Don't use \s because of perl bug 21951
-        next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+        next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
         ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
     }
 
@@ -2566,6 +2576,7 @@ sub popup_menu {
     my(@values);
     @values = $self->_set_values_and_labels($values,\$labels,$name);
     $tabindex = $self->element_tab($tabindex);
+    $name = q{} if ! defined $name;
     $result = qq/<select name="$name" $tabindex$other>\n/;
     for (@values) {
         if (/<optgroup/) {
@@ -2626,7 +2637,7 @@ sub optgroup {
     @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
     my($other) = @other ? " @other" : '';
 
-    $name=$self->_maybe_escapeHTML($name);
+    $name = $self->_maybe_escapeHTML($name) || q{};
     $result = qq/<optgroup label="$name"$other>\n/;
     for (@values) {
         if (/<optgroup/) {
@@ -2842,21 +2853,22 @@ sub url {
 #    $uri            =~ s/\Q$path\E$//      if defined $path;      # remove path
 
     if ($full) {
-	my $protocol = $self->protocol();
-	$url = "$protocol://";
-	my $vh = http('x_forwarded_host') || http('host') || '';
-        $vh =~ s/\:\d+$//;  # some clients add the port number (incorrectly). Get rid of it.
-	if ($vh) {
-	    $url .= $vh;
-	} else {
-	    $url .= server_name();
-	}
-        my $port = $self->server_port;
-	$url .= ":" . $port
-	  unless (lc($protocol) eq 'http'  && $port == 80)
-		|| (lc($protocol) eq 'https' && $port == 443);
+        my $protocol = $self->protocol();
+        $url = "$protocol://";
+        my $vh = http('x_forwarded_host') || http('host') || '';
+            $vh =~ s/\:\d+$//;  # some clients add the port number (incorrectly). Get rid of it.
+
+        $url .= $vh || server_name();
+
+        my $port = $self->virtual_port;
+
+        # add the port to the url unless it's the protocol's default port
+        $url .= ':' . $port unless (lc($protocol) eq 'http'  && $port == 80)
+                                or (lc($protocol) eq 'https' && $port == 443);
+
         return $url if $base;
-	$url .= $uri;
+
+        $url .= $uri;
     } elsif ($relative) {
 	($url) = $uri =~ m!([^/]+)$!;
     } elsif ($absolute) {
@@ -4759,7 +4771,7 @@ a short example of creating multiple session records:
 
    use CGI;
 
-   open (OUT,">>test.out") || die;
+   open (OUT,'>>','test.out') || die;
    $records = 5;
    for (0..$records) {
        my $q = CGI->new;
@@ -4769,7 +4781,7 @@ a short example of creating multiple session records:
    close OUT;
 
    # reopen for reading
-   open (IN,"test.out") || die;
+   open (IN,'<','test.out') || die;
    while (!eof(IN)) {
        my $q = CGI->new(\*IN);
        print $q->param('counter'),"\n";
@@ -5265,6 +5277,18 @@ In either case, the outgoing header will be formatted as:
 
   P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
 
+Note that if a header value contains a carriage return, a leading space will be
+added to each new line that doesn't already have one as specified by RFC2616
+section 4.2.  For example:
+
+    print header( -ingredients => "ham\neggs\nbacon" );
+
+will generate
+
+    Ingredients: ham
+     eggs
+     bacon
+
 =head2 GENERATING A REDIRECTION HEADER
 
    print $q->redirect('http://somewhere.else/in/movie/land');
@@ -6198,12 +6222,12 @@ handle for a file upload field like this:
   # undef may be returned if it's not a valid file handle
   if (defined $lightweight_fh) {
     # Upgrade the handle to one compatible with IO::Handle:
-     my $io_handle = $lightweight_fh->handle;
+    my $io_handle = $lightweight_fh->handle;
 
-	open (OUTFILE,">>/usr/local/web/users/feedback");
-   while ($bytesread = $io_handle->read($buffer,1024)) {
-	   print OUTFILE $buffer;
-	}
+    open (OUTFILE,'>>','/usr/local/web/users/feedback');
+    while ($bytesread = $io_handle->read($buffer,1024)) {
+      print OUTFILE $buffer;
+    }
   }
 
 In a list context, upload() will return an array of filehandles.
@@ -8024,13 +8048,12 @@ for suggestions and bug fixes.
 	}
 
 	sub do_work {
-	   my(@values,$key);
 
 	   print "<h2>Here are the current settings in this form</h2>";
 
-	   for $key (param) {
+	   for my $key (param) {
 	      print "<strong>$key</strong> -> ";
-	      @values = param($key);
+	      my @values = param($key);
 	      print join(", ",@values),"<br>\n";
 	  }
 	}
diff --git a/cpan/CGI/lib/CGI/Carp.pm b/cpan/CGI/lib/CGI/Carp.pm
index 381635e87e..5f9911b32e 100644
--- a/cpan/CGI/lib/CGI/Carp.pm
+++ b/cpan/CGI/lib/CGI/Carp.pm
@@ -423,35 +423,26 @@ sub ineval {
 sub die {
   my ($arg,@rest) = @_;
 
-  if ($DIE_HANDLER) {
-      &$DIE_HANDLER($arg,@rest);
-  }
+  &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
 
-  if ( ineval() )  {
-    if (!ref($arg)) {
-      $arg = join("",($arg,@rest)) || "Died";
-      my($file,$line,$id) = id(1);
-      $arg .= " at $file line $line.\n" unless $arg=~/\n$/;
-      realdie($arg);
-    }
-    else {
-      realdie($arg,@rest);
-    }
-  }
+  # if called as die( $object, 'string' ),
+  # all is stringified, just like with
+  # the real 'die'
+  $arg = join '' => "$arg", @rest if @rest;
+
+  $arg ||= 'Died';
+
+  my($file,$line,$id) = id(1);
+
+  $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
+
+  realdie $arg           if ineval();
+  &fatalsToBrowser($arg) if $WRAP;
+
+  $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
+
+  $arg .= "\n" unless $arg =~ /\n$/;
 
-  if (!ref($arg)) {
-    $arg = join("", ($arg,@rest));
-    my($file,$line,$id) = id(1);
-    $arg .= " at $file line $line." unless $arg=~/\n$/;
-    &fatalsToBrowser($arg) if $WRAP;
-    if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) {
-      my $stamp = stamp;
-      $arg=~s/^/$stamp/gm;
-    }
-    if ($arg !~ /\n$/) {
-      $arg .= "\n";
-    }
-  }
   realdie $arg;
 }
 
@@ -503,11 +494,15 @@ sub warningsToBrowser {
 
 # headers
 sub fatalsToBrowser {
-  my($msg) = @_;
+  my $msg = shift;
+
+  $msg = "$msg" if ref $msg;
+
   $msg=~s/&/&amp;/g;
   $msg=~s/>/&gt;/g;
   $msg=~s/</&lt;/g;
-  $msg=~s/\"/&quot;/g;
+  $msg=~s/"/&quot;/g;
+
   my($wm) = $ENV{SERVER_ADMIN} ? 
     qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
       "this site's webmaster";
diff --git a/cpan/CGI/lib/CGI/Cookie.pm b/cpan/CGI/lib/CGI/Cookie.pm
index 85a07f0bc0..7bc090d418 100644
--- a/cpan/CGI/lib/CGI/Cookie.pm
+++ b/cpan/CGI/lib/CGI/Cookie.pm
@@ -1,5 +1,8 @@
 package CGI::Cookie;
 
+use strict;
+use warnings;
+
 # See the bottom of this file for the POD documentation.  Search for the
 # string '=head'.
 
@@ -78,14 +81,13 @@ sub get_raw_cookie {
   $r ||= eval { $MOD_PERL == 2                    ? 
                   Apache2::RequestUtil->request() :
                   Apache->request } if $MOD_PERL;
-  if ($r) {
-    $raw_cookie = $r->headers_in->{'Cookie'};
-  } else {
-    if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) {
-      die "Run $r->subprocess_env; before calling fetch()";
-    }
-    $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
-  }
+
+  return $r->headers_in->{'Cookie'} if $r;
+
+  die "Run $r->subprocess_env; before calling fetch()" 
+    if $MOD_PERL and !exists $ENV{REQUEST_METHOD};
+    
+  return $ENV{HTTP_COOKIE} || $ENV{COOKIE};
 }
 
 
@@ -122,7 +124,8 @@ sub new {
   shift if ref $_[0]
         && eval { $_[0]->isa('Apache::Request::Req') || $_[0]->isa('Apache') };
   my($name,$value,$path,$domain,$secure,$expires,$httponly) =
-    rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@_);
+    rearrange([ 'NAME', ['VALUE','VALUES'], qw/ PATH DOMAIN SECURE EXPIRES
+        HTTPONLY / ], @_);
   
   # Pull out our parameters.
   my @values;
diff --git a/cpan/CGI/lib/CGI/Fast.pm b/cpan/CGI/lib/CGI/Fast.pm
index 67d67ee685..e31dac3f50 100644
--- a/cpan/CGI/lib/CGI/Fast.pm
+++ b/cpan/CGI/lib/CGI/Fast.pm
@@ -1,6 +1,10 @@
 package CGI::Fast;
 use strict;
-$^W=1; # A way to say "use warnings" that's compatible with even older perls.
+
+# A way to say "use warnings" that's compatible with even older perls.
+# making it local will not affect the code that loads this module
+# and since we're not in a BLOCK, warnings are enabled until the EOF
+local $^W = 1;
 
 # See the bottom of this file for the POD documentation.  Search for the
 # string '=head'.
@@ -15,7 +19,7 @@ $^W=1; # A way to say "use warnings" that's compatible with even older perls.
 # wish, but if you redistribute a modified version, please attach a note
 # listing the modifications you have made.
 
-$CGI::Fast::VERSION='1.07';
+$CGI::Fast::VERSION='1.08';
 
 use CGI;
 use FCGI;
diff --git a/cpan/CGI/lib/CGI/Util.pm b/cpan/CGI/lib/CGI/Util.pm
index 1f4201d064..eb639e40d5 100644
--- a/cpan/CGI/lib/CGI/Util.pm
+++ b/cpan/CGI/lib/CGI/Util.pm
@@ -244,11 +244,38 @@ sub unescape {
 # was always so and cannot be fixed without breaking the binary data case.
 # -- Stepan Kasal <skasal@redhat.com>
 #
+if ($] == 5.008) {
+   package utf8;
+
+   no warnings 'redefine'; # needed for Perl 5.8.1+
+
+   my $is_utf8_redefinition = <<'EOR';
+      sub is_utf8 {
+         my ($text) = @_;
+
+         my $ctext = pack q{C0a*}, $text;
+
+         return ($text ne $ctext) && ($ctext =~ m/^(
+          [\x09\x0A\x0D\x20-\x7E]
+          | [\xC2-\xDF][\x80-\xBF]
+          | \xE0[\xA0-\xBF][\x80-\xBF]
+          | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}
+          | \xED[\x80-\x9F][\x80-\xBF]
+          | \xF0[\x90-\xBF][\x80-\xBF]{2}
+          | [\xF1-\xF3][\x80-\xBF]{3}
+          | \xF4[\x80-\x8F][\x80-\xBF]{2}
+          )*$/xo);
+      }
+EOR
+
+   eval $is_utf8_redefinition;
+}
+
 sub escape {
   shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
   my $toencode = shift;
   return undef unless defined($toencode);
-  utf8::encode($toencode) if ($] > 5.008001 && utf8::is_utf8($toencode));
+  utf8::encode($toencode) if ($] >= 5.008 && utf8::is_utf8($toencode));
     if ($EBCDIC) {
       $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
     } else {
diff --git a/cpan/CGI/t/carp.t b/cpan/CGI/t/carp.t
index ff5eaf498e..be6292867b 100644
--- a/cpan/CGI/t/carp.t
+++ b/cpan/CGI/t/carp.t
@@ -3,7 +3,7 @@
 
 use strict;
 
-use Test::More tests => 41;
+use Test::More tests => 59;
 use IO::Handle;
 
 BEGIN { use_ok('CGI::Carp') };
@@ -116,12 +116,13 @@ like($@,
 # Test that realwarn is called
 {
   local $^W = 0;
-  eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
-}
+  local *CGI::Carp::realdie = sub { my $mess = shift; return $mess };
 
-like(CGI::Carp::die('There is a problem'),
-     $stamp,
-     'CGI::Carp::die calls CORE::die, but adds stamp');
+    like(CGI::Carp::die('There is a problem'),
+        $stamp,
+        'CGI::Carp::die calls CORE::die, but adds stamp');
+
+}
 
 #-----------------------------------------------------------------------------
 # Test set_message
@@ -273,3 +274,100 @@ ok( defined buffer( $fh ),         '$fh returns proper filehandle');
 ok( defined buffer('::STDOUT'),    'STDIN returns proper filehandle');
 ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
 ok(!defined buffer("WIBBLE"),      '"WIBBLE" doesn\'t returns proper filehandle');
+
+# Calling die with code refs with no WRAP
+{
+    local $CGI::Carp::WRAP = 0;
+
+    eval { CGI::Carp::die( 'regular string' ) };
+    like $@ => qr/regular string/, 'die with string';
+
+    eval { CGI::Carp::die( [ 1..10 ] ) };
+    like $@ => qr/ARRAY\(0x[\da-f]+\)/, 'die with array ref';
+
+    eval { CGI::Carp::die( { a => 1 } ) };
+    like $@ => qr/HASH\(0x[\da-f]+\)/, 'die with hash ref';
+
+    eval { CGI::Carp::die( sub { 'Farewell' } ) };
+    like $@ => qr/CODE\(0x[\da-f]+\)/, 'die with code ref';
+
+    eval { CGI::Carp::die( My::Plain::Object->new ) };
+    isa_ok $@, 'My::Plain::Object';
+
+    eval { CGI::Carp::die( My::Plain::Object->new, ' and another argument' ) };
+    like $@ => qr/My::Plain::Object/,     'object is stringified';
+    like $@ => qr/and another argument/, 'second argument is present';
+
+    eval { CGI::Carp::die( My::Stringified::Object->new ) };
+    isa_ok $@, 'My::Stringified::Object';
+
+    eval { CGI::Carp::die( My::Stringified::Object->new, ' and another argument' ) };
+    like $@ => qr/stringified/,          'object is stringified';
+    like $@ => qr/and another argument/, 'second argument is present';
+
+    eval { CGI::Carp::die() };
+    like $@ => qr/Died at/, 'die with no argument';
+}
+
+# Calling die with code refs when WRAPped
+{
+    local $CGI::Carp::WRAP = 1;
+    local *CGI::Carp::realdie = sub { return @_ };
+    local *STDOUT;
+
+    tie *STDOUT, 'StoreStuff';
+
+    my %result;   # store results because stdout is kidnapped
+
+    CGI::Carp::die( 'regular string' );
+    $result{string} .= $_ while <STDOUT>;
+
+    CGI::Carp::die( [ 1..10 ] );
+    $result{array_ref} .= $_ while <STDOUT>;
+
+    CGI::Carp::die( { a => 1 } );
+    $result{hash_ref} .= $_ while <STDOUT>;
+
+    CGI::Carp::die( sub { 'Farewell' } );
+    $result{code_ref} .= $_ while <STDOUT>;
+
+    CGI::Carp::die( My::Plain::Object->new );
+    $result{plain_object} .= $_ while <STDOUT>;
+
+    CGI::Carp::die( My::Stringified::Object->new );
+    $result{string_object} .= $_ while <STDOUT>;
+
+    CGI::Carp::die();
+    $result{no_args} .= $_ while <STDOUT>;
+
+    untie *STDOUT;
+
+    like $result{string}    => qr/regular string/, 'regular string, wrapped';
+    like $result{array_ref} => qr/ARRAY\(\w+?\)/,  'array ref, wrapped';
+    like $result{hash_ref}  => qr/HASH\(\w+?\)/,   'hash ref, wrapped';
+    like $result{code_ref}  => qr/CODE\(\w+?\)/,   'code ref, wrapped';
+    like $result{plain_object} => qr/My::Plain::Object/,
+      'plain object, wrapped';
+    like $result{string_object} => qr/stringified/,
+      'stringified object, wrapped';
+    like $result{no_args} => qr/Died at/, 'no args, wrapped';
+
+}
+
+{
+    package My::Plain::Object;
+
+    sub new {
+        return bless {}, shift;
+    }
+}
+
+{
+    package My::Stringified::Object;
+
+    use overload '""' => sub { 'stringified' };
+
+    sub new {
+        return bless {}, shift;
+    }
+}
diff --git a/cpan/CGI/t/function.t b/cpan/CGI/t/function.t
index 316b5858a6..101333953f 100644
--- a/cpan/CGI/t/function.t
+++ b/cpan/CGI/t/function.t
@@ -32,11 +32,6 @@ if ($^O eq 'VMS') { $CRLF = "\n"; }
 
 if (ord("\t") != 9) { $CRLF = "\r\n"; }
 
-# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII
-# translation hence CRLF is used as \r\n within CGI.pm on such machines.
-
-if (ord("\t") != 9) { $CRLF = "\r\n"; }
- 
 # Set up a CGI environment
 $ENV{REQUEST_METHOD}='GET';
 $ENV{QUERY_STRING}  ='game=chess&game=checkers&weather=dull';
diff --git a/cpan/CGI/t/url.t b/cpan/CGI/t/url.t
new file mode 100644
index 0000000000..16e20b6fc1
--- /dev/null
+++ b/cpan/CGI/t/url.t
@@ -0,0 +1,23 @@
+use strict;
+use warnings;
+
+use Test::More tests => 4;    # last test to print
+
+use CGI qw/ :all /;
+
+$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:8484';
+$ENV{SERVER_PROTOCOL}       = 'HTTP/1.0';
+$ENV{SERVER_PORT}           = 8080;
+$ENV{SERVER_NAME}           = 'the.good.ship.lollypop.com';
+
+is virtual_port() => 8484, 'virtual_port()';
+is server_port()  => 8080, 'server_port()';
+
+is url() => 'http://proxy:8484', 'url()';
+
+# let's see if we do the defaults right
+
+$ENV{HTTP_X_FORWARDED_HOST} = 'proxy:80';
+
+is url() => 'http://proxy', 'url() with default port';
+