merge in perl 5.6.1 with our local changes

1 files changed, 54 insertions, 44 deletions

diff --git a/gnu/usr.bin/perl/lib/diagnostics.pm b/gnu/usr.bin/perl/lib/diagnostics.pm
index a2c927baca5..884ea3ca655 100644
--- a/gnu/usr.bin/perl/lib/diagnostics.pm
+++ b/gnu/usr.bin/perl/lib/diagnostics.pm
@@ -44,7 +44,7 @@ These still go out B<STDERR>.
 Due to the interaction between runtime and compiletime issues,
 and because it's probably not a very good idea anyway,
 you may not use C<no diagnostics> to turn them off at compiletime.
-However, you may control there behaviour at runtime using the 
+However, you may control their behaviour at runtime using the 
 disable() and enable() methods to turn them off and on respectively.
 
 The B<-verbose> flag first prints out the L<perldiag> introduction before
@@ -167,19 +167,23 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 
 =cut
 
+use strict;
 use 5.005_64;
 use Carp;
 
-$VERSION = v1.0;
+our $VERSION = v1.0;
+our $DEBUG;
+our $VERBOSE;
+our $PRETTY;
 
 use Config;
-($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
+my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
 if ($^O eq 'VMS') {
     require VMS::Filespec;
     $privlib = VMS::Filespec::unixify($privlib);
     $archlib = VMS::Filespec::unixify($archlib);
 }
-@trypod = (
+my @trypod = (
 	   "$archlib/pod/perldiag.pod",
 	   "$privlib/pod/perldiag-$Config{version}.pod",
 	   "$privlib/pod/perldiag.pod",
@@ -189,21 +193,21 @@ if ($^O eq 'VMS') {
 	  );
 # handy for development testing of new warnings etc
 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
-($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
+(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
 
 $DEBUG ||= 0;
 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 
-$| = 1;
-
+local $| = 1;
 local $_;
 
+my $standalone;
+my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
+
 CONFIG: {
-    $opt_p = $opt_d = $opt_v = $opt_f = '';
-    %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();  
-    %exact_duplicate = ();
+    our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
 
-    unless (caller) { 
+    unless (caller) {
 	$standalone++;
 	require Getopt::Std;
 	Getopt::Std::getopts('pdvf:')
@@ -212,7 +216,7 @@ CONFIG: {
 	$DEBUG = 2 if $opt_d;
 	$VERBOSE = $opt_v;
 	$PRETTY = $opt_p;
-    } 
+    }
 
     if (open(POD_DIAG, $PODFILE)) {
 	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
@@ -221,11 +225,12 @@ CONFIG: {
 
     if (caller) {
 	INCPATH: {
-	    for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
+	    for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
 		warn "Checking $file\n" if $DEBUG;
 		if (open(POD_DIAG, $file)) {
 		    while (<POD_DIAG>) {
-			next unless /^__END__\s*# wish diag dbase were more accessible/;
+			next unless
+			    /^__END__\s*# wish diag dbase were more accessible/;
 			print STDERR "podfile is $file\n" if $DEBUG;
 			last INCPATH;
 		    }
@@ -274,6 +279,7 @@ if (eof(POD_DIAG)) {
     # etc
 );
 
+our %HTML_Escapes;
 *HTML_Escapes = do {
     if ($standalone) {
 	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 
@@ -284,20 +290,20 @@ if (eof(POD_DIAG)) {
 
 *THITHER = $standalone ? *STDOUT : *STDERR;
 
-$transmo = <<EOFUNC;
+my $transmo = <<EOFUNC;
 sub transmo {
     #local \$^W = 0;  # recursive warnings we do NOT need!
     study;
 EOFUNC
 
-### sub finish_compilation {  # 5.001e panic: top_level for embedded version
+my %msg;
+{
     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
-    ### local 
-    $RS = '';
+    local $/ = '';
     local $_;
+    my $header;
+    my $for_item;
     while (<POD_DIAG>) {
-	#s/(.*)\n//;
-	#$header = $1;
 
 	unescape();
 	if ($PRETTY) {
@@ -321,29 +327,35 @@ EOFUNC
 		} 
 		s/^/    /gm;
 		$msg{$header} .= $_;
+	 	undef $for_item;	
 	    }
 	    next;
 	} 
-	unless ( s/=item (.*)\s*\Z//) {
+	unless ( s/=item (.*?)\s*\z//) {
 
 	    if ( s/=head1\sDESCRIPTION//) {
 		$msg{$header = 'DESCRIPTION'} = '';
+		undef $for_item;
 	    }
+	    elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
+		$for_item = $1;
+	    } 
 	    next;
 	}
 
 	# strip formatting directives in =item line
-	($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
+	$header = $for_item || $1;
+	undef $for_item;	
+	$header =~ s/[A-Z]<(.*?)>/$1/g;
 
 	if ($header =~ /%[csd]/) {
-	    $rhs = $lhs = $header;
-	    #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g)  {
-	    if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g)  {
+	    my $rhs = my $lhs = $header;
+	    if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g)  {
 		$lhs =~ s/\\%s/.*?/g;
 	    } else {
-		# if i had lookbehind negations, i wouldn't have to do this \377 noise
+		# if i had lookbehind negations,
+		# i wouldn't have to do this \377 noise
 		$lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
-		#$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
 		$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
 		$lhs =~ s/\377//g;
 		$lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
@@ -369,25 +381,23 @@ EOFUNC
     print STDERR $transmo if $DEBUG;
     eval $transmo;
     die $@ if $@;
-    $RS = "\n";
-### }
+}
 
 if ($standalone) {
     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
-    while (defined ($error = <>)) {
+    while (defined (my $error = <>)) {
 	splainthis($error) || print THITHER $error;
     } 
     exit;
-} else { 
-    #$old_w = 0;
-    $oldwarn = ''; $olddie = '';
-}
+} 
+
+my $olddie;
+my $oldwarn;
 
 sub import {
     shift;
-    #$old_w = $^W;
-    $^W = 1; # yup, clobbered the global variable; tough, if you
-	     # want diags, you want diags.
+    $^W = 1; # yup, clobbered the global variable; 
+	     # tough, if you want diags, you want diags.
     return if $SIG{__WARN__} eq \&warn_trap;
 
     for (@_) {
@@ -421,10 +431,9 @@ sub enable { &import }
 
 sub disable {
     shift;
-    #$^W = $old_w;
     return unless $SIG{__WARN__} eq \&warn_trap;
-    $SIG{__WARN__} = $oldwarn;
-    $SIG{__DIE__} = $olddie;
+    $SIG{__WARN__} = $oldwarn || '';
+    $SIG{__DIE__} = $olddie || '';
 } 
 
 sub warn_trap {
@@ -465,6 +474,10 @@ sub death_trap {
 	# into an indirect recursion loop
 };
 
+my %exact_duplicate;
+my %old_diag;
+my $count;
+my $wantspace;
 sub splainthis {
     local $_ = shift;
     local $\;
@@ -473,7 +486,7 @@ sub splainthis {
     my $orig = $_;
     # return unless defined;
     s/, <.*?> (?:line|chunk).*$//;
-    $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
+    my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
     s/^\((.*)\)$/$1/;
     if ($exact_duplicate{$orig}++) {
 	return &transmo;
@@ -542,8 +555,5 @@ sub shorten {
 } 
 
 
-# have to do this: RS isn't set until run time, but we're executing at compiletime
-$RS = "\n";
-
 1 unless $standalone;  # or it'll complain about itself
 __END__ # wish diag dbase were more accessible