1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
|
#!/usr/bin/perl
use warnings;
use strict;
chdir 't';
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';
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 $text_re = qr/"(?<text>(?:\\"|[^"]|"\s*[A-Z_]+\s*")*)"/;
my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
\(aTHX_ \s*
(?:packWARN\d*\((?<category>.*?)\),)? \s*
$text_re /x;
my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
my %entries;
# Get the ignores that are compiled into this file
while (<DATA>) {
chomp;
$entries{$_}{todo}=1;
}
my $pod = "pod/perldiag.pod";
my $cur_entry;
open my $diagfh, "<", $pod
or die "Can't open $pod: $!";
my $category_re = qr/ [a-z0-9_]+?/; # Note: requires an initial space
my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
# be of the form 'S|P|W'
while (<$diagfh>) {
if (m/^=item (.*)/) {
$cur_entry = $1;
if (exists $entries{$cur_entry}) {
TODO: {
local $::TODO = "Remove the TODO entry \"$cur_entry\" from DATA as it is already in $pod near line $.";
ok($cur_entry);
}
}
# Make sure to init this here, so an actual entry in perldiag
# overwrites one in DATA.
$entries{$cur_entry}{todo} = 0;
$entries{$cur_entry}{line_number} = $.;
next;
}
next if ! defined $cur_entry;
if (! $entries{$cur_entry}{severity}) {
if (/^ \( ( $severity_re )
# Can have multiple categories separated by commas
(?: ( $category_re ) (?: , $category_re)* )? \) /x)
{
$entries{$cur_entry}{severity} = $1;
$entries{$cur_entry}{category} = $2;
}
elsif (! $entries{$cur_entry}{first_line} && $_ =~ /\S/) {
# Keep track of first line of text if doesn't contain a severity, so
# that can later examine it to determine if that is ok or not
$entries{$cur_entry}{first_line} = $_;
}
}
}
foreach my $cur_entry ( keys %entries) {
next if $entries{$cur_entry}{todo}; # If in this file, won't have a severity
if (! exists $entries{$cur_entry}{severity}
# If there is no first line, it was two =items in a row, so the
# second one is the one with with text, not this one.
&& exists $entries{$cur_entry}{first_line}
# If the first line refers to another message, no need for severity
&& $entries{$cur_entry}{first_line} !~ /^See/)
{
fail($cur_entry);
diag(
" $pod entry at line $entries{$cur_entry}{line_number}\n"
. " \"$cur_entry\"\n"
. " is missing a severity and/or category"
);
}
}
# List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
# Convert from internal formats to ones that the readers will be familiar
# with, while removing any format modifiers, such as precision, the
# presence of which would just confuse the pod's explanation
my %specialformats = (IVdf => 'd',
UVuf => 'd',
UVof => 'o',
UVxf => 'x',
UVXf => 'X',
NVef => 'f',
NVff => 'f',
NVgf => 'f',
HEKf256=>'s',
HEKf => 's',
SVf256=>'s',
SVf32=> 's',
SVf => 's');
my $format_modifiers = qr/ [#0\ +-]* # optional flags
(?: [1-9][0-9]* | \* )? # optional field width
(?: \. \d* )? # optional precision
(?: h|l )? # optional length modifier
/x;
my $specialformats =
join '|', sort { length $b cmp length $a } keys %specialformats;
my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
# Recursively descend looking for source files.
my @todo = sort <*>;
while (@todo) {
my $todo = shift @todo;
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';
if (-d $todo) {
unshift @todo, sort glob "$todo/*";
} elsif ($todo =~ m/\.[ch]$/) {
check_file($todo);
}
}
# 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 "# Checking $codefn\n";
open my $codefh, "<", $codefn
or die "Can't open $codefn: $!";
my $listed_as;
my $listed_as_line;
my $sub = 'top of file';
while (<$codefh>) {
chomp;
# Getting too much here isn't a problem; we only use this to skip
# errors inside of XS modules, which should get documented in the
# docs for the module.
if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
$sub = $_;
}
next if $sub =~ m/^XS/;
if (m</\* diag_listed_as: (.*) \*/>) {
$listed_as = $1;
$listed_as_line = $.+1;
}
next if /^#/;
next if /^ +/;
my $multiline = 0;
# Loop to accumulate the message text all on one line.
if (m/$source_msg_re(?:_nocontext)?\s*\(/) {
while (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
# code (preprocessor stuff, long comments). That's OK; we don't
# need those anyway.
last if not defined $nextline;
chomp $nextline;
$nextline =~ s/^\s+//;
$_ =~ s/\\$//;
# Note that we only want to do this where *both* are true.
if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
$_ =~ s/"$//;
$nextline =~ s/^"//;
}
$_ .= $nextline;
++$multiline;
}
}
# This should happen *after* unwrapping, or we don't reformat the things
# in later lines.
s/$specialformats_re/"%$specialformats{$1}" . (defined $2 ? '' : '"')/ge;
# Remove any remaining format modifiers, but not in %%
s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
# The %"foo" thing needs to happen *before* this regex.
# diag($_);
# DIE is just return Perl_die
my ($name, $category);
if (/$source_msg_call_re/) {
($name, $category) = ($+{'text'}, $+{'category'});
}
elsif (/$bad_version_re/) {
($name, $category) = ($+{'text'}, undef);
}
else {
next;
}
my $severity = {croak => [qw/P F/],
die => [qw/P F/],
warn => [qw/W D S/],
}->{$+{'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 {
# 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/(?:%s){2,}/%s/g;
$name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
$name =~ s/\\t/\t/g;
$name =~ s/\\n/\n/g;
$name =~ s/\s+$//;
$name =~ s/(\\)\\/$1/g;
}
# Extra explanatory info on an already-listed error, doesn't
# need it's own listing.
next if $name =~ m/^\t/;
# Happens fairly often with PL_no_modify.
next if $name eq '%s';
# Special syntax for magic comment, allows ignoring the fact
# that it isn't listed. Only use in very special circumstances,
# like this script failing to notice that the Perl_croak call is
# inside an #if 0 block.
next if $name eq 'SKIPME';
check_message(standardize($name),$codefn);
}
}
sub check_message {
my($name,$codefn,$partial) = @_;
my $key = $name =~ y/\n/ /r;
my $ret;
if (exists $entries{$key}) {
$ret = 1;
if ( $entries{$key}{seen}++ ) {
# no need to repeat entries we've tested
} elsif ($entries{$name}{todo}) {
TODO: {
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\n".
" (but it wasn't documented in 5.10 either, so marking it TODO)."
);
}
} else {
# 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 ($partial) {
# noop
} else {
my $ok;
if ($name =~ /\n/) {
$ok = 1;
check_message($_,$codefn,1) or $ok = 0, last for split /\n/, $name;
}
if ($ok) {
# noop
} elsif ($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 "$key\n";
} else {
# 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");
}
# seen it, so only fail once for this message
$entries{$name}{seen}++;
}
die if $name =~ /%$/;
return $ret;
}
# Lists all missing things as of the inauguration 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).
# Also FIXME this test, as the first entry in TODO *is* covered by the
# description: Malformed UTF-8 character (%s)
__DATA__
Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
%s (%d) does not match %s (%d),
%s (%d) smaller than %s (%d),
bad top format reference
Can't coerce readonly %s to string
Can't coerce readonly %s to string in %s
Can't fix broken locale name "%s"
Can't get short module name from a handle
Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
Can't spawn "%s": %s
Can't %s script `%s' with ARGV[0] being `%s'
Can't %s "%s": %s
Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
Can't use '%c' after -mname
Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
Can't use when() outside a topicalizer
\%c better written as $%c
Character(s) in '%c' format wrapped in %s
Cloning substitution context is unimplemented
Code missing after '/' in pack
Code missing after '/' in unpack
Corrupted regexp opcode %d > %d
'%c' outside of string in pack
Debug leaking scalars child failed%s with errno %d: %s
Deep recursion on anonymous subroutine
defined(\%hash) is deprecated
Don't know how to handle magic of type \%o
-Dp not implemented on this platform
Error reading "%s": %s
Filehandle opened only for %sput
Filehandle %s opened only for %sput
Filehandle STD%s reopened as %s only for input
YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!
Free to wrong pool %p not %p
get %s %p %p %p
glob failed (can't start child: %s)
glob failed (child exited with status %d%s)
Goto undefined subroutine
Goto undefined subroutine &%s
Hash \%%s missing the \% in argument %d of %s()
Illegal character %sin prototype for %s : %s
Integer overflow in version %d
internal %<num>p might conflict with future printf extensions
invalid control request: '\%o'
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 separator character %c%c%c in PerlIO layer specification %s
Invalid TOKEN object ignored
Invalid type '%c' in pack
Invalid type '%c' in %s
Invalid type '%c' in unpack
Invalid type ',' in %s
'j' not supported on this platform
'J' not supported on this platform
List form of piped open not implemented
%lx
Malformed UTF-8 character (fatal)
Missing (suid) fd script name
More than one argument to open
More than one argument to open(,':%s')
mprotect for %p %u failed with %d
mprotect RW for %p %u failed with %d
No code specified for -%c
No directory specified for -I
No such class field "%s"
Not an XSUB reference
Operator or semicolon missing before %c%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
ptr wrong %p != %p fl=%x nl=%p e=%p for %d
Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
Recursive call to Perl_load_module in PerlIO_find_layer
Reversed %c= operator
Runaway prototype
%s(%.0
%s(%f) failed
%sCompilation failed in regexp
%sCompilation failed in require
set %s %p %p %p
%s free() ignored (RMAGIC, PERL_CORE)
%s has too many errors.
SIG%s handler "%s" not defined.
%s in %s
Size magic not implemented
%s number > %s non-portable
%s object version %s does not match %s %s
%srealloc() %signored
%s returned from lvalue subroutine in scalar context
%s has too many errors.
%s on %s %s
%s on %s %s %s
Starting Full Screen process with flag=%d, mytype=%d
Starting PM process with flag=%d, mytype=%d
SWASHNEW didn't return an HV ref
-T and -B not implemented on filehandles
The flock() function is not implemented on NetWare
The rewinddir() function is not implemented on NetWare
The seekdir() function is not implemented on NetWare
The telldir() function is not implemented on NetWare
Too deeply nested ()-groups in %s
Too many args on %s line of "%s"
U0 mode on a byte string
Unbalanced string table refcount: (%d) for "%s"
Undefined top format called
Unexpected constant lvalue entersub entry via type/targ %d:%d
Unicode non-character 0x%X
Unstable directory path, current directory changed unexpectedly
Unterminated compressed integer in unpack
Usage: CODE(0x%x)(%s)
Usage: %s(%s)
Usage: %s::%s(%s)
Usage: VMS::Filespec::unixrealpath(spec)
Usage: VMS::Filespec::vmsrealpath(spec)
Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
utf8 "\x%X" does not map to Unicode
Value of logical "%s" too long. Truncating to %i bytes
value of node is %d in Offset macro
Variable "%c%s" is not imported
vector argument not supported with alpha versions
Wide character
Wide character in $/
Wide character in print
Within []-length '%c' not allowed in %s
Wrong syntax (suid) fd script name "%s"
'X' outside of string in unpack
|