Upgrade to CGI.pm 2.77.

p4raw-id: //depot/perl@11689

4 files changed, 109 insertions, 8 deletions

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");