#!/usr/bin/perl
use warnings;
use strict;
-use Test::More 'no_plan';
+
+require './test.pl';
+
+plan('no_plan');
+
$|=1;
+# --make-exceptions-list outputs the list of strings that don't have
+# perldiag.pod entries to STDERR without TAP formatting, so they can
+# easily be put in the __DATA__ section of this file. This was done
+# initially so as to not create new test failures upon the initial
+# creation of this test file. You probably shouldn't do it again.
+# Just add the documentation instead.
my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
-open my $diagfh, "<:raw", "../pod/perldiag.pod"
- or die "Can't open ../pod/perldiag.pod: $!";
+chdir '..' or die "Can't chdir ..: $!";
+BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
+
+my @functions;
+
+open my $func_fh, "<", "embed.fnc" or die "Can't open embed.fnc: $!";
+
+# Look for functions in embed.fnc that look like they could be diagnostic ones.
+while (<$func_fh>) {
+ chomp;
+ s/^\s+//;
+ while (s/\s*\\$//) { # Grab up all continuation lines, these end in \
+ my $next = <$func_fh>;
+ $next =~ s/^\s+//;
+ chomp $next;
+ $_ .= $next;
+ }
+ next if /^:/; # Lines beginning with colon are comments.
+ next unless /\|/; # Lines without a vertical bar are something we can't deal
+ # with
+ my @fields = split /\s*\|\s*/;
+ next unless $fields[2] =~ /warn|err|(\b|_)die|croak/i;
+ push @functions, $fields[2];
+
+ # The flag p means that this function may have a 'Perl_' prefix
+ # The flag s means that this function may have a 'S_' prefix
+ push @functions, "Perl_$fields[2]", if $fields[0] =~ /p/;
+ push @functions, "S_$fields[2]", if $fields[0] =~ /s/;
+}
+
+close $func_fh;
+
+my $function_re = join '|', @functions;
+my $source_msg_re = qr/(?<routine>\bDIE\b|$function_re)/;
my %entries;
+
+# Get the ignores that are compiled into this file
while (<DATA>) {
chomp;
$entries{$_}{todo}=1;
}
my $cur_entry;
+open my $diagfh, "<", "pod/perldiag.pod"
+ or die "Can't open pod/perldiag.pod: $!";
+
while (<$diagfh>) {
if (m/^=item (.*)/) {
$cur_entry = $1;
}
}
-my @todo = ('..');
+# Recursively descend looking for source files.
+my @todo = sort <*>;
while (@todo) {
my $todo = shift @todo;
- next if $todo ~~ ['../t', '../lib', '../ext', '../dist', '../cpan'];
+ next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
# opmini.c is just a copy of op.c, so there's no need to check again.
- next if $todo eq '../opmini.c';
+ next if $todo eq 'opmini.c';
if (-d $todo) {
- push @todo, glob "$todo/*";
+ unshift @todo, sort glob "$todo/*";
} elsif ($todo =~ m/\.[ch]$/) {
check_file($todo);
}
}
+sub find_message {
+ my ($line) = @_;
+ my $text_re = qr/"(?<text>(?:\\"|[^"])*?)"/;
+ if ($line =~ m/$source_msg_re(?:_nocontext)? \s*
+ \(aTHX_ \s*
+ (?:packWARN\d*\((?<category>.*?)\),)? \s*
+ $text_re /x
+ ) {
+ return [$+{'text'}, $+{'category'}];
+ }
+ elsif ( $line =~ m{BADVERSION\([^"]*$text_re}) {
+ return [$+{'text'}, undef];
+ }
+ return;
+}
+
+# Standardize messages with variants into the form that appears
+# in perldiag.pod -- useful for things without a diag_listed_as annotation
+sub standardize {
+ my ($name) = @_;
+
+ if ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
+ $name = "$1 (\%s)";
+ }
+ elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
+ $name = "$1 (\%s)";
+ }
+ elsif ($name =~ m/^panic: /) {
+ $name = "panic: \%s";
+ }
+
+ return $name;
+}
+
sub check_file {
my ($codefn) = @_;
- print "# $codefn\n";
+ print "# Checking $codefn\n";
- open my $codefh, "<:raw", $codefn
+ open my $codefh, "<", $codefn
or die "Can't open $codefn: $!";
my $listed_as;
}
next if /^#/;
next if /^ * /;
- while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) {
+
+ my $multiline = 0;
+ # Loop to accumulate the message text all on one line.
+ while (m/$source_msg_re/ and not m/\);$/) {
my $nextline = <$codefh>;
# Means we fell off the end of the file. Not terribly surprising;
# this code tries to merge a lot of things that aren't regular C
$nextline =~ s/^"//;
}
$_ = "$_$nextline";
+ ++$multiline;
}
# This should happen *after* unwrapping, or we don't reformat the things
# in later lines.
s/%"\s*$from/\%$specialformats{$from}"/g;
}
# The %"foo" thing needs to happen *before* this regex.
- if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s*
- \(aTHX_ \s*
- (?:packWARN\d*\((.*?)\),)? \s*
- "((?:\\"|[^"])*?)"/x) {
- # diag($_);
- # DIE is just return Perl_die
- my $severity = {croak => [qw/P F/],
+ if ( my $found = find_message($_) ) {
+ # diag($_);
+ # DIE is just return Perl_die
+ my ($name, $category) = @$found;
+ my $severity = {croak => [qw/P F/],
die => [qw/P F/],
warn => [qw/W D S/],
- }->{$1||'die'};
- my @categories;
- if ($2) {
- @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2;
- }
- my $name;
- if ($listed_as and $listed_as_line == $.) {
+ }->{$+{'routine'}||'die'};
+ my @categories;
+ if (defined $category) {
+ @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
+ }
+ if ($listed_as and $listed_as_line == $. - $multiline) {
$name = $listed_as;
- } else {
- $name = $3;
- # The form listed in perldiag ignores most sorts of fancy printf formatting,
- # or makes it more perlish.
+ } else {
+ # The form listed in perldiag ignores most sorts of fancy printf
+ # formatting, or makes it more perlish.
$name =~ s/%%/\\%/g;
$name =~ s/%l[ud]/%d/g;
$name =~ s/%\.(\d+|\*)s/\%s/g;
$name =~ s/\\t/\t/g;
$name =~ s/\\n/ /g;
$name =~ s/\s+$//;
+ $name =~ s/(\\)\\/$1/g;
}
# Extra explanatory info on an already-listed error, doesn't
# inside an #if 0 block.
next if $name eq 'SKIPME';
+ $name = standardize($name);
+
if (exists $entries{$name}) {
- if ($entries{$name}{todo}) {
+ if ( $entries{$name}{seen}++ ) {
+ # no need to repeat entries we've tested
+ } elsif ($entries{$name}{todo}) {
TODO: {
- local $TODO = 'in DATA';
- fail("Presence of '$name' from $codefn line $.");
+ no warnings 'once';
+ local $::TODO = 'in DATA';
+ # There is no listing, but it is in the list of exceptions. TODO FAIL.
+ fail($name);
+ diag(
+ " Message '$name'\n from $codefn line $. is not listed in pod/perldiag.pod\n".
+ " (but it wasn't documented in 5.10 either, so marking it TODO)."
+ );
}
} else {
- ok("Presence of '$name' from $codefn line $.");
+ # We found an actual valid entry in perldiag.pod for this error.
+ pass($name);
}
# Later, should start checking that the severity is correct, too.
- } elsif ($name =~ m/^panic: /) {
- # Just too many panic:s, they are hard to diagnose, and there
- # is a generic "panic: %s" entry. Leave these for another
- # pass.
- ok("Presence of '$name' from $codefn line $., covered by panic: %s entry");
} else {
if ($make_exceptions_list) {
+ # We're making an updated version of the exception list, to
+ # stick in the __DATA__ section. I honestly can't think of
+ # a situation where this is the right thing to do, but I'm
+ # leaving it here, just in case one of my descendents thinks
+ # it's a good idea.
print STDERR "$name\n";
} else {
- fail("Presence of '$name' from $codefn line $.");
+ # No listing found, and no excuse either.
+ # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
+ fail($name);
+ diag(" Message '$name'\n from $codefn line $. is not listed in pod/perldiag.pod");
}
+ # seen it, so only fail once for this message
+ $entries{$name}{seen}++;
}
die if $name =~ /%$/;
}
# Lists all missing things as of the inaguration of this script, so we
# don't have to go from "meh" to perfect all at once.
+#
+# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
+# pod/perldiag.pod for your new (warning|error).
__DATA__
-Ambiguous call resolved as CORE::%s(), %s
-Ambiguous use of %c resolved as operator %c
-Ambiguous use of %c{%s} resolved to %c%s
-Ambiguous use of %c{%s%s} resolved to %c%s%s
-Ambiguous use of -%s resolved as -&%s()
Argument "%s" isn't numeric
Argument "%s" isn't numeric in %s
-Assertion: marks beyond string end
-Assertion: string is shorter than advertised
Attempt to clear deleted array
Attempt to free non-arena SV: 0x%x
Attempt to free non-existent shared string '%s'%s
Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
Can't take %s of %f
Can't use '%c' after -mname
-Can't use \\%c to mean $%c in expression
+Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
+Can't use \%c to mean $%c in expression
Can't use when() outside a topicalizer
-\\%c better written as $%c
+\%c better written as $%c
Character(s) in '%c' format wrapped in %s
$%c is no longer supported
Cloning substitution context is unimplemented
Debug leaking scalars child failed%s%s with errno %d: %s
Deep recursion on anonymous subroutine
defined(\%hash) is deprecated
-Don't know how to handle magic of type \\%o
+Don't know how to handle magic of type \%o
-Dp not implemented on this platform
entering effective gid failed
entering effective uid failed
Goto undefined subroutine
Goto undefined subroutine &%s
Hash \%%s missing the \% in argument %d of %s()
-Illegal character \\%03o (carriage return)
+Illegal character \%03o (carriage return)
Illegal character %sin prototype for %s : %s
+Integer overflow in binary number
Integer overflow in decimal number
+Integer overflow in hexadecimal number
+Integer overflow in octal number
Integer overflow in version %d
internal \%<num>p might conflict with future printf extensions
-invalid control request: '\\%03o'
+invalid control request: '\%03o'
Invalid module name %s with -%c option: contains single ':'
invalid option -D%c, use -D'' to see choices
Invalid range "%c-%c" in transliteration operator
Invalid type '%c' in %s
Invalid type '%c' in unpack
Invalid type ',' in %s
-Invalid version format (alpha without decimal)
-Invalid version format (misplaced _ in number)
-Invalid version object
+It is proposed that "\c{" no longer be valid. It has historically evaluated to ";". If you disagree with this proposal, send email to perl5-porters@perl.org Otherwise, or in the meantime, you can work around this failure by changing "\c{" to ";"
'j' not supported on this platform
'J' not supported on this platform
Layer does not match this perl
Opening dirhandle %s also as a file
Opening filehandle %s also as a directory
Operator or semicolon missing before %c%s
-Overloaded dereference did not return a reference
-Perl bug: predicted utf8 length not available
PERL_SIGNALS illegal: "%s"
Perl %s required (did you mean %s?)--this is only %s, stopped
Perl %s required--this is only %s, stopped
Perls since %s too modern--this is %s, stopped
-Possible unintended interpolation of $\\ in regex
+Possible unintended interpolation of $\ in regex
ptr wrong %p != %p fl=%08
Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
Recursive call to Perl_load_module in PerlIO_find_layer
refcnt_inc: fd %d: %d <= 0
Reversed %c= operator
Runaway prototype
+%s(%.0
%s(%.0f) failed
%s(%.0f) too large
Scalar value %s better written as $%s
Unbalanced string table refcount: (%d) for "%s"
Undefined top format called
Unexpected constant lvalue entersub entry via type/targ %d:%d
-Unicode character 0x%04
+Unicode non-character 0x%04
Unknown PerlIO layer "scalar"
Unknown Unicode option letter '%c'
-unrecognised control character '%c'
Unstable directory path, current directory changed unexpectedly
-Unsupported script encoding UTF16-BE
-Unsupported script encoding UTF16-LE
-Unsupported script encoding UTF32-BE
-Unsupported script encoding UTF32-LE
+Unsupported script encoding UTF-16BE
+Unsupported script encoding UTF-16LE
+Unsupported script encoding UTF-32BE
+Unsupported script encoding UTF-32LE
Unterminated compressed integer in unpack
Usage: CODE(0x%x)(%s)
Usage: %s(%s)
Usage: VMS::Filespec::vmsrealpath(spec)
Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
UTF-16 surrogate 0x%04
-utf8 "\\x%02X" does not map to Unicode
+utf8 "\x%02X" does not map to Unicode
Value of logical "%s" too long. Truncating to %i bytes
value of node is %d in Offset macro
Value of %s%s can be "0"; test with defined()
https://perl5.git.perl.org / perl5.git / blobdiff