4 @INC = '..' if -f '../TestInit.pm';
6 use TestInit qw(T); # T is chdir to the top level
14 # --make-exceptions-list outputs the list of strings that don't have
15 # perldiag.pod entries to STDERR without TAP formatting, so they can
16 # easily be put in the __DATA__ section of this file. This was done
17 # initially so as to not create new test failures upon the initial
18 # creation of this test file. You probably shouldn't do it again.
19 # Just add the documentation instead.
20 my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
22 require 'regen/embed_lib.pl';
24 # Look for functions that look like they could be diagnostic ones.
26 foreach (@{(setup_embed())[0]}) {
28 next unless $_->[2] =~ /warn|err|(\b|_)die|croak/i;
29 # The flag p means that this function may have a 'Perl_' prefix
30 # The flag s means that this function may have a 'S_' prefix
31 push @functions, $_->[2];
32 push @functions, 'Perl_' . $_->[2] if $_->[0] =~ /p/;
33 push @functions, 'S_' . $_->[2] if $_->[0] =~ /s/;
36 my $regcomp_re = "(?<routine>(?:ckWARN(?:\\d+)?reg\\w*|vWARN\\d+))";
37 my $function_re = join '|', @functions;
38 my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?\b';
40 "(?<routine>\\bDIE\\b|$function_re|$regcomp_fail_re)";
41 my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
42 my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
44 (?:packWARN\d*\((?<category>.*?)\),)? \s*
46 my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
47 $regcomp_fail_re = qr/$regcomp_fail_re\([^"]*$text_re/;
48 my $regcomp_call_re = qr/$regcomp_re.*?$text_re/;
52 # Get the ignores that are compiled into this file
53 my $reading_categorical_exceptions;
56 $entries{$_}{todo} = 1;
57 $reading_categorical_exceptions and $entries{$_}{cattodo}=1;
58 /__CATEGORIES__/ and ++$reading_categorical_exceptions;
61 my $pod = "pod/perldiag.pod";
63 open my $diagfh, "<", $pod
64 or die "Can't open $pod: $!";
66 my $category_re = qr/ [a-z0-9_:]+?/; # Note: requires an initial space
67 my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
68 # be of the form 'S|P|W'
74 # Allow multi-line headers
83 $cur_entry =~ s/\n/ /gs; # Fix multi-line headers if they have \n's
84 $cur_entry =~ s/\s+\z//;
86 if (exists $entries{$cur_entry} && $entries{$cur_entry}{todo}
87 && !$entries{$cur_entry}{cattodo}) {
89 local $::TODO = "Remove the TODO entry \"$cur_entry\" from DATA as it is already in $pod near line $.";
93 # Make sure to init this here, so an actual entry in perldiag
94 # overwrites one in DATA.
95 $entries{$cur_entry}{todo} = 0;
96 $entries{$cur_entry}{line_number} = $.;
99 next if ! defined $cur_entry;
101 if (! $entries{$cur_entry}{severity}) {
102 if (/^ \( ( $severity_re )
104 # Can have multiple categories separated by commas
105 ( $category_re (?: , $category_re)* )? \) /x)
107 $entries{$cur_entry}{severity} = $1;
108 $entries{$cur_entry}{category} =
109 $2 && join ", ", sort split " ", $2 =~ y/,//dr;
111 # Record it also for other messages sharing the same description
112 @$_{qw<severity category>} =
113 @{$entries{$cur_entry}}{qw<severity category>}
116 elsif (! $entries{$cur_entry}{first_line} && $_ =~ /\S/) {
118 # Keep track of first line of text if doesn't contain a severity, so
119 # that can later examine it to determine if that is ok or not
120 $entries{$cur_entry}{first_line} = $_;
126 push @same_descr, $entries{$cur_entry};
131 foreach my $cur_entry ( keys %entries) {
132 next if $entries{$cur_entry}{todo}; # If in this file, won't have a severity
133 if (! exists $entries{$cur_entry}{severity}
135 # If there is no first line, it was two =items in a row, so the
136 # second one is the one with with text, not this one.
137 && exists $entries{$cur_entry}{first_line}
139 # If the first line refers to another message, no need for severity
140 && $entries{$cur_entry}{first_line} !~ /^See/)
144 " $pod entry at line $entries{$cur_entry}{line_number}\n"
145 . " \"$cur_entry\"\n"
146 . " is missing a severity and/or category"
151 # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
152 # Convert from internal formats to ones that the readers will be familiar
153 # with, while removing any format modifiers, such as precision, the
154 # presence of which would just confuse the pod's explanation
155 my %specialformats = (IVdf => 'd',
169 my $format_modifiers = qr/ [#0\ +-]* # optional flags
170 (?: [1-9][0-9]* | \* )? # optional field width
171 (?: \. \d* )? # optional precision
172 (?: h|l )? # optional length modifier
176 join '|', sort { length $b cmp length $a } keys %specialformats;
177 my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
179 open my $fh, '<', 'MANIFEST' or die "Can't open MANIFEST: $!";
180 while (my $file = <$fh>) {
183 next unless $file =~ /\.(?:c|cpp|h|xs|y)\z/ or $file =~ /^perly\./;
184 # OS/2 extensions have never been migrated to ext/, hence the special case:
185 next if $file =~ m!\A(?:ext|dist|cpan|lib|t|os2/OS2)/!
186 && $file !~ m!\Aext/DynaLoader/!;
191 # Standardize messages with variants into the form that appears
192 # in perldiag.pod -- useful for things without a diag_listed_as annotation
196 if ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
199 elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
202 elsif ($name =~ m/^panic: /) {
203 $name = "panic: \%s";
212 print "# Checking $codefn\n";
214 open my $codefh, "<", $codefn
215 or die "Can't open $codefn: $!";
219 my $sub = 'top of file';
222 # Getting too much here isn't a problem; we only use this to skip
223 # errors inside of XS modules, which should get documented in the
224 # docs for the module.
225 if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
228 next if $sub =~ m/^XS/;
229 if (m</\*\s*diag_listed_as: (.*?)\s*\*/>) {
231 $listed_as_line = $.+1;
236 # Loop to accumulate the message text all on one line.
237 if (m/(?:$source_msg_re(?:_nocontext)?|$regcomp_re)\s*\(/) {
238 while (not m/\);$/) {
239 my $nextline = <$codefh>;
240 # Means we fell off the end of the file. Not terribly surprising;
241 # this code tries to merge a lot of things that aren't regular C
242 # code (preprocessor stuff, long comments). That's OK; we don't
244 last if not defined $nextline;
246 $nextline =~ s/^\s+//;
248 # Note that we only want to do this where *both* are true.
249 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
257 # This should happen *after* unwrapping, or we don't reformat the things
260 s/$specialformats_re/"%$specialformats{$1}" . (defined $2 ? '' : '"')/ge;
262 # Remove any remaining format modifiers, but not in %%
263 s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
265 # The %"foo" thing needs to happen *before* this regex.
267 # DIE is just return Perl_die
268 my ($name, $category, $routine);
269 if (/$source_msg_call_re/) {
270 ($name, $category, $routine) = ($+{'text'}, $+{'category'}, $+{'routine'});
271 # Sometimes the regexp will pick up too much for the category
272 # e.g., WARN_UNINITIALIZED), PL_warn_uninit_sv ... up to the next )
273 $category && $category =~ s/\).*//s;
275 elsif (/$bad_version_re/) {
276 ($name, $category) = ($+{'text'}, undef);
278 elsif (/$regcomp_fail_re/) {
279 # FAIL("foo") -> "foo in regex m/%s/"
280 # vFAIL("foo") -> "foo in regex; marked by <-- HERE in m/%s/"
281 ($name, $category) = ($+{'text'}, undef);
283 " in regex" . ("; marked by <-- HERE in" x /vFAIL/) . " m/%s/";
285 elsif (/$regcomp_call_re/) {
286 # vWARN/ckWARNreg("foo") -> "foo in regex; marked by <-- HERE in m/%s/
287 ($name, $category, $routine) = ($+{'text'}, undef, $+{'routine'});
288 $name .= " in regex; marked by <-- HERE in m/%s/";
289 $category = 'WARN_REGEXP';
290 if ($routine =~ /dep/) {
291 $category .= ',WARN_DEPRECATED';
298 # Try to guess what the severity should be. In the case of
299 # Perl_ck_warner and other _ck_ functions, we can tell whether it is
300 # a severe/default warning or no by the _d suffix. In the case of
301 # other warn functions we cannot tell, because Perl_warner may be pre-
302 # ceded by if(ckWARN) or if(ckWARN_d).
303 my $severity = !$routine ? '[PFX]'
304 : $routine =~ /warn.*_d\z/ ? '[DS]'
305 : $routine =~ /ck_warn/ ? 'W'
306 : $routine =~ /warner/ ? '[WDS]'
307 : $routine =~ /warn/ ? 'S'
308 : $routine =~ /ckWARN.*dep/ ? 'D'
309 : $routine =~ /ckWARN\d*reg/ ? 'W'
310 : $routine =~ /vWARN\d/ ? '[WDS]'
313 if (defined $category) {
314 $category =~ s/__/::/g;
317 sort map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
319 if ($listed_as and $listed_as_line == $. - $multiline) {
322 # The form listed in perldiag ignores most sorts of fancy printf
323 # formatting, or makes it more perlish.
325 $name =~ s/%l[ud]/%d/g;
326 $name =~ s/%\.(\d+|\*)s/\%s/g;
327 $name =~ s/(?:%s){2,}/%s/g;
328 $name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
332 $name =~ s/(\\)\\/$1/g;
335 # Extra explanatory info on an already-listed error, doesn't
336 # need it's own listing.
337 next if $name =~ m/^\t/;
339 # Happens fairly often with PL_no_modify.
340 next if $name eq '%s';
342 # Special syntax for magic comment, allows ignoring the fact
343 # that it isn't listed. Only use in very special circumstances,
344 # like this script failing to notice that the Perl_croak call is
345 # inside an #if 0 block.
346 next if $name eq 'SKIPME';
348 next if $name=~/\[TESTING\]/; # ignore these as they are works in progress
350 check_message(standardize($name),$codefn,$severity,$categories);
355 my($name,$codefn,$severity,$categories,$partial) = @_;
356 my $key = $name =~ y/\n/ /r;
359 # Try to reduce printf() formats to simplest forms
360 # Really this should be matching %s, etc like diagnostics.pm does
363 $key =~ s/%[#0\-+]/%/g;
366 $key =~ s/\%(\d+|\*)/%/g;
369 $key =~ s/\%\.(\d+|\*)/%/g;
371 if (exists $entries{$key} and
372 # todo + cattodo means it is not found and it is not in the
373 # regular todo list, either
374 !$entries{$key}{todo} || !$entries{$key}{cattodo}) {
376 if ( $entries{$key}{seen}++ ) {
377 # no need to repeat entries we've tested
378 } elsif ($entries{$key}{todo}) {
381 local $::TODO = 'in DATA';
382 # There is no listing, but it is in the list of exceptions. TODO FAIL.
385 " Message '$name'\n from $codefn line $. is not listed in $pod\n".
386 " (but it wasn't documented in 5.10 either, so marking it TODO)."
390 # We found an actual valid entry in perldiag.pod for this error.
394 if $entries{$key}{cattodo};
396 # Now check the category and severity
398 # Cache our severity qr thingies
401 my $qr = $qrs{$severity} ||= qr/$severity/;
403 like($entries{$key}{severity}, $qr,
405 ? "severity is one of $severity for $key"
406 : "severity is $severity for $key");
408 is($entries{$key}{category}, $categories,
409 ($categories ? "categories are [$categories]" : "no category")
418 check_message($_,$codefn,$severity,$categories,1) or $ok = 0, last
419 for split /\n/, $name;
423 } elsif ($make_exceptions_list) {
424 # We're making an updated version of the exception list, to
425 # stick in the __DATA__ section. I honestly can't think of
426 # a situation where this is the right thing to do, but I'm
427 # leaving it here, just in case one of my descendents thinks
429 print STDERR "$key\n";
431 # No listing found, and no excuse either.
432 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
434 diag(" Message '$name'\n from $codefn line $. is not listed in $pod");
436 # seen it, so only fail once for this message
437 $entries{$name}{seen}++;
440 die if $name =~ /%$/;
444 # Lists all missing things as of the inauguration of this script, so we
445 # don't have to go from "meh" to perfect all at once.
447 # PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
448 # pod/perldiag.pod for your new (warning|error). Nevertheless,
449 # listing exceptions here when this script is not smart enough
450 # to recognize the messages is not so bad, as long as there are
451 # entries in perldiag.
453 # Entries after __CATEGORIES__ are those that are in perldiag but fail the
454 # severity/category test.
456 # Also FIXME this test, as the first entry in TODO *is* covered by the
457 # description: Malformed UTF-8 character (%s)
459 Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
461 Cannot apply "%s" in non-PerlIO perl
462 Can't find string terminator %c%s%c anywhere before EOF
463 Can't fix broken locale name "%s"
464 Can't get short module name from a handle
465 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
469 Can't %s script `%s' with ARGV[0] being `%s'
471 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
472 Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
473 \%c better written as $%c
474 Character(s) in '%c' format wrapped in %s
475 chown not implemented!
477 Code missing after '/' in pack
478 Code missing after '/' in unpack
479 '%c' outside of string in pack
480 Debug leaking scalars child failed%s with errno %d: %s
481 '/' does not take a repeat count in %s
482 -Dp not implemented on this platform
483 Error reading "%s": %s
484 execl not implemented!
485 EVAL without pos change exceeded limit in regex
486 Filehandle opened only for %sput
487 Filehandle %s opened only for %sput
488 Filehandle STD%s reopened as %s only for input
489 filter_del can only delete in reverse order (currently)
490 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!
493 getpwnam returned invalid UIC %o for user "%s"
494 glob failed (can't start child: %s)
495 glob failed (child exited with status %d%s)
496 Goto undefined subroutine
497 Goto undefined subroutine &%s
499 ()-group starts with a count in %s
500 Illegal binary digit '%c' ignored
501 Illegal character %sin prototype for %s : %s
502 Illegal hexadecimal digit '%c' ignored
503 Illegal octal digit '%c' ignored
504 Invalid argument to sv_cat_decode
505 Invalid range "%c-%c" in transliteration operator
506 Invalid separator character %c%c%c in PerlIO layer specification %s
507 Invalid TOKEN object ignored
508 Invalid type '%c' in pack
509 Invalid type '%c' in %s
510 Invalid type '%c' in unpack
511 Invalid type ',' in %s
512 ioctlsocket not implemented!
513 killpg not implemented!
514 length() used on %s (did you mean "scalar(%s)"?)
515 length() used on %hash (did you mean "scalar(keys %hash)"?)
516 length() used on @array (did you mean "scalar(@array)"?)
517 List form of pipe open not implemented
518 Malformed integer in [] in %s
519 Malformed UTF-8 character (fatal)
520 Missing (suid) fd script name
521 More than one argument to open
522 More than one argument to open(,':%s')
523 mprotect for %p %u failed with %d
524 mprotect RW for %p %u failed with %d
525 \N{} in character class restricted to one character in regex; marked by <-- HERE in m/%s/
526 No %s allowed while running setgid
527 No %s allowed with (suid) fdscript
528 No such class field "%s"
529 Not an XSUB reference
530 Operator or semicolon missing before %c%s
531 Pattern subroutine nesting without pos change exceeded limit in regex
532 Perl %s required--this is only %s, stopped
533 PerlApp::TextQuery: no arguments, please
534 POSIX syntax [%c %c] is reserved for future extensions in regex; marked by <-- HERE in m/%s/
535 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
536 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
537 Regexp modifier "%c" may appear a maximum of twice in regex; marked by <-- HERE in m/%s/
538 Regexp modifier "%c" may not appear twice in regex; marked by <-- HERE in m/%s/
539 Regexp modifiers "%c" and "%c" are mutually exclusive in regex; marked by <-- HERE in m/%s/
540 Regexp *+ operand could be empty in regex; marked by <-- HERE in m/%s/
541 Repeated format line will never terminate (~~ and @#)
542 Reversed %c= operator
544 %sCompilation failed in require
545 Sequence (?%c...) not implemented in regex; marked by <-- HERE in m/%s/
546 Sequence (%s...) not recognized in regex; marked by <-- HERE in m/%s/
547 Sequence %s... not terminated in regex; marked by <-- HERE in m/%s/
548 Sequence (?%c... not terminated in regex; marked by <-- HERE in m/%s/
549 Sequence (?(%c... not terminated in regex; marked by <-- HERE in m/%s/
550 Sequence (?R) not terminated in regex m/%s/
552 %s free() ignored (RMAGIC, PERL_CORE)
553 %s has too many errors.
554 SIG%s handler "%s" not defined.
556 Size magic not implemented
557 %s number > %s non-portable
558 %srealloc() %signored
561 socketpair not implemented!
562 Starting Full Screen process with flag=%d, mytype=%d
563 Starting PM process with flag=%d, mytype=%d
564 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
565 SWASHNEW didn't return an HV ref
566 switching effective gid is not implemented
567 switching effective uid is not implemented
568 System V IPC is not implemented on this machine
569 -T and -B not implemented on filehandles
570 Terminating on signal SIG%s(%d)
571 The crypt() function is not implemented on NetWare
572 The flock() function is not implemented on NetWare
573 The rewinddir() function is not implemented on NetWare
574 The seekdir() function is not implemented on NetWare
575 The telldir() function is not implemented on NetWare
576 Too deeply nested ()-groups in %s
577 Too many args on %s line of "%s"
578 U0 mode on a byte string
579 unable to find VMSPIPE.COM for i/o piping
580 Unknown Unicode option value %d
581 Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
582 Unstable directory path, current directory changed unexpectedly
583 Unterminated compressed integer in unpack
585 Usage: File::Copy::rmscopy(from,to[,date_flag])
586 Usage: VMS::Filespec::candelete(spec)
587 Usage: VMS::Filespec::fileify(spec)
588 Usage: VMS::Filespec::pathify(spec)
589 Usage: VMS::Filespec::rmsexpand(spec[,defspec])
590 Usage: VMS::Filespec::unixify(spec)
591 Usage: VMS::Filespec::unixpath(spec)
592 Usage: VMS::Filespec::unixrealpath(spec)
593 Usage: VMS::Filespec::vmsify(spec)
594 Usage: VMS::Filespec::vmspath(spec)
595 Usage: VMS::Filespec::vmsrealpath(spec)
596 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
597 utf8 "\x%X" does not map to Unicode
598 Value of logical "%s" too long. Truncating to %i bytes
599 waitpid: process %x is not a child of process %x
602 Within []-length '*' not allowed in %s
603 Within []-length '%c' not allowed in %s
604 Wrong syntax (suid) fd script name "%s"
605 'X' outside of string in %s
606 'X' outside of string in unpack
607 Zero length \N{} in regex; marked by <-- HERE in m/%s/
610 Code point 0x%X is not Unicode, all \p{} matches fail; all \P{} matches succeed
611 Code point 0x%X is not Unicode, may not be portable
612 Illegal character \%o (carriage return)
613 Missing argument in %s
614 Unicode non-character U+%X is illegal for open interchange
615 Operation "%s" returns its argument for non-Unicode code point 0x%X
616 Operation "%s" returns its argument for UTF-16 surrogate U+%X
617 Unicode surrogate U+%X is illegal in UTF-8
618 UTF-16 surrogate U+%X
619 False [] range "%s" in regex; marked by <-- HERE in m/%s/