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