Update to CGI 2.70, from Lincoln Stein.

p4raw-id: //depot/perl@6580

5 files changed, 103 insertions, 62 deletions

diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm
index 0a5c1218ee..5aea1985ec 100644
--- a/lib/CGI/Carp.pm
+++ b/lib/CGI/Carp.pm
@@ -142,6 +142,33 @@ of the error message that caused the script to die.  Example:
 In order to correctly intercept compile-time errors, you should call
 set_message() from within a BEGIN{} block.
 
+=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
+
+It is now also possible to make non-fatal errors appear as HTML
+comments embedded in the output of your program.  To enable this
+feature, export the new "warningsToBrowser" subroutine.  Since sending
+warnings to the browser before the HTTP headers have been sent would
+cause an error, any warnings are stored in an internal buffer until
+you call the warningsToBrowser() subroutine with a true argument:
+
+    use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
+    use CGI qw(:standard);
+    print header();
+    warningsToBrowser(1);
+
+You may also give a false argument to warningsToBrowser() to prevent
+warnings from being sent to the browser while you are printing some
+content where HTML comments are not allowed:
+
+    warningsToBrowser(0);    # disable warnings
+    print "<SCRIPT type=javascript><!--\n";
+    print_some_javascript_code();
+    print "//--></SCRIPT>\n";
+    warningsToBrowser(1);    # re-enable warnings
+
+Note: In this respect warningsToBrowser() differs fundamentally from
+fatalsToBrowser(), which you should never call yourself!
+
 =head1 CHANGE LOG
 
 1.05 carpout() added and minor corrections by Marc Hedlund
@@ -166,7 +193,11 @@ set_message() from within a BEGIN{} block.
 1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
 
 1.13 Added cluck() to make the module orthogonal with Carp.
-    More mod_perl related fixes.
+     More mod_perl related fixes.
+
+1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi):  Added
+     warningsToBrowser().  Replaced <CODE> tags with <PRE> in
+     fatalsToBrowser() output.
 
 =head1 AUTHORS
 
@@ -190,18 +221,11 @@ use Carp;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck);
-
-BEGIN {
-  $] >= 5.005
-    ? eval q#sub ineval { defined $^S ? $^S : _longmess() =~ /eval [\{\']/m }#
-    : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#;
-  $@ and die;
-}
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
 $main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.16';
+$CGI::Carp::VERSION = '1.20';
 $CGI::Carp::CUSTOM_MSG = undef;
 
 # fancy import routine detects and handles 'errorWrap' specially.
@@ -210,6 +234,7 @@ sub import {
     my(%routines);
     grep($routines{$_}++,@_,@EXPORT);
     $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
+    $WARN++ if $routines{'warningsToBrowser'};
     my($oldlevel) = $Exporter::ExportLevel;
     $Exporter::ExportLevel = 1;
     Exporter::import($pkg,keys %routines);
@@ -223,7 +248,7 @@ sub realdie { CORE::die(@_); }
 sub id {
     my $level = shift;
     my($pack,$file,$line,$sub) = caller($level);
-    my($id) = $file=~m|([^/]+)\z|;
+    my($id) = $file=~m|([^/]+)$|;
     return ($file,$line,$id);
 }
 
@@ -235,7 +260,7 @@ sub stamp {
 	$id = $file;
 	($pack,$file) = caller($frame++);
     } until !$file;
-    ($id) = $id=~m|([^/]+)\z|;
+    ($id) = $id=~m|([^/]+)$|;
     return "[$time] $id: ";
 }
 
@@ -243,23 +268,40 @@ sub warn {
     my $message = shift;
     my($file,$line,$id) = id(1);
     $message .= " at $file line $line.\n" unless $message=~/\n$/;
+    _warn($message) if $WARN;
     my $stamp = stamp;
     $message=~s/^/$stamp/gm;
     realwarn $message;
 }
 
