# 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.
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);
}
push(@result,"</UL>");
}
- push(@result,"</UL>\n");
+ push(@result,"</UL>");
return join("\n",@result);
}
END_OF_FUNC
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);
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}";
$result .= "<option $selectit value=\"$value\">$label</option>\n";
}
- $result .= "</select>\n";
+ $result .= "</select>";
return $result;
}
END_OF_FUNC
my($value)=$self->escapeHTML($_,1);
$result .= "<option $selectit value=\"$value\">$label</option>\n";
}
- $result .= "</select>\n";
+ $result .= "</select>";
$self->register_parameter($name);
return $result;
}
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);
# 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);
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
# 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;
# 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);
}
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.
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.
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/);
}
$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);
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;
}
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>
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");
projects / p5sagit/p5-mst-13.2.git / commitdiff