don't depend on threads to do a watchdog when testing threads

[perl5.git] / lib / diagnostics.pm

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
old mode 100755 (executable)
new mode 100644 (file)
index a191035..a40da9e
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -60,7 +60,7 @@ allowing duplicate user messages to be displayed.
 
 This module also adds a stack trace to the error message when perl dies.
 This is useful for pinpointing what caused the death. The B<-traceonly> (or
-just B<-t>) flag turns off the explantions of warning messages leaving just
+just B<-t>) flag turns off the explanations of warning messages leaving just
 the stack traces. So if your script is dieing, run it again with
 
   perl -Mdiagnostics=-traceonly my_bad_script
@@ -181,11 +181,11 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 =cut
 
 use strict;
-use 5.006;
+use 5.009001;
 use Carp;
 $Carp::Internal{__PACKAGE__.""}++;
 
-our $VERSION = 1.14;
+our $VERSION = '1.25';
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
@@ -211,17 +211,12 @@ my @trypod = (
 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
 (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
 
-if ($^O eq 'MacOS') {
-    # just updir one from each lib dir, we'll find it ...
-    ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
-}
-
-
 $DEBUG ||= 0;
 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 
 local $| = 1;
-local $_;
+my $_;
+local $.;
 
 my $standalone;
 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
@@ -323,21 +318,49 @@ my %msg;
 {
     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
     local $/ = '';
-    local $_;
     my $header;
+    my @headers;
     my $for_item;
+    my $seen_body;
     while (<POD_DIAG>) {
 
+       sub _split_pod_link {
+           $_[0] =~ '(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?';
+           ($1,$2,$4);
+       }
+
        unescape();
        if ($PRETTY) {
            sub noop   { return $_[0] }  # spensive for a noop
            sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; } 
            sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; } 
            s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
-           s/[LIF]<(.*?)>/italic($1)/ges;
+           s/[IF]<(.*?)>/italic($1)/ges;
+           s/L<(.*?)>/
+              my($text,$page,$sect) = _split_pod_link($1);
+              defined $text
+               ? $text
+               : defined $sect
+                  ? italic($sect) . ' in ' . italic($page)
+                  : italic($page)
+            /ges;
+            s/S<(.*?)>/
+               $1
+             /ges;
        } else {
            s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
-           s/[LIF]<(.*?)>/$1/gs;
+           s/[IF]<(.*?)>/$1/gs;
+           s/L<(.*?)>/
+              my($text,$page,$sect) = _split_pod_link($1);
+              defined $text
+               ? $text
+               : defined $sect
+                  ? qq '"$sect" in $page'
+                  : $page
+            /ges;
+           s/S<(.*?)>/
+               $1
+             /ges;
        } 
        unless (/^=/) {
            if (defined $header) { 
@@ -350,10 +373,22 @@ my %msg;
                }
                s/^/    /gm;
                $msg{$header} .= $_;
+               for my $h(@headers) { $msg{$h} .= $_ }
+               ++$seen_body;
                undef $for_item;        
            }
            next;
        } 
+
+       # If we have not come across the body of the description yet, then
+       # the previous header needs to share the same description.
+       if ($seen_body) {
+           @headers = ();
+       }
+       else {
+           push @headers, $header if defined $header;
+       }
+
        unless ( s/=item (.*?)\s*\z//) {
 
            if ( s/=head1\sDESCRIPTION//) {
@@ -378,24 +413,27 @@ my %msg;
        # strip formatting directives from =item line
        $header =~ s/[A-Z]<(.*?)>/$1/g;
 
-        my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
+       # Since we strip "\.\n" when we search a warning, strip it here as well
+       $header =~ s/\.?$//;
+
+        my @toks = split( /(%l?[dx]|%u|%c|%(?:\.\d+)?[fs])/, $header );
        if (@toks > 1) {
             my $conlen = 0;
             for my $i (0..$#toks){
                 if( $i % 2 ){
                     if(      $toks[$i] eq '%c' ){
                         $toks[$i] = '.';
-                    } elsif( $toks[$i] eq '%d' ){
+                    } elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
                         $toks[$i] = '\d+';
-                    } elsif( $toks[$i] eq '%s' ){
+                    } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
                         $toks[$i] = $i == $#toks ? '.*' : '.*?';
                     } elsif( $toks[$i] =~ '%.(\d+)s' ){
                         $toks[$i] = ".{$1}";
-                     } elsif( $toks[$i] =~ '^%l*x$' ){
+                    } elsif( $toks[$i] =~ '^%l*x$' ){
                         $toks[$i] = '[\da-f]+';
-                   }
+                    }
                 } elsif( length( $toks[$i] ) ){
-                    $toks[$i] =~ s/^.*$/\Q$&\E/;
+                    $toks[$i] = quotemeta $toks[$i];
                     $conlen += length( $toks[$i] );
                 }
             }  
@@ -413,6 +451,7 @@ my %msg;
            if $msg{$header};
 
        $msg{$header} = '';
+       $seen_body = 0;
     } 
 
 
@@ -466,12 +505,12 @@ sub import {
                                    $PRETTY++;
                                    next;
                               };
-
-       /^-t(race)?$/           && do {
+       # matches trace and traceonly for legacy doc mixup reasons
+       /^-t(race(only)?)?$/    && do {
                                    $TRACEONLY++;
                                    next;
                               };
-       /^-w(arntrace)?$/               && do {
+       /^-w(arntrace)?$/       && do {
                                    $WARNTRACE++;
                                    next;
                               };
@@ -548,8 +587,9 @@ my $count;
 my $wantspace;
 sub splainthis {
     return 0 if $TRACEONLY;
-    local $_ = shift;
+    $_ = shift;
     local $\;
+    local $!;
     ### &finish_compilation unless %msg;
     s/\.?\n+$//;
     my $orig = $_;
@@ -559,9 +599,10 @@ sub splainthis {
     s/, <.*?> (?:line|chunk).*$//;
 
     # Discard 1st " at <file> line <no>" and all text beyond
-    # but be aware of messsages containing " at this-or-that"
+    # but be aware of messages containing " at this-or-that"
     my $real = 0;
     my @secs = split( / at / );
+    return unless @secs;
     $_ = $secs[0];
     for my $i ( 1..$#secs ){
         if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){