X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/43cc1d52f97c5f21f3207f045444707e7be33927..019070c31184a4deb57cb85f7e597a789c6c5b54:/lib/diagnostics.pm diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index f20b956..c734c85 100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -1,28 +1,12 @@ -#!/usr/local/bin/perl -eval 'exec perl -S $0 ${1+"$@"}' - if 0; - -use Config; -if ($^O eq 'VMS') { - $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlibexp'}) . - '/pod/perldiag.pod'; -} -else { $diagnostics::PODFILE= $Config{privlibexp} . "/pod/perldiag.pod"; } - package diagnostics; -require 5.001; -use English; -use Carp; =head1 NAME -diagnostics - Perl compiler pragma to force verbose warning diagnostics - -splain - standalone program to do the same thing +diagnostics, splain - produce verbose warning diagnostics =head1 SYNOPSIS -As a pragma: +Using the C pragma: use diagnostics; use diagnostics -verbose; @@ -30,20 +14,24 @@ As a pragma: enable diagnostics; disable diagnostics; -Aa a program: +Using the C 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 Pragma This module extends the terse diagnostics normally emitted by both the -perl compiler and the perl interpeter, augmenting them wtih the more +perl compiler and the perl interpreter (from running perl with a -w +switch or C), augmenting them with the more explicative and endearing descriptions found in L. Like the -other pragmata, it affects to compilation phase of your program rather +other pragmata, it affects the compilation phase of your program rather than merely the execution phase. To use in your program as a pragma, merely invoke @@ -58,12 +46,29 @@ These still go out B. 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 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 introduction before -any other diagnostics. The $diagnostics::PRETTY can generate nicer escape -sequences for pgers. +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) 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 Program @@ -98,7 +103,7 @@ afterwards, do this: ./splain < test.out Note that this is not in general possible in shells of more dubious heritage, -as the theorectical +as the theoretical (perl -w test.pl >/dev/tty) >& test.out ./splain < test.out @@ -143,7 +148,7 @@ runtime. Otherwise, they may be embedded in the file itself when the splain package is built. See the F for details. If an extant $SIG{__WARN__} handler is discovered, it will continue -to be honored, but only after the diagnostic::splainthis() function +to be honored, but only after the diagnostics::splainthis() function (the module's $SIG{__WARN__} interceptor) has had its way with your warnings. @@ -159,44 +164,72 @@ Not being able to say "no diagnostics" is annoying, but may not be insurmountable. The C<-pretty> directive is called too late to affect matters. -You have to to this instead, and I you load the module. +You have to do this instead, and I you load the module. BEGIN { $diagnostics::PRETTY = 1 } I could start up faster by delaying compilation until it should be -needed, but this gets a "panic: top_level" -when using the pragma form in 5.001e. +needed, but this gets a "panic: top_level" when using the pragma form +in Perl 5.001e. While it's true that this documentation is somewhat subserious, if you use a program named I, you should expect a bit of whimsy. =head1 AUTHOR -Tom Christiansen Ftchrist@mox.perl.comE>, 25 June 1995. +Tom Christiansen >, 25 June 1995. =cut +use strict; +use 5.009001; +use Carp; +$Carp::Internal{__PACKAGE__.""}++; + +our $VERSION = '1.31'; +our $DEBUG; +our $VERBOSE; +our $PRETTY; +our $TRACEONLY = 0; +our $WARNTRACE = 0; + +use Config; +my $privlib = $Config{privlibexp}; +if ($^O eq 'VMS') { + require VMS::Filespec; + $privlib = VMS::Filespec::unixify($privlib); +} +my @trypod = ( + "$privlib/pod/perldiag.pod", + "$privlib/pods/perldiag.pod", + ); +# handy for development testing of new warnings etc +unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; +(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; + $DEBUG ||= 0; my $WHOAMI = ref bless []; # nobody's business, prolly not even mine -$OUTPUT_AUTOFLUSH = 1; - +local $| = 1; local $_; +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:') || die "Usage: $0 [-v] [-p] [-f splainpod]"; + Getopt::Std::getopts('pdvf:') + or die "Usage: $0 [-v] [-p] [-f splainpod]"; $PODFILE = $opt_f if $opt_f; $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; @@ -205,11 +238,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 () { - 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; } @@ -258,6 +292,7 @@ if (eof(POD_DIAG)) { # etc ); +our %HTML_Escapes; *HTML_Escapes = do { if ($standalone) { $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; @@ -268,31 +303,60 @@ if (eof(POD_DIAG)) { *THITHER = $standalone ? *STDOUT : *STDERR; -$transmo = <) { - #s/(.*)\n//; - #$header = $1; + + 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/[BC]<(.*?)>/bold($1)/ges; - s/[LIF]<(.*?)>/italic($1)/ges; + s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/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/[BC]<(.*?)>/$1/gs; - s/[LIF]<(.*?)>/$1/gs; + s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/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) { @@ -302,41 +366,88 @@ EOFUNC ) ) { next; - } + } s/^/ /gm; $msg{$header} .= $_; + for my $h(@headers) { $msg{$h} .= $_ } + ++$seen_body; + undef $for_item; } next; } - unless ( s/=item (.*)\s*\Z//) { + + # 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//) { $msg{$header = 'DESCRIPTION'} = ''; + undef $for_item; } + elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { + $for_item = $1; + } next; } - $header = $1; - - if ($header =~ /%[sd]/) { - $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) { - $lhs =~ s/\\%s/.*?/g; - } else { - # 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; - } - $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; + + if( $for_item ) { $header = $for_item; undef $for_item } + else { + $header = $1; + while( $header =~ /[;,]\z/ ) { + =~ /^\s*(.*?)\s*\z/; + $header .= ' '.$1; + } + } + + # strip formatting directives from =item line + $header =~ s/[A-Z]<(.*?)>/$1/g; + + # Since we strip "\.\n" when we search a warning, strip it here as well + $header =~ s/\.?$//; + + my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\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] =~ /^%(?:d|u)$/ ){ + $toks[$i] = '\d+'; + } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){ + $toks[$i] = $i == $#toks ? '.*' : '.*?'; + } elsif( $toks[$i] =~ '%.(\d+)s' ){ + $toks[$i] = ".{$1}"; + } elsif( $toks[$i] =~ '^%l*([pxX])$' ){ + $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+'; + } + } elsif( length( $toks[$i] ) ){ + $toks[$i] = quotemeta $toks[$i]; + $conlen += length( $toks[$i] ); + } + } + my $lhs = join( '', @toks ); + $transfmt{$header}{pat} = + " s^$lhs\Q$header\Es\n\t&& return 1;\n"; + $transfmt{$header}{len} = $conlen; } else { - $transmo .= " m{^\Q$header\E} && return 1;\n"; + $transfmt{$header}{pat} = + " m^\Q$header\E && return 1;\n"; + $transfmt{$header}{len} = length( $header ); } - print STDERR "Already saw $header" if $msg{$header}; + print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" + if $msg{$header}; $msg{$header} = ''; + $seen_body = 0; } @@ -344,29 +455,34 @@ EOFUNC die "No diagnostics?" unless %msg; + # Apply patterns in order of decreasing sum of lengths of fixed parts + # Seems the best way of hitting the right one. + for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} } + keys %transfmt ){ + $transmo .= $transfmt{$hdr}{pat}; + } $transmo .= " return 0;\n}\n"; 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 ($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. - return if $SIG{__WARN__} eq \&warn_trap; + $^W = 1; # yup, clobbered the global variable; + # tough, if you want diags, you want diags. + return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap); for (@_) { @@ -385,6 +501,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: $_"; } @@ -399,57 +524,114 @@ 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 { 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 { my $exception = $_[0]; - splainthis($exception); + + # See if we are coming from anywhere within an eval. If so we don't + # want to explain the exception because it's going to get caught. + my $in_eval = $^S || !defined $^S; + + splainthis($exception) unless $in_eval; if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; + + return if $in_eval; + + # We don't want to unset these if we're coming from an eval because + # then we've turned off diagnostics. + + # Switch off our die/warn handlers so we don't wind up in our own + # traps. $SIG{__DIE__} = $SIG{__WARN__} = ''; - local($Carp::CarpLevel) = 1; - confess "Uncaught exception from user code:\n\t$exception"; + + $exception =~ s/\n(?=.)/\n\t/gas; + + die Carp::longmess("__diagnostics__") + =~ s/^__diagnostics__.*?line \d+\.?\n/ + "Uncaught exception from user code:\n\t$exception" + /re; # up we go; where we stop, nobody knows, but i think we die now # but i'm deeply afraid of the &$olddie guy reraising and us getting # into an indirect recursion loop }; +my %exact_duplicate; +my %old_diag; +my $count; +my $wantspace; sub splainthis { - local $_ = shift; + return 0 if $TRACEONLY; + for (my $tmp = shift) { + local $\; + local $!; ### &finish_compilation unless %msg; s/\.?\n+$//; my $orig = $_; # return unless defined; - if ($exact_duplicate{$_}++) { - return 1; - } + + # get rid of the where-are-we-in-input part s/, <.*?> (?:line|chunk).*$//; - $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; + + # Discard 1st " at line " and all text beyond + # 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+/ ){ + $real = 1; + last; + } else { + $_ .= ' at ' . $secs[$i]; + } + } + + # remove parenthesis occurring at the end of some messages s/^\((.*)\)$/$1/; - return 0 unless &transmo; - $orig = shorten($orig); + + if ($exact_duplicate{$orig}++) { + return &transmo; + } else { + return 0 unless &transmo; + } + + my $short = shorten($orig); if ($old_diag{$_}) { autodescribe(); - print THITHER "$orig (#$old_diag{$_})\n"; + print THITHER "$short (#$old_diag{$_})\n"; $wantspace = 1; + } elsif (!$msg{$_} && $orig =~ /\n./s) { + # A multiline message, like "Attempt to reload / + # Compilation failed" + my $found; + for (split /^/, $orig) { + splainthis($_) and $found = 1; + } + return $found; } else { autodescribe(); $old_diag{$_} = ++$count; print THITHER "\n" if $wantspace; $wantspace = 0; - print THITHER "$orig (#$old_diag{$_})\n"; + print THITHER "$short (#$old_diag{$_})\n"; if ($msg{$_}) { print THITHER $msg{$_}; } else { @@ -462,6 +644,7 @@ sub splainthis { } } return 1; + } } sub autodescribe { @@ -481,7 +664,7 @@ sub unescape { exists $HTML_Escapes{$1} ? do { $HTML_Escapes{$1} } : do { - warn "Unknown escape: $& in $_"; + warn "Unknown escape: E<$1> in $_"; "E<$1>"; } } @@ -490,7 +673,7 @@ sub unescape { sub shorten { my $line = $_[0]; - if (length $line > 79) { + if (length($line) > 79 and index($line, "\n") == -1) { my $space_place = rindex($line, ' ', 79); if ($space_place != -1) { substr($line, $space_place, 1) = "\n\t"; @@ -500,8 +683,5 @@ sub shorten { } -# have to do this: RS isn't set until run time, but we're executing at compile time -$RS = "\n"; - 1 unless $standalone; # or it'll complain about itself __END__ # wish diag dbase were more accessible