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

package diagnostics;

=head1 NAME

diagnostics - Perl compiler pragma to force verbose warning diagnostics

splain - standalone program to do the same thing

=head1 SYNOPSIS

As a pragma:

    use diagnostics;
    use diagnostics -verbose;

    enable  diagnostics;
    disable diagnostics;

Aa 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 ala 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.005_64;
use Carp;

our $VERSION = 1.0;
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];

$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 $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 in =item line
	$header =~ s/[A-Z]<(.*?)>/$1/g;

	if ($header =~ /%[csd]/) {
	    my $rhs = my $lhs = $header;
	    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//g;
		$lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
	    } 
	    $lhs =~ s/\\%c/./g;
	    $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
	} else {
	    $transmo .= "    m{^\Q$header\E} && return 1;\n";
	} 

	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;

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

    # 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
};

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;
    s/, <.*?> (?:line|chunk).*$//;
    my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
    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
ae2c041d	7	splain - standalone program to do the same thing
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
	19	Aa a program:
	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
	55	descriptions found in L<perldiag>) are only displayed once (no duplicate
	56	descriptions). User code generated warnings ala warn() are unaffected,
	57	allowing duplicate user messages to be displayed.
	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;
17f410f9	171	use 5.005_64;
5f05dabc	172	use Carp;
5f05dabc	173
b75c8c73	174	our $VERSION = 1.0;
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
4633a7c4	198	$DEBUG \|\|= 0;
	199	my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
	200
7a4340ed	201	local $\| = 1;
4633a7c4	202	local $_;
4633a7c4	203
7a4340ed	204	my $standalone;
	205	my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
	206
