[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 = v1.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;
	}

	# strip formatting directives in =item line
	$header = $for_item || $1;
	undef $for_item;	
	$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
7a4340ed	174	our $VERSION = v1.0;
	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
4fdae800	346	# strip formatting directives in =item line
7a4340ed	347	$header = $for_item \|\| $1;
	348	undef $for_item;
	349	$header =~ s/[A-Z]<(.*?)>/$1/g;
4633a7c4	350
9a7dcd9c	351	if ($header =~ /%[csd]/) {
7a4340ed	352	my $rhs = my $lhs = $header;
7a4340ed	353	if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E-?\\d+\Q$2\E/g) {
4633a7c4	354	$lhs =~ s/\\%s/.*?/g;
4633a7c4	355	} else {
7a4340ed	356	# if i had lookbehind negations,
7a4340ed	357	# i wouldn't have to do this \377 noise
4633a7c4	358	$lhs =~ s/(.?)%s/\Q$1\E.?\377/g;
4633a7c4	359	$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
4633a7c4	360	$lhs =~ s/\377//g;
e7ea3e70	361	$lhs =~ s/\.\\?$/./; # Allow %s at the end to eat it all
4633a7c4	362	}
9a7dcd9c	363	$lhs =~ s/\\%c/./g;
e7ea3e70	364	$transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
4633a7c4	365	} else {
	366	$transmo .= " m{^\Q$header\E} && return 1;\n";
	367	}
	368
eff9c6e2	369	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
eff9c6e2	370	if $msg{$header};
4633a7c4	371
	372	$msg{$header} = '';
	373	}
	374
	375
	376	close POD_DIAG unless main::DATA eq POD_DIAG;
	377
	378	die "No diagnostics?" unless %msg;
	379
	380	$transmo .= " return 0;\n}\n";
	381	print STDERR $transmo if $DEBUG;
	382	eval $transmo;
	383	die $@ if $@;
7a4340ed	384	}
4633a7c4	385
	386	if ($standalone) {
	387	if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
7a4340ed	388	while (defined (my $error = <>)) {
4633a7c4	389	splainthis($error) \|\| print THITHER $error;
	390	}
	391	exit;
7a4340ed	392	}
	393
	394	my $olddie;
	395	my $oldwarn;
4633a7c4	396
	397	sub import {
	398	shift;
7a4340ed	399	$^W = 1; # yup, clobbered the global variable;
7a4340ed	400	# tough, if you want diags, you want diags.
4633a7c4	401	return if $SIG{__WARN__} eq \&warn_trap;
	402
	403	for (@_) {
	404
	405	/^-d(ebug)?$/ && do {
	406	$DEBUG++;
	407	next;
	408	};
	409
	410	/^-v(erbose)?$/ && do {
	411	$VERBOSE++;
	412	next;
	413	};
	414
	415	/^-p(retty)?$/ && do {
	416	print STDERR "$0: I'm afraid it's too late for prettiness.\n";
	417	$PRETTY++;
	418	next;
	419	};
	420
	421	warn "Unknown flag: $_";
	422	}
	423
	424	$oldwarn = $SIG{__WARN__};
	425	$olddie = $SIG{__DIE__};
	426	$SIG{__WARN__} = \&warn_trap;
	427	$SIG{__DIE__} = \&death_trap;
	428	}
	429
	430	sub enable { &import }
	431
	432	sub disable {
	433	shift;
4633a7c4	434	return unless $SIG{__WARN__} eq \&warn_trap;
3d0ae7ba	435	$SIG{__WARN__} = $oldwarn \|\| '';
3d0ae7ba	436	$SIG{__DIE__} = $olddie \|\| '';
4633a7c4	437	}
	438
	439	sub warn_trap {
	440	my $warning = $_[0];
	441	if (caller eq $WHOAMI or !splainthis($warning)) {
	442	print STDERR $warning;
	443	}
37120919	444	&$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
4633a7c4	445	};
	446
	447	sub death_trap {
	448	my $exception = $_[0];
55497cff	449
	450	# See if we are coming from anywhere within an eval. If so we don't
	451	# want to explain the exception because it's going to get caught.
	452	my $in_eval = 0;
	453	my $i = 0;
	454	while (1) {
	455	my $caller = (caller($i++))[3] or last;
	456	if ($caller eq '(eval)') {
	457	$in_eval = 1;
	458	last;
	459	}
	460	}
	461
	462	splainthis($exception) unless $in_eval;
4633a7c4	463	if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919	464	&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
55497cff	465
	466	# We don't want to unset these if we're coming from an eval because
	467	# then we've turned off diagnostics. (Actually what does this next
	468	# line do? -PSeibel)
	469	$SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
6f48387a	470	local($Carp::CarpLevel) = 1;
6f48387a	471	confess "Uncaught exception from user code:\n\t$exception";
4633a7c4	472	# up we go; where we stop, nobody knows, but i think we die now
	473	# but i'm deeply afraid of the &$olddie guy reraising and us getting
	474	# into an indirect recursion loop
	475	};
	476
