perl5.005_03 (stock)

5 files changed, 256 insertions, 71 deletions

diff --git a/gnu/usr.bin/perl/lib/CGI/Apache.pm b/gnu/usr.bin/perl/lib/CGI/Apache.pm
index 6ea7523c571..d155f69439c 100644
--- a/gnu/usr.bin/perl/lib/CGI/Apache.pm
+++ b/gnu/usr.bin/perl/lib/CGI/Apache.pm
@@ -4,7 +4,7 @@ use vars qw(@ISA $VERSION);
 require CGI;
 @ISA = qw(CGI);
 
-$VERSION = (qw$Revision: 1.1 $)[1];
+$VERSION = (qw$Revision: 1.2 $)[1];
 $CGI::DefaultClass = 'CGI::Apache';
 $CGI::Apache::AutoloadClass = 'CGI';
 
@@ -78,7 +78,7 @@ CGI::Apache - Make things work with CGI.pm against Perl-Apache API
 =head1 DESCRIPTION
 
 When using the Perl-Apache API, your applications are faster, but the
-enviroment is different than CGI.
+environment is different than CGI.
 This module attempts to set-up that environment as best it can.
 
 =head1 NOTE 1
@@ -98,6 +98,6 @@ perl(1), Apache(3), CGI(3)
 
 =head1 AUTHOR
 
-Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas König E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt>
+Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt>
 
 =cut
diff --git a/gnu/usr.bin/perl/lib/CGI/Carp.pm b/gnu/usr.bin/perl/lib/CGI/Carp.pm
index 4cd79467fd8..dfae1a61b73 100644
--- a/gnu/usr.bin/perl/lib/CGI/Carp.pm
+++ b/gnu/usr.bin/perl/lib/CGI/Carp.pm
@@ -14,6 +14,12 @@ B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
     warn "I'm confused";
     die  "I'm dying.\n";
 
+    use CGI::Carp qw(cluck);
+    cluck "I wouldn't do that if I were you";
+
+    use CGI::Carp qw(fatalsToBrowser);
+    die "Fatal error messages are now sent to browser";
+
 =head1 DESCRIPTION
 
 CGI scripts have a nasty habit of leaving warning messages in the error
@@ -87,6 +93,8 @@ accepted as well:
 
     ... and so on
 
+FileHandle and other objects work as well.
+
 Use of carpout() is not great for performance, so it is recommended
 for debugging purposes or for moderate-use applications.  A future
 version of this module may delay redirecting STDERR until one of the
@@ -106,6 +114,34 @@ occur in the early compile phase will be seen.
 Nonfatal errors will still be directed to the log file only (unless redirected
 with carpout).
 
+=head2 Changing the default message
+
+By default, the software error message is followed by a note to
+contact the Webmaster by e-mail with the time and date of the error.
+If this message is not to your liking, you can change it using the
+set_message() routine.  This is not imported by default; you should
+import it on the use() line:
+
+    use CGI::Carp qw(fatalsToBrowser set_message);
+    set_message("It's not a bug, it's a feature!");
+
+You may also pass in a code reference in order to create a custom
+error message.  At run time, your code will be called with the text
+of the error message that caused the script to die.  Example:
+
+    use CGI::Carp qw(fatalsToBrowser set_message);
+    BEGIN {
+       sub handle_errors {
+          my $msg = shift;
+          print "<h1>Oh gosh</h1>";
+          print "Got an error: $msg";
+      }
+      set_message(\&handle_errors);
+    }
+
+In order to correctly intercept compile-time errors, you should call
+set_message() from within a BEGIN{} block.
+
 =head1 CHANGE LOG
 
 1.05 carpout() added and minor corrections by Marc Hedlund
@@ -114,11 +150,32 @@ with carpout).
 1.06 fatalsToBrowser() no longer aborts for fatal errors within
      eval() statements.
 
