extension to diagnostics.pm

Message-ID: <20040803233309.GA239@dyn.fergaldaly.com>

p4raw-id: //depot/perl@23191

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index ec58bb1..b51376f 100755 (executable)
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -19,6 +19,10 @@ 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
@@ -53,6 +57,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 explantions 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
@@ -167,11 +182,14 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 use strict;
 use 5.006;
 use Carp;
+$Carp::Internal{__PACKAGE__.""}++;
 
-our $VERSION = 1.13;
+our $VERSION = 1.14;
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
+our $TRACEONLY = 0;
+our $WARNTRACE = 0;
 
 use Config;
 my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
@@ -448,6 +466,15 @@ sub import {
                                    next;
                               };
 
+       /^-t(race)?$/           && 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,6 +546,7 @@ my %old_diag;
 my $count;
 my $wantspace;
 sub splainthis {
+    return 0 if $TRACEONLY;
     local $_ = shift;
     local $\;
     ### &finish_compilation unless %msg;