X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fdiagnostics.pm;h=7af5efa1778bb2974aa9aa2f00aa60c0cdc21b67;hb=2a773401c9513390fb5c5052085181dd7bea39e1;hp=2b751136316b65e38d80c52fb32f178cea7ae2f8;hpb=c7bcd97d6f3cca0cdeda5b0e9eabe2b3fcca0c57;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
old mode 100755
new mode 100644
index 2b75113..7af5efa
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -19,12 +19,17 @@ Using the C<splain> standalone filter program:
     perl program 2>diag.out
     splain [-v] [-p] diag.out
 
+Using diagnostics to get stack traces from a misbehaving script:
+
+    perl -Mdiagnostics=-traceonly my_script.pl
+
 =head1 DESCRIPTION
 
 =head2 The C<diagnostics> Pragma
 
 This module extends the terse diagnostics normally emitted by both the
-perl compiler and the perl interpreter, augmenting them with the more
+perl compiler and the perl interpreter (from running perl with a -w 
+switch or C<use warnings>), augmenting them with the more
 explicative and endearing descriptions found in L<perldiag>.  Like the
 other pragmata, it affects the compilation phase of your program rather
 than merely the execution phase.
@@ -53,6 +58,17 @@ descriptions found in L<perldiag>) are only displayed once (no duplicate
 descriptions).  User code generated warnings a la warn() are unaffected,
 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 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
+
+to see the call stack at the time of death. By supplying the B<-warntrace>
+(or just B<-w>) flag, any warnings emitted will also come with a stack
+trace.
+
 =head2 The I<splain> Program
 
 While apparently a whole nuther program, I<splain> is actually nothing
@@ -165,13 +181,16 @@ 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.11;
+our $VERSION = 1.17;
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
+our $TRACEONLY = 0;
+our $WARNTRACE = 0;
 
 use Config;
 my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
@@ -202,7 +221,7 @@ $DEBUG ||= 0;
 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 
 local $| = 1;
-local $_;
+my $_;
 
 my $standalone;
 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
@@ -304,7 +323,6 @@ my %msg;
 {
     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
     local $/ = '';
-    local $_;
     my $header;
     my $for_item;
     while (<POD_DIAG>) {
@@ -314,10 +332,10 @@ my %msg;
 	    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/[BC]<(.*?)>/bold($1)/ges;
+	    s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
 	    s/[LIF]<(.*?)>/italic($1)/ges;
 	} else {
-	    s/[BC]<(.*?)>/$1/gs;
+	    s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
 	    s/[LIF]<(.*?)>/$1/gs;
 	} 
 	unless (/^=/) {
@@ -376,7 +394,7 @@ my %msg;
                         $toks[$i] = '[\da-f]+';
                    }
                 } elsif( length( $toks[$i] ) ){
-                    $toks[$i] =~ s/^.*$/\Q$&\E/;
+                    $toks[$i] = quotemeta $toks[$i];
                     $conlen += length( $toks[$i] );
                 }
             }  
@@ -447,6 +465,15 @@ sub import {
 				    $PRETTY++;
 				    next;
 			       };
+	# matches trace and traceonly for legacy doc mixup reasons
+	/^-t(race(only)?)?$/	&& do {
+				    $TRACEONLY++;
+				    next;
+			       };
+	/^-w(arntrace)?$/ 	&& do {
+				    $WARNTRACE++;
+				    next;
+			       };
 
 	warn "Unknown flag: $_";
     } 
@@ -469,9 +496,13 @@ sub disable {
 sub warn_trap {
     my $warning = $_[0];
     if (caller eq $WHOAMI or !splainthis($warning)) {
-	print STDERR $warning;
+	if ($WARNTRACE) {
+	    print STDERR Carp::longmess($warning);
+	} else {
+	    print STDERR $warning;
+	}
     } 
-    &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
+    goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
 };
 
 sub death_trap {
@@ -481,8 +512,7 @@ sub death_trap {
     # want to explain the exception because it's going to get caught.
     my $in_eval = 0;
     my $i = 0;
-    while (1) {
-      my $caller = (caller($i++))[3] or last;
+    while (my $caller = (caller($i++))[3]) {
       if ($caller eq '(eval)') {
 	$in_eval = 1;
 	last;
@@ -516,8 +546,10 @@ my %old_diag;
 my $count;
 my $wantspace;
 sub splainthis {
-    local $_ = shift;
+    return 0 if $TRACEONLY;
+    $_ = shift;
     local $\;
+    local $!;
     ### &finish_compilation unless %msg;
     s/\.?\n+$//;
     my $orig = $_;
@@ -530,6 +562,7 @@ sub splainthis {
     # but be aware of messsages 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+/ ){