[p5sagit/p5-mst-13.2.git] / lib / diagnostics.pm

package diagnostics;

=head1 NAME

diagnostics, splain - produce verbose warning diagnostics

=head1 SYNOPSIS

Using the C<diagnostics> pragma:

    use diagnostics;
    use diagnostics -verbose;

    enable  diagnostics;
    disable diagnostics;

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 (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.

To use in your program as a pragma, merely invoke

    use diagnostics;

at the start (or near the start) of your program.  (Note 
that this I<does> enable perl's B<-w> flag.)  Your whole
compilation will then be subject(ed :-) to the enhanced diagnostics.
These still go out B<STDERR>.

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<no diagnostics> to turn them off at compiletime.
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<perldiag> introduction before
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<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
more than a link to the (executable) F<diagnostics.pm> module, as well as
a link to the F<diagnostics.pod> documentation.  The B<-v> flag is like
the C<use diagnostics -verbose> directive.
The B<-p> flag is like the
$diagnostics::PRETTY variable.  Since you're post-processing with 
I<splain>, there's no sense in being able to enable() or disable() processing.

Output from I<splain> is directed to B<STDOUT>, unlike the pragma.

=head1 EXAMPLES

The following file is certain to trigger a few errors at both
runtime and compiletime:

    use diagnostics;
    print NOWHERE "nothing\n";
    print STDERR "\n\tThis message should be unadorned.\n";
    warn "\tThis is a user warning";
    print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
    my $a, $b = scalar <STDIN>;
    print "\n";
    print $x/$y;

If you prefer to run your program first and look at its problem
afterwards, do this:

    perl -w test.pl 2>test.out
    ./splain < test.out

Note that this is not in general possible in shells of more dubious heritage, 
as the theoretical 

    (perl -w test.pl >/dev/tty) >& test.out
    ./splain < test.out

Because you just moved the existing B<stdout> to somewhere else.

If you don't want to modify your source code, but still have on-the-fly
warnings, do this:

    exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- 

Nifty, eh?

If you want to control warnings on the fly, do something like this.
Make sure you do the C<use> first, or you won't be able to get
at the enable() or disable() methods.

    use diagnostics; # checks entire compilation phase 
	print "\ntime for 1st bogus diags: SQUAWKINGS\n";
	print BOGUS1 'nada';
	print "done with 1st bogus\n";

    disable diagnostics; # only turns off runtime warnings
	print "\ntime for 2nd bogus: (squelched)\n";
	print BOGUS2 'nada';
	print "done with 2nd bogus\n";

    enable diagnostics; # turns back on runtime warnings
	print "\ntime for 3rd bogus: SQUAWKINGS\n";
	print BOGUS3 'nada';
	print "done with 3rd bogus\n";

    disable diagnostics;
	print "\ntime for 4th bogus: (squelched)\n";
	print BOGUS4 'nada';
	print "done with 4th bogus\n";

=head1 INTERNALS

Diagnostic messages derive from the F<perldiag.pod> file when available at
runtime.  Otherwise, they may be embedded in the file itself when the
splain package is built.   See the F<Makefile> for details.

If an extant $SIG{__WARN__} handler is discovered, it will continue
to be honored, but only after the diagnostics::splainthis() function 
(the module's $SIG{__WARN__} interceptor) has had its way with your
warnings.

There is a $diagnostics::DEBUG variable you may set if you're desperately
curious what sorts of things are being intercepted.

    BEGIN { $diagnostics::DEBUG = 1 } 


=head1 BUGS

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 do this instead, and I<before> 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 Perl 5.001e.

While it's true that this documentation is somewhat subserious, if you use
a program named I<splain>, you should expect a bit of whimsy.

=head1 AUTHOR

Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.

=cut

use strict;
use 5.009001;
use Carp;
$Carp::Internal{__PACKAGE__.""}++;

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)};
if ($^O eq 'VMS') {
    require VMS::Filespec;
    $privlib = VMS::Filespec::unixify($privlib);
    $archlib = VMS::Filespec::unixify($archlib);
}
my @trypod = (
	   "$archlib/pod/perldiag.pod",
	   "$privlib/pod/perldiag-$Config{version}.pod",
	   "$privlib/pod/perldiag.pod",
	   "$archlib/pods/perldiag.pod",
	   "$privlib/pods/perldiag-$Config{version}.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];

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;
my $_;

my $standalone;
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);

CONFIG: {
    our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';

    unless (caller) {
	$standalone++;
	require Getopt::Std;
	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;
	last CONFIG;
    } 

    if (caller) {
	INCPATH: {
	    for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
		warn "Checking $file\n" if $DEBUG;
		if (open(POD_DIAG, $file)) {
		    while (<POD_DIAG>) {
			next unless
			    /^__END__\s*# wish diag dbase were more accessible/;
			print STDERR "podfile is $file\n" if $DEBUG;
			last INCPATH;
		    }
		}
	    } 
	}
    } else { 
	print STDERR "podfile is <DATA>\n" if $DEBUG;
	*POD_DIAG = *main::DATA;
    }
}
if (eof(POD_DIAG)) { 
    die "couldn't find diagnostic data in $PODFILE @INC $0";
}


