[perl5.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 interpeter, 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 there behaviour at runtime using the 
disable() and enable() methods to turn them off and on respectively.

The B<-verbose> flag first prints out the L<perldiag> introduction before
any other diagnostics.  The $diagnostics::PRETTY variable can generate nicer
escape sequences for pagers.

=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

require 5.001;
use Carp;

use Config;
($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
if ($^O eq 'VMS') {
    require VMS::Filespec;
    $privlib = VMS::Filespec::unixify($privlib);
    $archlib = VMS::Filespec::unixify($archlib);
}
@trypod = ("$archlib/pod/perldiag.pod",
	   "$privlib/pod/perldiag-$].pod",
	   "$privlib/pod/perldiag.pod");
# handy for development testing of new warnings etc
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];

$DEBUG ||= 0;
my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine

$| = 1;

local $_;

CONFIG: {
    $opt_p = $opt_d = $opt_v = $opt_f = '';
    %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();  
    %exact_duplicate = ();

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

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

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

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

### sub finish_compilation {  # 5.001e panic: top_level for embedded version
    print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
    ### local 
    $RS = '';
    local $_;
    while (<POD_DIAG>) {
	#s/(.*)\n//;
	#$header = $1;

	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} .= $_;
	    }
	    next;
	} 
	unless ( s/=item (.*)\s*\Z//) {

	    if ( s/=head1\sDESCRIPTION//) {
		$msg{$header = 'DESCRIPTION'} = '';
	    }
	    next;
	}

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

	if ($header =~ /%[sd]/) {
	    $rhs = $lhs = $header;
	    #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g)  {
	    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([^\377]*)$/\Q$1\E/;
		$lhs =~ s/\377//g;
		$lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
	    } 
	    $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}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 $@;
    $RS = "\n";
### }

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

sub import {
    shift;
    $old_w = $^W;
    $^W = 1; # yup, clobbered the global variable; tough, if you
	     # want diags, you want diags.
    return if $SIG{__WARN__} eq \&warn_trap;

    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;
    $^W = $old_w;
    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
};

sub splainthis {
    local $_ = shift;
    local $\;
    ### &finish_compilation unless %msg;
    s/\.?\n+$//;
    my $orig = $_;
    # return unless defined;
    if ($exact_duplicate{$_}++) {
	return 1;
    } 
    s/, <.*?> (?:line|chunk).*$//;
    $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
    s/^\((.*)\)$/$1/;
    return 0 unless &transmo;
    $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;
} 


# have to do this: RS isn't set until run time, but we're executing at compile time
$RS = "\n";

1 unless $standalone;  # or it'll complain about itself
__END__ # wish diag dbase were more accessible
Commit	Line	Data
4633a7c4	1	package diagnostics;
4633a7c4 LW	2
	3	=head1 NAME
	4
	5	diagnostics - Perl compiler pragma to force verbose warning diagnostics
	6
	7	splain - standalone program to do the same thing
	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
1fef88e7	30	perl compiler and the perl interpeter, 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 LW	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
	44	Due to the interaction between runtime and compiletime issues,
	45	and because it's probably not a very good idea anyway,
	46	you may not use C<no diagnostics> to turn them off at compiletime.
	47	However, you may control there behaviour at runtime using the
	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 JM	51	any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
1fef88e7 JM	52	escape sequences for pagers.
4633a7c4 LW	53
	54	=head2 The I<splain> Program
	55
	56	While apparently a whole nuther program, I<splain> is actually nothing
	57	more than a link to the (executable) F<diagnostics.pm> module, as well as
	58	a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
	59	the C<use diagnostics -verbose> directive.
	60	The B<-p> flag is like the
	61	$diagnostics::PRETTY variable. Since you're post-processing with
	62	I<splain>, there's no sense in being able to enable() or disable() processing.
	63
	64	Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
	65
	66	=head1 EXAMPLES
	67
	68	The following file is certain to trigger a few errors at both
	69	runtime and compiletime:
	70
	71	use diagnostics;
	72	print NOWHERE "nothing\n";
	73	print STDERR "\n\tThis message should be unadorned.\n";
	74	warn "\tThis is a user warning";
	75	print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
	76	my $a, $b = scalar <STDIN>;
	77	print "\n";
	78	print $x/$y;
	79
	80	If you prefer to run your program first and look at its problem
	81	afterwards, do this:
	82
	83	perl -w test.pl 2>test.out
	84	./splain < test.out
	85
	86	Note that this is not in general possible in shells of more dubious heritage,
