Upgrade to CGI.pm 2.97.

p4raw-id: //depot/perl@19984

2 files changed, 73 insertions, 39 deletions

diff --git a/lib/CGI.pm b/lib/CGI.pm
index ecdb16448b..a30bb9ef0a 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.112 2003/04/28 13:35:56 lstein Exp $';
-$CGI::VERSION='2.93';
+$CGI::revision = '$Id: CGI.pm,v 1.125 2003/06/16 18:54:19 lstein Exp $';
+$CGI::VERSION='2.97';
 
 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -221,7 +221,7 @@ if ($needs_binmode) {
 			   base body Link nextid title meta kbd start_html end_html
 			   input Select option comment charset escapeHTML/],
 		':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param 
-			   embed basefont style span layer ilayer font frameset frame script small big/],
+			   embed basefont style span layer ilayer font frameset frame script small big Area Map/],
                 ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
                             ins label legend noframes noscript object optgroup Q 
                             thead tbody tfoot/], 
@@ -238,7 +238,6 @@ if ($needs_binmode) {
 			 remote_user user_name header redirect import_names put 
 			 Delete Delete_all url_param cgi_error/],
 		':ssl' => [qw/https/],
-		':imagemap' => [qw/Area Map/],
 		':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
 		':html' => [qw/:html2 :html3 :html4 :netscape/],
 		':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
@@ -445,6 +444,12 @@ sub init {
 
       # avoid unreasonably large postings
       if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
+	# quietly read and discard the post
+	  my $buffer;
+	  my $max = $content_length;
+	  while ($max > 0 && (my $bytes = read(STDIN,$buffer,$max < 10000 ? $max : 10000))) {
+	    $max -= $bytes;
+	  }
 	  $self->cgi_error("413 Request entity too large");
 	  last METHOD;
       }
@@ -529,7 +534,8 @@ sub init {
 # YL: Begin Change for XML handler 10/19/2001
     if ($meth eq 'POST'
         && defined($ENV{'CONTENT_TYPE'})
-        && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| ) {
+        && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
+	&& $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
         my($param) = 'POSTDATA' ;
         $self->add_parameter($param) ;
       push (@{$self->{$param}},$query_string);
@@ -662,7 +668,7 @@ sub _make_tag_func {
 	    my(\@attr) = make_attributes(\$a,\$q->{'escape'});
 	    \$attr = " \@attr" if \@attr;
 	  } else {
-	    unshift \@rest,\$a;
+	    unshift \@rest,\$a if defined \$a;
 	  }
 	);
     if ($tagname=~/start_(\w+)/i) {
@@ -671,8 +677,7 @@ sub _make_tag_func {
 	$func .= qq! return "<\L/$1\E>"; } !;
     } else {
 	$func .= qq#
-\#	    return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@_;
-	    return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest && defined(\$rest[0]);
+	    return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
 	    my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
 	    my \@result = map { "\$tag\$_\$untag" } 
                               (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
@@ -839,8 +844,8 @@ END_OF_FUNC
 ####
 sub delete {
     my($self,@p) = self_or_default(@_);
-    my($name) = rearrange([NAME],@p);
-    my @to_delete = ref($name) eq 'ARRAY' ? @$name : ($name);
+    my(@names) = rearrange([NAME],@p);
+    my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
     my %to_delete;
     foreach my $name (@to_delete)
     {
@@ -1051,7 +1056,7 @@ EOF
 'delete_all' => <<'EOF',
 sub delete_all {
     my($self) = self_or_default(@_);
-    my @param = $self->param;
+    my @param = $self->param();
     $self->delete(@param);
 }
 EOF
@@ -1136,12 +1141,12 @@ sub Dump {
     push(@result,"<ul>");
     foreach $param ($self->param) {
 	my($name)=$self->escapeHTML($param);
-	push(@result,"<li><strong>$param</strong>");
+	push(@result,"<li><strong>$param</strong></li>");
 	push(@result,"<ul>");
 	foreach $value ($self->param($param)) {
 	    $value = $self->escapeHTML($value);
-            $value =~ s/\n/<br>\n/g;
-	    push(@result,"<li>$value");
+            $value =~ s/\n/<br />\n/g;
+	    push(@result,"<li>$value</li>");
 	}
 	push(@result,"</ul>");
     }
@@ -1504,32 +1509,35 @@ sub _style {
     my $cdata_end   = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
 
     if (ref($style)) {
-     my($src,$code,$verbatim,$stype,@other) =
+     my($src,$code,$verbatim,$stype,$foo,@other) =
          rearrange([SRC,CODE,VERBATIM,TYPE],
-                    '-foo'=>'bar', # a trick to allow the '-' to be omitted
+                    '-foo'=>'bar',    # trick to allow dash to be omitted
                     ref($style) eq 'ARRAY' ? @$style : %$style);
-     $type = $stype if $stype;
-     
+     $type  = $stype if $stype;
+     my $other = @other ? join ' ',@other : '';
+
      if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
      { # If it is, push a LINK tag for each one
          foreach $src (@$src)
        {
-         push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
-                             : qq(<link rel="stylesheet" type="$type" href="$src">)) if $src;
+         push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+                             : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src;
        }
      }
      else
      { # Otherwise, push the single -src, if it exists.
-       push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
-                           : qq(<link rel="stylesheet" type="$type" href="$src">)
+       push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+                           : qq(<link rel="stylesheet" type="$type" href="$src"$other>)
             ) if $src;
       }
       if ($verbatim) {
          push(@result, "<style type=\"text/css\">\n$verbatim\n</style>");
-    }      
+    }
       push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
     } else {
-     push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
+         my $src = $style;
+         push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>)
+                             : qq(<link rel="stylesheet" type="$type" href="$src"$other>));
     }
     @result;
 }
@@ -1632,6 +1640,7 @@ sub startform {
            $action .= "?$ENV{QUERY_STRING}";
        }
     }
