Upgrade to CGI.pm 2.77.

p4raw-id: //depot/perl@11689

5 files changed, 130 insertions, 23 deletions

diff --git a/lib/CGI.pm b/lib/CGI.pm
index fe0fb323ad..3e8ed35be4 100644
--- a/lib/CGI.pm
+++ b/lib/CGI.pm
@@ -18,8 +18,8 @@ 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.49 2001/02/04 23:08:39 lstein Exp $';
-$CGI::VERSION='2.753';
+$CGI::revision = '$Id: CGI.pm,v 1.51 2001/08/07 12:28:43 lstein Exp $';
+$CGI::VERSION='2.77';
 
 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -546,7 +546,7 @@ sub parse_params {
     my($param,$value);
     foreach (@pairs) {
 	($param,$value) = split('=',$_,2);
-	next if $NO_UNDEF_PARAMS and not $value;
+	next if $NO_UNDEF_PARAMS and not defined $value;
 	$value = '' unless defined $value;
 	$param = unescape($param);
 	$value = unescape($value);
@@ -1034,7 +1034,7 @@ sub Dump {
 	}
 	push(@result,"</UL>");
     }
-    push(@result,"</UL>\n");
+    push(@result,"</UL>");
     return join("\n",@result);
 }
 END_OF_FUNC
