12 # --make-exceptions-list outputs the list of strings that don't have
13 # perldiag.pod entries to STDERR without TAP formatting, so they can
14 # easily be put in the __DATA__ section of this file. This was done
15 # initially so as to not create new test failures upon the initial
16 # creation of this test file. You probably shouldn't do it again.
17 # Just add the documentation instead.
18 my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
20 chdir '..' or die "Can't chdir ..: $!";
21 BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
25 open my $func_fh, "<", "embed.fnc" or die "Can't open embed.fnc: $!";
27 # Look for functions in embed.fnc that look like they could be diagnostic ones.
31 while (s/\s*\\$//) { # Grab up all continuation lines, these end in \
32 my $next = <$func_fh>;
37 next if /^:/; # Lines beginning with colon are comments.
38 next unless /\|/; # Lines without a vertical bar are something we can't deal
40 my @fields = split /\s*\|\s*/;
41 next unless $fields[2] =~ /warn|err|(\b|_)die|croak/i;
42 push @functions, $fields[2];
44 # The flag p means that this function may have a 'Perl_' prefix
45 # The flag s means that this function may have a 'S_' prefix
46 push @functions, "Perl_$fields[2]", if $fields[0] =~ /p/;
47 push @functions, "S_$fields[2]", if $fields[0] =~ /s/;
52 my $function_re = join '|', @functions;
53 my $source_msg_re = "(?<routine>\\bDIE\\b|$function_re)";
54 my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
55 my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
57 (?:packWARN\d*\((?<category>.*?)\),)? \s*
59 my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
63 # Get the ignores that are compiled into this file
69 my $pod = "pod/perldiag.pod";
71 open my $diagfh, "<", $pod
72 or die "Can't open $pod: $!";
74 my $category_re = qr/ [a-z0-9_]+?/; # Note: requires an initial space
75 my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
76 # be of the form 'S|P|W'
81 if (exists $entries{$cur_entry}) {
83 local $::TODO = "Remove the TODO entry \"$cur_entry\" from DATA as it is already in $pod near line $.";
87 # Make sure to init this here, so an actual entry in perldiag
88 # overwrites one in DATA.
89 $entries{$cur_entry}{todo} = 0;
90 $entries{$cur_entry}{line_number} = $.;
94 next if ! defined $cur_entry;
96 if (! $entries{$cur_entry}{severity}) {
97 if (/^ \( ( $severity_re )
99 # Can have multiple categories separated by commas
100 (?: ( $category_re ) (?: , $category_re)* )? \) /x)
102 $entries{$cur_entry}{severity} = $1;
103 $entries{$cur_entry}{category} = $2;
105 elsif (! $entries{$cur_entry}{first_line} && $_ =~ /\S/) {
107 # Keep track of first line of text if doesn't contain a severity, so
108 # that can later examine it to determine if that is ok or not
109 $entries{$cur_entry}{first_line} = $_;
114 foreach my $cur_entry ( keys %entries) {
115 next if $entries{$cur_entry}{todo}; # If in this file, won't have a severity
116 if (! exists $entries{$cur_entry}{severity}
118 # If there is no first line, it was two =items in a row, so the
119 # second one is the one with with text, not this one.
120 && exists $entries{$cur_entry}{first_line}
122 # If the first line refers to another message, no need for severity
123 && $entries{$cur_entry}{first_line} !~ /^See/)
127 " $pod entry at line $entries{$cur_entry}{line_number}\n"
128 . " \"$cur_entry\"\n"
129 . " is missing a severity and/or category"
134 # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
135 # Convert from internal formats to ones that the readers will be familiar
136 # with, while removing any format modifiers, such as precision, the
137 # presence of which would just confuse the pod's explanation
138 my %specialformats = (IVdf => 'd',
151 my $format_modifiers = qr/ [#0\ +-]* # optional flags
152 (?: [1-9][0-9]* | \* )? # optional field width
153 (?: \. \d* )? # optional precision
154 (?: h|l )? # optional length modifier
158 join '|', sort { length $b cmp length $a } keys %specialformats;
159 my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
161 # Recursively descend looking for source files.
164 my $todo = shift @todo;
165 next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
166 # opmini.c is just a copy of op.c, so there's no need to check again.
167 next if $todo eq 'opmini.c';
169 unshift @todo, sort glob "$todo/*";
170 } elsif ($todo =~ m/\.[ch]$/) {
175 # Standardize messages with variants into the form that appears
176 # in perldiag.pod -- useful for things without a diag_listed_as annotation
180 if ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
183 elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
186 elsif ($name =~ m/^panic: /) {
187 $name = "panic: \%s";
196 print "# Checking $codefn\n";
198 open my $codefh, "<", $codefn
199 or die "Can't open $codefn: $!";
203 my $sub = 'top of file';
206 # Getting too much here isn't a problem; we only use this to skip
207 # errors inside of XS modules, which should get documented in the
208 # docs for the module.
209 if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
212 next if $sub =~ m/^XS/;
213 if (m</\* diag_listed_as: (.*) \*/>) {
215 $listed_as_line = $.+1;
220 # Loop to accumulate the message text all on one line.
221 if (m/$source_msg_re(?:_nocontext)?\s*\(/) {
222 while (not m/\);$/) {
223 my $nextline = <$codefh>;
224 # Means we fell off the end of the file. Not terribly surprising;
225 # this code tries to merge a lot of things that aren't regular C
226 # code (preprocessor stuff, long comments). That's OK; we don't
228 last if not defined $nextline;
230 $nextline =~ s/^\s+//;
232 # Note that we only want to do this where *both* are true.
233 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
241 # This should happen *after* unwrapping, or we don't reformat the things
244 s/$specialformats_re/"%$specialformats{$1}" . (defined $2 ? '' : '"')/ge;
246 # Remove any remaining format modifiers, but not in %%
247 s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
249 # The %"foo" thing needs to happen *before* this regex.
251 # DIE is just return Perl_die
252 my ($name, $category);
253 if (/$source_msg_call_re/) {
254 ($name, $category) = ($+{'text'}, $+{'category'});
256 elsif (/$bad_version_re/) {
257 ($name, $category) = ($+{'text'}, undef);
263 my $severity = {croak => [qw/P F/],
266 }->{$+{'routine'}||'die'};
268 if (defined $category) {
269 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
271 if ($listed_as and $listed_as_line == $. - $multiline) {
274 # The form listed in perldiag ignores most sorts of fancy printf
275 # formatting, or makes it more perlish.
277 $name =~ s/%l[ud]/%d/g;
278 $name =~ s/%\.(\d+|\*)s/\%s/g;
279 $name =~ s/(?:%s){2,}/%s/g;
280 $name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
284 $name =~ s/(\\)\\/$1/g;
287 # Extra explanatory info on an already-listed error, doesn't
288 # need it's own listing.
289 next if $name =~ m/^\t/;
291 # Happens fairly often with PL_no_modify.
292 next if $name eq '%s';
294 # Special syntax for magic comment, allows ignoring the fact
295 # that it isn't listed. Only use in very special circumstances,
296 # like this script failing to notice that the Perl_croak call is
297 # inside an #if 0 block.
298 next if $name eq 'SKIPME';
300 check_message(standardize($name),$codefn);
305 my($name,$codefn,$partial) = @_;
306 my $key = $name =~ y/\n/ /r;
309 if (exists $entries{$key}) {
311 if ( $entries{$key}{seen}++ ) {
312 # no need to repeat entries we've tested
313 } elsif ($entries{$name}{todo}) {
316 local $::TODO = 'in DATA';
317 # There is no listing, but it is in the list of exceptions. TODO FAIL.
320 " Message '$name'\n from $codefn line $. is not listed in $pod\n".
321 " (but it wasn't documented in 5.10 either, so marking it TODO)."
325 # We found an actual valid entry in perldiag.pod for this error.
328 # Later, should start checking that the severity is correct, too.
335 check_message($_,$codefn,1) or $ok = 0, last for split /\n/, $name;
339 } elsif ($make_exceptions_list) {
340 # We're making an updated version of the exception list, to
341 # stick in the __DATA__ section. I honestly can't think of
342 # a situation where this is the right thing to do, but I'm
343 # leaving it here, just in case one of my descendents thinks
345 print STDERR "$key\n";
347 # No listing found, and no excuse either.
348 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
350 diag(" Message '$name'\n from $codefn line $. is not listed in $pod");
352 # seen it, so only fail once for this message
353 $entries{$name}{seen}++;
356 die if $name =~ /%$/;
360 # Lists all missing things as of the inauguration of this script, so we
361 # don't have to go from "meh" to perfect all at once.
363 # PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
364 # pod/perldiag.pod for your new (warning|error).
366 # Also FIXME this test, as the first entry in TODO *is* covered by the
367 # description: Malformed UTF-8 character (%s)
369 Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
371 %s (%d) does not match %s (%d),
372 %s (%d) smaller than %s (%d),
373 '%c' allowed only after types %s in %s
374 bad top format reference
375 Cannot apply "%s" in non-PerlIO perl
376 Can't %s big-endian %ss on this
377 Can't call mro_isa_changed_in() on anonymous symbol table
378 Can't call mro_method_changed_in() on anonymous symbol table
379 Can't coerce readonly %s to string
380 Can't coerce readonly %s to string in %s
381 Can't find string terminator %c%s%c anywhere before EOF
382 Can't fix broken locale name "%s"
383 Can't get short module name from a handle
384 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
388 Can't %s script `%s' with ARGV[0] being `%s'
390 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
391 Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
392 \%c better written as $%c
393 Character(s) in '%c' format wrapped in %s
394 chown not implemented!
396 Code missing after '/' in pack
397 Code missing after '/' in unpack
398 Corrupted regexp opcode %d > %d
399 '%c' outside of string in pack
400 Debug leaking scalars child failed%s with errno %d: %s
401 '/' does not take a repeat count in %s
402 Don't know how to get file name
403 Don't know how to handle magic of type \%o
404 -Dp not implemented on this platform
405 Error reading "%s": %s
406 execl not implemented!
407 EVAL without pos change exceeded limit in regex
408 Filehandle opened only for %sput
409 Filehandle %s opened only for %sput
410 Filehandle STD%s reopened as %s only for input
411 filter_del can only delete in reverse order (currently)
412 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!
413 fork() not implemented!
415 Free to wrong pool %p not %p
417 gethostent not implemented!
418 getpwnam returned invalid UIC %o for user "%s"
419 glob failed (can't start child: %s)
420 glob failed (child exited with status %d%s)
421 Goto undefined subroutine
422 Goto undefined subroutine &%s
424 ()-group starts with a count in %s
425 Illegal binary digit '%c' ignored
426 Illegal character %sin prototype for %s : %s
427 Illegal hexadecimal digit '%c' ignored
428 Illegal octal digit '%c' ignored
429 Infinite recursion in regex
430 Integer overflow in srand
431 internal %<num>p might conflict with future printf extensions
432 Invalid argument to sv_cat_decode
433 invalid control request: '\%o'
434 Invalid range "%c-%c" in transliteration operator
435 Invalid separator character %c%c%c in PerlIO layer specification %s
436 Invalid TOKEN object ignored
437 Invalid type '%c' in pack
438 Invalid type '%c' in %s
439 Invalid type '%c' in unpack
440 Invalid type ',' in %s
441 ioctlsocket not implemented!
442 'j' not supported on this platform
443 'J' not supported on this platform
444 killpg not implemented!
445 length() used on %s (did you mean "scalar(%s)"?)
446 length() used on %hash (did you mean "scalar(keys %hash)"?)
447 length() used on @array (did you mean "scalar(@array)"?)
448 List form of pipe open not implemented
449 Malformed integer in [] in %s
450 Malformed UTF-8 character (fatal)
451 Missing (suid) fd script name
452 More than one argument to open
453 More than one argument to open(,':%s')
454 mprotect for %p %u failed with %d
455 mprotect RW for %p %u failed with %d
456 No %s allowed while running setgid
457 No %s allowed with (suid) fdscript
458 No such class field "%s"
459 Not an XSUB reference
460 Operator or semicolon missing before %c%s
461 Pattern subroutine nesting without pos change exceeded limit in regex
462 Perl %s required--this is only %s, stopped
463 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
464 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
465 Repeated format line will never terminate (~~ and @#)
466 Reversed %c= operator
468 %sCompilation failed in regexp
469 %sCompilation failed in require
471 %s free() ignored (RMAGIC, PERL_CORE)
472 %s has too many errors.
473 SIG%s handler "%s" not defined.
475 Size magic not implemented
476 %s number > %s non-portable
477 %s object version %s does not match %s %s
478 %srealloc() %signored
479 %s has too many errors.
483 socketpair not implemented!
484 Starting Full Screen process with flag=%d, mytype=%d
485 Starting PM process with flag=%d, mytype=%d
486 sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%f U_V is 0x%x, IV_MAX is 0x%x
487 SWASHNEW didn't return an HV ref
488 switching effective gid is not implemented
489 switching effective uid is not implemented
490 System V IPC is not implemented on this machine
491 -T and -B not implemented on filehandles
492 Terminating on signal SIG%s(%d)
493 The crypt() function is unimplemented due to excessive paranoia.
494 The crypt() function is not implemented on NetWare
495 The flock() function is not implemented on NetWare
496 The rewinddir() function is not implemented on NetWare
497 The seekdir() function is not implemented on NetWare
498 The telldir() function is not implemented on NetWare
499 Too deeply nested ()-groups in %s
500 Too many args on %s line of "%s"
501 U0 mode on a byte string
502 unable to find VMSPIPE.COM for i/o piping
503 Unknown Unicode option value %d
504 Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
505 Unstable directory path, current directory changed unexpectedly
506 Unterminated compressed integer in unpack
507 Usage: CODE(0x%x)(%s)
510 Usage: File::Copy::rmscopy(from,to[,date_flag])
511 Usage: VMS::Filespec::candelete(spec)
512 Usage: VMS::Filespec::fileify(spec)
513 Usage: VMS::Filespec::pathify(spec)
514 Usage: VMS::Filespec::rmsexpand(spec[,defspec])
515 Usage: VMS::Filespec::unixify(spec)
516 Usage: VMS::Filespec::unixpath(spec)
517 Usage: VMS::Filespec::unixrealpath(spec)
518 Usage: VMS::Filespec::vmsify(spec)
519 Usage: VMS::Filespec::vmspath(spec)
520 Usage: VMS::Filespec::vmsrealpath(spec)
521 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
522 utf8 "\x%X" does not map to Unicode
523 Value of logical "%s" too long. Truncating to %i bytes
524 value of node is %d in Offset macro
525 Variable "%c%s" is not imported
526 waitpid: process %x is not a child of process %x
529 Wide character in print
530 Within []-length '*' not allowed in %s
531 Within []-length '%c' not allowed in %s
532 Wrong syntax (suid) fd script name "%s"
533 'X' outside of string in %s
534 'X' outside of string in unpack