X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/29ddc2a4443cff956621f7b060b68c8ff93220d4..0ecadccd45b827b7dab28b1089e2750d85f803c5:/lib/CGI.pm

diff --git a/lib/CGI.pm b/lib/CGI.pm
index 94c4e65..f5ecc2d 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.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.
@@ -177,20 +177,18 @@ $IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
 
 # 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;
   }
 }
 
@@ -233,7 +231,8 @@ if ($needs_binmode) {
 			  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
@@ -330,7 +329,7 @@ sub new {
   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);
   }
@@ -339,14 +338,16 @@ sub new {
     $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);
     }
@@ -889,6 +890,7 @@ sub element_id {
 
 sub element_tab {
   my ($self,$new_value) = self_or_default(@_);
+  $self->{'.etab'} ||= 1;
   $self->{'.etab'} = $new_value if defined $new_value;
   $self->{'.etab'}++;
 }
@@ -1133,7 +1135,7 @@ END_OF_FUNC
 ####
 '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) {
@@ -2608,18 +2610,6 @@ sub url {
     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://";
@@ -2737,9 +2727,8 @@ sub path_info {
 	$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;
 
@@ -2748,6 +2737,33 @@ sub path_info {
 }
 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'
@@ -2778,6 +2794,16 @@ sub path_translated {
 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
@@ -2933,10 +2959,14 @@ END_OF_FUNC
 ####
 '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
 
@@ -3875,9 +3905,12 @@ CGI - Simple Common Gateway Interface Class
         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;
    }
 
@@ -5938,7 +5971,7 @@ for each option element within the optgroup.
 =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
@@ -6645,7 +6678,7 @@ Netscape versions 2.0 and higher incorporate an interpreted language
 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
@@ -7345,13 +7378,15 @@ To make it easier to port existing programs that use cgi-lib.pl the
 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,