t/pod/diag.t

   1 #!/usr/bin/perl
   2 use warnings;
   3 use strict;
   4 use Test::More 'no_plan';
   5 $|=1;
   6
   7 open my $diagfh, "<:raw", "pod/perldiag.pod"
   8   or die "Can't open pod/perldiag.pod: $!";
   9
  10 my %entries;
  11 my $cur_entry;
  12 while (<$diagfh>) {
  13   if (m/^=item (.*)/) {
  14     $cur_entry = $1;
  15   } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) {
  16     $entries{$cur_entry}{severity} = $1;
  17     $entries{$cur_entry}{category} = $2;
  18   }
  19 }
  20
  21 my @todo = ('.');
  22 while (@todo) {
  23   my $todo = shift @todo;
  24   next if $todo ~~ ['./t', './lib', './ext'];
  25   # opmini.c is just a copy of op.c, so there's no need to check again.
  26   next if $todo eq './opmini.c';
  27   if (-d $todo) {
  28     push @todo, glob "$todo/*";
  29   } elsif ($todo =~ m/\.(c|h)$/) {
  30     check_file($todo);
  31   }
  32 }
  33
  34 sub check_file {
  35   my ($codefn) = @_;
  36
  37   diag($codefn);
  38
  39   open my $codefh, "<:raw", $codefn
  40     or die "Can't open $codefn: $!";
  41
  42   my $listed_as;
  43   my $listed_as_line;
  44   my $sub = 'top of file';
  45   while (<$codefh>) {
  46     chomp;
  47     # Getting too much here isn't a problem; we only use this to skip
  48     # errors inside of XS modules, which should get documented in the
  49     # docs for the module.
  50     if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) {
  51       $sub = $1;
  52     }
  53     next if $sub =~ m/^XS/;
  54     if (m</\* diag_listed_as: (.*) \*/>) {
  55       $listed_as = $1;
  56       $listed_as_line = $.+1;
  57     }
  58     next if /^#/;
  59     next if /^ * /;
  60     while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) {
  61       my $nextline = <$codefh>;
  62       # Means we fell off the end of the file.  Not terribly surprising;
  63       # this code tries to merge a lot of things that aren't regular C
  64       # code (preprocessor stuff, long comments).  That's OK; we don't
  65       # need those anyway.
  66       last if not defined $nextline;
  67       chomp $nextline;
  68       $nextline =~ s/^\s+//;
  69       # Note that we only want to do this where *both* are true.
  70       $_ =~ s/\\$//;
  71       if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
  72         $_ =~ s/"$//;
  73         $nextline =~ s/^"//;
  74       }
  75       $_ = "$_$nextline";
  76     }
  77     # This should happen *after* unwrapping, or we don't reformat the things
  78     # in later lines.
  79     # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
  80     my %specialformats = (IVdf => 'd',
  81                           UVuf => 'd',
  82                           UVof => 'o',
  83                           UVxf => 'x',
  84                           UVXf => 'X',
  85                           NVef => 'f',
  86                           NVff => 'f',
  87                           NVgf => 'f',
  88                           SVf  => 's');
  89     for my $from (keys %specialformats) {
  90       s/%"\s*$from\s*"/\%$specialformats{$from}/g;
  91       s/%"\s*$from/\%$specialformats{$from}"/g;
  92     }
  93     # The %"foo" thing needs to happen *before* this regex.
  94     if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s*
  95           \(aTHX_ \s*
  96           (?:packWARN\d*\((.*?)\),)? \s*
  97           "((?:\\"|[^"])*?)"/x) {
  98       # diag($_);
  99       # DIE is just return Perl_die
 100       my $severity = {croak => [qw/P F/],
 101                       die   => [qw/P F/],
 102                       warn  => [qw/W D S/],
 103                      }->{$1||'die'};
 104       my @categories;
 105       if ($2) {
 106         @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2;
 107       }
 108       my $name;
 109       if ($listed_as and $listed_as_line == $.) {
 110         $name = $listed_as;
 111       } else {
 112         $name = $3;
 113         # The form listed in perldiag ignores most sorts of fancy printf formatting,
 114         # or makes it more perlish.
 115         $name =~ s/%%/\\%/g;
 116         $name =~ s/%l[ud]/%d/g;
 117         $name =~ s/%\.(\d+|\*)s/\%s/g;
 118         $name =~ s/\\"/"/g;
 119         $name =~ s/\\t/\t/g;
 120         $name =~ s/\\n/\n/g;
 121         $name =~ s/\n$//;
 122       }
 123
 124       # Extra explanitory info on an already-listed error, doesn't need it's own listing.
 125       next if $name =~ m/^\t/;
 126
 127       # Happens fairly often with PL_no_modify.
 128       next if $name eq '%s';
 129
 130       # Special syntax for magic comment, allows ignoring the fact that it isn't listed.
 131       # Only use in very special circumstances, like this script failing to notice that
 132       # the Perl_croak call is inside an #if 0 block.
 133       next if $name eq 'SKIPME';
 134
 135       if (!exists $entries{$name}) {
 136         if ($name =~ m/^panic: /) {
 137           # Just too many panic:s, they are hard to diagnose, and there is a generic "panic: %s" entry.
 138           # Leave these for another pass.
 139           ok("Presence of '$name' from $codefn line $., covered by panic: %s entry");
 140         } else {
 141           fail("Presence of '$name' from $codefn line $.");
 142         }
 143       } else {
 144         ok("Presence of '$name' from $codefn line $.");
 145         # Commented: "substr outside of string" has is either a warning
 146         # or an error, depending how much was outside.
 147         # Also, plenty of failures without forcing further hardship...
 148 #         if ($entries{$name} and !($entries{$name}{severity} ~~ $severity)) {
 149 #           fail("Severity for '$name' from $codefn line $.: got $entries{$name}{severity}, expected $severity");
 150 #         } else {
 151 #           ok("Severity for '$name' from $codefn line $.: got $entries{$name}{severity}, expected $severity");
 152 #         }
 153       }
 154
 155       die if $name =~ /%$/;
 156     }
 157   }
 158 }