From 2618fad5bbb2d0182eb31ed805c41b543c513940 Mon Sep 17 00:00:00 2001
From: markm <markm@FreeBSD.org>
Date: Sun, 25 Jun 2000 11:04:01 +0000
Subject: Vendor import of Perl 5.006

---
 contrib/perl5/lib/diagnostics.pm | 44 +++++++++++++++++++++++++++-------------
 1 file changed, 30 insertions(+), 14 deletions(-)

(limited to 'contrib/perl5/lib/diagnostics.pm')

diff --git a/contrib/perl5/lib/diagnostics.pm b/contrib/perl5/lib/diagnostics.pm
index b9aaba5..a2c927b 100755
--- a/contrib/perl5/lib/diagnostics.pm
+++ b/contrib/perl5/lib/diagnostics.pm
@@ -51,6 +51,11 @@ The B<-verbose> flag first prints out the L<perldiag> introduction before
 any other diagnostics.  The $diagnostics::PRETTY variable can generate nicer
 escape sequences for pagers.
 
+Warnings dispatched from perl itself (or more accurately, those that match
+descriptions found in L<perldiag>) are only displayed once (no duplicate
+descriptions).  User code generated warnings ala warn() are unaffected,
+allowing duplicate user messages to be displayed.
+
 =head2 The I<splain> Program
 
 While apparently a whole nuther program, I<splain> is actually nothing
@@ -162,9 +167,11 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 
 =cut
 
-require 5.001;
+use 5.005_64;
 use Carp;
 
+$VERSION = v1.0;
+
 use Config;
 ($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
 if ($^O eq 'VMS') {
@@ -172,9 +179,14 @@ if ($^O eq 'VMS') {
     $privlib = VMS::Filespec::unixify($privlib);
     $archlib = VMS::Filespec::unixify($archlib);
 }
-@trypod = ("$archlib/pod/perldiag.pod",
-	   "$privlib/pod/perldiag-$].pod",
-	   "$privlib/pod/perldiag.pod");
+@trypod = (
+	   "$archlib/pod/perldiag.pod",
+	   "$privlib/pod/perldiag-$Config{version}.pod",
+	   "$privlib/pod/perldiag.pod",
+	   "$archlib/pods/perldiag.pod",
+	   "$privlib/pods/perldiag-$Config{version}.pod",
+	   "$privlib/pods/perldiag.pod",
+	  );
 # 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];
@@ -274,7 +286,7 @@ if (eof(POD_DIAG)) {
 
 $transmo = <<EOFUNC;
 sub transmo {
-    local \$^W = 0;  # recursive warnings we do NOT need!
+    #local \$^W = 0;  # recursive warnings we do NOT need!
     study;
 EOFUNC
 
@@ -323,7 +335,7 @@ EOFUNC
 	# strip formatting directives in =item line
 	($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
 
-	if ($header =~ /%[sd]/) {
+	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)  {
@@ -336,6 +348,7 @@ EOFUNC
 		$lhs =~ s/\377//g;
 		$lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
 	    } 
+	    $lhs =~ s/\\%c/./g;
 	    $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
 	} else {
 	    $transmo .= "    m{^\Q$header\E} && return 1;\n";
@@ -366,12 +379,13 @@ if ($standalone) {
     } 
     exit;
 } else { 
-    $old_w = 0; $oldwarn = ''; $olddie = '';
+    #$old_w = 0;
+    $oldwarn = ''; $olddie = '';
 }
 
 sub import {
     shift;
-    $old_w = $^W;
+    #$old_w = $^W;
     $^W = 1; # yup, clobbered the global variable; tough, if you
 	     # want diags, you want diags.
     return if $SIG{__WARN__} eq \&warn_trap;
@@ -407,7 +421,7 @@ sub enable { &import }
 
 sub disable {
     shift;
-    $^W = $old_w;
+    #$^W = $old_w;
     return unless $SIG{__WARN__} eq \&warn_trap;
     $SIG{__WARN__} = $oldwarn;
     $SIG{__DIE__} = $olddie;
@@ -458,13 +472,15 @@ sub splainthis {
     s/\.?\n+$//;
     my $orig = $_;
     # return unless defined;
-    if ($exact_duplicate{$_}++) {
-	return 1;
-    } 
     s/, <.*?> (?:line|chunk).*$//;
     $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
     s/^\((.*)\)$/$1/;
-    return 0 unless &transmo;
+    if ($exact_duplicate{$orig}++) {
+	return &transmo;
+    }
+    else {
+	return 0 unless &transmo;
+    }
     $orig = shorten($orig);
     if ($old_diag{$_}) {
 	autodescribe();
@@ -526,7 +542,7 @@ sub shorten {
 } 
 
 
-# have to do this: RS isn't set until run time, but we're executing at compile time
+# 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
-- 
cgit v1.1