%HTML_2_Troff = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'>',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    "Aacute"	=>	"A\\*'",	#   capital A, acute accent
    # etc

);

%HTML_2_Latin_1 = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'>',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    "Aacute"	=>	"\xC1"	#   capital A, acute accent

    # etc
);

%HTML_2_ASCII_7 = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'>',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    "Aacute"	=>	"A"	#   capital A, acute accent
    # etc
);

our %HTML_Escapes;
*HTML_Escapes = do {
    if ($standalone) {
	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 
    } else {
	\%HTML_2_Latin_1; 
    }
}; 

*THITHER = $standalone ? *STDOUT : *STDERR;

my %transfmt = (); 
my $transmo = <<EOFUNC;
sub transmo {
    #local \$^W = 0;  # recursive warnings we do NOT need!
    study;
EOFUNC

my %msg;
{
    print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
    local $/ = '';
    my $header;
    my $for_item;
    while (<POD_DIAG>) {

	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;
	} else {
	    s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
	    s/[LIF]<(.*?)>/$1/gs;
	} 
	unless (/^=/) {
	    if (defined $header) { 
		if ( $header eq 'DESCRIPTION' && 
		    (   /Optional warnings are enabled/ 
		     || /Some of these messages are generic./
		    ) )
		{
		    next;
		}
		s/^/    /gm;
		$msg{$header} .= $_;
	 	undef $for_item;	
	    }
	    next;
	} 
	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;
	}

	if( $for_item ) { $header = $for_item; undef $for_item } 
	else {
	    $header = $1;
	    while( $header =~ /[;,]\z/ ) {
		<POD_DIAG> =~ /^\s*(.*?)\s*\z/;
		$header .= ' '.$1;
	    }
	}

	# strip formatting directives from =item line
	$header =~ s/[A-Z]<(.*?)>/$1/g;

        my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $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' ){
                        $toks[$i] = '\d+';
                    } elsif( $toks[$i] eq '%s' ){
                        $toks[$i] = $i == $#toks ? '.*' : '.*?';
                    } elsif( $toks[$i] =~ '%.(\d+)s' ){
                        $toks[$i] = ".{$1}";
                     } elsif( $toks[$i] =~ '^%l*x$' ){
                        $toks[$i] = '[\da-f]+';
                   }
                } elsif( length( $toks[$i] ) ){
                    $toks[$i] = quotemeta $toks[$i];
                    $conlen += length( $toks[$i] );
                }
            }  
            my $lhs = join( '', @toks );
	    $transfmt{$header}{pat} =
              "    s{^$lhs}\n     {\Q$header\E}s\n\t&& return 1;\n";
            $transfmt{$header}{len} = $conlen;
	} else {
            $transfmt{$header}{pat} =
	      "    m{^\Q$header\E} && return 1;\n";
            $transfmt{$header}{len} = length( $header );
	} 

	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
	    if $msg{$header};

	$msg{$header} = '';
    } 


    close POD_DIAG unless *main::DATA eq *POD_DIAG;

    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 $@;
}

if ($standalone) {
    if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
    while (defined (my $error = <>)) {
	splainthis($error) || print THITHER $error;
    } 
    exit;
} 

my $olddie;
my $oldwarn;

sub import {
    shift;
    $^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 (@_) {

	/^-d(ebug)?$/ 	   	&& do {
				    $DEBUG++;
				    next;
				   };

	/^-v(erbose)?$/ 	&& do {
				    $VERBOSE++;
				    next;
				   };

	/^-p(retty)?$/ 		&& do {
				    print STDERR "$0: I'm afraid it's too late for prettiness.\n";
				    $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: $_";
    } 

    $oldwarn = $SIG{__WARN__};
    $olddie = $SIG{__DIE__};
    $SIG{__WARN__} = \&warn_trap;
    $SIG{__DIE__} = \&death_trap;
} 

sub enable { &import }

sub disable {
    shift;
    return unless $SIG{__WARN__} eq \&warn_trap;
    $SIG{__WARN__} = $oldwarn || '';
    $SIG{__DIE__} = $olddie || '';
} 

sub warn_trap {
    my $warning = $_[0];
    if (caller eq $WHOAMI or !splainthis($warning)) {
	if ($WARNTRACE) {
	    print STDERR Carp::longmess($warning);
	} else {
	    print STDERR $warning;
	}
    } 
    goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
};

sub death_trap {
    my $exception = $_[0];

    # 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 (my $caller = (caller($i++))[3]) {
      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;

    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__} = '';

    # Have carp skip over death_trap() when showing the stack trace.
    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
};

