This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Documentation for the 'qr' overload.
[perl5.git] / t / porting / diag.t
1 #!/usr/bin/perl
2 use warnings;
3 use strict;
4
5 require './test.pl';
6
7 plan('no_plan');
8
9 $|=1;
10
11 my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
12
13 open my $diagfh, "<", "../pod/perldiag.pod"
14   or die "Can't open ../pod/perldiag.pod: $!";
15
16 my %entries;
17 while (<DATA>) {
18   chomp;
19   $entries{$_}{todo}=1;
20 }
21
22 my $cur_entry;
23 while (<$diagfh>) {
24   if (m/^=item (.*)/) {
25     $cur_entry = $1;
26   } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) {
27     # Make sure to init this here, so an actual entry in perldiag overwrites
28     # one in DATA.
29     $entries{$cur_entry}{todo} = 0;
30     $entries{$cur_entry}{severity} = $1;
31     $entries{$cur_entry}{category} = $2;
32   }
33 }
34
35 my @todo = ('..');
36 while (@todo) {
37   my $todo = shift @todo;
38   next if $todo ~~ ['../t', '../lib', '../ext', '../dist', '../cpan'];
39   # opmini.c is just a copy of op.c, so there's no need to check again.
40   next if $todo eq '../opmini.c';
41   if (-d $todo) {
42     push @todo, glob "$todo/*";
43   } elsif ($todo =~ m/\.[ch]$/) {
44     check_file($todo);
45   }
46 }
47
48 sub check_file {
49   my ($codefn) = @_;
50
51   print "# $codefn\n";
52
53   open my $codefh, "<", $codefn
54     or die "Can't open $codefn: $!";
55
56   my $listed_as;
57   my $listed_as_line;
58   my $sub = 'top of file';
59   while (<$codefh>) {
60     chomp;
61     # Getting too much here isn't a problem; we only use this to skip
62     # errors inside of XS modules, which should get documented in the
63     # docs for the module.
64     if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) {
65       $sub = $1;
66     }
67     next if $sub =~ m/^XS/;
68     if (m</\* diag_listed_as: (.*) \*/>) {
69       $listed_as = $1;
70       $listed_as_line = $.+1;
71     }
72     next if /^#/;
73     next if /^ * /;
74     while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) {
75       my $nextline = <$codefh>;
76       # Means we fell off the end of the file.  Not terribly surprising;
77       # this code tries to merge a lot of things that aren't regular C
78       # code (preprocessor stuff, long comments).  That's OK; we don't
79       # need those anyway.
80       last if not defined $nextline;
81       chomp $nextline;
82       $nextline =~ s/^\s+//;
83       # Note that we only want to do this where *both* are true.
84       $_ =~ s/\\$//;
85       if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
86         $_ =~ s/"$//;
87         $nextline =~ s/^"//;
88       }
89       $_ = "$_$nextline";
90     }
91     # This should happen *after* unwrapping, or we don't reformat the things
92     # in later lines.
93     # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
94     my %specialformats = (IVdf => 'd',
95                           UVuf => 'd',
96                           UVof => 'o',
97                           UVxf => 'x',
98                           UVXf => 'X',
99                           NVef => 'f',
100                           NVff => 'f',
101                           NVgf => 'f',
102                           SVf  => 's');
103     for my $from (keys %specialformats) {
104       s/%"\s*$from\s*"/\%$specialformats{$from}/g;
105       s/%"\s*$from/\%$specialformats{$from}"/g;
106     }
107     # The %"foo" thing needs to happen *before* this regex.
108     if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s*
109           \(aTHX_ \s*
110           (?:packWARN\d*\((.*?)\),)? \s*
111           "((?:\\"|[^"])*?)"/x) {
112       # diag($_);
113       # DIE is just return Perl_die
114       my $severity = {croak => [qw/P F/],
115                       die   => [qw/P F/],
116                       warn  => [qw/W D S/],
117                      }->{$1||'die'};
118       my @categories;
119       if ($2) {
120         @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2;
121       }
122       my $name;
123       if ($listed_as and $listed_as_line == $.) {
124         $name = $listed_as;
125       } else {
126         $name = $3;
127         # The form listed in perldiag ignores most sorts of fancy printf formatting,
128         # or makes it more perlish.
129         $name =~ s/%%/\\%/g;
130         $name =~ s/%l[ud]/%d/g;
131         $name =~ s/%\.(\d+|\*)s/\%s/g;
132         $name =~ s/\\"/"/g;
133         $name =~ s/\\t/\t/g;
134         $name =~ s/\\n/ /g;
135         $name =~ s/\s+$//;
136       }
137
138       # Extra explanatory info on an already-listed error, doesn't
139       # need it's own listing.
140       next if $name =~ m/^\t/;
141
142       # Happens fairly often with PL_no_modify.
143       next if $name eq '%s';
144
145       # Special syntax for magic comment, allows ignoring the fact
146       # that it isn't listed.  Only use in very special circumstances,
147       # like this script failing to notice that the Perl_croak call is
148       # inside an #if 0 block.
149       next if $name eq 'SKIPME';
150
151       if (exists $entries{$name}) {
152         if ($entries{$name}{todo}) {
153         TODO: {
154             no warnings 'once';
155             local $::TODO = 'in DATA';
156             fail("Presence of '$name' from $codefn line $.");
157           }
158         } else {
159           ok("Presence of '$name' from $codefn line $.");
160         }
161         # Later, should start checking that the severity is correct, too.
162       } elsif ($name =~ m/^panic: /) {
163         # Just too many panic:s, they are hard to diagnose, and there
164         # is a generic "panic: %s" entry.  Leave these for another
165         # pass.
166         ok("Presence of '$name' from $codefn line $., covered by panic: %s entry");
167       } else {
168         if ($make_exceptions_list) {
169           print STDERR "$name\n";
170         } else {
171           fail("Presence of '$name' from $codefn line $.");
172         }
173       }
174
175       die if $name =~ /%$/;
176     }
177   }
178 }
179 # Lists all missing things as of the inaguration of this script, so we
180 # don't have to go from "meh" to perfect all at once.
181 __DATA__
182 Ambiguous call resolved as CORE::%s(), %s
183 Ambiguous use of %c resolved as operator %c
184 Ambiguous use of %c{%s} resolved to %c%s
185 Ambiguous use of %c{%s%s} resolved to %c%s%s
186 Ambiguous use of -%s resolved as -&%s()
187 Argument "%s" isn't numeric
188 Argument "%s" isn't numeric in %s
189 Attempt to clear deleted array
190 Attempt to free non-arena SV: 0x%x
191 Attempt to free non-existent shared string '%s'%s
192 Attempt to free temp prematurely: SV 0x%x
193 Attempt to free unreferenced scalar: SV 0x%x
194 Attempt to reload %s aborted. Compilation failed in require
195 av_reify called on tied array
196 Bad name after %s%s
197 Bad symbol for %s
198 bad top format reference
199 Bizarre copy of %s
200 Bizarre SvTYPE [%d]
201 Cannot copy to %s
202 Can't call method "%s" %s
203 Can't coerce readonly %s to string
204 Can't coerce readonly %s to string in %s
205 Can't fix broken locale name "%s"
206 Can't get short module name from a handle
207 Can't goto subroutine from an eval-block
208 Can't goto subroutine from an eval-string
209 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
210 Can't modify non-existent substring
211 Can't open
212 Can't open perl script "%s": %s
213 Can't open %s
214 Can't reset \%ENV on this system
215 Can't return array to lvalue scalar context
216 Can't return a %s from lvalue subroutine
217 Can't return hash to lvalue scalar context
218 Can't spawn "%s": %s
219 Can't %s script `%s' with ARGV[0] being `%s'
220 Can't %s "%s": %s
221 Can't %s %s%s%s
222 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
223 Can't take %s of %f
224 Can't use '%c' after -mname
225 Can't use \\%c to mean $%c in expression
226 Can't use when() outside a topicalizer
227 \\%c better written as $%c
228 Character(s) in '%c' format wrapped in %s
229 $%c is no longer supported
230 Cloning substitution context is unimplemented
231 Code missing after '/' in pack
232 Code missing after '/' in unpack
233 Compilation failed in require
234 Corrupted regexp opcode %d > %d
235 '%c' outside of string in pack
236 Debug leaking scalars child failed%s%s with errno %d: %s
237 Deep recursion on anonymous subroutine
238 defined(\%hash) is deprecated
239 Don't know how to handle magic of type \\%o
240 -Dp not implemented on this platform
241 entering effective gid failed
242 entering effective uid failed
243 Error reading "%s": %s
244 Exiting %s via %s
245 Filehandle opened only for %sput
246 Filehandle %s opened only for %sput
247 Filehandle STD%s reopened as %s only for input
248 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!
249 Format STDOUT redefined
250 Free to wrong pool %p not %p
251 get %s %p %p %p
252 glob failed (can't start child: %s)
253 glob failed (child exited with status %d%s)
254 Goto undefined subroutine
255 Goto undefined subroutine &%s
256 Hash \%%s missing the \% in argument %d of %s()
257 Illegal character \\%03o (carriage return)
258 Illegal character %sin prototype for %s : %s
259 Integer overflow in decimal number
260 Integer overflow in version %d
261 internal \%<num>p might conflict with future printf extensions
262 invalid control request: '\\%03o'
263 Invalid module name %s with -%c option: contains single ':'
264 invalid option -D%c, use -D'' to see choices
265 Invalid range "%c-%c" in transliteration operator
266 Invalid separator character %c%c%c in PerlIO layer specification %s
267 Invalid TOKEN object ignored
268 Invalid type '%c' in pack
269 Invalid type '%c' in %s
270 Invalid type '%c' in unpack
271 Invalid type ',' in %s
272 Invalid version format (alpha without decimal)
273 Invalid version format (misplaced _ in number)
274 Invalid version object
275 'j' not supported on this platform
276 'J' not supported on this platform
277 Layer does not match this perl
278 leaving effective gid failed
279 leaving effective uid failed
280 List form of piped open not implemented
281 Lost precision when decrementing %f by 1
282 Lost precision when incrementing %f by 1
283 %lx
284 Malformed UTF-16 surrogate
285 Malformed UTF-8 character (fatal)
286 '\%' may not be used in pack
287 Missing (suid) fd script name
288 More than one argument to open
289 More than one argument to open(,':%s')
290 mprotect for %p %d failed with %d
291 mprotect RW for %p %d failed with %d
292 No code specified for -%c
293 No directory specified for -I
294 No such class field "%s"
295 Not an XSUB reference
296 Not %s reference
297 Offset outside string
298 Opening dirhandle %s also as a file
299 Opening filehandle %s also as a directory
300 Operator or semicolon missing before %c%s
301 PERL_SIGNALS illegal: "%s"
302 Perl %s required (did you mean %s?)--this is only %s, stopped
303 Perl %s required--this is only %s, stopped
304 Perls since %s too modern--this is %s, stopped
305 Possible unintended interpolation of $\\ in regex
306 ptr wrong %p != %p fl=%08
307 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
308 Recursive call to Perl_load_module in PerlIO_find_layer
309 refcnt_dec: fd %d < 0
310 refcnt_dec: fd %d: %d <= 0
311 refcnt_dec: fd %d >= refcnt_size %d
312 refcnt_inc: fd %d < 0
313 refcnt_inc: fd %d: %d <= 0
314 Reversed %c= operator
315 Runaway prototype
316 %s(%.0f) failed
317 %s(%.0f) too large
318 Scalar value %s better written as $%s
319 %sCompilation failed in regexp
320 %sCompilation failed in require
321 set %s %p %p %p
322 %s free() ignored (RMAGIC, PERL_CORE)
323 %s has too many errors.
324 SIG%s handler "%s" not defined.
325 %s: illegal mapping '%s'
326 %s in %s
327 Size magic not implemented
328 %s limit (%d) exceeded
329 %s method "%s" overloading "%s" in package "%s"
330 %s number > %s non-portable
331 %s object version %s does not match %s%s%s%s %s
332 %srealloc() %signored
333 %s returned from lvalue subroutine in scalar context
334 %s%s has too many errors.
335 %s%s on %s %s
336 %s%s on %s %s %s
337 Starting Full Screen process with flag=%d, mytype=%d
338 Starting PM process with flag=%d, mytype=%d
339 strxfrm() gets absurd
340 SWASHNEW didn't return an HV ref
341 -T and -B not implemented on filehandles
342 The flock() function is not implemented on NetWare
343 The rewinddir() function is not implemented on NetWare
344 The seekdir() function is not implemented on NetWare
345 The stat preceding lstat() wasn't an lstat
346 The telldir() function is not implemented on NetWare
347 Too deeply nested ()-groups in %s
348 Too late to run CHECK block
349 Too late to run INIT block
350 Too many args on %s line of "%s"
351 U0 mode on a byte string
352 Unbalanced string table refcount: (%d) for "%s"
353 Undefined top format called
354 Unexpected constant lvalue entersub entry via type/targ %d:%d
355 Unicode non-character 0x%04
356 Unknown PerlIO layer "scalar"
357 Unknown Unicode option letter '%c'
358 unrecognised control character '%c'
359 Unstable directory path, current directory changed unexpectedly
360 Unsupported script encoding UTF16-BE
361 Unsupported script encoding UTF16-LE
362 Unsupported script encoding UTF32-BE
363 Unsupported script encoding UTF32-LE
364 Unterminated compressed integer in unpack
365 Usage: CODE(0x%x)(%s)
366 Usage: %s(%s)
367 Usage: %s::%s(%s)
368 Usage: VMS::Filespec::unixrealpath(spec)
369 Usage: VMS::Filespec::vmsrealpath(spec)
370 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
371 UTF-16 surrogate 0x%04
372 utf8 "\\x%02X" does not map to Unicode
373 Value of logical "%s" too long. Truncating to %i bytes
374 value of node is %d in Offset macro
375 Value of %s%s can be "0"; test with defined()
376 Variable "%c%s" is not imported
377 vector argument not supported with alpha versions
378 Wide character
379 Wide character in $/
380 Wide character in print
381 Wide character in %s
382 Within []-length '%c' not allowed in %s
383 Wrong syntax (suid) fd script name "%s"
384 'X' outside of string in unpack