1fef88e7	87	as the theoretical
4633a7c4 LW	88
	89	(perl -w test.pl >/dev/tty) >& test.out
	90	./splain < test.out
	91
	92	Because you just moved the existing B<stdout> to somewhere else.
	93
	94	If you don't want to modify your source code, but still have on-the-fly
	95	warnings, do this:
	96
	97	exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- \| splain 1>&2 3>&-
	98
	99	Nifty, eh?
	100
	101	If you want to control warnings on the fly, do something like this.
	102	Make sure you do the C<use> first, or you won't be able to get
	103	at the enable() or disable() methods.
	104
	105	use diagnostics; # checks entire compilation phase
	106	print "\ntime for 1st bogus diags: SQUAWKINGS\n";
	107	print BOGUS1 'nada';
	108	print "done with 1st bogus\n";
	109
	110	disable diagnostics; # only turns off runtime warnings
	111	print "\ntime for 2nd bogus: (squelched)\n";
	112	print BOGUS2 'nada';
	113	print "done with 2nd bogus\n";
	114
	115	enable diagnostics; # turns back on runtime warnings
	116	print "\ntime for 3rd bogus: SQUAWKINGS\n";
	117	print BOGUS3 'nada';
	118	print "done with 3rd bogus\n";
	119
	120	disable diagnostics;
	121	print "\ntime for 4th bogus: (squelched)\n";
	122	print BOGUS4 'nada';
	123	print "done with 4th bogus\n";
	124
	125	=head1 INTERNALS
	126
	127	Diagnostic messages derive from the F<perldiag.pod> file when available at
	128	runtime. Otherwise, they may be embedded in the file itself when the
	129	splain package is built. See the F<Makefile> for details.
	130
	131	If an extant $SIG{__WARN__} handler is discovered, it will continue