my %exact_duplicate;
my %old_diag;
my $count;
my $wantspace;
sub splainthis {
    return 0 if $TRACEONLY;
    $_ = shift;
    local $\;
    local $!;
    ### &finish_compilation unless %msg;
    s/\.?\n+$//;
    my $orig = $_;
    # return unless defined;

    # get rid of the where-are-we-in-input part
    s/, <.*?> (?:line|chunk).*$//;

    # Discard 1st " at <file> line <no>" and all text beyond
    # 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+/ ){
            $real = 1;
            last;
        } else {
            $_ .= ' at ' . $secs[$i];
	}
    }
    
    # remove parenthesis occurring at the end of some messages 
    s/^\((.*)\)$/$1/;

    if ($exact_duplicate{$orig}++) {
	return &transmo;
    } else {
	return 0 unless &transmo;
    }

    $orig = shorten($orig);
    if ($old_diag{$_}) {
	autodescribe();
	print THITHER "$orig (#$old_diag{$_})\n";
	$wantspace = 1;
    } else {
	autodescribe();
	$old_diag{$_} = ++$count;
	print THITHER "\n" if $wantspace;
	$wantspace = 0;
	print THITHER "$orig (#$old_diag{$_})\n";
	if ($msg{$_}) {
	    print THITHER $msg{$_};
	} else {
	    if (0 and $standalone) { 
		print THITHER "    **** Error #$old_diag{$_} ",
			($real ? "is" : "appears to be"),
			" an unknown diagnostic message.\n\n";
	    }
	    return 0;
	} 
    }
    return 1;
} 

sub autodescribe {
    if ($VERBOSE and not $count) {
	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
		"\n$msg{DESCRIPTION}\n";
    } 
} 

sub unescape { 
    s {
            E<  
            ( [A-Za-z]+ )       
            >   
    } { 
         do {   
             exists $HTML_Escapes{$1}
                ? do { $HTML_Escapes{$1} }
                : do {
                    warn "Unknown escape: E<$1> in $_";
                    "E<$1>";
                } 
         } 
    }egx;
}

sub shorten {
    my $line = $_[0];
    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";
	} 
    } 
    return $line;
} 


1 unless $standalone;  # or it'll complain about itself
__END__ # wish diag dbase were more accessible
Commit	Line	Data
4633a7c4	1	package diagnostics;
4633a7c4	2
	3	=head1 NAME
	4
c7bcd97d	5	diagnostics, splain - produce verbose warning diagnostics
4633a7c4	6
	7	=head1 SYNOPSIS
	8
c7bcd97d	9	Using the C<diagnostics> pragma:
4633a7c4	10
	11	use diagnostics;
	12	use diagnostics -verbose;
	13
	14	enable diagnostics;
	15	disable diagnostics;
	16
c7bcd97d	17	Using the C<splain> standalone filter program:
4633a7c4	18
	19	perl program 2>diag.out
	20	splain [-v] [-p] diag.out
	21
58618f23	22	Using diagnostics to get stack traces from a misbehaving script:
	23
	24	perl -Mdiagnostics=-traceonly my_script.pl
	25
4633a7c4	26	=head1 DESCRIPTION
	27
	28	=head2 The C<diagnostics> Pragma
	29
	30	This module extends the terse diagnostics normally emitted by both the