@@ -1203,6 +1203,7 @@ sub header {
     foreach (@other) {
         next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
 	($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
+        $header = ucfirst($header);
     }
 
     $type ||= 'text/html' unless defined($type);
@@ -1231,7 +1232,7 @@ sub header {
     push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
     push(@header,"Pragma: no-cache") if $self->cache();
     push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
-    push(@header,@other);
+    push(@header,map {ucfirst $_} @other);
     push(@header,"Content-Type: $type") if $type ne '';
 
     my $header = join($CRLF,@header)."${CRLF}${CRLF}";
@@ -2100,7 +2101,7 @@ sub popup_menu {
 	$result .= "<option $selectit value=\"$value\">$label</option>\n";
     }
 
-    $result .= "</select>\n";
+    $result .= "</select>";
     return $result;
 }
 END_OF_FUNC
@@ -2153,7 +2154,7 @@ sub scrolling_list {
 	my($value)=$self->escapeHTML($_,1);
 	$result .= "<option $selectit value=\"$value\">$label</option>\n";
     }
-    $result .= "</select>\n";
+    $result .= "</select>";
     $self->register_parameter($name);
     return $result;
 }
@@ -2915,7 +2916,7 @@ sub read_multipart {
 	    last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
             $seqno += int rand(100);
           }
-          die "CGI open of tmpfile: $!\n" unless $filehandle;
+          die "CGI open of tmpfile: $!\n" unless defined $filehandle;
 	  $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
 
 	  my ($data);
@@ -3112,7 +3113,7 @@ sub new {
 
 	# BUG: IE 3.01 on the Macintosh uses just the boundary -- not
 	# the two extra hyphens.  We do a special case here on the user-agent!!!!
-	$boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac');
+	$boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
 
     } else { # otherwise we find it ourselves
 	my($old);
@@ -6261,12 +6262,17 @@ mode, CGI.pm will output the necessary extra header information when
 the header() and redirect() methods are
 called.
 
-The Microsoft Internet Information Server requires NPH mode.  As of version
-2.30, CGI.pm will automatically detect when the script is running under IIS
-and put itself into this mode.  You do not need to do this manually, although
-it won't hurt anything if you do.
-
-There are a number of ways to put CGI.pm into NPH mode:
+The Microsoft Internet Information Server requires NPH mode.  As of
+version 2.30, CGI.pm will automatically detect when the script is
+running under IIS and put itself into this mode.  You do not need to
+do this manually, although it won't hurt anything if you do.  However,
+note that if you have applied Service Pack 6, much of the
+functionality of NPH scripts, including the ability to redirect while
+setting a cookie, b<do not work at all> on IIS without a special patch
+from Microsoft.  See
+http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
+Non-Parsed Headers Stripped From CGI Applications That Have nph-
+Prefix in Name.
 
 =over 4
 
diff --git a/lib/CGI/Fast.pm b/lib/CGI/Fast.pm
index b4851862dc..669b38e010 100644
--- a/lib/CGI/Fast.pm
+++ b/lib/CGI/Fast.pm
@@ -16,7 +16,7 @@ package CGI::Fast;
 # The most recent version and complete docs are available at:
 #   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
 #   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
-$CGI::Fast::VERSION='1.02';
+$CGI::Fast::VERSION='1.04';
 
 use CGI;
 use FCGI;
@@ -31,13 +31,32 @@ sub save_request {
     # no-op
 }
 
+# If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle
+# in this package variable.
+use vars qw($Ext_Request);
+BEGIN {
+   # If ENV{FCGI_SOCKET_PATH} is given, explicitly open the socket,
+   # and keep the request handle around from which to call Accept().
+   if ($ENV{FCGI_SOCKET_PATH}) {
+	my $path    = $ENV{FCGI_SOCKET_PATH};
+	my $backlog = $ENV{FCGI_LISTEN_QUEUE} || 100;
+	my $socket  = FCGI::OpenSocket( $path, $backlog );
+	$Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR, 
+					\%ENV, $socket, 1 );
+   }
+}
+
 # New is slightly different in that it calls FCGI's
 # accept() method.
 sub new {
      my ($self, $initializer, @param) = @_;
      unless (defined $initializer) {
+	if ($Ext_Request) {
+          return undef unless $Ext_Request->Accept() >= 0;
+	} else {
          return undef unless FCGI::accept() >= 0;
      }
+     }
      return $CGI::Q = $self->SUPER::new($initializer, @param);
 }
 
@@ -139,7 +158,7 @@ the Apache server, the following line must be added to srm.conf:
 FastCGI scripts must end in the extension .fcgi.  For each script you
 install, you must add something like the following to srm.conf:
 
-   AppClass /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
+    FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
 
 This instructs Apache to launch two copies of file_upload.fcgi at 
 startup time.
@@ -150,6 +169,43 @@ Any script that works correctly as a FastCGI script will also work
 correctly when installed as a vanilla CGI script.  However it will
 not see any performance benefit.
 
+=head1 EXTERNAL FASTCGI SERVER INVOCATION
+
+FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run
+external to the webserver, perhaps on a remote machine.  To configure the
+webserver to connect to an external FastCGI server, you would add the following
+to your srm.conf:
+
+    FastCgiExternalServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -host sputnik:8888
+
+Two environment variables affect how the C<CGI::Fast> object is created,
+allowing C<CGI::Fast> to be used as an external FastCGI server.  (See C<FCGI>
+documentation for C<FCGI::OpenSocket> for more information.)
+
+=over
+
+=item FCGI_SOCKET_PATH
+
+The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI
+script to which bind an listen for incoming connections from the web server.
+
+=item FCGI_LISTEN_QUEUE
+
+Maximum length of the queue of pending connections.  
+
+=back
+
+For example:
+
+    #!/usr/local/bin/perl    # must be a FastCGI version of perl!
+    use CGI::Fast;
+    &do_some_initialization();
+    $ENV{FCGI_SOCKET_PATH} = "sputnik:8888";
+    $ENV{FCGI_LISTEN_QUEUE} = 100;
+    while ($q = new CGI::Fast) {
+	&process_request($q);
+    }
+
 =head1 CAVEATS
 
 I haven't tested this very much.
diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm
index aba0ba5834..2b48ff2531 100644
--- a/lib/CGI/Util.pm
+++ b/lib/CGI/Util.pm
@@ -115,7 +115,12 @@ sub make_attributes {
     foreach (keys %{$attr}) {
 	my($key) = $_;
 	$key=~s/^\-//;     # get rid of initial - if present
-	$key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
+
+	# old way: breaks EBCDIC!
+	# $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
+
+	($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/);
     }
@@ -134,6 +139,45 @@ sub simple_escape {
   $toencode;
 }
 
+sub utf8_chr ($) {
+        my $c = shift(@_);
+
+        if ($c < 0x80) {
+                return sprintf("%c", $c);
+        } elsif ($c < 0x800) {
+                return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f));
+        } elsif ($c < 0x10000) {
+                return sprintf("%c%c%c",
+                                           0xe0 |  ($c >> 12),
+                                           0x80 | (($c >>  6) & 0x3f),
+                                           0x80 | ( $c          & 0x3f));
+        } elsif ($c < 0x200000) {
+                return sprintf("%c%c%c%c",
+                                           0xf0 |  ($c >> 18),
+                                           0x80 | (($c >> 12) & 0x3f),
+                                           0x80 | (($c >>  6) & 0x3f),
+                                           0x80 | ( $c          & 0x3f));
+        } elsif ($c < 0x4000000) {
+                return sprintf("%c%c%c%c%c",
+                                           0xf8 |  ($c >> 24),
+                                           0x80 | (($c >> 18) & 0x3f),
+                                           0x80 | (($c >> 12) & 0x3f),
+                                           0x80 | (($c >>  6) & 0x3f),
+                                           0x80 | ( $c          & 0x3f));
+
+        } elsif ($c < 0x80000000) {
+                return sprintf("%c%c%c%c%c%c",
+                                           0xfe |  ($c >> 30),
+                                           0x80 | (($c >> 24) & 0x3f),
+                                           0x80 | (($c >> 18) & 0x3f),
+                                           0x80 | (($c >> 12) & 0x3f),
+                                           0x80 | (($c >> 6)  & 0x3f),
+                                           0x80 | ( $c          & 0x3f));
+        } else {
+                return utf8(0xfffd);
+        }
+}
+
 # unescape URL-encoded data
 sub unescape {
   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
@@ -144,7 +188,8 @@ sub unescape {
     if ($EBCDIC) {
       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
     } else {
-      $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
+      $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
+	defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
     }
   return $todecode;
 }
diff --git a/lib/CGI/t/form.t b/lib/CGI/t/form.t
index 2922903499..05d1b49396 100755
--- a/lib/CGI/t/form.t
+++ b/lib/CGI/t/form.t
@@ -80,7 +80,7 @@ test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq
 test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq 
      qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage),
      'checkbox_group()');
-test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()');
+test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1)."\n" eq <<END,'checkbox_group()');
 <select name="game">
 <option  value="checkers">checkers</option>
 <option  value="chess">chess</option>
diff --git a/lib/CGI/t/function.t b/lib/CGI/t/function.t
index b670e33cd7..9f5deb8e79 100755
--- a/lib/CGI/t/function.t
+++ b/lib/CGI/t/function.t
@@ -105,7 +105,7 @@ if ($Config{d_fork}) {
   print "ok 23 # Skip\n";
   print "ok 24 # Skip\n";
 }
-test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
+test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}Location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1");
 my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html');
-test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
-test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
+test(26,$h eq "Status: 302 Moved${CRLF}Location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");
+test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}Location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2");