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

package diagnostics;

=head1 NAME

diagnostics - Perl compiler pragma to force verbose warning diagnostics

splain - filter to produce verbose descriptions of perl warning diagnostics

=head1 SYNOPSIS

As a pragma:

    use diagnostics;
    use diagnostics -verbose;

    enable  diagnostics;
    disable diagnostics;

As a program:

    perl program 2>diag.out
    splain [-v] [-p] diag.out


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

=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.006;
use Carp;

our $VERSION = 1.11;
our $DEBUG;
our $VERBOSE;
our $PRETTY;

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

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 $/ = '';
    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/[BC]<(.*?)>/bold($1)/ges;
	    s/[LIF]<(.*?)>/italic($1)/ges;
	} else {
	    s/[BC]<(.*?)>/$1/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] =~ s/^.*$/\Q$&\E/;
                    $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;
			       };

	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)) {
	print STDERR $warning;
    } 
    &$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 (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;

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