c411974d	31	perl compiler and the perl interpreter (from running perl with a -w
c411974d	32	switch or C<use warnings>), augmenting them with the more
4633a7c4	33	explicative and endearing descriptions found in L<perldiag>. Like the
1fef88e7	34	other pragmata, it affects the compilation phase of your program rather
4633a7c4	35	than merely the execution phase.
	36
	37	To use in your program as a pragma, merely invoke
	38
	39	use diagnostics;
	40
	41	at the start (or near the start) of your program. (Note
	42	that this I<does> enable perl's B<-w> flag.) Your whole
	43	compilation will then be subject(ed :-) to the enhanced diagnostics.
	44	These still go out B<STDERR>.
	45
ae2c041d	46	Due to the interaction between runtime and compiletime issues,
4633a7c4	47	and because it's probably not a very good idea anyway,
ae2c041d	48	you may not use C<no diagnostics> to turn them off at compiletime.
3d0ae7ba	49	However, you may control their behaviour at runtime using the
4633a7c4	50	disable() and enable() methods to turn them off and on respectively.
	51
	52	The B<-verbose> flag first prints out the L<perldiag> introduction before
1fef88e7	53	any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
1fef88e7	54	escape sequences for pagers.
4633a7c4	55
097b73fc	56	Warnings dispatched from perl itself (or more accurately, those that match
097b73fc	57	descriptions found in L<perldiag>) are only displayed once (no duplicate
49704364	58	descriptions). User code generated warnings a la warn() are unaffected,
097b73fc	59	allowing duplicate user messages to be displayed.
097b73fc	60
58618f23	61	This module also adds a stack trace to the error message when perl dies.
58618f23	62	This is useful for pinpointing what caused the death. The B<-traceonly> (or
3c4b39be	63	just B<-t>) flag turns off the explanations of warning messages leaving just
58618f23	64	the stack traces. So if your script is dieing, run it again with
	65
	66	perl -Mdiagnostics=-traceonly my_bad_script
	67
	68	to see the call stack at the time of death. By supplying the B<-warntrace>
	69	(or just B<-w>) flag, any warnings emitted will also come with a stack
	70	trace.
	71
4633a7c4	72	=head2 The I<splain> Program
	73
	74	While apparently a whole nuther program, I<splain> is actually nothing
	75	more than a link to the (executable) F<diagnostics.pm> module, as well as
	76	a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
	77	the C<use diagnostics -verbose> directive.
	78	The B<-p> flag is like the
	79	$diagnostics::PRETTY variable. Since you're post-processing with
	80	I<splain>, there's no sense in being able to enable() or disable() processing.
	81
	82	Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
	83
	84	=head1 EXAMPLES
	85
	86	The following file is certain to trigger a few errors at both
ae2c041d	87	runtime and compiletime:
4633a7c4	88
	89	use diagnostics;
	90	print NOWHERE "nothing\n";
	91	print STDERR "\n\tThis message should be unadorned.\n";
	92	warn "\tThis is a user warning";
	93	print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
	94	my $a, $b = scalar <STDIN>;
	95	print "\n";
	96	print $x/$y;
	97
	98	If you prefer to run your program first and look at its problem
	99	afterwards, do this:
	100
	101	perl -w test.pl 2>test.out
	102	./splain < test.out
	103
	104	Note that this is not in general possible in shells of more dubious heritage,
1fef88e7	105	as the theoretical
4633a7c4	106
	107	(perl -w test.pl >/dev/tty) >& test.out
	108	./splain < test.out
	109
	110	Because you just moved the existing B<stdout> to somewhere else.
	111
	112	If you don't want to modify your source code, but still have on-the-fly
	113	warnings, do this:
	114
	115	exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- \| splain 1>&2 3>&-
	116
	117	Nifty, eh?
	118
	119	If you want to control warnings on the fly, do something like this.
	120	Make sure you do the C<use> first, or you won't be able to get
	121	at the enable() or disable() methods.
	122
	123	use diagnostics; # checks entire compilation phase
	124	print "\ntime for 1st bogus diags: SQUAWKINGS\n";
	125	print BOGUS1 'nada';
	126	print "done with 1st bogus\n";
	127
	128	disable diagnostics; # only turns off runtime warnings
	129	print "\ntime for 2nd bogus: (squelched)\n";
	130	print BOGUS2 'nada';
	131	print "done with 2nd bogus\n";
	132
	133	enable diagnostics; # turns back on runtime warnings
	134	print "\ntime for 3rd bogus: SQUAWKINGS\n";
	135	print BOGUS3 'nada';
	136	print "done with 3rd bogus\n";
	137
	138	disable diagnostics;
	139	print "\ntime for 4th bogus: (squelched)\n";
	140	print BOGUS4 'nada';
	141	print "done with 4th bogus\n";
	142
	143	=head1 INTERNALS
	144
	145	Diagnostic messages derive from the F<perldiag.pod> file when available at
	146	runtime. Otherwise, they may be embedded in the file itself when the
	147	splain package is built. See the F<Makefile> for details.
	148
	149	If an extant $SIG{__WARN__} handler is discovered, it will continue
1fef88e7	150	to be honored, but only after the diagnostics::splainthis() function
4633a7c4	151	(the module's $SIG{__WARN__} interceptor) has had its way with your
	152	warnings.
	153
	154	There is a $diagnostics::DEBUG variable you may set if you're desperately
	155	curious what sorts of things are being intercepted.
	156
	157	BEGIN { $diagnostics::DEBUG = 1 }
	158
	159
	160	=head1 BUGS
	161
	162	Not being able to say "no diagnostics" is annoying, but may not be
	163	insurmountable.
	164
	165	The C<-pretty> directive is called too late to affect matters.
864e1151	166	You have to do this instead, and I<before> you load the module.
4633a7c4	167
	168	BEGIN { $diagnostics::PRETTY = 1 }
	169
	170	I could start up faster by delaying compilation until it should be
a6006777	171	needed, but this gets a "panic: top_level" when using the pragma form
a6006777	172	in Perl 5.001e.
4633a7c4	173
	174	While it's true that this documentation is somewhat subserious, if you use
	175	a program named I<splain>, you should expect a bit of whimsy.
	176
	177	=head1 AUTHOR
	178
352854fa	179	Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
4633a7c4	180
	181	=cut
	182
7a4340ed	183	use strict;
d923656e	184	use 5.009001;
5f05dabc	185	use Carp;
58618f23	186	$Carp::Internal{__PACKAGE__.""}++;
5f05dabc	187
d923656e	188	our $VERSION = 1.17;
7a4340ed	189	our $DEBUG;
	190	our $VERBOSE;
	191	our $PRETTY;
58618f23	192	our $TRACEONLY = 0;
58618f23	193	our $WARNTRACE = 0;
1e4e2d84	194
5f05dabc	195	use Config;
7a4340ed	196	my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
5f05dabc	197	if ($^O eq 'VMS') {
91a06757	198	require VMS::Filespec;
	199	$privlib = VMS::Filespec::unixify($privlib);
	200	$archlib = VMS::Filespec::unixify($archlib);
5f05dabc	201	}
7a4340ed	202	my @trypod = (
7ec2cea4	203	"$archlib/pod/perldiag.pod",
0ff3fa1a	204	"$privlib/pod/perldiag-$Config{version}.pod",
5459498c	205	"$privlib/pod/perldiag.pod",
7ec2cea4	206	"$archlib/pods/perldiag.pod",
0ff3fa1a	207	"$privlib/pods/perldiag-$Config{version}.pod",
5459498c	208	"$privlib/pods/perldiag.pod",
7ec2cea4	209	);
fb73857a	210	# handy for development testing of new warnings etc
fb73857a	211	unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
7a4340ed	212	(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
5f05dabc	213
95e8664e	214	if ($^O eq 'MacOS') {
	215	# just updir one from each lib dir, we'll find it ...
	216	($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
	217	}
	218
	219
4633a7c4	220	$DEBUG \|\|= 0;
	221	my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
	222
7a4340ed	223	local $\| = 1;
d923656e	224	my $_;
4633a7c4	225
7a4340ed	226	my $standalone;
	227	my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
	228
4633a7c4	229	CONFIG: {
7a4340ed	230	our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
4633a7c4	231
7a4340ed	232	unless (caller) {
4633a7c4	233	$standalone++;
4633a7c4	234	require Getopt::Std;
91a06757	235	Getopt::Std::getopts('pdvf:')
91a06757	236	or die "Usage: $0 [-v] [-p] [-f splainpod]";
4633a7c4	237	$PODFILE = $opt_f if $opt_f;
	238	$DEBUG = 2 if $opt_d;
	239	$VERBOSE = $opt_v;
	240	$PRETTY = $opt_p;
7a4340ed	241	}
4633a7c4	242
	243	if (open(POD_DIAG, $PODFILE)) {
	244	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
	245	last CONFIG;
	246	}
	247
	248	if (caller) {
	249	INCPATH: {
7a4340ed	250	for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
4633a7c4	251	warn "Checking $file\n" if $DEBUG;
	252	if (open(POD_DIAG, $file)) {
	253	while (<POD_DIAG>) {
7a4340ed	254	next unless
7a4340ed	255	/^__END__\s*# wish diag dbase were more accessible/;
4633a7c4	256	print STDERR "podfile is $file\n" if $DEBUG;
	257	last INCPATH;
	258	}
	259	}
	260	}
	261	}
	262	} else {
	263	print STDERR "podfile is <DATA>\n" if $DEBUG;
	264	POD_DIAG = main::DATA;
	265	}
	266	}
	267	if (eof(POD_DIAG)) {
	268	die "couldn't find diagnostic data in $PODFILE @INC $0";
	269	}
	270
	271
	272	%HTML_2_Troff = (
	273	'amp' => '&', # ampersand
	274	'lt' => '<', # left chevron, less-than
	275	'gt' => '>', # right chevron, greater-than
	276	'quot' => '"', # double quote
	277
	278	"Aacute" => "A\\*'", # capital A, acute accent
	279	# etc
	280
	281	);
	282
	283	%HTML_2_Latin_1 = (
	284	'amp' => '&', # ampersand
	285	'lt' => '<', # left chevron, less-than
	286	'gt' => '>', # right chevron, greater-than
	287	'quot' => '"', # double quote
	288
	289	"Aacute" => "\xC1" # capital A, acute accent
	290
	291	# etc
	292	);
	293
	294	%HTML_2_ASCII_7 = (
	295	'amp' => '&', # ampersand
	296	'lt' => '<', # left chevron, less-than
	297	'gt' => '>', # right chevron, greater-than
	298	'quot' => '"', # double quote
	299
	300	"Aacute" => "A" # capital A, acute accent
	301	# etc
	302	);
	303
7a4340ed	304	our %HTML_Escapes;
4633a7c4	305	*HTML_Escapes = do {
	306	if ($standalone) {
	307	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
	308	} else {
	309	\%HTML_2_Latin_1;
	310	}
	311	};
	312
	313	THITHER = $standalone ? STDOUT : *STDERR;
	314
49704364	315	my %transfmt = ();
7a4340ed	316	my $transmo = <<EOFUNC;
4633a7c4	317	sub transmo {
599cee73	318	#local \$^W = 0; # recursive warnings we do NOT need!
4633a7c4	319	study;
	320	EOFUNC
	321
7a4340ed	322	my %msg;
7a4340ed	323	{
4633a7c4	324	print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
7a4340ed	325	local $/ = '';
7a4340ed	326	my $header;
7a4340ed	327	my $for_item;
4633a7c4	328	while (<POD_DIAG>) {
4633a7c4	329
	330	unescape();
	331	if ($PRETTY) {
	332	sub noop { return $_[0] } # spensive for a noop
	333	sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
	334	sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
67612b68	335	s/C<<< (.?) >>>\|C<< (.?) >>\|[BC]<(.*?)>/bold($+)/ges;
4633a7c4	336	s/[LIF]<(.*?)>/italic($1)/ges;
4633a7c4	337	} else {
67612b68	338	s/C<<< (.?) >>>\|C<< (.?) >>\|[BC]<(.*?)>/$+/gs;
4633a7c4	339	s/[LIF]<(.*?)>/$1/gs;
	340	}
	341	unless (/^=/) {
	342	if (defined $header) {
	343	if ( $header eq 'DESCRIPTION' &&
	344	( /Optional warnings are enabled/
	345	\|\| /Some of these messages are generic./
	346	) )
	347	{
	348	next;
49704364	349	}
4633a7c4	350	s/^/ /gm;
4633a7c4	351	$msg{$header} .= $_;
7a4340ed	352	undef $for_item;
4633a7c4	353	}
	354	next;
	355	}
7a4340ed	356	unless ( s/=item (.?)\s\z//) {
4633a7c4	357
	358	if ( s/=head1\sDESCRIPTION//) {
	359	$msg{$header = 'DESCRIPTION'} = '';
7a4340ed	360	undef $for_item;
4633a7c4	361	}
7a4340ed	362	elsif( s/^=for\s+diagnostics\s\n(.?)\s*\z// ) {
	363	$for_item = $1;
	364	}
4633a7c4	365	next;
4633a7c4	366	}
4fdae800	367
5cd5c422	368	if( $for_item ) { $header = $for_item; undef $for_item }
	369	else {
	370	$header = $1;
	371	while( $header =~ /[;,]\z/ ) {
	372	<POD_DIAG> =~ /^\s(.?)\s*\z/;
	373	$header .= ' '.$1;
	374	}
	375	}
	376
49704364	377	# strip formatting directives from =item line
7a4340ed	378	$header =~ s/[A-Z]<(.*?)>/$1/g;
4633a7c4	379
49704364	380	my @toks = split( /(%l?[dx]\|%c\|%(?:\.\d+)?s)/, $header );
	381	if (@toks > 1) {
	382	my $conlen = 0;
	383	for my $i (0..$#toks){
	384	if( $i % 2 ){
	385	if( $toks[$i] eq '%c' ){
	386	$toks[$i] = '.';
	387	} elsif( $toks[$i] eq '%d' ){
	388	$toks[$i] = '\d+';
	389	} elsif( $toks[$i] eq '%s' ){
	390	$toks[$i] = $i == $#toks ? '.' : '.?';
	391	} elsif( $toks[$i] =~ '%.(\d+)s' ){
	392	$toks[$i] = ".{$1}";
	393	} elsif( $toks[$i] =~ '^%l*x$' ){
	394	$toks[$i] = '[\da-f]+';
	395	}
	396	} elsif( length( $toks[$i] ) ){
8ec7363a	397	$toks[$i] = quotemeta $toks[$i];
49704364	398	$conlen += length( $toks[$i] );
	399	}
	400	}
	401	my $lhs = join( '', @toks );
	402	$transfmt{$header}{pat} =
	403	" s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
	404	$transfmt{$header}{len} = $conlen;
4633a7c4	405	} else {
49704364	406	$transfmt{$header}{pat} =
	407	" m{^\Q$header\E} && return 1;\n";
	408	$transfmt{$header}{len} = length( $header );
4633a7c4	409	}
4633a7c4	410
eff9c6e2	411	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
eff9c6e2	412	if $msg{$header};
4633a7c4	413
	414	$msg{$header} = '';
	415	}
	416
	417
	418	close POD_DIAG unless main::DATA eq POD_DIAG;
	419
	420	die "No diagnostics?" unless %msg;
	421
49704364	422	# Apply patterns in order of decreasing sum of lengths of fixed parts
	423	# Seems the best way of hitting the right one.
	424	for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
	425	keys %transfmt ){
	426	$transmo .= $transfmt{$hdr}{pat};
	427	}
4633a7c4	428	$transmo .= " return 0;\n}\n";
	429	print STDERR $transmo if $DEBUG;
	430	eval $transmo;
	431	die $@ if $@;
7a4340ed	432	}
4633a7c4	433
	434	if ($standalone) {
	435	if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
7a4340ed	436	while (defined (my $error = <>)) {
4633a7c4	437	splainthis($error) \|\| print THITHER $error;
	438	}
	439	exit;
7a4340ed	440	}
	441
	442	my $olddie;
	443	my $oldwarn;
4633a7c4	444
	445	sub import {
	446	shift;
7a4340ed	447	$^W = 1; # yup, clobbered the global variable;
7a4340ed	448	# tough, if you want diags, you want diags.
0dc02ca5	449	return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
4633a7c4	450
	451	for (@_) {
	452
	453	/^-d(ebug)?$/ && do {
	454	$DEBUG++;
	455	next;
	456	};
	457
	458	/^-v(erbose)?$/ && do {
	459	$VERBOSE++;
	460	next;
	461	};
	462
	463	/^-p(retty)?$/ && do {
	464	print STDERR "$0: I'm afraid it's too late for prettiness.\n";
	465	$PRETTY++;
	466	next;
	467	};
b4e8c6dd	468	# matches trace and traceonly for legacy doc mixup reasons
b4e8c6dd	469	/^-t(race(only)?)?$/ && do {
58618f23	470	$TRACEONLY++;
	471	next;
	472	};
b4e8c6dd	473	/^-w(arntrace)?$/ && do {
58618f23	474	$WARNTRACE++;
	475	next;
	476	};
	477
4633a7c4	478	warn "Unknown flag: $_";
	479	}
	480
	481	$oldwarn = $SIG{__WARN__};
	482	$olddie = $SIG{__DIE__};
	483	$SIG{__WARN__} = \&warn_trap;
	484	$SIG{__DIE__} = \&death_trap;
	485	}
	486
	487	sub enable { &import }
	488
	489	sub disable {
	490	shift;
4633a7c4	491	return unless $SIG{__WARN__} eq \&warn_trap;
3d0ae7ba	492	$SIG{__WARN__} = $oldwarn \|\| '';
3d0ae7ba	493	$SIG{__DIE__} = $olddie \|\| '';
4633a7c4	494	}
	495
	496	sub warn_trap {
	497	my $warning = $_[0];
	498	if (caller eq $WHOAMI or !splainthis($warning)) {
58618f23	499	if ($WARNTRACE) {
	500	print STDERR Carp::longmess($warning);
	501	} else {
	502	print STDERR $warning;
	503	}
4633a7c4	504	}
58618f23	505	goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
4633a7c4	506	};
	507
	508	sub death_trap {
	509	my $exception = $_[0];
55497cff	510
	511	# See if we are coming from anywhere within an eval. If so we don't
	512	# want to explain the exception because it's going to get caught.
	513	my $in_eval = 0;
	514	my $i = 0;
58618f23	515	while (my $caller = (caller($i++))[3]) {
55497cff	516	if ($caller eq '(eval)') {
	517	$in_eval = 1;
	518	last;
	519	}
	520	}
	521
	522	splainthis($exception) unless $in_eval;
4633a7c4	523	if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919	524	&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
55497cff	525
d23f0205	526	return if $in_eval;
d23f0205	527
55497cff	528	# We don't want to unset these if we're coming from an eval because
d23f0205	529	# then we've turned off diagnostics.
	530
	531	# Switch off our die/warn handlers so we don't wind up in our own
	532	# traps.
	533	$SIG{__DIE__} = $SIG{__WARN__} = '';
	534
	535	# Have carp skip over death_trap() when showing the stack trace.
6f48387a	536	local($Carp::CarpLevel) = 1;
d23f0205	537
6f48387a	538	confess "Uncaught exception from user code:\n\t$exception";
4633a7c4	539	# up we go; where we stop, nobody knows, but i think we die now
	540	# but i'm deeply afraid of the &$olddie guy reraising and us getting
	541	# into an indirect recursion loop
	542	};
	543
7a4340ed	544	my %exact_duplicate;
	545	my %old_diag;
	546	my $count;
	547	my $wantspace;
4633a7c4	548	sub splainthis {
58618f23	549	return 0 if $TRACEONLY;
d923656e	550	$_ = shift;
5025c45a	551	local $\;
2a6a970f	552	local $!;
4633a7c4	553	### &finish_compilation unless %msg;
	554	s/\.?\n+$//;
	555	my $orig = $_;
	556	# return unless defined;
49704364	557
49704364	558	# get rid of the where-are-we-in-input part
4633a7c4	559	s/, <.?> (?:line\|chunk).$//;
49704364	560
	561	# Discard 1st " at <file> line <no>" and all text beyond
	562	# but be aware of messsages containing " at this-or-that"
	563	my $real = 0;
	564	my @secs = split( / at / );
18d238e4	565	return unless @secs;
49704364	566	$_ = $secs[0];
	567	for my $i ( 1..$#secs ){
	568	if( $secs[$i] =~ /.+? (?:line\|chunk) \d+/ ){
	569	$real = 1;
	570	last;
	571	} else {
	572	$_ .= ' at ' . $secs[$i];
	573	}
	574	}
	575
	576	# remove parenthesis occurring at the end of some messages
4633a7c4	577	s/^\((.*)\)$/$1/;
49704364	578
097b73fc	579	if ($exact_duplicate{$orig}++) {
097b73fc	580	return &transmo;
49704364	581	} else {
097b73fc	582	return 0 unless &transmo;
097b73fc	583	}
49704364	584
4633a7c4	585	$orig = shorten($orig);
	586	if ($old_diag{$_}) {
	587	autodescribe();
	588	print THITHER "$orig (#$old_diag{$_})\n";
	589	$wantspace = 1;
	590	} else {
	591	autodescribe();
	592	$old_diag{$_} = ++$count;
	593	print THITHER "\n" if $wantspace;
	594	$wantspace = 0;
	595	print THITHER "$orig (#$old_diag{$_})\n";
	596	if ($msg{$_}) {
	597	print THITHER $msg{$_};
	598	} else {
	599	if (0 and $standalone) {
	600	print THITHER " **** Error #$old_diag{$_} ",
	601	($real ? "is" : "appears to be"),
	602	" an unknown diagnostic message.\n\n";
	603	}
	604	return 0;
	605	}
	606	}
	607	return 1;
	608	}
	609
	610	sub autodescribe {
	611	if ($VERBOSE and not $count) {
	612	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
	613	"\n$msg{DESCRIPTION}\n";
	614	}
	615	}
	616
	617	sub unescape {
	618	s {
	619	E<
	620	( [A-Za-z]+ )
	621	>
	622	} {
	623	do {
	624	exists $HTML_Escapes{$1}
	625	? do { $HTML_Escapes{$1} }
	626	: do {
f02a87df	627	warn "Unknown escape: E<$1> in $_";
4633a7c4	628	"E<$1>";
	629	}
	630	}
	631	}egx;
	632	}
	633
	634	sub shorten {
	635	my $line = $_[0];
774d564b	636	if (length($line) > 79 and index($line, "\n") == -1) {
4633a7c4	637	my $space_place = rindex($line, ' ', 79);
	638	if ($space_place != -1) {
	639	substr($line, $space_place, 1) = "\n\t";
	640	}
	641	}
	642	return $line;
	643	}
	644
	645
4633a7c4	646	1 unless $standalone; # or it'll complain about itself
4633a7c4	647	__END__ # wish diag dbase were more accessible