source: for-distributions/trunk/bin/windows/perl/bin/splain.bat@ 14489

Last change on this file since 14489 was 14489, checked in by oranfry, 17 years ago

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