# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.177 2005/03/09 21:04:48 lstein Exp $';
-$CGI::VERSION=3.06;
+$CGI::revision = '$Id: CGI.pm,v 1.185 2005/08/03 21:14:55 lstein Exp $';
+$CGI::VERSION='3.11_01';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
# Turn on special checking for Doug MacEachern's modperl
if (exists $ENV{MOD_PERL}) {
- eval "require mod_perl";
# mod_perl handlers may run system() on scripts using CGI.pm;
# Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
- if (defined $mod_perl::VERSION) {
- if ($mod_perl::VERSION >= 1.99) {
- $MOD_PERL = 2;
- require Apache::Response;
- require Apache::RequestRec;
- require Apache::RequestUtil;
- require APR::Pool;
- } else {
- $MOD_PERL = 1;
- require Apache;
- }
+ if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $MOD_PERL = 2;
+ require Apache2::Response;
+ require Apache2::RequestRec;
+ require Apache2::RequestUtil;
+ require Apache2::RequestIO;
+ require APR::Pool;
+ } else {
+ $MOD_PERL = 1;
+ require Apache;
}
}
submit reset defaults radio_group popup_menu button autoEscape
scrolling_list image_button start_form end_form startform endform
start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
+ ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
+ cookie Dump
raw_cookie request_method query_string Accept user_agent remote_host content_type
remote_addr referer server_name server_software server_port server_protocol virtual_port
virtual_host remote_ident auth_type http append
if (ref($initializer[0])
&& (UNIVERSAL::isa($initializer[0],'Apache')
||
- UNIVERSAL::isa($initializer[0],'Apache::RequestRec')
+ UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
)) {
$self->r(shift @initializer);
}
$self->upload_hook(shift @initializer, shift @initializer);
}
if ($MOD_PERL) {
- $self->r(Apache->request) unless $self->r;
- my $r = $self->r;
if ($MOD_PERL == 1) {
+ $self->r(Apache->request) unless $self->r;
+ my $r = $self->r;
$r->register_cleanup(\&CGI::_reset_globals);
}
else {
# XXX: once we have the new API
# will do a real PerlOptions -SetupEnv check
+ $self->r(Apache2::RequestUtil->request) unless $self->r;
+ my $r = $self->r;
$r->subprocess_env unless exists $ENV{REQUEST_METHOD};
$r->pool->cleanup_register(\&CGI::_reset_globals);
}
sub element_tab {
my ($self,$new_value) = self_or_default(@_);
+ $self->{'.etab'} ||= 1;
$self->{'.etab'} = $new_value if defined $new_value;
$self->{'.etab'}++;
}
####
'append' => <<'EOF',
sub append {
- my($self,@p) = @_;
+ my($self,@p) = self_or_default(@_);
my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
if (@values) {
my $path = $self->path_info;
my $script_name = $self->script_name;
- # for compatibility with Apache's MultiViews
- if (exists($ENV{REQUEST_URI})) {
- my $index;
- $script_name = unescape($ENV{REQUEST_URI});
- $script_name =~ s/\?.+$//s; # strip query string
- # and path
- if (exists($ENV{PATH_INFO})) {
- my $encoded_path = unescape($ENV{PATH_INFO});
- $script_name =~ s/\Q$encoded_path\E$//i;
- }
- }
-
if ($full) {
my $protocol = $self->protocol();
$url = "$protocol://";
$info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
$self->{'.path_info'} = $info;
} elsif (! defined($self->{'.path_info'}) ) {
- $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
- $ENV{'PATH_INFO'} : '';
-
+ my (undef,$path_info) = $self->_name_and_path_from_env;
+ $self->{'.path_info'} = $path_info || '';
# hack to fix broken path info in IIS
$self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
}
END_OF_FUNC
+# WE USE THIS TO COMPENSATE FOR A BUG IN APACHE 2 PRESENT AT LEAST UP THROUGH 2.0.54
+'_name_and_path_from_env' => <<'END_OF_FUNC',
+sub _name_and_path_from_env {
+ my $self = shift;
+ my $raw_script_name = $ENV{SCRIPT_NAME} || '';
+ my $raw_path_info = $ENV{PATH_INFO} || '';
+ my $uri = $ENV{REQUEST_URI} || '';
+
+ my @uri_double_slashes = $uri =~ m^(/{2,}?)^g;
+ my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;
+
+ my $apache_bug = @uri_double_slashes != @path_double_slashes;
+ return ($raw_script_name,$raw_path_info) unless $apache_bug;
+
+ my $path_info_search = $raw_path_info;
+ # these characters will not (necessarily) be escaped
+ $path_info_search =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg;
+ $path_info_search = quotemeta($path_info_search);
+ $path_info_search =~ s!/!/+!g;
+ if ($uri =~ m/^(.+)($path_info_search)/) {
+ return ($1,$2);
+ } else {
+ return ($raw_script_name,$raw_path_info);
+ }
+}
+END_OF_FUNC
+
#### Method: request_method
# Returns 'POST', 'GET', 'PUT' or 'HEAD'
END_OF_FUNC
+#### Method: request_uri
+# Return the literal request URI
+####
+'request_uri' => <<'END_OF_FUNC',
+sub request_uri {
+ return $ENV{'REQUEST_URI'};
+}
+END_OF_FUNC
+
+
#### Method: query_string
# Synthesize a query string from our current
# parameters
####
'script_name' => <<'END_OF_FUNC',
sub script_name {
- return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
- # These are for debugging
- return "/$0" unless $0=~/^\//;
- return $0;
+ my ($self,@p) = self_or_default(@_);
+ if (@p) {
+ $self->{'.script_name'} = shift;
+ } elsif (!exists $self->{'.script_name'}) {
+ my ($script_name,$path_info) = $self->_name_and_path_from_env();
+ $self->{'.script_name'} = $script_name;
+ }
+ return $self->{'.script_name'};
}
END_OF_FUNC
hr;
if (param()) {
- print "Your name is",em(param('name')),p,
- "The keywords are: ",em(join(", ",param('words'))),p,
- "Your favorite color is ",em(param('color')),
+ my $name = param('name');
+ my $keywords = join ', ',param('words');
+ my $color = param('color');
+ print "Your name is",em(escapeHTML($name)),p,
+ "The keywords are: ",em(escapeHTML($keywords)),p,
+ "Your favorite color is ",em(escapeHTML($color)),
hr;
}
=item 5.
An optional fifth parameter (-novals) can be set to a true value and
-indicates to suppress the val attribut in each option element within
+indicates to suppress the val attribute in each option element within
the optgroup.
See the discussion on optgroup at W3C
called JavaScript. Internet Explorer, 3.0 and higher, supports a
closely-related dialect called JScript. JavaScript isn't the same as
Java, and certainly isn't at all the same as Perl, which is a great
-pity. JavaScript allows you to programatically change the contents of
+pity. JavaScript allows you to programmatically change the contents of
fill-out forms, create new windows, and pop up dialog box from within
Netscape itself. From the point of view of CGI scripting, JavaScript
is quite useful for validating fill-out forms prior to submitting
compatibility routine "ReadParse" is provided. Porting is simple:
OLD VERSION
+
require "cgi-lib.pl";
&ReadParse;
print "The value of the antique is $in{antique}.\n";
NEW VERSION
+
use CGI;
- CGI::ReadParse;
+ CGI::ReadParse();
print "The value of the antique is $in{antique}.\n";
CGI.pm's ReadParse() routine creates a tied variable named %in,
https://perl5.git.perl.org / perl5.git / blobdiff