[perl5.git] / lib / diagnostics.pm

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

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