1fef88e7	132	to be honored, but only after the diagnostics::splainthis() function
4633a7c4 LW	133	(the module's $SIG{__WARN__} interceptor) has had its way with your
	134	warnings.
	135
	136	There is a $diagnostics::DEBUG variable you may set if you're desperately
	137	curious what sorts of things are being intercepted.
	138
	139	BEGIN { $diagnostics::DEBUG = 1 }
	140
	141
	142	=head1 BUGS
	143
	144	Not being able to say "no diagnostics" is annoying, but may not be
	145	insurmountable.
	146
	147	The C<-pretty> directive is called too late to affect matters.
864e1151	148	You have to do this instead, and I<before> you load the module.
4633a7c4 LW	149
	150	BEGIN { $diagnostics::PRETTY = 1 }
	151
	152	I could start up faster by delaying compilation until it should be
a6006777	153	needed, but this gets a "panic: top_level" when using the pragma form
a6006777	154	in Perl 5.001e.
4633a7c4 LW	155
	156	While it's true that this documentation is somewhat subserious, if you use
	157	a program named I<splain>, you should expect a bit of whimsy.
	158
	159	=head1 AUTHOR
	160
352854fa	161	Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
4633a7c4 LW	162
	163	=cut
	164
5f05dabc	165	require 5.001;
5f05dabc	166	use Carp;
	167
	168	use Config;
91a06757	169	($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
5f05dabc	170	if ($^O eq 'VMS') {
91a06757 CS	171	require VMS::Filespec;
	172	$privlib = VMS::Filespec::unixify($privlib);
	173	$archlib = VMS::Filespec::unixify($archlib);
5f05dabc	174	}
91a06757 CS	175	@trypod = ("$archlib/pod/perldiag.pod",
	176	"$privlib/pod/perldiag-$].pod",
	177	"$privlib/pod/perldiag.pod");
fb73857a	178	# handy for development testing of new warnings etc
fb73857a	179	unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
91a06757	180	($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
5f05dabc	181
4633a7c4 LW	182	$DEBUG \|\|= 0;
	183	my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
	184
6dab8668	185	$\| = 1;
4633a7c4 LW	186
	187	local $_;
	188
	189	CONFIG: {
	190	$opt_p = $opt_d = $opt_v = $opt_f = '';
	191	%HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
	192	%exact_duplicate = ();
	193
	194	unless (caller) {
	195	$standalone++;
	196	require Getopt::Std;
91a06757 CS	197	Getopt::Std::getopts('pdvf:')
91a06757 CS	198	or die "Usage: $0 [-v] [-p] [-f splainpod]";
4633a7c4 LW	199	$PODFILE = $opt_f if $opt_f;
	200	$DEBUG = 2 if $opt_d;
	201	$VERBOSE = $opt_v;
	202	$PRETTY = $opt_p;
	203	}
	204
	205	if (open(POD_DIAG, $PODFILE)) {
	206	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
	207	last CONFIG;
	208	}
	209
	210	if (caller) {
	211	INCPATH: {
	212	for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
	213	warn "Checking $file\n" if $DEBUG;
	214	if (open(POD_DIAG, $file)) {
	215	while (<POD_DIAG>) {
	216	next unless /^__END__\s*# wish diag dbase were more accessible/;
	217	print STDERR "podfile is $file\n" if $DEBUG;
	218	last INCPATH;
	219	}
	220	}
	221	}
	222	}
	223	} else {
	224	print STDERR "podfile is <DATA>\n" if $DEBUG;
	225	POD_DIAG = main::DATA;
	226	}
	227	}
	228	if (eof(POD_DIAG)) {
	229	die "couldn't find diagnostic data in $PODFILE @INC $0";
	230	}
	231
	232
	233	%HTML_2_Troff = (
	234	'amp' => '&', # ampersand
	235	'lt' => '<', # left chevron, less-than
	236	'gt' => '>', # right chevron, greater-than
	237	'quot' => '"', # double quote
	238
	239	"Aacute" => "A\\*'", # capital A, acute accent
	240	# etc
	241
	242	);
	243
	244	%HTML_2_Latin_1 = (
	245	'amp' => '&', # ampersand
	246	'lt' => '<', # left chevron, less-than
	247	'gt' => '>', # right chevron, greater-than
	248	'quot' => '"', # double quote
	249
	250	"Aacute" => "\xC1" # capital A, acute accent
	251
	252	# etc
	253	);
	254
	255	%HTML_2_ASCII_7 = (
	256	'amp' => '&', # ampersand
	257	'lt' => '<', # left chevron, less-than
	258	'gt' => '>', # right chevron, greater-than
	259	'quot' => '"', # double quote
	260
	261	"Aacute" => "A" # capital A, acute accent
	262	# etc
263	);
264
265	*HTML_Escapes = do {
266	if ($standalone) {
267	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
268	} else {
269	\%HTML_2_Latin_1;
270	}
271	};
272
273	THITHER = $standalone ? STDOUT : *STDERR;
274
275	$transmo = <<EOFUNC;
276	sub transmo {
277	local \$^W = 0; # recursive warnings we do NOT need!
278	study;
279	EOFUNC
280
281	### sub finish_compilation { # 5.001e panic: top_level for embedded version
282	print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
283	### local
284	$RS = '';
285	local $_;
286	while (<POD_DIAG>) {
287	#s/(.*)\n//;
288	#$header = $1;
289
290	unescape();
291	if ($PRETTY) {
292	sub noop { return $_[0] } # spensive for a noop
293	sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
294	sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
295	s/[BC]<(.*?)>/bold($1)/ges;
296	s/[LIF]<(.*?)>/italic($1)/ges;
297	} else {
298	s/[BC]<(.*?)>/$1/gs;
299	s/[LIF]<(.*?)>/$1/gs;
300	}
301	unless (/^=/) {
302	if (defined $header) {
303	if ( $header eq 'DESCRIPTION' &&
304	( /Optional warnings are enabled/
305	\|\| /Some of these messages are generic./
306	) )
307	{
308	next;
309	}
310	s/^/ /gm;
311	$msg{$header} .= $_;
312	}
313	next;
314	}
315	unless ( s/=item (.)\s\Z//) {
316
317	if ( s/=head1\sDESCRIPTION//) {
318	$msg{$header = 'DESCRIPTION'} = '';
319	}
320	next;
321	}
4fdae800	322
	323	# strip formatting directives in =item line
	324	($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
4633a7c4 LW	325
	326	if ($header =~ /%[sd]/) {
	327	$rhs = $lhs = $header;
	328	#if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E\\d+\Q$2\E\$/g) {
	329	if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E\\d+\Q$2\E/g) {
	330	$lhs =~ s/\\%s/.*?/g;
	331	} else {
	332	# if i had lookbehind negations, i wouldn't have to do this \377 noise
	333	$lhs =~ s/(.?)%s/\Q$1\E.?\377/g;
	334	#$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
	335	$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
	336	$lhs =~ s/\377//g;
e7ea3e70	337	$lhs =~ s/\.\\?$/./; # Allow %s at the end to eat it all
4633a7c4	338	}
e7ea3e70	339	$transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
4633a7c4 LW	340	} else {
	341	$transmo .= " m{^\Q$header\E} && return 1;\n";
	342	}
	343
eff9c6e2 CS	344	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
eff9c6e2 CS	345	if $msg{$header};
4633a7c4 LW	346
	347	$msg{$header} = '';
	348	}
	349
	350
	351	close POD_DIAG unless main::DATA eq POD_DIAG;
	352
	353	die "No diagnostics?" unless %msg;
	354
	355	$transmo .= " return 0;\n}\n";
	356	print STDERR $transmo if $DEBUG;
	357	eval $transmo;
	358	die $@ if $@;
	359	$RS = "\n";
	360	### }
	361
	362	if ($standalone) {
	363	if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
40da2db3	364	while (defined ($error = <>)) {
4633a7c4 LW	365	splainthis($error) \|\| print THITHER $error;
	366	}
	367	exit;
	368	} else {
	369	$old_w = 0; $oldwarn = ''; $olddie = '';
	370	}
	371
	372	sub import {
	373	shift;
	374	$old_w = $^W;
	375	$^W = 1; # yup, clobbered the global variable; tough, if you
	376	# want diags, you want diags.
	377	return if $SIG{__WARN__} eq \&warn_trap;
	378
	379	for (@_) {
	380
	381	/^-d(ebug)?$/ && do {
	382	$DEBUG++;
	383	next;
	384	};
	385
	386	/^-v(erbose)?$/ && do {
	387	$VERBOSE++;
	388	next;
	389	};
	390
	391	/^-p(retty)?$/ && do {
	392	print STDERR "$0: I'm afraid it's too late for prettiness.\n";
	393	$PRETTY++;
	394	next;
	395	};
	396
	397	warn "Unknown flag: $_";
	398	}
	399
	400	$oldwarn = $SIG{__WARN__};
	401	$olddie = $SIG{__DIE__};
	402	$SIG{__WARN__} = \&warn_trap;
	403	$SIG{__DIE__} = \&death_trap;
	404	}
	405
	406	sub enable { &import }
	407
	408	sub disable {
	409	shift;
	410	$^W = $old_w;
	411	return unless $SIG{__WARN__} eq \&warn_trap;
	412	$SIG{__WARN__} = $oldwarn;
	413	$SIG{__DIE__} = $olddie;
	414	}
	415
	416	sub warn_trap {
	417	my $warning = $_[0];
	418	if (caller eq $WHOAMI or !splainthis($warning)) {
	419	print STDERR $warning;
	420	}
37120919	421	&$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
4633a7c4 LW	422	};
	423
	424	sub death_trap {
	425	my $exception = $_[0];
55497cff	426
	427	# See if we are coming from anywhere within an eval. If so we don't
	428	# want to explain the exception because it's going to get caught.
	429	my $in_eval = 0;
	430	my $i = 0;
	431	while (1) {
	432	my $caller = (caller($i++))[3] or last;
	433	if ($caller eq '(eval)') {
	434	$in_eval = 1;
	435	last;
	436	}
	437	}
	438
	439	splainthis($exception) unless $in_eval;
4633a7c4	440	if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919	441	&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
55497cff	442
	443	# We don't want to unset these if we're coming from an eval because
	444	# then we've turned off diagnostics. (Actually what does this next
	445	# line do? -PSeibel)
	446	$SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
6f48387a	447	local($Carp::CarpLevel) = 1;
6f48387a	448	confess "Uncaught exception from user code:\n\t$exception";
4633a7c4 LW	449	# up we go; where we stop, nobody knows, but i think we die now
	450	# but i'm deeply afraid of the &$olddie guy reraising and us getting
	451	# into an indirect recursion loop
	452	};
	453
	454	sub splainthis {
	455	local $_ = shift;
5025c45a	456	local $\;
4633a7c4 LW	457	### &finish_compilation unless %msg;
	458	s/\.?\n+$//;
	459	my $orig = $_;
	460	# return unless defined;
	461	if ($exact_duplicate{$_}++) {
	462	return 1;
	463	}
	464	s/, <.?> (?:line\|chunk).$//;
	465	$real = s/(.?) at .? (?:line\|chunk) \d+.*/$1/;
	466	s/^\((.*)\)$/$1/;
	467	return 0 unless &transmo;
	468	$orig = shorten($orig);
	469	if ($old_diag{$_}) {
	470	autodescribe();
	471	print THITHER "$orig (#$old_diag{$_})\n";
	472	$wantspace = 1;
	473	} else {
	474	autodescribe();
	475	$old_diag{$_} = ++$count;
	476	print THITHER "\n" if $wantspace;
	477	$wantspace = 0;
	478	print THITHER "$orig (#$old_diag{$_})\n";
	479	if ($msg{$_}) {
	480	print THITHER $msg{$_};
	481	} else {
	482	if (0 and $standalone) {
	483	print THITHER " **** Error #$old_diag{$_} ",
	484	($real ? "is" : "appears to be"),
	485	" an unknown diagnostic message.\n\n";
	486	}
	487	return 0;
	488	}
	489	}
	490	return 1;
	491	}
	492
	493	sub autodescribe {
	494	if ($VERBOSE and not $count) {
	495	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
	496	"\n$msg{DESCRIPTION}\n";
	497	}
	498	}
	499
	500	sub unescape {
	501	s {
	502	E<
	503	( [A-Za-z]+ )
	504	>
	505	} {
	506	do {
	507	exists $HTML_Escapes{$1}
	508	? do { $HTML_Escapes{$1} }
	509	: do {
f02a87df	510	warn "Unknown escape: E<$1> in $_";
4633a7c4 LW	511	"E<$1>";
	512	}
	513	}
	514	}egx;
	515	}
	516
	517	sub shorten {
	518	my $line = $_[0];
774d564b	519	if (length($line) > 79 and index($line, "\n") == -1) {
4633a7c4 LW	520	my $space_place = rindex($line, ' ', 79);
	521	if ($space_place != -1) {
	522	substr($line, $space_place, 1) = "\n\t";
	523	}
	524	}
	525	return $line;
	526	}
	527
	528
	529	# have to do this: RS isn't set until run time, but we're executing at compile time
	530	$RS = "\n";
	531
	532	1 unless $standalone; # or it'll complain about itself
	533	__END__ # wish diag dbase were more accessible