[perl5.git] / lib / diagnostics.pm

#!/usr/local/bin/perl
eval 'exec perl -S $0  ${1+"$@"}'
    if 0;

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

package diagnostics;
require 5.001;
use English;
use Carp;

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

$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;
	    } 
	    $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}\n\t&& return 1;\n";
	} else {
	    $transmo .= "    m{^\Q$header\E} && return 1;\n";
	} 

	print STDERR "Already saw $header" 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 ($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];
    splainthis($exception);
    if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 
    &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
    $SIG{__DIE__} = $SIG{__WARN__} = '';
    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) {
	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 LW	1	#!/usr/local/bin/perl
4633a7c4 LW	2	eval 'exec perl -S $0 ${1+"$@"}'
37120919	3	if 0;
4633a7c4 LW	4
4633a7c4 LW	5	use Config;
c6538b72	6	if ($^O eq 'VMS') {
1446e948	7	$diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlibexp'}) .
c07a80fd	8	'/pod/perldiag.pod';
c07a80fd	9	}
1446e948	10	else { $diagnostics::PODFILE= $Config{privlibexp} . "/pod/perldiag.pod"; }
4633a7c4 LW	11
	12	package diagnostics;
	13	require 5.001;
	14	use English;
	15	use Carp;
	16
	17	=head1 NAME
	18
	19	diagnostics - Perl compiler pragma to force verbose warning diagnostics
	20
	21	splain - standalone program to do the same thing
	22
	23	=head1 SYNOPSIS
	24
	25	As a pragma:
	26
	27	use diagnostics;
	28	use diagnostics -verbose;
	29
	30	enable diagnostics;
	31	disable diagnostics;
	32
	33	Aa a program:
	34
	35	perl program 2>diag.out
	36	splain [-v] [-p] diag.out
	37
	38
	39	=head1 DESCRIPTION
	40
	41	=head2 The C<diagnostics> Pragma
	42
	43	This module extends the terse diagnostics normally emitted by both the
1fef88e7	44	perl compiler and the perl interpeter, augmenting them with the more
4633a7c4	45	explicative and endearing descriptions found in L<perldiag>. Like the
1fef88e7	46	other pragmata, it affects the compilation phase of your program rather
4633a7c4 LW	47	than merely the execution phase.
	48
	49	To use in your program as a pragma, merely invoke
	50
	51	use diagnostics;
	52
	53	at the start (or near the start) of your program. (Note
	54	that this I<does> enable perl's B<-w> flag.) Your whole
	55	compilation will then be subject(ed :-) to the enhanced diagnostics.
	56	These still go out B<STDERR>.
	57
	58	Due to the interaction between runtime and compiletime issues,
	59	and because it's probably not a very good idea anyway,
	60	you may not use C<no diagnostics> to turn them off at compiletime.
	61	However, you may control there behaviour at runtime using the
	62	disable() and enable() methods to turn them off and on respectively.
	63
	64	The B<-verbose> flag first prints out the L<perldiag> introduction before
1fef88e7 JM	65	any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
1fef88e7 JM	66	escape sequences for pagers.
4633a7c4 LW	67
	68	=head2 The I<splain> Program
	69
	70	While apparently a whole nuther program, I<splain> is actually nothing
	71	more than a link to the (executable) F<diagnostics.pm> module, as well as
	72	a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
	73	the C<use diagnostics -verbose> directive.
	74	The B<-p> flag is like the
	75	$diagnostics::PRETTY variable. Since you're post-processing with
	76	I<splain>, there's no sense in being able to enable() or disable() processing.
	77
	78	Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
	79
	80	=head1 EXAMPLES
	81
	82	The following file is certain to trigger a few errors at both
	83	runtime and compiletime:
	84
	85	use diagnostics;
	86	print NOWHERE "nothing\n";
	87	print STDERR "\n\tThis message should be unadorned.\n";
	88	warn "\tThis is a user warning";
	89	print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
	90	my $a, $b = scalar <STDIN>;
	91	print "\n";
	92	print $x/$y;
	93
	94	If you prefer to run your program first and look at its problem
	95	afterwards, do this:
	96
	97	perl -w test.pl 2>test.out
	98	./splain < test.out
	99
	100	Note that this is not in general possible in shells of more dubious heritage,
1fef88e7	101	as the theoretical
4633a7c4 LW	102
	103	(perl -w test.pl >/dev/tty) >& test.out
	104	./splain < test.out
	105
	106	Because you just moved the existing B<stdout> to somewhere else.
	107
	108	If you don't want to modify your source code, but still have on-the-fly
	109	warnings, do this:
	110
	111	exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- \| splain 1>&2 3>&-
	112
	113	Nifty, eh?
	114
	115	If you want to control warnings on the fly, do something like this.
	116	Make sure you do the C<use> first, or you won't be able to get
	117	at the enable() or disable() methods.
	118
	119	use diagnostics; # checks entire compilation phase
	120	print "\ntime for 1st bogus diags: SQUAWKINGS\n";
	121	print BOGUS1 'nada';
	122	print "done with 1st bogus\n";
	123
	124	disable diagnostics; # only turns off runtime warnings
	125	print "\ntime for 2nd bogus: (squelched)\n";
	126	print BOGUS2 'nada';
	127	print "done with 2nd bogus\n";
	128
	129	enable diagnostics; # turns back on runtime warnings
	130	print "\ntime for 3rd bogus: SQUAWKINGS\n";
	131	print BOGUS3 'nada';
	132	print "done with 3rd bogus\n";
	133
	134	disable diagnostics;
	135	print "\ntime for 4th bogus: (squelched)\n";
	136	print BOGUS4 'nada';
	137	print "done with 4th bogus\n";
	138
	139	=head1 INTERNALS
	140
	141	Diagnostic messages derive from the F<perldiag.pod> file when available at
	142	runtime. Otherwise, they may be embedded in the file itself when the
	143	splain package is built. See the F<Makefile> for details.
	144
	145	If an extant $SIG{__WARN__} handler is discovered, it will continue
1fef88e7	146	to be honored, but only after the diagnostics::splainthis() function
4633a7c4 LW	147	(the module's $SIG{__WARN__} interceptor) has had its way with your
	148	warnings.
	149
	150	There is a $diagnostics::DEBUG variable you may set if you're desperately
	151	curious what sorts of things are being intercepted.
	152
	153	BEGIN { $diagnostics::DEBUG = 1 }
	154
	155
	156	=head1 BUGS
	157
	158	Not being able to say "no diagnostics" is annoying, but may not be
	159	insurmountable.
	160
	161	The C<-pretty> directive is called too late to affect matters.
	162	You have to to this instead, and I<before> you load the module.
	163
	164	BEGIN { $diagnostics::PRETTY = 1 }
	165
	166	I could start up faster by delaying compilation until it should be
	167	needed, but this gets a "panic: top_level"
	168	when using the pragma form in 5.001e.
	169
	170	While it's true that this documentation is somewhat subserious, if you use
	171	a program named I<splain>, you should expect a bit of whimsy.
	172
	173	=head1 AUTHOR
	174
	175	Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
	176
	177	=cut
	178
	179	$DEBUG \|\|= 0;
	180	my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
	181
	182	$OUTPUT_AUTOFLUSH = 1;
	183
	184	local $_;
	185
	186	CONFIG: {
	187	$opt_p = $opt_d = $opt_v = $opt_f = '';
	188	%HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
	189	%exact_duplicate = ();
	190
	191	unless (caller) {
	192	$standalone++;
	193	require Getopt::Std;
	194	Getopt::Std::getopts('pdvf:') \|\| die "Usage: $0 [-v] [-p] [-f splainpod]";
	195	$PODFILE = $opt_f if $opt_f;
	196	$DEBUG = 2 if $opt_d;
	197	$VERBOSE = $opt_v;
	198	$PRETTY = $opt_p;
	199	}
	200
	201	if (open(POD_DIAG, $PODFILE)) {
	202	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
	203	last CONFIG;
	204	}
	205
	206	if (caller) {
	207	INCPATH: {
	208	for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
	209	warn "Checking $file\n" if $DEBUG;
	210	if (open(POD_DIAG, $file)) {
211	while (<POD_DIAG>) {
212	next unless /^__END__\s*# wish diag dbase were more accessible/;
213	print STDERR "podfile is $file\n" if $DEBUG;
214	last INCPATH;
215	}
216	}
217	}
218	}
219	} else {
220	print STDERR "podfile is <DATA>\n" if $DEBUG;
221	POD_DIAG = main::DATA;
222	}
223	}
224	if (eof(POD_DIAG)) {
225	die "couldn't find diagnostic data in $PODFILE @INC $0";
226	}
227
228
229	%HTML_2_Troff = (
230	'amp' => '&', # ampersand
231	'lt' => '<', # left chevron, less-than
232	'gt' => '>', # right chevron, greater-than
233	'quot' => '"', # double quote
234
235	"Aacute" => "A\\*'", # capital A, acute accent
236	# etc
237
238	);
239
240	%HTML_2_Latin_1 = (
241	'amp' => '&', # ampersand
242	'lt' => '<', # left chevron, less-than
243	'gt' => '>', # right chevron, greater-than
244	'quot' => '"', # double quote
245
246	"Aacute" => "\xC1" # capital A, acute accent
247
248	# etc
249	);
250
251	%HTML_2_ASCII_7 = (
252	'amp' => '&', # ampersand
253	'lt' => '<', # left chevron, less-than
254	'gt' => '>', # right chevron, greater-than
255	'quot' => '"', # double quote
256
257	"Aacute" => "A" # capital A, acute accent
258	# etc
259	);
260
261	*HTML_Escapes = do {
262	if ($standalone) {
263	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
264	} else {
265	\%HTML_2_Latin_1;
266	}
267	};
268
269	THITHER = $standalone ? STDOUT : *STDERR;
270
271	$transmo = <<EOFUNC;
272	sub transmo {
273	local \$^W = 0; # recursive warnings we do NOT need!
274	study;
275	EOFUNC
276
277	### sub finish_compilation { # 5.001e panic: top_level for embedded version
278	print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
279	### local
280	$RS = '';
281	local $_;
282	while (<POD_DIAG>) {
283	#s/(.*)\n//;
284	#$header = $1;
285
286	unescape();
287	if ($PRETTY) {
288	sub noop { return $_[0] } # spensive for a noop
289	sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
290	sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
291	s/[BC]<(.*?)>/bold($1)/ges;
292	s/[LIF]<(.*?)>/italic($1)/ges;
293	} else {
294	s/[BC]<(.*?)>/$1/gs;
295	s/[LIF]<(.*?)>/$1/gs;
296	}
297	unless (/^=/) {
298	if (defined $header) {
299	if ( $header eq 'DESCRIPTION' &&
300	( /Optional warnings are enabled/
301	\|\| /Some of these messages are generic./
302	) )
303	{
304	next;
305	}
306	s/^/ /gm;
307	$msg{$header} .= $_;
308	}
309	next;
310	}
311	unless ( s/=item (.)\s\Z//) {
312
313	if ( s/=head1\sDESCRIPTION//) {
314	$msg{$header = 'DESCRIPTION'} = '';
315	}
316	next;
317	}
318	$header = $1;
319
320	if ($header =~ /%[sd]/) {
321	$rhs = $lhs = $header;
322	#if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E\\d+\Q$2\E\$/g) {
323	if ($lhs =~ s/(.?)%d(?!%d)(.)/\Q$1\E\\d+\Q$2\E/g) {
324	$lhs =~ s/\\%s/.*?/g;
325	} else {
326	# if i had lookbehind negations, i wouldn't have to do this \377 noise
327	$lhs =~ s/(.?)%s/\Q$1\E.?\377/g;
328	#$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
329	$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
330	$lhs =~ s/\377//g;
331	}
332	$transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n";
333	} else {
334	$transmo .= " m{^\Q$header\E} && return 1;\n";
335	}
336
337	print STDERR "Already saw $header" if $msg{$header};
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" }
356	while ($error = <>) {
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 LW	414	};
	415
	416	sub death_trap {
	417	my $exception = $_[0];
	418	splainthis($exception);
	419	if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919	420	&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
4633a7c4	421	$SIG{__DIE__} = $SIG{__WARN__} = '';
6f48387a	422	local($Carp::CarpLevel) = 1;
6f48387a	423	confess "Uncaught exception from user code:\n\t$exception";
4633a7c4 LW	424	# up we go; where we stop, nobody knows, but i think we die now
	425	# but i'm deeply afraid of the &$olddie guy reraising and us getting
	426	# into an indirect recursion loop
	427	};
	428
	429	sub splainthis {
	430	local $_ = shift;
	431	### &finish_compilation unless %msg;
	432	s/\.?\n+$//;
	433	my $orig = $_;
	434	# return unless defined;
	435	if ($exact_duplicate{$_}++) {
	436	return 1;
	437	}
	438	s/, <.?> (?:line\|chunk).$//;
	439	$real = s/(.?) at .? (?:line\|chunk) \d+.*/$1/;
	440	s/^\((.*)\)$/$1/;
	441	return 0 unless &transmo;
	442	$orig = shorten($orig);
	443	if ($old_diag{$_}) {
	444	autodescribe();
	445	print THITHER "$orig (#$old_diag{$_})\n";
	446	$wantspace = 1;
	447	} else {
	448	autodescribe();
	449	$old_diag{$_} = ++$count;
	450	print THITHER "\n" if $wantspace;
	451	$wantspace = 0;
	452	print THITHER "$orig (#$old_diag{$_})\n";
	453	if ($msg{$_}) {
	454	print THITHER $msg{$_};
	455	} else {
	456	if (0 and $standalone) {
	457	print THITHER " **** Error #$old_diag{$_} ",
	458	($real ? "is" : "appears to be"),
	459	" an unknown diagnostic message.\n\n";
	460	}
	461	return 0;
	462	}
	463	}
	464	return 1;
	465	}
	466
	467	sub autodescribe {
	468	if ($VERBOSE and not $count) {
	469	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
	470	"\n$msg{DESCRIPTION}\n";
	471	}
	472	}
	473
	474	sub unescape {
	475	s {
	476	E<
	477	( [A-Za-z]+ )
	478	>
	479	} {
	480	do {
	481	exists $HTML_Escapes{$1}
	482	? do { $HTML_Escapes{$1} }
	483	: do {
	484	warn "Unknown escape: $& in $_";
	485	"E<$1>";
	486	}
	487	}
488	}egx;
489	}
490
491	sub shorten {
492	my $line = $_[0];
493	if (length $line > 79) {
494	my $space_place = rindex($line, ' ', 79);
495	if ($space_place != -1) {
496	substr($line, $space_place, 1) = "\n\t";
497	}
498	}
499	return $line;
500	}
501
502
503	# have to do this: RS isn't set until run time, but we're executing at compile time
504	$RS = "\n";
505
506	1 unless $standalone; # or it'll complain about itself
507	__END__ # wish diag dbase were more accessible