+sub _warn {
+    my $msg = shift;
+    if ($EMIT_WARNINGS) {
+	# We need to mangle the message a bit to make it a valid HTML
+	# comment.  This is done by substituting similar-looking ISO
+	# 8859-1 characters for <, > and -.  This is a hack.
+	$msg =~ tr/<>-/\253\273\255/;
+	chomp $msg;
+	print STDOUT "<!-- warning: $msg -->\n";
+    } else {
+	push @WARNINGS, $msg;
+    }
+}
+
+sub ineval { _longmess() =~ /eval [\{\']/m }
+
 # The mod_perl package Apache::Registry loads CGI programs by calling
 # eval.  These evals don't count when looking at the stack backtrace.
 sub _longmess {
     my $message = Carp::longmess();
     my $mod_perl = exists $ENV{MOD_PERL};
     $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
-    return( $message );    
+    return $message;    
 }
 
 sub die {
   realdie @_ if ineval;
-  my $message = shift;
+  my ($message) = @_;
   my $time = scalar(localtime);
   my($file,$line,$id) = id(1);
   $message .= " at $file line $line." unless $message=~/\n$/;
@@ -299,6 +341,11 @@ sub carpout {
 	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
 }
 
+sub warningsToBrowser {
+    $EMIT_WARNINGS = @_ ? shift : 1;
+    _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
+}
+
 # headers
 sub fatalsToBrowser {
     my($msg) = @_;
@@ -318,6 +365,8 @@ END
     print STDOUT "Content-type: text/html\n\n" 
 	unless $mod_perl;
 
+    warningsToBrowser(1);    # emit warnings before dying
+
     if ($CUSTOM_MSG) {
 	if (ref($CUSTOM_MSG) eq 'CODE') {
 	    &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
@@ -329,7 +378,7 @@ END
     
     my $mess = <<END;
 <H1>Software error:</H1>
-<CODE>$msg</CODE>
+<PRE>$msg</PRE>
 <P>
 $outer_message
 END
diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm
index 575ae79458..8c5ac1efc6 100644
--- a/lib/CGI/Cookie.pm
+++ b/lib/CGI/Cookie.pm
@@ -40,17 +40,18 @@ sub raw_fetch {
     my %results;
     my($key,$value);
 
-    my(@pairs) = split("; ",$raw_cookie);
+    my(@pairs) = split("; ?",$raw_cookie);
     foreach (@pairs) {
-	if (/^([^=]+)=(.*)/) {
-	    $key = $1;
-	    $value = $2;
-	}
-	else {
-	    $key = $_;
-	    $value = '';
-	}
-	$results{$key} = $value;
+      s/\s*(.*?)\s*/$1/;
+      if (/^([^=]+)=(.*)/) {
+	$key = $1;
+	$value = $2;
+      }
+      else {
+	$key = $_;
+	$value = '';
+      }
+      $results{$key} = $value;
     }
     return \%results unless wantarray;
     return %results;
@@ -60,17 +61,18 @@ sub parse {
     my ($self,$raw_cookie) = @_;
     my %results;
 
-    my(@pairs) = split("; ",$raw_cookie);
+    my(@pairs) = split("; ?",$raw_cookie);
     foreach (@pairs) {
-	my($key,$value) = split("=");
-	my(@values) = map unescape($_),split('&',$value);
-	$key = unescape($key);
-	# Some foreign cookies are not in name=value format, so ignore
-	# them.
-	next if !defined($value);
-	# A bug in Netscape can cause several cookies with same name to
-	# appear.  The FIRST one in HTTP_COOKIE is the most recent version.
-	$results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+      s/\s*(.*?)\s*/$1/;
+      my($key,$value) = split("=");
+      my(@values) = map unescape($_),split('&',$value);
+      $key = unescape($key);
+      # Some foreign cookies are not in name=value format, so ignore
+      # them.
+      next if !defined($value);
+      # A bug in Netscape can cause several cookies with same name to
+      # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
+      $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
     }
     return \%results unless wantarray;
     return %results;
@@ -382,7 +384,7 @@ Get or set the cookie's value.  Example:
 	$value = $c->value;
 	@new_value = $c->value(['a','b','c','d']);
 
-B<value()> is context sensitive.  In a list context it will return
+B<value()> is context sensitive.  In an array context it will return
 the current value of the cookie as an array.  In a scalar context it
 will return the B<first> value of a multivalued cookie.
 
diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm
index 20173f9acf..d348807d68 100644
--- a/lib/CGI/Pretty.pm
+++ b/lib/CGI/Pretty.pm
@@ -72,7 +72,7 @@ sub _make_tag_func {
 		\$attr = " \@attr" if \@attr;
 	    }
 
-	    my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
+	    my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
 	    return \$tag unless \@_;
 
 	    my \@result;
@@ -128,7 +128,7 @@ sub initialize_globals {
     $CGI::Pretty::LINEBREAK = "\n";
 
     # These tags are not prettify'd.
-    @CGI::Pretty::AS_IS = qw( A PRE CODE SCRIPT TEXTAREA );
+    @CGI::Pretty::AS_IS = qw( a pre code script textarea );
 
     1;
 }
diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm
index 6b8e012a15..83002f2336 100644
--- a/lib/CGI/Push.pm
+++ b/lib/CGI/Push.pm
@@ -16,7 +16,7 @@ package CGI::Push;
 # The most recent version and complete docs are available at:
 #   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::Push::VERSION='1.02';
+$CGI::Push::VERSION='1.03';
 use CGI;
 use CGI::Util 'rearrange';
 @ISA = ('CGI');
@@ -60,7 +60,7 @@ sub do_push {
     while (1) {
 	last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]);
 	print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" 
-	    unless $type eq 'dynamic';
+	    unless $type =~ /^dynamic|heterogeneous$/i;
 	print @contents,"$CGI::CRLF";
 	print "${boundary}$CGI::CRLF";
 	do_sleep($self->push_delay()) if $self->push_delay();
diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm
index cb6dd8a9e2..ac7376d41a 100644
--- a/lib/CGI/Util.pm
+++ b/lib/CGI/Util.pm
@@ -1,13 +1,5 @@
 package CGI::Util;
 
-=pod
-
-=head1 NAME
-
-CGI::Util - various utilities
-
-=cut
-
 use strict;
 use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
 require Exporter;
@@ -56,14 +48,14 @@ sub rearrange {
     my ($i,%pos);
     $i = 0;
     foreach (@$order) {
-	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
+	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
 	$i++;
     }
 
     my (@result,%leftover);
     $#result = $#$order;  # preextend
     while (@param) {
-	my $key = uc(shift(@param));
+	my $key = lc(shift(@param));
 	$key =~ s/^\-//;
 	if (exists $pos{$key}) {
 	    $result[$pos{$key}] = shift(@param);
@@ -72,7 +64,7 @@ sub rearrange {
 	}
     }
 
-    push (@result,make_attributes(\%leftover)) if %leftover;
+    push (@result,make_attributes(\%leftover,1)) if %leftover;
     @result;
 }
 
@@ -84,7 +76,7 @@ sub make_attributes {
     foreach (keys %{$attr}) {
 	my($key) = $_;
 	$key=~s/^\-//;     # get rid of initial - if present
-	$key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
+	$key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
 	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
 	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
     }
@@ -92,16 +84,14 @@ sub make_attributes {
 }
 
 sub simple_escape {
-  return unless defined (my $toencode = shift);
-  $toencode =~ s{(.)}{
-              if    ($1 eq '<')                            { '&lt;'    }
-              elsif ($1 eq '>')                            { '&gt;'    }
-              elsif ($1 eq '&')                            { '&amp;'   }
-              elsif ($1 eq '"')                            { '&quot;'  }
-              elsif ($1 eq "\x8b")                         { '&#139;'  }
-              elsif ($1 eq "\x9b")                         { '&#155;'  }
-              else                                         { $1        }
-       }gsex;
+  return unless defined(my $toencode = shift);
+  $toencode =~ s{&}{&amp;}gso;
+  $toencode =~ s{<}{&lt;}gso;
+  $toencode =~ s{>}{&gt;}gso;
+  $toencode =~ s{\"}{&quot;}gso;
+# Doesn't work.  Can't work.  forget it.
+#  $toencode =~ s{\x8b}{&#139;}gso;
+#  $toencode =~ s{\x9b}{&#155;}gso;
   $toencode;
 }