[p5sagit/p5-mst-13.2.git] / lib / diagnostics.pm

package diagnostics;

=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 interpreter, augmenting them with the more
explicative and endearing descriptions found in L<perldiag>.  Like the
other pragmata, it affects the 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 their 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 variable can generate nicer
escape sequences for pagers.

Warnings dispatched from perl itself (or more accurately, those that match
descriptions found in L<perldiag>) are only displayed once (no duplicate
descriptions).  User code generated warnings ala warn() are unaffected,
allowing duplicate user messages to be displayed.

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

    (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 diagnostics::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 do 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 Perl 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<tchrist@mox.perl.com>>, 25 June 1995.

=cut

use strict;
use 5.006;
use Carp;

our $VERSION = 1.1;
our $DEBUG;
our $VERBOSE;
our $PRETTY;

use Config;
my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
if ($^O eq 'VMS') {
    require VMS::Filespec;
    $privlib = VMS::Filespec::unixify($privlib);
    $archlib = VMS::Filespec::unixify($archlib);
}
my @trypod = (
	   "$archlib/pod/perldiag.pod",
	   "$privlib/pod/perldiag-$Config{version}.pod",
	   "$privlib/pod/perldiag.pod",
	   "$archlib/pods/perldiag.pod",
	   "$privlib/pods/perldiag-$Config{version}.pod",
	   "$privlib/pods/perldiag.pod",
	  );
# handy for development testing of new warnings etc
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];

if ($^O eq 'MacOS') {
    # just updir one from each lib dir, we'll find it ...
    ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
}


$DEBUG ||= 0;
my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine

local $| = 1;
local $_;

my $standalone;
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);

CONFIG: {
    our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';

    unless (caller) {
	$standalone++;
	require Getopt::Std;
	Getopt::Std::getopts('pdvf:')
	    or 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 my $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
);

our %HTML_Escapes;
*HTML_Escapes = do {
    if ($standalone) {
	$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 
    } else {
	\%HTML_2_Latin_1; 
    }
}; 

*THITHER = $standalone ? *STDOUT : *STDERR;

my $transmo = <<EOFUNC;
sub transmo {
    #local \$^W = 0;  # recursive warnings we do NOT need!
    study;
EOFUNC

my %msg;
{
    print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
    local $/ = '';
    local $_;
    my $header;
    my $for_item;
    while (<POD_DIAG>) {

	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} .= $_;
	 	undef $for_item;	
	    }
	    next;
	} 
	unless ( s/=item (.*?)\s*\z//) {

	    if ( s/=head1\sDESCRIPTION//) {
		$msg{$header = 'DESCRIPTION'} = '';
		undef $for_item;
	    }
	    elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
		$for_item = $1;
	    } 
	    next;
	}

	if( $for_item ) { $header = $for_item; undef $for_item } 
	else {
	    $header = $1;
	    while( $header =~ /[;,]\z/ ) {
		<POD_DIAG> =~ /^\s*(.*?)\s*\z/;
		$header .= ' '.$1;
	    }
	}

	# strip formatting directives in =item line
	$header =~ s/[A-Z]<(.*?)>/$1/g;

	if ($header =~ /%[csd]/) {
	    my $rhs = my $lhs = $header;
	    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//g;
		$lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
	    } 
	    $lhs =~ s/\\%c/./g;
	    $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
	} else {
	    $transmo .= "    m{^\Q$header\E} && return 1;\n";
	} 

	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
	    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 $@;
}

if ($standalone) {
    if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
    while (defined (my $error = <>)) {
	splainthis($error) || print THITHER $error;
    } 
    exit;
} 

my $olddie;
my $oldwarn;

sub import {
    shift;
    $^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;
    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];

    # See if we are coming from anywhere within an eval. If so we don't
    # want to explain the exception because it's going to get caught.
    my $in_eval = 0;
    my $i = 0;
    while (1) {
      my $caller = (caller($i++))[3] or last;
      if ($caller eq '(eval)') {
	$in_eval = 1;
	last;
      }
    }

    splainthis($exception) unless $in_eval;
    if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 
    &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;

    return if $in_eval;

    # We don't want to unset these if we're coming from an eval because
    # then we've turned off diagnostics.

    # Switch off our die/warn handlers so we don't wind up in our own
    # traps.
    $SIG{__DIE__} = $SIG{__WARN__} = '';

    # Have carp skip over death_trap() when showing the stack trace.
    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
};

my %exact_duplicate;
my %old_diag;
my $count;
my $wantspace;
sub splainthis {
    local $_ = shift;
    local $\;
    ### &finish_compilation unless %msg;
    s/\.?\n+$//;
    my $orig = $_;
    # return unless defined;
    s/, <.*?> (?:line|chunk).*$//;
    my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
    s/^\((.*)\)$/$1/;
    if ($exact_duplicate{$orig}++) {
	return &transmo;
    }
    else {
	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: E<$1> in $_";
                    "E<$1>";
                } 
         } 
    }egx;
}

sub shorten {
    my $line = $_[0];
    if (length($line) > 79 and index($line, "\n") == -1) {
	my $space_place = rindex($line, ' ', 79);
	if ($space_place != -1) {
	    substr($line, $space_place, 1) = "\n\t";
	} 
    } 
    return $line;
} 


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