From: Jarkko Hietaniemi Date: Thu, 16 Aug 2001 11:29:30 +0000 (+0000) Subject: Upgrade to CGI.pm 2.77. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=69c89ae7c8e657da80c1a551520c53d86073f166;p=p5sagit%2Fp5-mst-13.2.git Upgrade to CGI.pm 2.77. p4raw-id: //depot/perl@11689 --- diff --git a/lib/CGI.pm b/lib/CGI.pm index fe0fb32..3e8ed35 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,""); } - push(@result,"\n"); + push(@result,""); 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 .= "\n"; } - $result .= "\n"; + $result .= ""; return $result; } END_OF_FUNC @@ -2153,7 +2154,7 @@ sub scrolling_list { my($value)=$self->escapeHTML($_,1); $result .= "\n"; } - $result .= "\n"; + $result .= ""; $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 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 b485186..669b38e 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 object is created, +allowing C to be used as an external FastCGI server. (See C +documentation for C 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 aba0ba5..2b48ff2 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 2922903..05d1b49 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(checkers chess cribbage), 'checkbox_group()'); -test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1)."\n" eq < diff --git a/lib/CGI/t/function.t b/lib/CGI/t/function.t index b670e33..9f5deb8 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");