[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 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 to 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<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.

=cut

require 5.001;
use English;
use Carp;

use Config;
if ($^O eq 'VMS') {
    $PODFILE = VMS::Filespec::unixify($Config{privlibexp}).'/pod/perldiag.pod';
}
else {
    $PODFILE = $Config{privlibexp} . "/pod/perldiag.pod";
}

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

$OUTPUT_AUTOFLUSH = 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:') || 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;
	}
	$header = $1;

	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;
    ### &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: $& 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	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	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	51	any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
1fef88e7	52	escape sequences for pagers.
4633a7c4	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	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	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.
	148	You have to to this instead, and I<before> you load the module.
	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	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
	161	Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
	162
	163	=cut
	164
5f05dabc	165	require 5.001;
	166	use English;
	167	use Carp;
	168
	169	use Config;
	170	if ($^O eq 'VMS') {
	171	$PODFILE = VMS::Filespec::unixify($Config{privlibexp}).'/pod/perldiag.pod';
	172	}
	173	else {
	174	$PODFILE = $Config{privlibexp} . "/pod/perldiag.pod";
	175	}
	176
4633a7c4	177	$DEBUG \|\|= 0;
	178	my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
	179
	180	$OUTPUT_AUTOFLUSH = 1;
	181
	182	local $_;
	183
	184	CONFIG: {
	185	$opt_p = $opt_d = $opt_v = $opt_f = '';
	186	%HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
	187	%exact_duplicate = ();
	188
	189	unless (caller) {
	190	$standalone++;
	191	require Getopt::Std;
	192	Getopt::Std::getopts('pdvf:') \|\| die "Usage: $0 [-v] [-p] [-f splainpod]";
	193	$PODFILE = $opt_f if $opt_f;
	194	$DEBUG = 2 if $opt_d;
	195	$VERBOSE = $opt_v;
	196	$PRETTY = $opt_p;
	197	}
	198
	199	if (open(POD_DIAG, $PODFILE)) {
	200	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
	201	last CONFIG;
	202	}
	203
	204	if (caller) {
	205	INCPATH: {
	206	for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
	207	warn "Checking $file\n" if $DEBUG;
	208	if (open(POD_DIAG, $file)) {
	209	while (<POD_DIAG>) {
	210	next unless /^__END__\s*# wish diag dbase were more accessible/;
	211	print STDERR "podfile is $file\n" if $DEBUG;
	212	last INCPATH;
	213	}
	214	}
	215	}
	216	}
	217	} else {
	218	print STDERR "podfile is <DATA>\n" if $DEBUG;
	219	POD_DIAG = main::DATA;
	220	}
	221	}
	222	if (eof(POD_DIAG)) {
	223	die "couldn't find diagnostic data in $PODFILE @INC $0";
	224	}
	225
	226
	227	%HTML_2_Troff = (
	228	'amp' => '&', # ampersand
	229	'lt' => '<', # left chevron, less-than
	230	'gt' => '>', # right chevron, greater-than
	231	'quot' => '"', # double quote
	232
	233	"Aacute" => "A\\*'", # capital A, acute accent
	234	# etc
	235
	236	);
	237
	238	%HTML_2_Latin_1 = (
	239	'amp' => '&', # ampersand
	240	'lt' => '<', # left chevron, less-than
241	'gt' => '>', # right chevron, greater-than
242	'quot' => '"', # double quote
243
244	"Aacute" => "\xC1" # capital A, acute accent
245
246	# etc
247	);
248
249	%HTML_2_ASCII_7 = (
250	'amp' => '&', # ampersand
251	'lt' => '<', # left chevron, less-than
252	'gt' => '>', # right chevron, greater-than
253	'quot' => '"', # double quote
254
255	"Aacute" => "A" # capital A, acute accent
256	# etc
257	);
258
259	*HTML_Escapes = do {
260	if ($standalone) {
261	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
262	} else {
263	\%HTML_2_Latin_1;
264	}
265	};
266
267	THITHER = $standalone ? STDOUT : *STDERR;
268
269	$transmo = <<EOFUNC;
270	sub transmo {
271	local \$^W = 0; # recursive warnings we do NOT need!
272	study;
273	EOFUNC
274
275	### sub finish_compilation { # 5.001e panic: top_level for embedded version
276	print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
277	### local
278	$RS = '';
279	local $_;
280	while (<POD_DIAG>) {
281	#s/(.*)\n//;
282	#$header = $1;
283
284	unescape();
285	if ($PRETTY) {
286	sub noop { return $_[0] } # spensive for a noop
287	sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
288	sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
289	s/[BC]<(.*?)>/bold($1)/ges;
290	s/[LIF]<(.*?)>/italic($1)/ges;
291	} else {
292	s/[BC]<(.*?)>/$1/gs;
293	s/[LIF]<(.*?)>/$1/gs;
294	}
295	unless (/^=/) {
296	if (defined $header) {
297	if ( $header eq 'DESCRIPTION' &&
298	( /Optional warnings are enabled/
299	\|\| /Some of these messages are generic./
300	) )
301	{
302	next;
303	}
304	s/^/ /gm;
305	$msg{$header} .= $_;
306	}
307	next;
308	}
309	unless ( s/=item (.)\s\Z//) {
310
311	if ( s/=head1\sDESCRIPTION//) {
312	$msg{$header = 'DESCRIPTION'} = '';
313	}
314	next;
315	}
316	$header = $1;
317
318	if ($header =~ /%[sd]/) {
319	$rhs = $lhs = $header;
320	#if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E\\d+\Q$2\E\$/g) {
321	if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E\\d+\Q$2\E/g) {
322	$lhs =~ s/\\%s/.*?/g;
323	} else {
324	# if i had lookbehind negations, i wouldn't have to do this \377 noise
325	$lhs =~ s/(.?)%s/\Q$1\E.?\377/g;
326	#$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
327	$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
328	$lhs =~ s/\377//g;
e7ea3e70	329	$lhs =~ s/\.\\?$/./; # Allow %s at the end to eat it all
4633a7c4	330	}
e7ea3e70	331	$transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
4633a7c4	332	} else {
	333	$transmo .= " m{^\Q$header\E} && return 1;\n";
	334	}
	335
eff9c6e2	336	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
eff9c6e2	337	if $msg{$header};
4633a7c4	338
	339	$msg{$header} = '';
	340	}
	341
	342
	343	close POD_DIAG unless main::DATA eq POD_DIAG;
	344
	345	die "No diagnostics?" unless %msg;
	346
	347	$transmo .= " return 0;\n}\n";
	348	print STDERR $transmo if $DEBUG;
	349	eval $transmo;
	350	die $@ if $@;
	351	$RS = "\n";
	352	### }
	353
	354	if ($standalone) {
	355	if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
40da2db3	356	while (defined ($error = <>)) {
4633a7c4	357	splainthis($error) \|\| print THITHER $error;
	358	}
	359	exit;
	360	} else {
	361	$old_w = 0; $oldwarn = ''; $olddie = '';
	362	}
	363
	364	sub import {
	365	shift;
	366	$old_w = $^W;
	367	$^W = 1; # yup, clobbered the global variable; tough, if you
	368	# want diags, you want diags.
	369	return if $SIG{__WARN__} eq \&warn_trap;
	370
	371	for (@_) {
	372
	373	/^-d(ebug)?$/ && do {
	374	$DEBUG++;
	375	next;
	376	};
	377
	378	/^-v(erbose)?$/ && do {
	379	$VERBOSE++;
	380	next;
	381	};
	382
	383	/^-p(retty)?$/ && do {
	384	print STDERR "$0: I'm afraid it's too late for prettiness.\n";
	385	$PRETTY++;
	386	next;
	387	};
	388
	389	warn "Unknown flag: $_";
	390	}
	391
	392	$oldwarn = $SIG{__WARN__};
	393	$olddie = $SIG{__DIE__};
	394	$SIG{__WARN__} = \&warn_trap;
	395	$SIG{__DIE__} = \&death_trap;
	396	}
	397
	398	sub enable { &import }
	399
	400	sub disable {
	401	shift;
	402	$^W = $old_w;
	403	return unless $SIG{__WARN__} eq \&warn_trap;
	404	$SIG{__WARN__} = $oldwarn;
	405	$SIG{__DIE__} = $olddie;
	406	}
	407
	408	sub warn_trap {
	409	my $warning = $_[0];
	410	if (caller eq $WHOAMI or !splainthis($warning)) {
	411	print STDERR $warning;
	412	}
37120919	413	&$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
4633a7c4	414	};
	415
	416	sub death_trap {
	417	my $exception = $_[0];
55497cff	418
	419	# See if we are coming from anywhere within an eval. If so we don't
	420	# want to explain the exception because it's going to get caught.
	421	my $in_eval = 0;
	422	my $i = 0;
	423	while (1) {
	424	my $caller = (caller($i++))[3] or last;
	425	if ($caller eq '(eval)') {
	426	$in_eval = 1;
	427	last;
	428	}
	429	}
	430
	431	splainthis($exception) unless $in_eval;
4633a7c4	432	if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919	433	&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
55497cff	434
	435	# We don't want to unset these if we're coming from an eval because
	436	# then we've turned off diagnostics. (Actually what does this next
	437	# line do? -PSeibel)
	438	$SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
6f48387a	439	local($Carp::CarpLevel) = 1;
6f48387a	440	confess "Uncaught exception from user code:\n\t$exception";
4633a7c4	441	# up we go; where we stop, nobody knows, but i think we die now
	442	# but i'm deeply afraid of the &$olddie guy reraising and us getting
	443	# into an indirect recursion loop
	444	};
	445
	446	sub splainthis {
	447	local $_ = shift;
	448	### &finish_compilation unless %msg;
	449	s/\.?\n+$//;
	450	my $orig = $_;
	451	# return unless defined;
	452	if ($exact_duplicate{$_}++) {
	453	return 1;
	454	}
	455	s/, <.?> (?:line\|chunk).$//;
	456	$real = s/(.?) at .? (?:line\|chunk) \d+.*/$1/;
	457	s/^\((.*)\)$/$1/;
	458	return 0 unless &transmo;
	459	$orig = shorten($orig);
	460	if ($old_diag{$_}) {
	461	autodescribe();
	462	print THITHER "$orig (#$old_diag{$_})\n";
	463	$wantspace = 1;
	464	} else {
	465	autodescribe();
	466	$old_diag{$_} = ++$count;
	467	print THITHER "\n" if $wantspace;
	468	$wantspace = 0;
	469	print THITHER "$orig (#$old_diag{$_})\n";
	470	if ($msg{$_}) {
	471	print THITHER $msg{$_};
	472	} else {
	473	if (0 and $standalone) {
	474	print THITHER " **** Error #$old_diag{$_} ",
	475	($real ? "is" : "appears to be"),
	476	" an unknown diagnostic message.\n\n";
	477	}
	478	return 0;
	479	}
	480	}
	481	return 1;
	482	}
	483
	484	sub autodescribe {
	485	if ($VERBOSE and not $count) {
	486	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
	487	"\n$msg{DESCRIPTION}\n";
	488	}
	489	}
	490
	491	sub unescape {
	492	s {
	493	E<
	494	( [A-Za-z]+ )
	495	>
	496	} {
	497	do {
	498	exists $HTML_Escapes{$1}
	499	? do { $HTML_Escapes{$1} }
	500	: do {
	501	warn "Unknown escape: $& in $_";
	502	"E<$1>";
	503	}
	504	}
505	}egx;
506	}
507
508	sub shorten {
509	my $line = $_[0];
e7ea3e70	510	if (length $line > 79 and index $line, "\n" == -1) {
4633a7c4	511	my $space_place = rindex($line, ' ', 79);
	512	if ($space_place != -1) {
	513	substr($line, $space_place, 1) = "\n\t";
	514	}
	515	}
	516	return $line;
	517	}
	518
	519
	520	# have to do this: RS isn't set until run time, but we're executing at compile time
	521	$RS = "\n";
	522
	523	1 unless $standalone; # or it'll complain about itself
	524	__END__ # wish diag dbase were more accessible