11 # --make-exceptions-list outputs the list of strings that don't have
12 # perldiag.pod entries to STDERR without TAP formatting, so they can
13 # easily be put in the __DATA__ section of this file. This was done
14 # initially so as to not create new test failures upon the initial
15 # creation of this test file. You probably shouldn't do it again.
16 # Just add the documentation instead.
17 my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
19 chdir '..' or die "Can't chdir ..: $!";
20 BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
24 open my $func_fh, "<", "embed.fnc" or die "Can't open embed.fnc: $!";
26 # Look for functions in embed.fnc that look like they could be diagnostic ones.
30 while (s/\s*\\$//) { # Grab up all continuation lines, these end in \
31 my $next = <$func_fh>;
36 next if /^:/; # Lines beginning with colon are comments.
37 next unless /\|/; # Lines without a vertical bar are something we can't deal
39 my @fields = split /\s*\|\s*/;
40 next unless $fields[2] =~ /warn|err|(\b|_)die|croak/i;
41 push @functions, $fields[2];
43 # The flag p means that this function may have a 'Perl_' prefix
44 # The flag s means that this function may have a 'S_' prefix
45 push @functions, "Perl_$fields[2]", if $fields[0] =~ /p/;
46 push @functions, "S_$fields[2]", if $fields[0] =~ /s/;
51 my $function_re = join '|', @functions;
52 my $source_msg_re = qr/(?<routine>\bDIE\b|$function_re)/;
53 my $text_re = qr/"(?<text>(?:\\"|[^"])*?)"/;
54 my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
56 (?:packWARN\d*\((?<category>.*?)\),)? \s*
58 my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
62 # Get the ignores that are compiled into this file
68 my $pod = "pod/perldiag.pod";
70 open my $diagfh, "<", $pod
71 or die "Can't open $pod: $!";
73 my $category_re = qr/ [a-z0-9_]+?/; # Note: requires an initial space
74 my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
75 # be of the form 'S|P|W'
80 if (exists $entries{$cur_entry}) {
82 local $::TODO = "Remove the TODO entry \"$cur_entry\" from DATA as it is already in $pod near line $.";
86 # Make sure to init this here, so an actual entry in perldiag
87 # overwrites one in DATA.
88 $entries{$cur_entry}{todo} = 0;
89 $entries{$cur_entry}{line_number} = $.;
93 next if ! defined $cur_entry;
95 if (! $entries{$cur_entry}{severity}) {
96 if (/^ \( ( $severity_re )
98 # Can have multiple categories separated by commas
99 (?: ( $category_re ) (?: , $category_re)* )? \) /x)
101 $entries{$cur_entry}{severity} = $1;
102 $entries{$cur_entry}{category} = $2;
104 elsif (! $entries{$cur_entry}{first_line} && $_ =~ /\S/) {
106 # Keep track of first line of text if doesn't contain a severity, so
107 # that can later examine it to determine if that is ok or not
108 $entries{$cur_entry}{first_line} = $_;
113 foreach my $cur_entry ( keys %entries) {
114 next if $entries{$cur_entry}{todo}; # If in this file, won't have a severity
115 if (! exists $entries{$cur_entry}{severity}
117 # If there is no first line, it was two =items in a row, so the
118 # second one is the one with with text, not this one.
119 && exists $entries{$cur_entry}{first_line}
121 # If the first line refers to another message, no need for severity
122 && $entries{$cur_entry}{first_line} !~ /^See/)
126 " $pod entry at line $entries{$cur_entry}{line_number}\n"
127 . " \"$cur_entry\"\n"
128 . " is missing a severity and/or category"
133 # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
134 # Convert from internal formats to ones that the readers will be familiar
135 # with, while removing any format modifiers, such as precision, the
136 # presence of which would just confuse the pod's explanation
137 my %specialformats = (IVdf => 'd',
146 my $format_modifiers = qr/ [#0\ +-]* # optional flags
147 (?: [1-9][0-9]* | \* )? # optional field width
148 (?: \. \d* )? # optional precision
149 (?: h|l )? # optional length modifier
152 my $specialformats = join '|', sort keys %specialformats;
153 my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
155 # Recursively descend looking for source files.
158 my $todo = shift @todo;
159 next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
160 # opmini.c is just a copy of op.c, so there's no need to check again.
161 next if $todo eq 'opmini.c';
163 unshift @todo, sort glob "$todo/*";
164 } elsif ($todo =~ m/\.[ch]$/) {
169 # Standardize messages with variants into the form that appears
170 # in perldiag.pod -- useful for things without a diag_listed_as annotation
174 if ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
177 elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
180 elsif ($name =~ m/^panic: /) {
181 $name = "panic: \%s";
190 print "# Checking $codefn\n";
192 open my $codefh, "<", $codefn
193 or die "Can't open $codefn: $!";
197 my $sub = 'top of file';
200 # Getting too much here isn't a problem; we only use this to skip
201 # errors inside of XS modules, which should get documented in the
202 # docs for the module.
203 if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
206 next if $sub =~ m/^XS/;
207 if (m</\* diag_listed_as: (.*) \*/>) {
209 $listed_as_line = $.+1;
215 # Loop to accumulate the message text all on one line.
216 if (m/$source_msg_re/) {
217 while (not m/\);$/) {
218 my $nextline = <$codefh>;
219 # Means we fell off the end of the file. Not terribly surprising;
220 # this code tries to merge a lot of things that aren't regular C
221 # code (preprocessor stuff, long comments). That's OK; we don't
223 last if not defined $nextline;
225 $nextline =~ s/^\s+//;
227 # Note that we only want to do this where *both* are true.
228 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
236 # This should happen *after* unwrapping, or we don't reformat the things
239 s/$specialformats_re/"%$specialformats{$1}" . (defined $2 ? '' : '"')/ge;
241 # Remove any remaining format modifiers, but not in %%
242 s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
244 # The %"foo" thing needs to happen *before* this regex.
246 # DIE is just return Perl_die
247 my ($name, $category);
248 if (/$source_msg_call_re/) {
249 ($name, $category) = ($+{'text'}, $+{'category'});
251 elsif (/$bad_version_re/) {
252 ($name, $category) = ($+{'text'}, undef);
258 my $severity = {croak => [qw/P F/],
261 }->{$+{'routine'}||'die'};
263 if (defined $category) {
264 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
266 if ($listed_as and $listed_as_line == $. - $multiline) {
269 # The form listed in perldiag ignores most sorts of fancy printf
270 # formatting, or makes it more perlish.
272 $name =~ s/%l[ud]/%d/g;
273 $name =~ s/%\.(\d+|\*)s/\%s/g;
278 $name =~ s/(\\)\\/$1/g;
281 # Extra explanatory info on an already-listed error, doesn't
282 # need it's own listing.
283 next if $name =~ m/^\t/;
285 # Happens fairly often with PL_no_modify.
286 next if $name eq '%s';
288 # Special syntax for magic comment, allows ignoring the fact
289 # that it isn't listed. Only use in very special circumstances,
290 # like this script failing to notice that the Perl_croak call is
291 # inside an #if 0 block.
292 next if $name eq 'SKIPME';
294 $name = standardize($name);
296 if (exists $entries{$name}) {
297 if ( $entries{$name}{seen}++ ) {
298 # no need to repeat entries we've tested
299 } elsif ($entries{$name}{todo}) {
302 local $::TODO = 'in DATA';
303 # There is no listing, but it is in the list of exceptions. TODO FAIL.
306 " Message '$name'\n from $codefn line $. is not listed in $pod\n".
307 " (but it wasn't documented in 5.10 either, so marking it TODO)."
311 # We found an actual valid entry in perldiag.pod for this error.
314 # Later, should start checking that the severity is correct, too.
316 if ($make_exceptions_list) {
317 # We're making an updated version of the exception list, to
318 # stick in the __DATA__ section. I honestly can't think of
319 # a situation where this is the right thing to do, but I'm
320 # leaving it here, just in case one of my descendents thinks
322 print STDERR "$name\n";
324 # No listing found, and no excuse either.
325 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
327 diag(" Message '$name'\n from $codefn line $. is not listed in $pod");
329 # seen it, so only fail once for this message
330 $entries{$name}{seen}++;
333 die if $name =~ /%$/;
337 # Lists all missing things as of the inauguration of this script, so we
338 # don't have to go from "meh" to perfect all at once.
340 # PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
341 # pod/perldiag.pod for your new (warning|error).
343 # Also FIXME this test, as the first entry in TODO *is* covered by the
344 # description: Malformed UTF-8 character (%s)
346 Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
348 %s (%d) does not match %s (%d),
349 %s (%d) smaller than %s (%d),
350 Argument "%s" isn't numeric
351 Argument "%s" isn't numeric in %s
352 Attempt to clear deleted array
353 Attempt to free non-existent shared string '%s'%s
354 Attempt to free temp prematurely: SV 0x%x
355 Attempt to free unreferenced scalar: SV 0x%x
356 Attempt to reload %s aborted. Compilation failed in require
357 av_reify called on tied array
360 bad top format reference
364 Can't call method "%s" %s
365 Can't coerce readonly %s to string
366 Can't coerce readonly %s to string in %s
367 Can't fix broken locale name "%s"
368 Can't get short module name from a handle
369 Can't goto subroutine from an eval-block
370 Can't goto subroutine from an eval-string
371 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
372 Can't modify non-existent substring
374 Can't open perl script "%s": %s
376 Can't reset \%ENV on this system
377 Can't return array to lvalue scalar context
378 Can't return a %s from lvalue subroutine
379 Can't return hash to lvalue scalar context
381 Can't %s script `%s' with ARGV[0] being `%s'
384 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
386 Can't use '%c' after -mname
387 Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
388 Can't use when() outside a topicalizer
389 \%c better written as $%c
390 Character(s) in '%c' format wrapped in %s
391 $%c is no longer supported
392 Cloning substitution context is unimplemented
393 Code missing after '/' in pack
394 Code missing after '/' in unpack
395 Corrupted regexp opcode %d > %d
396 '%c' outside of string in pack
397 Debug leaking scalars child failed%s%s with errno %d: %s
398 Deep recursion on anonymous subroutine
399 defined(\%hash) is deprecated
400 Don't know how to handle magic of type \%o
401 -Dp not implemented on this platform
402 entering effective gid failed
403 entering effective uid failed
404 Error reading "%s": %s
406 Filehandle opened only for %sput
407 Filehandle %s opened only for %sput
408 Filehandle STD%s reopened as %s only for input
409 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!
410 Format STDOUT redefined
411 Free to wrong pool %p not %p
413 glob failed (can't start child: %s)
414 glob failed (child exited with status %d%s)
415 Goto undefined subroutine
416 Goto undefined subroutine &%s
417 Hash \%%s missing the \% in argument %d of %s()
418 Illegal character %sin prototype for %s : %s
419 Integer overflow in binary number
420 Integer overflow in decimal number
421 Integer overflow in hexadecimal number
422 Integer overflow in octal number
423 Integer overflow in version %d
424 internal \%<num>p might conflict with future printf extensions
425 invalid control request: '\%o'
426 Invalid module name %s with -%c option: contains single ':'
427 invalid option -D%c, use -D'' to see choices
428 Invalid range "%c-%c" in transliteration operator
429 Invalid separator character %c%c%c in PerlIO layer specification %s
430 Invalid TOKEN object ignored
431 Invalid type '%c' in pack
432 Invalid type '%c' in %s
433 Invalid type '%c' in unpack
434 Invalid type ',' in %s
435 'j' not supported on this platform
436 'J' not supported on this platform
437 leaving effective gid failed
438 leaving effective uid failed
439 List form of piped open not implemented
440 Lost precision when decrementing %f by 1
441 Lost precision when incrementing %f by 1
443 Malformed UTF-8 character (fatal)
444 '\%' may not be used in pack
445 Missing (suid) fd script name
446 More than one argument to open
447 More than one argument to open(,':%s')
448 mprotect for %p %u failed with %d
449 mprotect RW for %p %u failed with %d
450 No code specified for -%c
451 No directory specified for -I
452 No such class field "%s"
453 Not an XSUB reference
455 Operator or semicolon missing before %c%s
456 Perl %s required (did you mean %s?)--this is only %s, stopped
457 Perl %s required--this is only %s, stopped
458 Perls since %s too modern--this is %s, stopped
459 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
460 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
461 Recursive call to Perl_load_module in PerlIO_find_layer
462 Reversed %c= operator
468 Scalar value %s better written as $%s
469 %sCompilation failed in regexp
470 %sCompilation failed in require
472 %s free() ignored (RMAGIC, PERL_CORE)
473 %s has too many errors.
474 SIG%s handler "%s" not defined.
475 %s: illegal mapping '%s'
477 Size magic not implemented
478 %s limit (%d) exceeded
479 %s method "%s" overloading "%s" in package "%s"
480 %s number > %s non-portable
481 %s object version %s does not match %s%s%s%s %s
482 %srealloc() %signored
483 %s returned from lvalue subroutine in scalar context
484 %s%s has too many errors.
487 Starting Full Screen process with flag=%d, mytype=%d
488 Starting PM process with flag=%d, mytype=%d
489 strxfrm() gets absurd
490 SWASHNEW didn't return an HV ref
491 -T and -B not implemented on filehandles
492 The flock() function is not implemented on NetWare
493 The rewinddir() function is not implemented on NetWare
494 The seekdir() function is not implemented on NetWare
495 The stat preceding lstat() wasn't an lstat
496 The telldir() function is not implemented on NetWare
497 Too deeply nested ()-groups in %s
498 Too late to run CHECK block
499 Too late to run INIT block
500 Too many args on %s line of "%s"
501 U0 mode on a byte string
502 Unbalanced string table refcount: (%d) for "%s"
503 Undefined top format called
504 Unexpected constant lvalue entersub entry via type/targ %d:%d
505 Unicode non-character 0x%X
506 Unknown PerlIO layer "scalar"
507 Unstable directory path, current directory changed unexpectedly
508 Unsupported script encoding UTF-16BE
509 Unsupported script encoding UTF-16LE
510 Unsupported script encoding UTF-32BE
511 Unsupported script encoding UTF-32LE
512 Unterminated compressed integer in unpack
513 Usage: CODE(0x%x)(%s)
516 Usage: VMS::Filespec::unixrealpath(spec)
517 Usage: VMS::Filespec::vmsrealpath(spec)
518 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
519 utf8 "\x%X" does not map to Unicode
520 Value of logical "%s" too long. Truncating to %i bytes
521 value of node is %d in Offset macro
522 Value of %s%s can be "0"; test with defined()
523 Variable "%c%s" is not imported
524 vector argument not supported with alpha versions
527 Wide character in print
528 Within []-length '%c' not allowed in %s
529 Wrong syntax (suid) fd script name "%s"
530 'X' outside of string in unpack