add CGI.pm v2.66 (from Lincoln Stein)

p4raw-id: //depot/perl@6029

5 files changed, 213 insertions, 27 deletions

diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm
index 90e9552c75..0a5c1218ee 100644
--- a/lib/CGI/Carp.pm
+++ b/lib/CGI/Carp.pm
@@ -194,14 +194,14 @@ use Carp;
 
 BEGIN {
   $] >= 5.005
-    ? eval q#sub ineval { $^S }#
-      : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#;
+    ? eval q#sub ineval { defined $^S ? $^S : _longmess() =~ /eval [\{\']/m }#
+    : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#;
   $@ and die;
 }
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
 $main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.14';
+$CGI::Carp::VERSION = '1.16';
 $CGI::Carp::CUSTOM_MSG = undef;
 
 # fancy import routine detects and handles 'errorWrap' specially.
@@ -335,8 +335,7 @@ $outer_message
 END
     ;
 
-    if ($mod_perl) {
-	my $r = Apache->request;
+    if ($mod_perl && (my $r = Apache->request)) {
 	# If bytes have already been sent, then
 	# we print the message out directly.
 	# Otherwise we make a custom error
diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm
index bd3c3d8875..9e5a14b47b 100644
--- a/lib/CGI/Cookie.pm
+++ b/lib/CGI/Cookie.pm
@@ -13,9 +13,9 @@ package CGI::Cookie;
 # wish, but if you redistribute a modified version, please attach a note
 # listing the modifications you have made.
 
-$CGI::Cookie::VERSION='1.12';
+$CGI::Cookie::VERSION='1.16';
 
-use CGI qw(-no_debug);
+use CGI::Util qw(rearrange unescape escape);
 use overload '""' => \&as_string,
     'cmp' => \&compare,
     'fallback'=>1;
@@ -63,8 +63,11 @@ sub parse {
     my(@pairs) = split("; ",$raw_cookie);
     foreach (@pairs) {
 	my($key,$value) = split("=");
-	my(@values) = map CGI::unescape($_),split('&',$value);
-	$key = CGI::unescape($key);
+	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);
@@ -77,7 +80,7 @@ sub new {
     my $class = shift;
     $class = ref($class) if ref($class);
     my($name,$value,$path,$domain,$secure,$expires) =
-	CGI->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
+      rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
 
     # Pull out our parameters.
     my @values;
@@ -97,7 +100,7 @@ sub new {
 	},$class;
 
     # IE requires the path and domain to be present for some reason.
-    $path   = CGI::url(-absolute=>1) unless defined $path;
+    $path   ||= '/';
 # however, this breaks networks which use host tables without fully qualified
 # names, so we comment it out.
 #    $domain = CGI::virtual_host()    unless defined $domain;
@@ -120,8 +123,8 @@ sub as_string {
     push(@constant_values,"expires=$expires") if $expires = $self->expires;
     push(@constant_values,'secure') if $secure = $self->secure;
 
-    my($key) = CGI::escape($self->name);
-    my($cookie) = join("=",$key,join("&",map CGI::escape($_),$self->value));
+    my($key) = escape($self->name);
+    my($cookie) = join("=",$key,join("&",map escape($_),$self->value));
     return join("; ",$cookie,@constant_values);
 }
 
@@ -163,7 +166,7 @@ sub secure {
 sub expires {
     my $self = shift;
     my $expires = shift;
-    $self->{'expires'} = CGI::expires($expires,'cookie') if defined $expires;
+    $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
     return $self->{'expires'};
 }
 
@@ -252,8 +255,8 @@ against your script's URL before returning the cookie.  For example,
 if you specify the path "/cgi-bin", then the cookie will be returned
 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
 "/cgi-bin/customer_service/complain.pl", but not to the script
-"/cgi-private/site_admin.pl".  By default, the path is set to your
-script, so that only it will receive the cookie.
+"/cgi-private/site_admin.pl".  By default, the path is set to "/", so
+that all scripts at your site will receive the cookie.
 
 =item B<4. secure flag>
 
diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm
index 4f2eed4ce9..20173f9acf 100644
--- a/lib/CGI/Pretty.pm
+++ b/lib/CGI/Pretty.pm
@@ -10,7 +10,7 @@ package CGI::Pretty;
 use strict;
 use CGI ();
 
-$CGI::Pretty::VERSION = '1.03';
+$CGI::Pretty::VERSION = '1.04';
 $CGI::DefaultClass = __PACKAGE__;
 $CGI::Pretty::AutoloadClass = 'CGI';
 @CGI::Pretty::ISA = qw( CGI );
@@ -62,15 +62,13 @@ sub _make_tag_func {
 	sub $tagname { 
 	    # handle various cases in which we're called
 	    # most of this bizarre stuff is to avoid -w errors
-	    shift if \$_[0] && 
-		(!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
-		    (ref(\$_[0]) &&
-		     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
-		    UNIVERSAL::isa(\$_[0],'CGI')));
-	    
+            shift if \$_[0] && 
+                    (ref(\$_[0]) &&
+                     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
+                    UNIVERSAL::isa(\$_[0],'CGI')));
 	    my(\$attr) = '';
 	    if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
-		my(\@attr) = make_attributes('',shift);
+		my(\@attr) = make_attributes(shift);
 		\$attr = " \@attr" if \@attr;
 	    }
 
diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm
index 80683a2e80..6b8e012a15 100644
--- a/lib/CGI/Push.pm
+++ b/lib/CGI/Push.pm
@@ -16,8 +16,9 @@ package CGI::Push;
 # The most recent version and complete docs are available at:
 #   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::Push::VERSION='1.01';
+$CGI::Push::VERSION='1.02';
 use CGI;
+use CGI::Util 'rearrange';
 @ISA = ('CGI');
 
 $CGI::DefaultClass = 'CGI::Push';
@@ -37,7 +38,7 @@ sub do_push {
 
     my (@header);
     my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,@other) =
-	$self->rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p);
+	rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p);
     $type = 'text/html' unless $type;
     $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
     $delay = 1 unless defined($delay);
@@ -53,7 +54,7 @@ sub do_push {
     push(@o,'-nph'=>1);
     print $self->header(@o);
     print "${boundary}$CGI::CRLF";
-    
+
     # now we enter a little loop
     my @contents;
     while (1) {
@@ -143,6 +144,9 @@ in such a way that it will replace what was there beforehand.  The
 technique will work with HTML pages as well as with graphics files, 
 allowing you to create animated GIFs.
 
+Only Netscape Navigator supports server push.  Internet Explorer
+browsers do not.
+
 =head1 USING CGI::Push
 
 CGI::Push adds one new method to the standard CGI suite, do_push().
diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm
new file mode 100644
index 0000000000..0a5c48b6f3
--- /dev/null
+++ b/lib/CGI/Util.pm
@@ -0,0 +1,182 @@
+package CGI::Util;
+
+use strict;
+use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
+
+$VERSION = '1.1';
+
+$EBCDIC = "\t" ne "\011";
+if ($EBCDIC) {
+@A2E = (
+  0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
+ 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
+240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
+124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
+215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
+121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
+151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
+ 32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
+ 48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
+ 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
+144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
+100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
+172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
+ 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
+140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
+      );
+}
+
+# Smart rearrangement of parameters to allow named parameter
+# calling.  We do the rearangement if:
+# the first parameter begins with a -
+sub rearrange {
+    my($order,@param) = @_;
+    return () unless @param;
+
+    if (ref($param[0]) eq 'HASH') {
+	@param = %{$param[0]};
+    } else {
+	return @param 
+	    unless (defined($param[0]) && substr($param[0],0,1) eq '-');
+    }
+
+    # map parameters into positional indices
+    my ($i,%pos);
+    $i = 0;
+    foreach (@$order) {
+	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
+	$i++;
+    }
+
+    my (@result,%leftover);
+    $#result = $#$order;  # preextend
+    while (@param) {
+	my $key = uc(shift(@param));
+	$key =~ s/^\-//;
+	if (exists $pos{$key}) {
+	    $result[$pos{$key}] = shift(@param);
+	} else {
+	    $leftover{$key} = shift(@param);
+	}
+    }
+
+    push (@result,make_attributes(\%leftover)) if %leftover;
+    @result;
+}
+
+sub make_attributes {
+    my $attr = shift;
+    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
+    my $escape = shift || 0;
+    my(@att);
+    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
+	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
+	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
+    }
+    return @att;
+}
+
+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;
+  $toencode;
+}
+
+# unescape URL-encoded data
+sub unescape {
+  shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
+  my $todecode = shift;
+  return undef unless defined($todecode);
+  $todecode =~ tr/+/ /;       # pluses become spaces
+    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;
+    }
+  return $todecode;
+}
+
+# URL-encode data
+sub escape {
+  shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
+  my $toencode = shift;
+  return undef unless defined($toencode);
+  $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+  return $toencode;
+}
+
+# This internal routine creates date strings suitable for use in
+# cookies and HTTP headers.  (They differ, unfortunately.)
+# Thanks to Mark Fisher for this.
+sub expires {
+    my($time,$format) = @_;
+    $format ||= 'http';
+
+    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
+
+    # pass through preformatted dates for the sake of expire_calc()
+    $time = expire_calc($time);
+    return $time unless $time =~ /^\d+$/;
+
+    # make HTTP/cookie date string from GMT'ed time
+    # (cookies use '-' as date separator, HTTP uses ' ')
+    my($sc) = ' ';
+    $sc = '-' if $format eq "cookie";
+    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
+    $year += 1900;
+    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
+                   $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+}
+
+# This internal routine creates an expires time exactly some number of
+# hours from the current time.  It incorporates modifications from 
+# Mark Fisher.
+sub expire_calc {
+    my($time) = @_;
+    my(%mult) = ('s'=>1,
+                 'm'=>60,
+                 'h'=>60*60,
+                 'd'=>60*60*24,
+                 'M'=>60*60*24*30,
+                 'y'=>60*60*24*365);
+    # format for time can be in any of the forms...
+    # "now" -- expire immediately
+    # "+180s" -- in 180 seconds
+    # "+2m" -- in 2 minutes
+    # "+12h" -- in 12 hours
+    # "+1d"  -- in 1 day
+    # "+3M"  -- in 3 months
+    # "+2y"  -- in 2 years
+    # "-3m"  -- 3 minutes ago(!)
+    # If you don't supply one of these forms, we assume you are
+    # specifying the date yourself
+    my($offset);
+    if (!$time || (lc($time) eq 'now')) {
+        $offset = 0;
+    } elsif ($time=~/^\d+/) {
+        return $time;
+    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
+        $offset = ($mult{$2} || 1)*$1;
+    } else {
+        return $time;
+    }
+    return (time+$offset);
+}
+
+1;