[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{'privlib'}) .
                           '/pod/perldiag.pod';
}
else { $diagnostics::PODFILE= $Config{privlib} . "/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 wtih the more
explicative and endearing descriptions found in L<perldiag>.  Like the
other pragmata, it affects to 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 can generate nicer escape
sequences for pgers.

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

    (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 diagnostic::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') {
d9ae0549	7	$diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlib'}) .
c07a80fd	8	'/pod/perldiag.pod';
	9	}
	10	else { $diagnostics::PODFILE= $Config{privlib} . "/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
	44	perl compiler and the perl interpeter, augmenting them wtih the more
	45	explicative and endearing descriptions found in L<perldiag>. Like the
	46	other pragmata, it affects to compilation phase of your program rather
	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
	65	any other diagnostics. The $diagnostics::PRETTY can generate nicer escape
	66	sequences for pgers.
	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,
101	as the theorectical
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
146	to be honored, but only after the diagnostic::splainthis() function
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