7a4340ed	477	my %exact_duplicate;
	478	my %old_diag;
	479	my $count;
	480	my $wantspace;
4633a7c4	481	sub splainthis {
4633a7c4	482	local $_ = shift;
5025c45a	483	local $\;
4633a7c4	484	### &finish_compilation unless %msg;
	485	s/\.?\n+$//;
	486	my $orig = $_;
	487	# return unless defined;
4633a7c4	488	s/, <.?> (?:line\|chunk).$//;
7a4340ed	489	my $real = s/(.?) at .? (?:line\|chunk) \d+.*/$1/;
4633a7c4	490	s/^\((.*)\)$/$1/;
097b73fc	491	if ($exact_duplicate{$orig}++) {
	492	return &transmo;
	493	}
	494	else {
	495	return 0 unless &transmo;
	496	}
4633a7c4	497	$orig = shorten($orig);
	498	if ($old_diag{$_}) {
	499	autodescribe();
	500	print THITHER "$orig (#$old_diag{$_})\n";
	501	$wantspace = 1;
	502	} else {
	503	autodescribe();
	504	$old_diag{$_} = ++$count;
	505	print THITHER "\n" if $wantspace;
	506	$wantspace = 0;
	507	print THITHER "$orig (#$old_diag{$_})\n";
	508	if ($msg{$_}) {
	509	print THITHER $msg{$_};
	510	} else {
	511	if (0 and $standalone) {
	512	print THITHER " **** Error #$old_diag{$_} ",
	513	($real ? "is" : "appears to be"),
	514	" an unknown diagnostic message.\n\n";
	515	}
	516	return 0;
	517	}
	518	}
	519	return 1;
	520	}
	521
	522	sub autodescribe {
	523	if ($VERBOSE and not $count) {
	524	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
	525	"\n$msg{DESCRIPTION}\n";
	526	}
	527	}
	528
	529	sub unescape {
	530	s {
	531	E<
	532	( [A-Za-z]+ )
	533	>
	534	} {
	535	do {
	536	exists $HTML_Escapes{$1}
	537	? do { $HTML_Escapes{$1} }
	538	: do {
f02a87df	539	warn "Unknown escape: E<$1> in $_";
4633a7c4	540	"E<$1>";
	541	}
	542	}
	543	}egx;
	544	}
	545
	546	sub shorten {
	547	my $line = $_[0];
774d564b	548	if (length($line) > 79 and index($line, "\n") == -1) {
4633a7c4	549	my $space_place = rindex($line, ' ', 79);
	550	if ($space_place != -1) {
	551	substr($line, $space_place, 1) = "\n\t";
	552	}
	553	}
	554	return $line;
	555	}
	556
	557
4633a7c4	558	1 unless $standalone; # or it'll complain about itself
4633a7c4	559	__END__ # wish diag dbase were more accessible