1package diagnostics;
2
3=head1 NAME
4
5diagnostics, splain - produce verbose warning diagnostics
6
7=head1 SYNOPSIS
8
9Using the C<diagnostics> pragma:
10
11    use diagnostics;
12    use diagnostics -verbose;
13
14    enable  diagnostics;
15    disable diagnostics;
16
17Using the C<splain> standalone filter program:
18
19    perl program 2>diag.out
20    splain [-v] [-p] diag.out
21
22=head1 DESCRIPTION
23
24=head2 The C<diagnostics> Pragma
25
26This module extends the terse diagnostics normally emitted by both the
27perl compiler and the perl interpreter, augmenting them with the more
28explicative and endearing descriptions found in L<perldiag>.  Like the
29other pragmata, it affects the compilation phase of your program rather
30than merely the execution phase.
31
32To use in your program as a pragma, merely invoke
33
34    use diagnostics;
35
36at the start (or near the start) of your program.  (Note
37that this I<does> enable perl's B<-w> flag.)  Your whole
38compilation will then be subject(ed :-) to the enhanced diagnostics.
39These still go out B<STDERR>.
40
41Due to the interaction between runtime and compiletime issues,
42and because it's probably not a very good idea anyway,
43you may not use C<no diagnostics> to turn them off at compiletime.
44However, you may control their behaviour at runtime using the
45disable() and enable() methods to turn them off and on respectively.
46
47The B<-verbose> flag first prints out the L<perldiag> introduction before
48any other diagnostics.  The $diagnostics::PRETTY variable can generate nicer
49escape sequences for pagers.
50
51Warnings dispatched from perl itself (or more accurately, those that match
52descriptions found in L<perldiag>) are only displayed once (no duplicate
53descriptions).  User code generated warnings a la warn() are unaffected,
54allowing duplicate user messages to be displayed.
55
56=head2 The I<splain> Program
57
58While apparently a whole nuther program, I<splain> is actually nothing
59more than a link to the (executable) F<diagnostics.pm> module, as well as
60a link to the F<diagnostics.pod> documentation.  The B<-v> flag is like
61the C<use diagnostics -verbose> directive.
62The B<-p> flag is like the
63$diagnostics::PRETTY variable.  Since you're post-processing with
64I<splain>, there's no sense in being able to enable() or disable() processing.
65
66Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
67
68=head1 EXAMPLES
69
70The following file is certain to trigger a few errors at both
71runtime and compiletime:
72
73    use diagnostics;
74    print NOWHERE "nothing\n";
75    print STDERR "\n\tThis message should be unadorned.\n";
76    warn "\tThis is a user warning";
77    print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
78    my $a, $b = scalar <STDIN>;
79    print "\n";
80    print $x/$y;
81
82If you prefer to run your program first and look at its problem
83afterwards, do this:
84
85    perl -w test.pl 2>test.out
86    ./splain < test.out
87
88Note that this is not in general possible in shells of more dubious heritage,
89as the theoretical
90
91    (perl -w test.pl >/dev/tty) >& test.out
92    ./splain < test.out
93
94Because you just moved the existing B<stdout> to somewhere else.
95
96If you don't want to modify your source code, but still have on-the-fly
97warnings, do this:
98
99    exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
100
101Nifty, eh?
102
103If you want to control warnings on the fly, do something like this.
104Make sure you do the C<use> first, or you won't be able to get
105at the enable() or disable() methods.
106
107    use diagnostics; # checks entire compilation phase
108	print "\ntime for 1st bogus diags: SQUAWKINGS\n";
109	print BOGUS1 'nada';
110	print "done with 1st bogus\n";
111
112    disable diagnostics; # only turns off runtime warnings
113	print "\ntime for 2nd bogus: (squelched)\n";
114	print BOGUS2 'nada';
115	print "done with 2nd bogus\n";
116
117    enable diagnostics; # turns back on runtime warnings
118	print "\ntime for 3rd bogus: SQUAWKINGS\n";
119	print BOGUS3 'nada';
120	print "done with 3rd bogus\n";
121
122    disable diagnostics;
123	print "\ntime for 4th bogus: (squelched)\n";
124	print BOGUS4 'nada';
125	print "done with 4th bogus\n";
126
127=head1 INTERNALS
128
129Diagnostic messages derive from the F<perldiag.pod> file when available at
130runtime.  Otherwise, they may be embedded in the file itself when the
131splain package is built.   See the F<Makefile> for details.
132
133If an extant $SIG{__WARN__} handler is discovered, it will continue
134to be honored, but only after the diagnostics::splainthis() function
135(the module's $SIG{__WARN__} interceptor) has had its way with your
136warnings.
137
138There is a $diagnostics::DEBUG variable you may set if you're desperately
139curious what sorts of things are being intercepted.
140
141    BEGIN { $diagnostics::DEBUG = 1 }
142
143
144=head1 BUGS
145
146Not being able to say "no diagnostics" is annoying, but may not be
147insurmountable.
148
149The C<-pretty> directive is called too late to affect matters.
150You have to do this instead, and I<before> you load the module.
151
152    BEGIN { $diagnostics::PRETTY = 1 }
153
154I could start up faster by delaying compilation until it should be
155needed, but this gets a "panic: top_level" when using the pragma form
156in Perl 5.001e.
157
158While it's true that this documentation is somewhat subserious, if you use
159a program named I<splain>, you should expect a bit of whimsy.
160
161=head1 AUTHOR
162
163Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
164
165=cut
166
167use strict;
168use 5.006;
169use Carp;
170
171our $VERSION = 1.12;
172our $DEBUG;
173our $VERBOSE;
174our $PRETTY;
175
176use Config;
177my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
178if ($^O eq 'VMS') {
179    require VMS::Filespec;
180    $privlib = VMS::Filespec::unixify($privlib);
181    $archlib = VMS::Filespec::unixify($archlib);
182}
183my @trypod = (
184	   "$archlib/pod/perldiag.pod",
185	   "$privlib/pod/perldiag-$Config{version}.pod",
186	   "$privlib/pod/perldiag.pod",
187	   "$archlib/pods/perldiag.pod",
188	   "$privlib/pods/perldiag-$Config{version}.pod",
189	   "$privlib/pods/perldiag.pod",
190	  );
191# handy for development testing of new warnings etc
192unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
193(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
194
195if ($^O eq 'MacOS') {
196    # just updir one from each lib dir, we'll find it ...
197    ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
198}
199
200
201$DEBUG ||= 0;
202my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
203
204local $| = 1;
205local $_;
206
207my $standalone;
208my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
209
210CONFIG: {
211    our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
212
213    unless (caller) {
214	$standalone++;
215	require Getopt::Std;
216	Getopt::Std::getopts('pdvf:')
217	    or die "Usage: $0 [-v] [-p] [-f splainpod]";
218	$PODFILE = $opt_f if $opt_f;
219	$DEBUG = 2 if $opt_d;
220	$VERBOSE = $opt_v;
221	$PRETTY = $opt_p;
222    }
223
224    if (open(POD_DIAG, $PODFILE)) {
225	warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
226	last CONFIG;
227    }
228
229    if (caller) {
230	INCPATH: {
231	    for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
232		warn "Checking $file\n" if $DEBUG;
233		if (open(POD_DIAG, $file)) {
234		    while (<POD_DIAG>) {
235			next unless
236			    /^__END__\s*# wish diag dbase were more accessible/;
237			print STDERR "podfile is $file\n" if $DEBUG;
238			last INCPATH;
239		    }
240		}
241	    }
242	}
243    } else {
244	print STDERR "podfile is <DATA>\n" if $DEBUG;
245	*POD_DIAG = *main::DATA;
246    }
247}
248if (eof(POD_DIAG)) {
249    die "couldn't find diagnostic data in $PODFILE @INC $0";
250}
251
252
253%HTML_2_Troff = (
254    'amp'	=>	'&',	#   ampersand
255    'lt'	=>	'<',	#   left chevron, less-than
256    'gt'	=>	'>',	#   right chevron, greater-than
257    'quot'	=>	'"',	#   double quote
258
259    "Aacute"	=>	"A\\*'",	#   capital A, acute accent
260    # etc
261
262);
263
264%HTML_2_Latin_1 = (
265    'amp'	=>	'&',	#   ampersand
266    'lt'	=>	'<',	#   left chevron, less-than
267    'gt'	=>	'>',	#   right chevron, greater-than
268    'quot'	=>	'"',	#   double quote
269
270    "Aacute"	=>	"\xC1"	#   capital A, acute accent
271
272    # etc
273);
274
275%HTML_2_ASCII_7 = (
276    'amp'	=>	'&',	#   ampersand
277    'lt'	=>	'<',	#   left chevron, less-than
278    'gt'	=>	'>',	#   right chevron, greater-than
279    'quot'	=>	'"',	#   double quote
280
281    "Aacute"	=>	"A"	#   capital A, acute accent
282    # etc
283);
284
285our %HTML_Escapes;
286*HTML_Escapes = do {
287    if ($standalone) {
288	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
289    } else {
290	\%HTML_2_Latin_1;
291    }
292};
293
294*THITHER = $standalone ? *STDOUT : *STDERR;
295
296my %transfmt = ();
297my $transmo = <<EOFUNC;
298sub transmo {
299    #local \$^W = 0;  # recursive warnings we do NOT need!
300    study;
301EOFUNC
302
303my %msg;
304{
305    print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
306    local $/ = '';
307    local $_;
308    my $header;
309    my $for_item;
310    while (<POD_DIAG>) {
311
312	unescape();
313	if ($PRETTY) {
314	    sub noop   { return $_[0] }  # spensive for a noop
315	    sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; }
316	    sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; }
317	    s/[BC]<(.*?)>/bold($1)/ges;
318	    s/[LIF]<(.*?)>/italic($1)/ges;
319	} else {
320	    s/[BC]<(.*?)>/$1/gs;
321	    s/[LIF]<(.*?)>/$1/gs;
322	}
323	unless (/^=/) {
324	    if (defined $header) {
325		if ( $header eq 'DESCRIPTION' &&
326		    (   /Optional warnings are enabled/
327		     || /Some of these messages are generic./
328		    ) )
329		{
330		    next;
331		}
332		s/^/    /gm;
333		$msg{$header} .= $_;
334	 	undef $for_item;
335	    }
336	    next;
337	}
338	unless ( s/=item (.*?)\s*\z//) {
339
340	    if ( s/=head1\sDESCRIPTION//) {
341		$msg{$header = 'DESCRIPTION'} = '';
342		undef $for_item;
343	    }
344	    elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
345		$for_item = $1;
346	    }
347	    next;
348	}
349
350	if( $for_item ) { $header = $for_item; undef $for_item }
351	else {
352	    $header = $1;
353	    while( $header =~ /[;,]\z/ ) {
354		<POD_DIAG> =~ /^\s*(.*?)\s*\z/;
355		$header .= ' '.$1;
356	    }
357	}
358
359	# strip formatting directives from =item line
360	$header =~ s/[A-Z]<(.*?)>/$1/g;
361
362        my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
363	if (@toks > 1) {
364            my $conlen = 0;
365            for my $i (0..$#toks){
366                if( $i % 2 ){
367                    if(      $toks[$i] eq '%c' ){
368                        $toks[$i] = '.';
369                    } elsif( $toks[$i] eq '%d' ){
370                        $toks[$i] = '\d+';
371                    } elsif( $toks[$i] eq '%s' ){
372                        $toks[$i] = $i == $#toks ? '.*' : '.*?';
373                    } elsif( $toks[$i] =~ '%.(\d+)s' ){
374                        $toks[$i] = ".{$1}";
375                     } elsif( $toks[$i] =~ '^%l*x$' ){
376                        $toks[$i] = '[\da-f]+';
377                   }
378                } elsif( length( $toks[$i] ) ){
379                    $toks[$i] =~ s/^.*$/\Q$&\E/;
380                    $conlen += length( $toks[$i] );
381                }
382            }
383            my $lhs = join( '', @toks );
384	    $transfmt{$header}{pat} =
385              "    s{^$lhs}\n     {\Q$header\E}s\n\t&& return 1;\n";
386            $transfmt{$header}{len} = $conlen;
387	} else {
388            $transfmt{$header}{pat} =
389	      "    m{^\Q$header\E} && return 1;\n";
390            $transfmt{$header}{len} = length( $header );
391	}
392
393	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
394	    if $msg{$header};
395
396	$msg{$header} = '';
397    }
398
399
400    close POD_DIAG unless *main::DATA eq *POD_DIAG;
401
402    die "No diagnostics?" unless %msg;
403
404    # Apply patterns in order of decreasing sum of lengths of fixed parts
405    # Seems the best way of hitting the right one.
406    for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
407                  keys %transfmt ){
408        $transmo .= $transfmt{$hdr}{pat};
409    }
410    $transmo .= "    return 0;\n}\n";
411    print STDERR $transmo if $DEBUG;
412    eval $transmo;
413    die $@ if $@;
414}
415
416if ($standalone) {
417    if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
418    while (defined (my $error = <>)) {
419	splainthis($error) || print THITHER $error;
420    }
421    exit;
422}
423
424my $olddie;
425my $oldwarn;
426
427sub import {
428    shift;
429    $^W = 1; # yup, clobbered the global variable;
430	     # tough, if you want diags, you want diags.
431    return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
432
433    for (@_) {
434
435	/^-d(ebug)?$/ 	   	&& do {
436				    $DEBUG++;
437				    next;
438				   };
439
440	/^-v(erbose)?$/ 	&& do {
441				    $VERBOSE++;
442				    next;
443				   };
444
445	/^-p(retty)?$/ 		&& do {
446				    print STDERR "$0: I'm afraid it's too late for prettiness.\n";
447				    $PRETTY++;
448				    next;
449			       };
450
451	warn "Unknown flag: $_";
452    }
453
454    $oldwarn = $SIG{__WARN__};
455    $olddie = $SIG{__DIE__};
456    $SIG{__WARN__} = \&warn_trap;
457    $SIG{__DIE__} = \&death_trap;
458}
459
460sub enable { &import }
461
462sub disable {
463    shift;
464    return unless $SIG{__WARN__} eq \&warn_trap;
465    $SIG{__WARN__} = $oldwarn || '';
466    $SIG{__DIE__} = $olddie || '';
467}
468
469sub warn_trap {
470    my $warning = $_[0];
471    if (caller eq $WHOAMI or !splainthis($warning)) {
472	print STDERR $warning;
473    }
474    &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
475};
476
477sub death_trap {
478    my $exception = $_[0];
479
480    # See if we are coming from anywhere within an eval. If so we don't
481    # want to explain the exception because it's going to get caught.
482    my $in_eval = 0;
483    my $i = 0;
484    while (1) {
485      my $caller = (caller($i++))[3] or last;
486      if ($caller eq '(eval)') {
487	$in_eval = 1;
488	last;
489      }
490    }
491
492    splainthis($exception) unless $in_eval;
493    if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
494    &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
495
496    return if $in_eval;
497
498    # We don't want to unset these if we're coming from an eval because
499    # then we've turned off diagnostics.
500
501    # Switch off our die/warn handlers so we don't wind up in our own
502    # traps.
503    $SIG{__DIE__} = $SIG{__WARN__} = '';
504
505    # Have carp skip over death_trap() when showing the stack trace.
506    local($Carp::CarpLevel) = 1;
507
508    confess "Uncaught exception from user code:\n\t$exception";
509	# up we go; where we stop, nobody knows, but i think we die now
510	# but i'm deeply afraid of the &$olddie guy reraising and us getting
511	# into an indirect recursion loop
512};
513
514my %exact_duplicate;
515my %old_diag;
516my $count;
517my $wantspace;
518sub splainthis {
519    local $_ = shift;
520    local $\;
521    ### &finish_compilation unless %msg;
522    s/\.?\n+$//;
523    my $orig = $_;
524    # return unless defined;
525
526    # get rid of the where-are-we-in-input part
527    s/, <.*?> (?:line|chunk).*$//;
528
529    # Discard 1st " at <file> line <no>" and all text beyond
530    # but be aware of messsages containing " at this-or-that"
531    my $real = 0;
532    my @secs = split( / at / );
533    $_ = $secs[0];
534    for my $i ( 1..$#secs ){
535        if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
536            $real = 1;
537            last;
538        } else {
539            $_ .= ' at ' . $secs[$i];
540	}
541    }
542
543    # remove parenthesis occurring at the end of some messages
544    s/^\((.*)\)$/$1/;
545
546    if ($exact_duplicate{$orig}++) {
547	return &transmo;
548    } else {
549	return 0 unless &transmo;
550    }
551
552    $orig = shorten($orig);
553    if ($old_diag{$_}) {
554	autodescribe();
555	print THITHER "$orig (#$old_diag{$_})\n";
556	$wantspace = 1;
557    } else {
558	autodescribe();
559	$old_diag{$_} = ++$count;
560	print THITHER "\n" if $wantspace;
561	$wantspace = 0;
562	print THITHER "$orig (#$old_diag{$_})\n";
563	if ($msg{$_}) {
564	    print THITHER $msg{$_};
565	} else {
566	    if (0 and $standalone) {
567		print THITHER "    **** Error #$old_diag{$_} ",
568			($real ? "is" : "appears to be"),
569			" an unknown diagnostic message.\n\n";
570	    }
571	    return 0;
572	}
573    }
574    return 1;
575}
576
577sub autodescribe {
578    if ($VERBOSE and not $count) {
579	print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
580		"\n$msg{DESCRIPTION}\n";
581    }
582}
583
584sub unescape {
585    s {
586            E<
587            ( [A-Za-z]+ )
588            >
589    } {
590         do {
591             exists $HTML_Escapes{$1}
592                ? do { $HTML_Escapes{$1} }
593                : do {
594                    warn "Unknown escape: E<$1> in $_";
595                    "E<$1>";
596                }
597         }
598    }egx;
599}
600
601sub shorten {
602    my $line = $_[0];
603    if (length($line) > 79 and index($line, "\n") == -1) {
604	my $space_place = rindex($line, ' ', 79);
605	if ($space_place != -1) {
606	    substr($line, $space_place, 1) = "\n\t";
607	}
608    }
609    return $line;
610}
611
612
6131 unless $standalone;  # or it'll complain about itself
614__END__ # wish diag dbase were more accessible
615