From: Gurusamy Sarathy Date: Mon, 1 May 2000 15:19:41 +0000 (+0000) Subject: small nits in diagnostics.pm (from Robin Barker) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a4340ed1c0dcc7503198c180f1c721ca55a63be;p=p5sagit%2Fp5-mst-13.2.git small nits in diagnostics.pm (from Robin Barker) p4raw-id: //depot/perl@6031 --- diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index a2c927b..8c7aedc 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -167,19 +167,23 @@ Tom Christiansen >, 25 June 1995. =cut +use strict; use 5.005_64; use Carp; -$VERSION = v1.0; +our $VERSION = v1.0; +our $DEBUG; +our $VERBOSE; +our $PRETTY; use Config; -($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; +my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; if ($^O eq 'VMS') { require VMS::Filespec; $privlib = VMS::Filespec::unixify($privlib); $archlib = VMS::Filespec::unixify($archlib); } -@trypod = ( +my @trypod = ( "$archlib/pod/perldiag.pod", "$privlib/pod/perldiag-$Config{version}.pod", "$privlib/pod/perldiag.pod", @@ -189,21 +193,21 @@ if ($^O eq 'VMS') { ); # handy for development testing of new warnings etc unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; -($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; +(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; $DEBUG ||= 0; my $WHOAMI = ref bless []; # nobody's business, prolly not even mine -$| = 1; - +local $| = 1; local $_; +my $standalone; +my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); + CONFIG: { - $opt_p = $opt_d = $opt_v = $opt_f = ''; - %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); - %exact_duplicate = (); + our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; - unless (caller) { + unless (caller) { $standalone++; require Getopt::Std; Getopt::Std::getopts('pdvf:') @@ -212,7 +216,7 @@ CONFIG: { $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; @@ -221,11 +225,12 @@ CONFIG: { if (caller) { INCPATH: { - for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { + for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { warn "Checking $file\n" if $DEBUG; if (open(POD_DIAG, $file)) { while () { - next unless /^__END__\s*# wish diag dbase were more accessible/; + next unless + /^__END__\s*# wish diag dbase were more accessible/; print STDERR "podfile is $file\n" if $DEBUG; last INCPATH; } @@ -274,6 +279,7 @@ if (eof(POD_DIAG)) { # etc ); +our %HTML_Escapes; *HTML_Escapes = do { if ($standalone) { $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; @@ -284,20 +290,20 @@ if (eof(POD_DIAG)) { *THITHER = $standalone ? *STDOUT : *STDERR; -$transmo = <) { - #s/(.*)\n//; - #$header = $1; unescape(); if ($PRETTY) { @@ -321,29 +327,35 @@ EOFUNC } s/^/ /gm; $msg{$header} .= $_; + undef $for_item; } next; } - unless ( s/=item (.*)\s*\Z//) { + 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; } # strip formatting directives in =item line - ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; + $header = $for_item || $1; + undef $for_item; + $header =~ s/[A-Z]<(.*?)>/$1/g; if ($header =~ /%[csd]/) { - $rhs = $lhs = $header; - #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { - if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { + 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 + # if i had lookbehind negations, + # i wouldn't have to do this \377 noise $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; - #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; $lhs =~ s/\377([^\377]*)$/\Q$1\E/; $lhs =~ s/\377//g; $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all @@ -369,25 +381,23 @@ EOFUNC print STDERR $transmo if $DEBUG; eval $transmo; die $@ if $@; - $RS = "\n"; -### } +} if ($standalone) { if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } - while (defined ($error = <>)) { + while (defined (my $error = <>)) { splainthis($error) || print THITHER $error; } exit; -} else { - #$old_w = 0; - $oldwarn = ''; $olddie = ''; -} +} + +my $olddie; +my $oldwarn; sub import { shift; - #$old_w = $^W; - $^W = 1; # yup, clobbered the global variable; tough, if you - # want diags, you want diags. + $^W = 1; # yup, clobbered the global variable; + # tough, if you want diags, you want diags. return if $SIG{__WARN__} eq \&warn_trap; for (@_) { @@ -421,7 +431,6 @@ sub enable { &import } sub disable { shift; - #$^W = $old_w; return unless $SIG{__WARN__} eq \&warn_trap; $SIG{__WARN__} = $oldwarn; $SIG{__DIE__} = $olddie; @@ -465,6 +474,10 @@ sub death_trap { # into an indirect recursion loop }; +my %exact_duplicate; +my %old_diag; +my $count; +my $wantspace; sub splainthis { local $_ = shift; local $\; @@ -473,7 +486,7 @@ sub splainthis { my $orig = $_; # return unless defined; s/, <.*?> (?:line|chunk).*$//; - $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; + my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; s/^\((.*)\)$/$1/; if ($exact_duplicate{$orig}++) { return &transmo; @@ -542,8 +555,5 @@ sub shorten { } -# have to do this: RS isn't set until run time, but we're executing at compiletime -$RS = "\n"; - 1 unless $standalone; # or it'll complain about itself __END__ # wish diag dbase were more accessible diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 1657c45..a49b9af 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1856,13 +1856,13 @@ catches that. But an easy way to do the same thing is: Another way is to assign to a substr() that's off the end of the string. -=item Modification of non-creatable array value attempted, subscript %d +=item Modification of non-creatable array value attempted, %s (F) You tried to make an array value spring into existence, and the subscript was probably negative, even counting from end of the array backwards. -=item Modification of non-creatable hash value attempted, subscript "%s" +=item Modification of non-creatable hash value attempted, %s (P) You tried to make a hash value spring into existence, and it couldn't be created for some peculiar reason. @@ -2680,7 +2680,7 @@ which is why it's currently left out of your copy. (F) More than 100 levels of inheritance were used. Probably indicates an unintended loop in your inheritance hierarchy. -=item Recursive inheritance detected while looking for method '%s' in package '%s' +=item Recursive inheritance detected while looking for method %s (F) More than 100 levels of inheritance were encountered while invoking a method. Probably indicates an unintended loop in your inheritance @@ -2976,7 +2976,7 @@ quantifier inside the assertion instead. For example, the way to match "abc" provided that it is followed by three repetitions of "xyz" is C, not C. -=item Stub found while resolving method `%s' overloading `%s' in package `%s' +=item Stub found while resolving method `%s' overloading %s (P) Overloading resolution over @ISA tree may be broken by importation stubs. Stubs should never be implicitly created, but explicit calls to