X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fdiagnostics.pm;h=f174ee5feb8148045b9c7f382ae252006a4ed850;hb=054b02d6604bb3beeebed2d8a040d025b131c9a6;hp=6016d961d83ff718aa1855961e62f5bff84dccd7;hpb=3712091946b37b5feabcc1f630b32639406ad717;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 6016d96..f174ee5 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -1,14 +1,4 @@ -#!/usr/local/bin/perl -eval 'exec perl -S $0 ${1+"$@"}' - if 0; - -use Config; -$diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod"; - package diagnostics; -require 5.001; -use English; -use Carp; =head1 NAME @@ -37,9 +27,9 @@ Aa a program: =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, 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,8 +48,13 @@ However, you may control there 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 ala warn() are unaffected, +allowing duplicate user messages to be displayed. =head2 The I Program @@ -94,7 +89,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 @@ -139,7 +134,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. @@ -155,27 +150,44 @@ 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 +require 5.001; +use Carp; + +use Config; +($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; +if ($^O eq 'VMS') { + require VMS::Filespec; + $privlib = VMS::Filespec::unixify($privlib); + $archlib = VMS::Filespec::unixify($archlib); +} +@trypod = ("$archlib/pod/perldiag.pod", + "$privlib/pod/perldiag-$].pod", + "$privlib/pod/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]; + $DEBUG ||= 0; my $WHOAMI = ref bless []; # nobody's business, prolly not even mine -$OUTPUT_AUTOFLUSH = 1; +$| = 1; local $_; @@ -187,7 +199,8 @@ CONFIG: { 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; @@ -266,7 +279,7 @@ if (eof(POD_DIAG)) { $transmo = </$1/g; if ($header =~ /%[sd]/) { $rhs = $lhs = $header; @@ -324,13 +339,15 @@ EOFUNC #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; $lhs =~ s/\377([^\377]*)$/\Q$1\E/; $lhs =~ s/\377//g; + $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all } - $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; + $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; } else { $transmo .= " m{^\Q$header\E} && return 1;\n"; } - print STDERR "Already saw $header" if $msg{$header}; + print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" + if $msg{$header}; $msg{$header} = ''; } @@ -349,7 +366,7 @@ EOFUNC if ($standalone) { if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while ($error = <>) { + while (defined ($error = <>)) { splainthis($error) || print THITHER $error; } exit; @@ -359,7 +376,7 @@ if ($standalone) { 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; @@ -395,7 +412,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; @@ -411,11 +428,29 @@ sub 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 = 0; + my $i = 0; + while (1) { + my $caller = (caller($i++))[3] or last; + if ($caller eq '(eval)') { + $in_eval = 1; + last; + } + } + + 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; - $SIG{__DIE__} = $SIG{__WARN__} = ''; - confess "Uncaught exception from user code:\n\t$exception Bailing out"; + + # We don't want to unset these if we're coming from an eval because + # then we've turned off diagnostics. (Actually what does this next + # line do? -PSeibel) + $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval; + local($Carp::CarpLevel) = 1; + confess "Uncaught exception from user code:\n\t$exception"; # 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 @@ -423,17 +458,20 @@ sub death_trap { sub splainthis { local $_ = shift; + local $\; ### &finish_compilation unless %msg; 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(); @@ -476,7 +514,7 @@ sub unescape { exists $HTML_Escapes{$1} ? do { $HTML_Escapes{$1} } : do { - warn "Unknown escape: $& in $_"; + warn "Unknown escape: E<$1> in $_"; "E<$1>"; } } @@ -485,7 +523,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"; @@ -495,7 +533,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