This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add tests for cmp, eq, ne for UTF-8 vs octet representation.
[perl5.git] / t / porting / diag.t
CommitLineData
fe13d51d
JM
1#!/usr/bin/perl
2use warnings;
3use strict;
f7b649f0
NC
4
5require './test.pl';
6
7plan('no_plan');
8
fe13d51d
JM
9$|=1;
10
1eb3f3ad
JM
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.
f7223e8e 17my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
87a63fff 18
45f1c7ba 19chdir '..' or die "Can't chdir ..: $!";
47f6eaac 20BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
45f1c7ba 21
1b1ee2ef
KW
22my @functions;
23
24open my $func_fh, "<", "embed.fnc" or die "Can't open embed.fnc: $!";
25
26# Look for functions in embed.fnc that look like they could be diagnostic ones.
27while (<$func_fh>) {
28 chomp;
29 s/^\s+//;
30 while (s/\s*\\$//) { # Grab up all continuation lines, these end in \
31 my $next = <$func_fh>;
32 $next =~ s/^\s+//;
33 chomp $next;
34 $_ .= $next;
35 }
36 next if /^:/; # Lines beginning with colon are comments.
37 next unless /\|/; # Lines without a vertical bar are something we can't deal
38 # with
39 my @fields = split /\s*\|\s*/;
40 next unless $fields[2] =~ /warn|err|(\b|_)die|croak/i;
41 push @functions, $fields[2];
42
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/;
47}
48
49close $func_fh;
50
51my $function_re = join '|', @functions;
52my $source_msg_re = qr/(?<routine>\bDIE\b|$function_re)/;
fe13d51d
JM
53
54my %entries;
1b1ee2ef
KW
55
56# Get the ignores that are compiled into this file
87a63fff
JM
57while (<DATA>) {
58 chomp;
59 $entries{$_}{todo}=1;
60}
61
fe13d51d 62my $cur_entry;
1b1ee2ef
KW
63open my $diagfh, "<", "pod/perldiag.pod"
64 or die "Can't open pod/perldiag.pod: $!";
65
fe13d51d
JM
66while (<$diagfh>) {
67 if (m/^=item (.*)/) {
68 $cur_entry = $1;
69 } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) {
87a63fff
JM
70 # Make sure to init this here, so an actual entry in perldiag overwrites
71 # one in DATA.
72 $entries{$cur_entry}{todo} = 0;
fe13d51d
JM
73 $entries{$cur_entry}{severity} = $1;
74 $entries{$cur_entry}{category} = $2;
75 }
76}
77
1b1ee2ef 78# Recursively descend looking for source files.
abd65dc0 79my @todo = sort <*>;
fe13d51d
JM
80while (@todo) {
81 my $todo = shift @todo;
45f1c7ba 82 next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
fe13d51d 83 # opmini.c is just a copy of op.c, so there's no need to check again.
45f1c7ba 84 next if $todo eq 'opmini.c';
fe13d51d 85 if (-d $todo) {
abd65dc0 86 unshift @todo, sort glob "$todo/*";
87a63fff 87 } elsif ($todo =~ m/\.[ch]$/) {
fe13d51d
JM
88 check_file($todo);
89 }
90}
91
49a5993e
DG
92sub find_message {
93 my ($line) = @_;
94 my $text_re = qr/"(?<text>(?:\\"|[^"])*?)"/;
95 if ($line =~ m/$source_msg_re(?:_nocontext)? \s*
96 \(aTHX_ \s*
97 (?:packWARN\d*\((?<category>.*?)\),)? \s*
98 $text_re /x
99 ) {
100 return [$+{'text'}, $+{'category'}];
101 }
102 elsif ( $line =~ m{BADVERSION\([^"]*$text_re}) {
103 return [$+{'text'}, undef];
104 }
105 return;
106}
107
abd65dc0
DG
108# Standardize messages with variants into the form that appears
109# in perldiag.pod -- useful for things without a diag_listed_as annotation
110sub standardize {
111 my ($name) = @_;
112
113 if ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
114 $name = "$1 (\%s)";
115 }
116 elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
117 $name = "$1 (\%s)";
118 }
119 elsif ($name =~ m/^panic: /) {
120 $name = "panic: \%s";
121 }
122
123 return $name;
124}
125
fe13d51d
JM
126sub check_file {
127 my ($codefn) = @_;
128
abd65dc0 129 print "# Checking $codefn\n";
fe13d51d 130
38ec24b4 131 open my $codefh, "<", $codefn
fe13d51d
JM
132 or die "Can't open $codefn: $!";
133
134 my $listed_as;
135 my $listed_as_line;
136 my $sub = 'top of file';
137 while (<$codefh>) {
138 chomp;
139 # Getting too much here isn't a problem; we only use this to skip
140 # errors inside of XS modules, which should get documented in the
141 # docs for the module.
142 if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) {
143 $sub = $1;
144 }
145 next if $sub =~ m/^XS/;
146 if (m</\* diag_listed_as: (.*) \*/>) {
147 $listed_as = $1;
148 $listed_as_line = $.+1;
149 }
150 next if /^#/;
151 next if /^ * /;
1b1ee2ef 152
c4ea5f2e 153 my $multiline = 0;
1b1ee2ef
KW
154 # Loop to accumulate the message text all on one line.
155 while (m/$source_msg_re/ and not m/\);$/) {
fe13d51d
JM
156 my $nextline = <$codefh>;
157 # Means we fell off the end of the file. Not terribly surprising;
158 # this code tries to merge a lot of things that aren't regular C
159 # code (preprocessor stuff, long comments). That's OK; we don't
160 # need those anyway.
161 last if not defined $nextline;
162 chomp $nextline;
163 $nextline =~ s/^\s+//;
164 # Note that we only want to do this where *both* are true.
165 $_ =~ s/\\$//;
166 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
167 $_ =~ s/"$//;
168 $nextline =~ s/^"//;
169 }
170 $_ = "$_$nextline";
c4ea5f2e 171 ++$multiline;
fe13d51d
JM
172 }
173 # This should happen *after* unwrapping, or we don't reformat the things
174 # in later lines.
175 # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
176 my %specialformats = (IVdf => 'd',
177 UVuf => 'd',
178 UVof => 'o',
179 UVxf => 'x',
180 UVXf => 'X',
181 NVef => 'f',
182 NVff => 'f',
183 NVgf => 'f',
184 SVf => 's');
185 for my $from (keys %specialformats) {
186 s/%"\s*$from\s*"/\%$specialformats{$from}/g;
187 s/%"\s*$from/\%$specialformats{$from}"/g;
188 }
189 # The %"foo" thing needs to happen *before* this regex.
49a5993e 190 if ( my $found = find_message($_) ) {
1b1ee2ef
KW
191 # diag($_);
192 # DIE is just return Perl_die
49a5993e 193 my ($name, $category) = @$found;
1b1ee2ef 194 my $severity = {croak => [qw/P F/],
fe13d51d
JM
195 die => [qw/P F/],
196 warn => [qw/W D S/],
1b1ee2ef
KW
197 }->{$+{'routine'}||'die'};
198 my @categories;
49a5993e
DG
199 if (defined $category) {
200 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
1b1ee2ef 201 }
c4ea5f2e 202 if ($listed_as and $listed_as_line == $. - $multiline) {
fe13d51d 203 $name = $listed_as;
1b1ee2ef 204 } else {
1b1ee2ef
KW
205 # The form listed in perldiag ignores most sorts of fancy printf
206 # formatting, or makes it more perlish.
fe13d51d
JM
207 $name =~ s/%%/\\%/g;
208 $name =~ s/%l[ud]/%d/g;
209 $name =~ s/%\.(\d+|\*)s/\%s/g;
210 $name =~ s/\\"/"/g;
211 $name =~ s/\\t/\t/g;
87a63fff
JM
212 $name =~ s/\\n/ /g;
213 $name =~ s/\s+$//;
4a68bf9d 214 $name =~ s/(\\)\\/$1/g;
fe13d51d
JM
215 }
216
87a63fff
JM
217 # Extra explanatory info on an already-listed error, doesn't
218 # need it's own listing.
fe13d51d
JM
219 next if $name =~ m/^\t/;
220
221 # Happens fairly often with PL_no_modify.
222 next if $name eq '%s';
223
87a63fff
JM
224 # Special syntax for magic comment, allows ignoring the fact
225 # that it isn't listed. Only use in very special circumstances,
226 # like this script failing to notice that the Perl_croak call is
227 # inside an #if 0 block.
fe13d51d
JM
228 next if $name eq 'SKIPME';
229
abd65dc0 230 $name = standardize($name);
2c86d456 231
87a63fff 232 if (exists $entries{$name}) {
abd65dc0
DG
233 if ( $entries{$name}{seen}++ ) {
234 # no need to repeat entries we've tested
235 } elsif ($entries{$name}{todo}) {
87a63fff 236 TODO: {
1b1ee2ef 237 no warnings 'once';
f7b649f0 238 local $::TODO = 'in DATA';
1eb3f3ad 239 # There is no listing, but it is in the list of exceptions. TODO FAIL.
abd65dc0
DG
240 fail($name);
241 diag(
242 " Message '$name'\n from $codefn line $. is not listed in pod/perldiag.pod\n".
243 " (but it wasn't documented in 5.10 either, so marking it TODO)."
244 );
87a63fff 245 }
fe13d51d 246 } else {
1eb3f3ad 247 # We found an actual valid entry in perldiag.pod for this error.
abd65dc0 248 pass($name);
fe13d51d 249 }
87a63fff 250 # Later, should start checking that the severity is correct, too.
fe13d51d 251 } else {
87a63fff 252 if ($make_exceptions_list) {
1eb3f3ad
JM
253 # We're making an updated version of the exception list, to
254 # stick in the __DATA__ section. I honestly can't think of
255 # a situation where this is the right thing to do, but I'm
256 # leaving it here, just in case one of my descendents thinks
257 # it's a good idea.
87a63fff
JM
258 print STDERR "$name\n";
259 } else {
1eb3f3ad
JM
260 # No listing found, and no excuse either.
261 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
abd65dc0
DG
262 fail($name);
263 diag(" Message '$name'\n from $codefn line $. is not listed in pod/perldiag.pod");
87a63fff 264 }
abd65dc0
DG
265 # seen it, so only fail once for this message
266 $entries{$name}{seen}++;
fe13d51d
JM
267 }
268
269 die if $name =~ /%$/;
270 }
271 }
272}
f7223e8e 273# Lists all missing things as of the inaguration of this script, so we
87a63fff 274# don't have to go from "meh" to perfect all at once.
b0227916
JM
275#
276# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
277# pod/perldiag.pod for your new (warning|error).
87a63fff 278__DATA__
0dc17498
TM
279%s (%d) does not match %s (%d),
280%s (%d) smaller than %s (%d),
87a63fff
JM
281Argument "%s" isn't numeric
282Argument "%s" isn't numeric in %s
87a63fff
JM
283Attempt to clear deleted array
284Attempt to free non-arena SV: 0x%x
285Attempt to free non-existent shared string '%s'%s
286Attempt to free temp prematurely: SV 0x%x
287Attempt to free unreferenced scalar: SV 0x%x
288Attempt to reload %s aborted. Compilation failed in require
289av_reify called on tied array
290Bad name after %s%s
d5713896 291Bad symbol for %s
87a63fff
JM
292bad top format reference
293Bizarre copy of %s
294Bizarre SvTYPE [%d]
295Cannot copy to %s
296Can't call method "%s" %s
297Can't coerce readonly %s to string
298Can't coerce readonly %s to string in %s
299Can't fix broken locale name "%s"
300Can't get short module name from a handle
301Can't goto subroutine from an eval-block
302Can't goto subroutine from an eval-string
303Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
304Can't modify non-existent substring
305Can't open
306Can't open perl script "%s": %s
307Can't open %s
308Can't reset \%ENV on this system
309Can't return array to lvalue scalar context
310Can't return a %s from lvalue subroutine
311Can't return hash to lvalue scalar context
312Can't spawn "%s": %s
313Can't %s script `%s' with ARGV[0] being `%s'
314Can't %s "%s": %s
315Can't %s %s%s%s
316Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
317Can't take %s of %f
318Can't use '%c' after -mname
973a7615 319Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
4a68bf9d 320Can't use \%c to mean $%c in expression
87a63fff 321Can't use when() outside a topicalizer
4a68bf9d 322\%c better written as $%c
87a63fff
JM
323Character(s) in '%c' format wrapped in %s
324$%c is no longer supported
325Cloning substitution context is unimplemented
326Code missing after '/' in pack
327Code missing after '/' in unpack
328Compilation failed in require
329Corrupted regexp opcode %d > %d
330'%c' outside of string in pack
331Debug leaking scalars child failed%s%s with errno %d: %s
332Deep recursion on anonymous subroutine
333defined(\%hash) is deprecated
4a68bf9d 334Don't know how to handle magic of type \%o
87a63fff
JM
335-Dp not implemented on this platform
336entering effective gid failed
337entering effective uid failed
338Error reading "%s": %s
339Exiting %s via %s
340Filehandle opened only for %sput
341Filehandle %s opened only for %sput
342Filehandle STD%s reopened as %s only for input
343YOU 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!
344Format STDOUT redefined
345Free to wrong pool %p not %p
346get %s %p %p %p
347glob failed (can't start child: %s)
348glob failed (child exited with status %d%s)
349Goto undefined subroutine
350Goto undefined subroutine &%s
351Hash \%%s missing the \% in argument %d of %s()
4a68bf9d 352Illegal character \%03o (carriage return)
87a63fff 353Illegal character %sin prototype for %s : %s
1b1ee2ef 354Integer overflow in binary number
87a63fff 355Integer overflow in decimal number
1b1ee2ef
KW
356Integer overflow in hexadecimal number
357Integer overflow in octal number
87a63fff
JM
358Integer overflow in version %d
359internal \%<num>p might conflict with future printf extensions
4a68bf9d 360invalid control request: '\%03o'
87a63fff
JM
361Invalid module name %s with -%c option: contains single ':'
362invalid option -D%c, use -D'' to see choices
363Invalid range "%c-%c" in transliteration operator
364Invalid separator character %c%c%c in PerlIO layer specification %s
365Invalid TOKEN object ignored
366Invalid type '%c' in pack
367Invalid type '%c' in %s
368Invalid type '%c' in unpack
369Invalid type ',' in %s
4a68bf9d 370It 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 ";"
87a63fff
JM
371'j' not supported on this platform
372'J' not supported on this platform
87a63fff
JM
373leaving effective gid failed
374leaving effective uid failed
375List form of piped open not implemented
376Lost precision when decrementing %f by 1
377Lost precision when incrementing %f by 1
378%lx
379Malformed UTF-16 surrogate
380Malformed UTF-8 character (fatal)
381'\%' may not be used in pack
382Missing (suid) fd script name
383More than one argument to open
384More than one argument to open(,':%s')
385mprotect for %p %d failed with %d
386mprotect RW for %p %d failed with %d
387No code specified for -%c
388No directory specified for -I
389No such class field "%s"
390Not an XSUB reference
391Not %s reference
392Offset outside string
393Opening dirhandle %s also as a file
394Opening filehandle %s also as a directory
395Operator or semicolon missing before %c%s
87a63fff
JM
396PERL_SIGNALS illegal: "%s"
397Perl %s required (did you mean %s?)--this is only %s, stopped
398Perl %s required--this is only %s, stopped
399Perls since %s too modern--this is %s, stopped
4a68bf9d 400Possible unintended interpolation of $\ in regex
87a63fff
JM
401ptr wrong %p != %p fl=%08
402Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
403Recursive call to Perl_load_module in PerlIO_find_layer
404refcnt_dec: fd %d < 0
405refcnt_dec: fd %d: %d <= 0
406refcnt_dec: fd %d >= refcnt_size %d
407refcnt_inc: fd %d < 0
408refcnt_inc: fd %d: %d <= 0
409Reversed %c= operator
410Runaway prototype
1b1ee2ef 411%s(%.0
87a63fff
JM
412%s(%.0f) failed
413%s(%.0f) too large
414Scalar value %s better written as $%s
415%sCompilation failed in regexp
416%sCompilation failed in require
417set %s %p %p %p
418%s free() ignored (RMAGIC, PERL_CORE)
419%s has too many errors.
420SIG%s handler "%s" not defined.
421%s: illegal mapping '%s'
422%s in %s
423Size magic not implemented
424%s limit (%d) exceeded
425%s method "%s" overloading "%s" in package "%s"
426%s number > %s non-portable
427%s object version %s does not match %s%s%s%s %s
428%srealloc() %signored
429%s returned from lvalue subroutine in scalar context
430%s%s has too many errors.
431%s%s on %s %s
432%s%s on %s %s %s
433Starting Full Screen process with flag=%d, mytype=%d
434Starting PM process with flag=%d, mytype=%d
435strxfrm() gets absurd
436SWASHNEW didn't return an HV ref
437-T and -B not implemented on filehandles
438The flock() function is not implemented on NetWare
439The rewinddir() function is not implemented on NetWare
440The seekdir() function is not implemented on NetWare
441The stat preceding lstat() wasn't an lstat
442The telldir() function is not implemented on NetWare
443Too deeply nested ()-groups in %s
444Too late to run CHECK block
445Too late to run INIT block
446Too many args on %s line of "%s"
447U0 mode on a byte string
448Unbalanced string table refcount: (%d) for "%s"
449Undefined top format called
450Unexpected constant lvalue entersub entry via type/targ %d:%d
6f6ac1de 451Unicode non-character 0x%04
87a63fff
JM
452Unknown PerlIO layer "scalar"
453Unknown Unicode option letter '%c'
87a63fff 454Unstable directory path, current directory changed unexpectedly
ee6ba15d
EB
455Unsupported script encoding UTF-16BE
456Unsupported script encoding UTF-16LE
457Unsupported script encoding UTF-32BE
458Unsupported script encoding UTF-32LE
87a63fff
JM
459Unterminated compressed integer in unpack
460Usage: CODE(0x%x)(%s)
461Usage: %s(%s)
462Usage: %s::%s(%s)
463Usage: VMS::Filespec::unixrealpath(spec)
464Usage: VMS::Filespec::vmsrealpath(spec)
465Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
466UTF-16 surrogate 0x%04
4a68bf9d 467utf8 "\x%02X" does not map to Unicode
87a63fff
JM
468Value of logical "%s" too long. Truncating to %i bytes
469value of node is %d in Offset macro
470Value of %s%s can be "0"; test with defined()
471Variable "%c%s" is not imported
472vector argument not supported with alpha versions
473Wide character
474Wide character in $/
475Wide character in print
476Wide character in %s
477Within []-length '%c' not allowed in %s
478Wrong syntax (suid) fd script name "%s"
479'X' outside of string in unpack