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