4633a7c4	207	CONFIG: {
7a4340ed	208	our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
4633a7c4	209
7a4340ed	210	unless (caller) {
4633a7c4	211	$standalone++;
4633a7c4	212	require Getopt::Std;
91a06757	213	Getopt::Std::getopts('pdvf:')
91a06757	214	or die "Usage: $0 [-v] [-p] [-f splainpod]";
4633a7c4	215	$PODFILE = $opt_f if $opt_f;
	216	$DEBUG = 2 if $opt_d;
	217	$VERBOSE = $opt_v;
	218	$PRETTY = $opt_p;
7a4340ed	219	}
4633a7c4	220
	221	if (open(POD_DIAG, $PODFILE)) {
	222	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
	223	last CONFIG;
	224	}
	225
	226	if (caller) {
	227	INCPATH: {
7a4340ed	228	for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
4633a7c4	229	warn "Checking $file\n" if $DEBUG;
	230	if (open(POD_DIAG, $file)) {
	231	while (<POD_DIAG>) {
7a4340ed	232	next unless
7a4340ed	233	/^__END__\s*# wish diag dbase were more accessible/;
4633a7c4	234	print STDERR "podfile is $file\n" if $DEBUG;
	235	last INCPATH;
	236	}
	237	}
	238	}
	239	}
	240	} else {
	241	print STDERR "podfile is <DATA>\n" if $DEBUG;
	242	POD_DIAG = main::DATA;
	243	}
	244	}
	245	if (eof(POD_DIAG)) {
	246	die "couldn't find diagnostic data in $PODFILE @INC $0";
	247	}
	248
	249
	250	%HTML_2_Troff = (
	251	'amp' => '&', # ampersand
	252	'lt' => '<', # left chevron, less-than
	253	'gt' => '>', # right chevron, greater-than
	254	'quot' => '"', # double quote
	255
	256	"Aacute" => "A\\*'", # capital A, acute accent
	257	# etc
	258
	259	);
	260
	261	%HTML_2_Latin_1 = (
	262	'amp' => '&', # ampersand
	263	'lt' => '<', # left chevron, less-than
	264	'gt' => '>', # right chevron, greater-than
	265	'quot' => '"', # double quote
	266
	267	"Aacute" => "\xC1" # capital A, acute accent
	268
	269	# etc
	270	);
	271
	272	%HTML_2_ASCII_7 = (
	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
7a4340ed	282	our %HTML_Escapes;
4633a7c4	283	*HTML_Escapes = do {
	284	if ($standalone) {
	285	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
	286	} else {
	287	\%HTML_2_Latin_1;
	288	}
	289	};
	290
	291	THITHER = $standalone ? STDOUT : *STDERR;
	292
7a4340ed	293	my $transmo = <<EOFUNC;
4633a7c4	294	sub transmo {
599cee73	295	#local \$^W = 0; # recursive warnings we do NOT need!
4633a7c4	296	study;
	297	EOFUNC
	298
7a4340ed	299	my %msg;
7a4340ed	300	{
4633a7c4	301	print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
7a4340ed	302	local $/ = '';
4633a7c4	303	local $_;
7a4340ed	304	my $header;
7a4340ed	305	my $for_item;
4633a7c4	306	while (<POD_DIAG>) {
4633a7c4	307
	308	unescape();
	309	if ($PRETTY) {
	310	sub noop { return $_[0] } # spensive for a noop
	311	sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
	312	sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
	313	s/[BC]<(.*?)>/bold($1)/ges;
	314	s/[LIF]<(.*?)>/italic($1)/ges;
	315	} else {
	316	s/[BC]<(.*?)>/$1/gs;
	317	s/[LIF]<(.*?)>/$1/gs;
	318	}
	319	unless (/^=/) {
	320	if (defined $header) {
	321	if ( $header eq 'DESCRIPTION' &&
	322	( /Optional warnings are enabled/
	323	\|\| /Some of these messages are generic./
	324	) )
	325	{
	326	next;
	327	}
	328	s/^/ /gm;
	329	$msg{$header} .= $_;
7a4340ed	330	undef $for_item;
4633a7c4	331	}
	332	next;
	333	}
7a4340ed	334	unless ( s/=item (.?)\s\z//) {
4633a7c4	335
	336	if ( s/=head1\sDESCRIPTION//) {
	337	$msg{$header = 'DESCRIPTION'} = '';
7a4340ed	338	undef $for_item;
4633a7c4	339	}
7a4340ed	340	elsif( s/^=for\s+diagnostics\s\n(.?)\s*\z// ) {
	341	$for_item = $1;
	342	}
4633a7c4	343	next;
4633a7c4	344	}
4fdae800	345
5cd5c422	346	if( $for_item ) { $header = $for_item; undef $for_item }
	347	else {
	348	$header = $1;
	349	while( $header =~ /[;,]\z/ ) {
	350	<POD_DIAG> =~ /^\s(.?)\s*\z/;
	351	$header .= ' '.$1;
	352	}
	353	}
	354
4fdae800	355	# strip formatting directives in =item line
7a4340ed	356	$header =~ s/[A-Z]<(.*?)>/$1/g;
4633a7c4	357
9a7dcd9c	358	if ($header =~ /%[csd]/) {
7a4340ed	359	my $rhs = my $lhs = $header;
7a4340ed	360	if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E-?\\d+\Q$2\E/g) {
4633a7c4	361	$lhs =~ s/\\%s/.*?/g;
4633a7c4	362	} else {
7a4340ed	363	# if i had lookbehind negations,
7a4340ed	364	# i wouldn't have to do this \377 noise
4633a7c4	365	$lhs =~ s/(.?)%s/\Q$1\E.?\377/g;
4633a7c4	366	$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
4633a7c4	367	$lhs =~ s/\377//g;
e7ea3e70	368	$lhs =~ s/\.\\?$/./; # Allow %s at the end to eat it all
4633a7c4	369	}
9a7dcd9c	370	$lhs =~ s/\\%c/./g;
e7ea3e70	371	$transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
4633a7c4	372	} else {
	373	$transmo .= " m{^\Q$header\E} && return 1;\n";
	374	}
	375
eff9c6e2	376	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
eff9c6e2	377	if $msg{$header};
4633a7c4	378
	379	$msg{$header} = '';
	380	}
	381
	382
	383	close POD_DIAG unless main::DATA eq POD_DIAG;
	384
	385	die "No diagnostics?" unless %msg;
	386
	387	$transmo .= " return 0;\n}\n";
	388	print STDERR $transmo if $DEBUG;
	389	eval $transmo;
	390	die $@ if $@;
7a4340ed	391	}
4633a7c4	392
	393	if ($standalone) {
	394	if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
7a4340ed	395	while (defined (my $error = <>)) {
4633a7c4	396	splainthis($error) \|\| print THITHER $error;
	397	}
	398	exit;
7a4340ed	399	}
	400
	401	my $olddie;
	402	my $oldwarn;
4633a7c4	403
	404	sub import {
	405	shift;
7a4340ed	406	$^W = 1; # yup, clobbered the global variable;
7a4340ed	407	# tough, if you want diags, you want diags.
4633a7c4	408	return if $SIG{__WARN__} eq \&warn_trap;
	409
	410	for (@_) {
	411
	412	/^-d(ebug)?$/ && do {
	413	$DEBUG++;
	414	next;
	415	};
	416
	417	/^-v(erbose)?$/ && do {
	418	$VERBOSE++;
	419	next;
	420	};
	421
	422	/^-p(retty)?$/ && do {
	423	print STDERR "$0: I'm afraid it's too late for prettiness.\n";
	424	$PRETTY++;
	425	next;
	426	};
	427
	428	warn "Unknown flag: $_";
	429	}
	430
	431	$oldwarn = $SIG{__WARN__};
	432	$olddie = $SIG{__DIE__};
	433	$SIG{__WARN__} = \&warn_trap;
	434	$SIG{__DIE__} = \&death_trap;
	435	}
	436
	437	sub enable { &import }
	438
	439	sub disable {
	440	shift;
4633a7c4	441	return unless $SIG{__WARN__} eq \&warn_trap;
3d0ae7ba	442	$SIG{__WARN__} = $oldwarn \|\| '';
3d0ae7ba	443	$SIG{__DIE__} = $olddie \|\| '';
4633a7c4	444	}
	445
	446	sub warn_trap {
	447	my $warning = $_[0];
	448	if (caller eq $WHOAMI or !splainthis($warning)) {
	449	print STDERR $warning;
	450	}
37120919	451	&$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
4633a7c4	452	};
	453
	454	sub death_trap {
	455	my $exception = $_[0];
55497cff	456
	457	# See if we are coming from anywhere within an eval. If so we don't
	458	# want to explain the exception because it's going to get caught.
	459	my $in_eval = 0;
	460	my $i = 0;
	461	while (1) {
	462	my $caller = (caller($i++))[3] or last;
	463	if ($caller eq '(eval)') {
	464	$in_eval = 1;
	465	last;
	466	}
	467	}
	468
	469	splainthis($exception) unless $in_eval;
4633a7c4	470	if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919	471	&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
55497cff	472
	473	# We don't want to unset these if we're coming from an eval because
	474	# then we've turned off diagnostics. (Actually what does this next
	475	# line do? -PSeibel)
	476	$SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
6f48387a	477	local($Carp::CarpLevel) = 1;
6f48387a	478	confess "Uncaught exception from user code:\n\t$exception";
4633a7c4	479	# up we go; where we stop, nobody knows, but i think we die now
	480	# but i'm deeply afraid of the &$olddie guy reraising and us getting
	481	# into an indirect recursion loop
	482	};
	483
7a4340ed	484	my %exact_duplicate;
	485	my %old_diag;
	486	my $count;
	487	my $wantspace;
4633a7c4	488	sub splainthis {
4633a7c4	489	local $_ = shift;
5025c45a	490	local $\;
4633a7c4	491	### &finish_compilation unless %msg;
	492	s/\.?\n+$//;
	493	my $orig = $_;
	494	# return unless defined;
4633a7c4	495	s/, <.?> (?:line\|chunk).$//;
7a4340ed	496	my $real = s/(.?) at .? (?:line\|chunk) \d+.*/$1/;
4633a7c4	497	s/^\((.*)\)$/$1/;
097b73fc	498	if ($exact_duplicate{$orig}++) {
	499	return &transmo;
	500	}
	501	else {
	502	return 0 unless &transmo;
	503	}
4633a7c4	504	$orig = shorten($orig);
	505	if ($old_diag{$_}) {
	506	autodescribe();
	507	print THITHER "$orig (#$old_diag{$_})\n";
	508	$wantspace = 1;
	509	} else {
	510	autodescribe();
	511	$old_diag{$_} = ++$count;
	512	print THITHER "\n" if $wantspace;
	513	$wantspace = 0;
	514	print THITHER "$orig (#$old_diag{$_})\n";
	515	if ($msg{$_}) {
	516	print THITHER $msg{$_};
	517	} else {
	518	if (0 and $standalone) {
	519	print THITHER " **** Error #$old_diag{$_} ",
	520	($real ? "is" : "appears to be"),
	521	" an unknown diagnostic message.\n\n";
	522	}
	523	return 0;
	524	}
	525	}
	526	return 1;
	527	}
	528
	529	sub autodescribe {
	530	if ($VERBOSE and not $count) {
	531	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
	532	"\n$msg{DESCRIPTION}\n";
	533	}
	534	}
	535
	536	sub unescape {
	537	s {
	538	E<
	539	( [A-Za-z]+ )
	540	>
	541	} {
	542	do {
	543	exists $HTML_Escapes{$1}
	544	? do { $HTML_Escapes{$1} }
	545	: do {
f02a87df	546	warn "Unknown escape: E<$1> in $_";
4633a7c4	547	"E<$1>";
	548	}
	549	}
	550	}egx;
	551	}
	552
	553	sub shorten {
	554	my $line = $_[0];
774d564b	555	if (length($line) > 79 and index($line, "\n") == -1) {
4633a7c4	556	my $space_place = rindex($line, ' ', 79);
	557	if ($space_place != -1) {
	558	substr($line, $space_place, 1) = "\n\t";
	559	}
	560	}
	561	return $line;
	562	}
	563
	564
4633a7c4	565	1 unless $standalone; # or it'll complain about itself
4633a7c4	566	__END__ # wish diag dbase were more accessible