+    $action =~ s/\"/%22/g;  # fix cross-site scripting bug reported by obscure
     $action = qq(action="$action");
     my($other) = @other ? " @other" : '';
     $self->{'.parametersToAdd'}={};
@@ -1875,7 +1884,6 @@ END_OF_FUNC
 sub reset {
     my($self,@p) = self_or_default(@_);
     my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@p);
-    warn "label = $label, value = $value";
     $label=$self->escapeHTML($label);
     $value=$self->escapeHTML($value,1);
     my ($name) = ' name=".reset"';
@@ -6460,6 +6468,26 @@ This will generate an HTML header that contains this:
    @import url("/server-common/css/main.css");
    </style>
 
+Any additional arguments passed in the -style value will be
+incorporated into the <link> tag.  For example:
+
+ start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
+			  -media => 'all'});
+
+This will give:
+
+ <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
+ <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
+
+<p>
+
+To make more complicated <link> tags, use the Link() function
+and pass it to start_html() in the -head argument, as in:
+
+  @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
+        Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
+  print start_html({-head=>\@h})
+
 =head1 DEBUGGING
 
 If you are running the script from the command line or in the perl
@@ -6595,7 +6623,6 @@ Returns either the remote host name or IP address.
 if the former is unavailable.
 
 =item B<script_name()>
-
 Return the script name as a partial URL, for self-refering
 scripts.
 
diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm
index 3ae9c5be7d..8420eb2d67 100644
--- a/lib/CGI/Carp.pm
+++ b/lib/CGI/Carp.pm
@@ -239,6 +239,10 @@ non-overridden program name
 1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
      for overriding program name.
 
+1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
+     former isn't working in some people's hands.  There is no such thing
+     as reliable exception handling in Perl.
+
 =head1 AUTHORS
 
 Copyright 1995-2002, Lincoln D. Stein.  All rights reserved.  
@@ -262,18 +266,23 @@ CGI::Response
 require 5.000;
 use Exporter;
 #use Carp;
-BEGIN { require Carp; }
+BEGIN { 
+  require Carp; 
+  *CORE::GLOBAL::die = \&CGI::Carp::die;
+}
+
 use File::Spec;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name=);
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name= die);
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
-*CORE::GLOBAL::die = \&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.25';
+
+$CGI::Carp::VERSION    = '1.26';
 $CGI::Carp::CUSTOM_MSG = undef;
 
+
 # fancy import routine detects and handles 'errorWrap' specially.
 sub import {
     my $pkg = shift;
@@ -294,6 +303,8 @@ sub import {
     $Exporter::ExportLevel = 1;
     Exporter::import($pkg,keys %routines);
     $Exporter::ExportLevel = $oldlevel;
+    $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
+#    $pkg->export('CORE::GLOBAL','die');
 }
 
 # These are the originals
@@ -442,7 +453,7 @@ END
       $outer_message = $CUSTOM_MSG;
     }
   }
-    
+
   my $mess = <<END;
 <h1>Software error:</h1>
 <pre>$msg</pre>
@@ -451,7 +462,7 @@ $outer_message
 </p>
 END
   ;
-  
+
   if ($mod_perl) {
     require mod_perl;
     if ($mod_perl::VERSION >= 1.99) {
@@ -472,15 +483,11 @@ END
       $r->print($mess);
       $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
     } else {
-      # MSIE browsers don't show the $mess when sent
-      # a custom 500 response.
+      # MSIE won't display a custom 500 response unless it is >512 bytes!
       if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
-	$r->send_http_header('text/html');
-	$r->print($mess);
-	$mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
-      } else {
-	$r->custom_response(500,$mess);
+        $mess = "<!-- " . (' ' x 513) . " -->\n$mess";
       }
+      $r->custom_response(500,$mess);
     }
   } else {
     print STDOUT $mess;