+1.08 set_message() added and carpout() expanded to allow for FileHandle
+     objects.
+
+1.09 set_message() now allows users to pass a code REFERENCE for 
+     really custom error messages.  croak and carp are now
+     exported by default.  Thanks to Gunther Birznieks for the
+     patches.
+
+1.10 Patch from Chris Dean (ctdean@cogit.com) to allow 
+     module to run correctly under mod_perl.
+
+1.11 Changed order of &gt; and &lt; escapes.
+
+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.
+
 =head1 AUTHORS
 
-Lincoln D. Stein <lstein@genome.wi.mit.edu>.  Feel free to redistribute
-this under the Perl Artistic License.
+Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.  
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
 
+Address bug reports and comments to: lstein@cshl.org
 
 =head1 SEE ALSO
 
@@ -133,18 +190,19 @@ use Carp;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser);
+@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck);
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
 $main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.06';
+$CGI::Carp::VERSION = '1.13';
+$CGI::Carp::CUSTOM_MSG = undef;
 
 # fancy import routine detects and handles 'errorWrap' specially.
 sub import {
     my $pkg = shift;
     my(%routines);
-    grep($routines{$_}++,@_);
-    $WRAP++ if $routines{'fatalsToBrowser'};
+    grep($routines{$_}++,@_,@EXPORT);
+    $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
     my($oldlevel) = $Exporter::ExportLevel;
     $Exporter::ExportLevel = 1;
     Exporter::import($pkg,keys %routines);
@@ -152,8 +210,8 @@ sub import {
 }
 
 # These are the originals
-sub realwarn { warn(@_); }
-sub realdie { die(@_); }
+sub realwarn { CORE::warn(@_); }
+sub realdie { CORE::die(@_); }
 
 sub id {
     my $level = shift;
@@ -183,26 +241,40 @@ sub warn {
     realwarn $message;
 }
 
+# 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 );    
+}
+
 sub die {
     my $message = shift;
     my $time = scalar(localtime);
     my($file,$line,$id) = id(1);
-    return undef if $file=~/^\(eval/;
-    $message .= " at $file line $line.\n" unless $message=~/\n$/;
-    &fatalsToBrowser($message) if $WRAP;
+    $message .= " at $file line $line." unless $message=~/\n$/;
+    &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m;
     my $stamp = stamp;
     $message=~s/^/$stamp/gm;
     realdie $message;
 }
 
+sub set_message {
+    $CGI::Carp::CUSTOM_MSG = shift;
+    return $CGI::Carp::CUSTOM_MSG;
+}
+
 # Avoid generating "subroutine redefined" warnings with the following
 # hack:
 {
     local $^W=0;
     eval <<EOF;
 sub confess { CGI::Carp::die Carp::longmess \@_; }
-sub croak { CGI::Carp::die Carp::shortmess \@_; }
-sub carp { CGI::Carp::warn Carp::shortmess \@_; }
+sub croak   { CGI::Carp::die Carp::shortmess \@_; }
+sub carp    { CGI::Carp::warn Carp::shortmess \@_; }
+sub cluck   { CGI::Carp::warn Carp::longmess \@_; }
 EOF
     ;
 }
@@ -211,14 +283,8 @@ EOF
 # or a string.
 sub carpout {
     my($in) = @_;
-    $in = $$in if ref($in); # compatability with Marc's method;
-    my($no) = fileno($in);
-    unless (defined($no)) {
-	my($package) = caller;
-	my($handle) = $in=~/[':]/ ? $in : "$package\:\:$in"; 
-	$no = fileno($handle);
-    }
-    die "Invalid filehandle $in\n" unless $no;
+    my($no) = fileno(to_filehandle($in));
+    realdie("Invalid filehandle $in\n") unless defined $no;
     
     open(SAVEERR, ">&STDERR");
     open(STDERR, ">&$no") or 
@@ -228,15 +294,72 @@ sub carpout {
 # headers
 sub fatalsToBrowser {
     my($msg) = @_;
+    $msg=~s/&/&amp;/g;
     $msg=~s/>/&gt;/g;
     $msg=~s/</&lt;/g;
-    print STDOUT "Content-type: text/html\n\n";
-    print STDOUT <<END;
+    $msg=~s/\"/&quot;/g;
+    my($wm) = $ENV{SERVER_ADMIN} ? 
+	qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
+	"this site's webmaster";
+    my ($outer_message) = <<END;
+For help, please send mail to $wm, giving this error message 
+and the time and date of the error.
+END
+    ;
+    my $mod_perl = exists $ENV{MOD_PERL};
+    print STDOUT "Content-type: text/html\n\n" 
+	unless $mod_perl;
+
+    if ($CUSTOM_MSG) {
+	if (ref($CUSTOM_MSG) eq 'CODE') {
+	    &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
+	    return;
+	} else {
+	    $outer_message = $CUSTOM_MSG;
+	}
+    }
+    
+    my $mess = <<END;
 <H1>Software error:</H1>
 <CODE>$msg</CODE>
 <P>
-Please send mail to this site's webmaster for help.
+$outer_message
 END
+    ;
+
+    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
+	# handler to produce the doc for us.
+	if ($r->bytes_sent) {
+	    $r->print($mess);
+	    $r->exit;
+	} else {
+	    $r->status(500);
+	    $r->custom_response(500,$mess);
+	}
+    } else {
+	print STDOUT $mess;
+    }
+}
+
+# Cut and paste from CGI.pm so that we don't have the overhead of
+# always loading the entire CGI module.
+sub to_filehandle {
+    my $thingy = shift;
+    return undef unless $thingy;
+    return $thingy if UNIVERSAL::isa($thingy,'GLOB');
+    return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
+    if (!ref($thingy)) {
+	my $caller = 1;
+	while (my $package = caller($caller++)) {
+	    my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; 
+	    return $tmp if defined(fileno($tmp));
+	}
+    }
+    return undef;
 }
 
 1;
diff --git a/gnu/usr.bin/perl/lib/CGI/Fast.pm b/gnu/usr.bin/perl/lib/CGI/Fast.pm
index 03b54072c96..a39fe052e86 100644
--- a/gnu/usr.bin/perl/lib/CGI/Fast.pm
+++ b/gnu/usr.bin/perl/lib/CGI/Fast.pm
@@ -16,7 +16,7 @@ package CGI::Fast;
 # The most recent version and complete docs are available at:
 #   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
 #   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
-$CGI::Fast::VERSION='1.00a';
+$CGI::Fast::VERSION='1.01';
 
 use CGI;
 use FCGI;
@@ -34,9 +34,11 @@ sub save_request {
 # New is slightly different in that it calls FCGI's
 # accept() method.
 sub new {
-    return undef unless FCGI::accept() >= 0;
-    my($self,@param) = @_;
-    return $CGI::Q = $self->SUPER::new(@param);
+     my ($self, $initializer, @param) = @_;
+     unless (defined $initializer) {
+         return undef unless FCGI::accept() >= 0;
+     }
+     return $CGI::Q = $self->SUPER::new($initializer, @param);
 }
 
 1;
@@ -154,13 +156,12 @@ I haven't tested this very much.
 
 =head1 AUTHOR INFORMATION
 
-be used and modified freely, but I do request that this copyright
-notice remain attached to the file.  You may modify this module as you
-wish, but if you redistribute a modified version, please attach a note
-listing the modifications you have made.
+Copyright 1996-1998, Lincoln D. Stein.  All rights reserved.  
 
-Address bug reports and comments to:
-lstein@genome.wi.mit.edu
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Address bug reports and comments to: lstein@cshl.org
 
 =head1 BUGS
 
diff --git a/gnu/usr.bin/perl/lib/CGI/Push.pm b/gnu/usr.bin/perl/lib/CGI/Push.pm
index 4390d0383e6..e4a66aee72d 100644
--- a/gnu/usr.bin/perl/lib/CGI/Push.pm
+++ b/gnu/usr.bin/perl/lib/CGI/Push.pm
@@ -14,23 +14,25 @@ package CGI::Push;
 # listing the modifications you have made.
 
 # The most recent version and complete docs are available at:
-#   http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
-#   ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+#   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::Push::VERSION='1.00';
+$CGI::Push::VERSION='1.01';
 use CGI;
 @ISA = ('CGI');
 
-# add do_push() to exported tags
-push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push');
+$CGI::DefaultClass = 'CGI::Push';
+$CGI::Push::AutoloadClass = 'CGI';
+
+# add do_push() and push_delay() to exported tags
+push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
 
 sub do_push {
-    my ($self,@p) = CGI::self_or_CGI(@_);
+    my ($self,@p) = CGI::self_or_default(@_);
 
     # unbuffer output
     $| = 1;
     srand;
-    my ($random) = rand()*1E16;
+    my ($random) = sprintf("%16.0f",rand()*1E16);
     my ($boundary) = "----------------------------------$random";
 
     my (@header);
@@ -39,6 +41,7 @@ sub do_push {
     $type = 'text/html' unless $type;
     $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
     $delay = 1 unless defined($delay);
+    $self->push_delay($delay);
 
     my(@o);
     foreach (@other) { push(@o,split("=")); }
@@ -55,15 +58,18 @@ sub do_push {
     my @contents;
     while (1) {
 	last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]);
-	print "Content-type: ${type}$CGI::CRLF$CGI::CRLF";
+	print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" 
+	    unless $type eq 'dynamic';
 	print @contents,"$CGI::CRLF";
 	print "${boundary}$CGI::CRLF";
-	do_sleep($delay) if $delay;
+	do_sleep($self->push_delay()) if $self->push_delay();
+    }
+
+    # Optional last page
+    if ($last_page && ref($last_page) eq 'CODE') {
+	print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+	print  &$last_page($self,$COUNTER),"$CGI::CRLF${boundary}$CGI::CRLF";
     }
-    print "Content-type: ${type}$CGI::CRLF$CGI::CRLF",
-          &$last_page($self,++$COUNTER),
-          "$CGI::CRLF${boundary}$CGI::CRLF"
-	      if $last_page && ref($last_page) eq 'CODE';
 }
 
 sub simple_counter {
@@ -87,6 +93,12 @@ sub do_sleep {
     }
 }
 
+sub push_delay {
+   my ($self,$delay) = CGI::self_or_default(@_);
+   return defined($delay) ? $self->{'.delay'} = 
+	$delay : $self->{'.delay'};
+}
+
 1;
 
 =head1 NAME
@@ -176,6 +188,9 @@ redrawing loop and print out the final page (if any)
 	       "This page called $counter times";
     }
 
+You are of course free to refer to create and use global variables
+within your draw routine in order to achieve special effects.
+
 =item -last_page
 
 This optional parameter points to a reference to the subroutine
@@ -187,8 +202,12 @@ itself should have exactly the same calling conventions as the
 =item -type
 
 This optional parameter indicates the content type of each page.  It
-defaults to "text/html".  Currently, server push of heterogeneous
-document types is not supported.
+defaults to "text/html".  Normally the module assumes that each page
+is of a homogenous MIME type.  However if you provide either of the
+magic values "heterogeneous" or "dynamic" (the latter provided for the
+convenience of those who hate long parameter names), you can specify
+the MIME type -- and other header fields -- on a per-page basis.  See 
+"heterogeneous pages" for more details.
 
 =item -delay
 
@@ -204,6 +223,60 @@ CGI::header().
 
 =back
 
+=head2 Heterogeneous Pages
+
+Ordinarily all pages displayed by CGI::Push share a common MIME type.
+However by providing a value of "heterogeneous" or "dynamic" in the
+do_push() -type parameter, you can specify the MIME type of each page
+on a case-by-case basis.  
+
+If you use this option, you will be responsible for producing the
+HTTP header for each page.  Simply modify your draw routine to
+look like this:
+
+    sub my_draw_routine {
+        my($q,$counter) = @_;
+        return header('text/html'),   # note we're producing the header here
+	       start_html('testing'),
+               h1('testing'),
+	       "This page called $counter times";
+    }
+
+You can add any header fields that you like, but some (cookies and
+status fields included) may not be interpreted by the browser.  One
+interesting effect is to display a series of pages, then, after the
+last page, to redirect the browser to a new URL.  Because redirect() 
+does b<not> work, the easiest way is with a -refresh header field,
+as shown below:
+
+    sub my_draw_routine {
+        my($q,$counter) = @_;
+	return undef if $counter > 10;
+        return header('text/html'),   # note we're producing the header here
+	       start_html('testing'),
+               h1('testing'),
+	       "This page called $counter times";
+    }
+   
+    sub my_last_page {
+	header(-refresh=>'5; URL=http://somewhere.else/finished.html',
+	       -type=>'text/html'),
+        start_html('Moved'),
+        h1('This is the last page'),
+	'Goodbye!'
+         hr,	
+         end_html; 
+    }
+
+=head2 Changing the Page Delay on the Fly
+
+If you would like to control the delay between pages on a page-by-page
+basis, call push_delay() from within your draw routine.  push_delay()
+takes a single numeric argument representing the number of seconds you
+wish to delay after the current page is displayed and before
+displaying the next one.  The delay may be fractional.  Without
+parameters, push_delay() just returns the current delay.
+
 =head1 INSTALLING CGI::Push SCRIPTS
 
 Server push scripts B<must> be installed as no-parsed-header (NPH)
@@ -213,19 +286,14 @@ Recognition of NPH scripts happens automatically with WebSTAR and
 Microsoft IIS.  Users of other servers should see their documentation
 for help.
 
-=head1 CAVEATS
-
-This is a new module.  It hasn't been extensively tested.
-
 =head1 AUTHOR INFORMATION
 
-be used and modified freely, but I do request that this copyright
-notice remain attached to the file.  You may modify this module as you
-wish, but if you redistribute a modified version, please attach a note
-listing the modifications you have made.
+Copyright 1995-1998, Lincoln D. Stein.  All rights reserved.  
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
 
-Address bug reports and comments to:
-lstein@genome.wi.mit.edu
+Address bug reports and comments to: lstein@cshl.org
 
 =head1 BUGS
 
diff --git a/gnu/usr.bin/perl/lib/CGI/Switch.pm b/gnu/usr.bin/perl/lib/CGI/Switch.pm
index 420fff7643c..8afc6a6cb34 100644
--- a/gnu/usr.bin/perl/lib/CGI/Switch.pm
+++ b/gnu/usr.bin/perl/lib/CGI/Switch.pm
@@ -2,7 +2,7 @@ package CGI::Switch;
 use Carp;
 use strict;
 use vars qw($VERSION @Pref);
-$VERSION = '0.05';
+$VERSION = '0.06';
 @Pref = qw(CGI::Apache CGI); #default
 
 sub import {
@@ -33,13 +33,6 @@ sub new {
     Carp::croak "Couldn't load+construct any of @Pref\n";
 }
 
-# there's a trick in Lincoln's package that determines the calling
-# package.  The reason is to have a filehandle with the same name as
-# the filename.  To tell this trick that we are not the calling
-# package we have to follow this dirty convention. It's a questionable
-# trick imho, but for now I want to have something working
-sub isaCGI { 1 }
-
 1;
 __END__
 
@@ -73,6 +66,6 @@ perl(1), Apache(3), CGI(3), CGI::XA(3)
 
 =head1 AUTHOR
 
-Andreas König E<lt>a.koenig@mind.deE<gt>
+Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>
 
 =cut