4 chdir '..' if -d '../pod' && -d '../t';
12 $SIG{__WARN__} = sub { $w = shift };
13 use_ok('diagnostics');
14 is $w, undef, 'no warnings when loading diagnostics.pm';
20 'base'->import(qw(I::do::not::exist));
23 like( $@, qr/^Base class package "I::do::not::exist" is empty/,
24 'diagnostics not tripped up by "use base qw(Dont::Exist)"');
26 open *whatever, ">", \my $warning
27 or die "Couldn't redirect STDERR to var: $!";
28 my $old_stderr = *STDERR{IO};
29 *STDERR = *whatever{IO};
31 # Test for %.0f patterns in perldiag, added in 5.11.0
32 warn('gmtime(nan) too large');
33 like $warning, qr/\(W overflow\) You called/, '%0.f patterns';
38 warn("accept() on closed socket spanner");
39 like $warning, qr/"accept" in perlfunc/, 'L<foo/bar> links';
41 # L<foo|bar/baz> links
45 'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input';
46 like $warning, qr/lex_stuff_pvn or similar/, 'L<foo|bar/baz>';
48 # Multiple messages with the same description
51 warn 'Deep recursion on anonymous subroutine';
52 like $warning, qr/W recursion/,
53 'Message sharing its description with the following message';
56 warn 'Deep recursion on subroutine "foo"';
57 like $warning, qr/W recursion/,
58 'Message sharing its description with the preceding message';
60 # Periods at end of entries in perldiag.pod get matched correctly
63 warn "Execution of -e aborted due to compilation errors.\n";
64 like $warning, qr/The final summary message/, 'Periods at end of line';
69 warn "Bad arg length for us, is 4, should be 42";
70 like $warning, qr/In C parlance/, '%u works';
75 warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
76 like $warning, qr/You had a UTF-16 surrogate/, '%X';
81 warn "Slab leaked from cv fadedc0ffee";
82 like $warning, qr/bookkeeping of op trees/, '%p';
88 like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>';
90 # Errors ending with dots
93 warn "I had compilation errors.\n";
94 like $warning, qr/final summary message/, 'dotty errors';
99 warn "Attempt to reload weapon aborted.\nCompilation failed in require";
101 qr/You tried to load a file.*Perl could not compile/s,
104 # Multiline entry in perldiag.pod
107 warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/";
109 qr/A charnames handler may return a sequence/s,
110 'multi-line entries in perldiag.pod match';
112 # ; at end of entry in perldiag.pod
115 warn "Perl folding rules are not up-to-date for 0x0A; please use the perlbug utility to report; in regex; marked by <-- HERE in m/\ <-- HERE q/";
117 qr/You used a regular expression with case-insensitive matching/s,
118 '; works at the end of entries in perldiag.pod';
120 # Differences in spaces in warnings (Why not be nice and accept them?)
123 warn "Assignment to both a list and a scalar\n";
126 'spaces in warnings are matched lightly';
128 # Differences in spaces in warnings with a period at the end
131 warn "perl: warning: Setting locale failed.\n";
133 qr/The whole warning/s,
134 'spaces in warnings with periods at the end are matched lightly';
138 skip("We no longer have any multi-line links", 1);
141 warn "Argument \"%s\" treated as 0 in increment (++)";
143 qr/Auto-increment.*Auto-decrement/s,
144 'multiline links are not truncated';
148 # Find last warning in perldiag.pod, and last items if any
153 open(my $f, '<', "pod/perldiag.pod")
154 or die "failed to open pod/perldiag.pod for reading: $!";
157 if ( /^=item\s+(.*)/) {
166 $_ =~ s/\w<(.*?)>/$1/g;
169 $_ =~ s/(^\s+|\s+$)//g;
180 ok($item, "(sanity...) found an item to check with ($item)");
184 ok($warning, '(sanity...) got a warning');
187 "Junk after =back doesn't show up in last warning";
190 *STDERR = $old_stderr;
192 # These tests use a panic under the hope that the description is not likely
195 switches => [ '-Ilib', '-Mdiagnostics' ],
197 nolib => 1, # -I../lib would go outside the build dir
200 "sub foo{bar()}sub bar{baz()}sub baz{die q _panic: gremlins_}foo()";
201 is runperl(@runperl_args, prog => $subs),
202 << 'EOT', 'internal error with backtrace';
203 panic: gremlins at -e line 1 (#1)
204 (P) An internal error.
206 Uncaught exception from user code:
207 panic: gremlins at -e line 1.
208 main::baz() called at -e line 1
209 main::bar() called at -e line 1
210 main::foo() called at -e line 1
212 is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r),
213 << 'EOU', 'user error with backtrace';
214 Uncaught exception from user code:
215 panick: gremlins at -e line 1.
216 main::baz() called at -e line 1
217 main::bar() called at -e line 1
218 main::foo() called at -e line 1
220 is runperl(@runperl_args, prog => 'die q _panic: gremlins_'),
221 << 'EOV', 'no backtrace from top-level internal error';
222 panic: gremlins at -e line 1 (#1)
223 (P) An internal error.
225 Uncaught exception from user code:
226 panic: gremlins at -e line 1.
228 is runperl(@runperl_args, prog => 'die q _panick: gremlins_'),
229 << 'EOW', 'no backtrace from top-level user error';
230 Uncaught exception from user code:
231 panick: gremlins at -e line 1.
236 s[q _panic: gremlins_]
237 [qq _Attempt to reload foo aborted.\\nCompilation failed in require_]r,
239 qr/Uncaught exception from user code:
240 Attempt to reload foo aborted\.
241 Compilation failed in require at -e line \d+\.
242 main::baz\(\) called at -e line \d+
243 main::bar\(\) called at -e line \d+
244 main::foo\(\) called at -e line \d+
245 /, 'backtrace from multiline error';
246 is runperl(@runperl_args, prog => 'BEGIN { die q _panic: gremlins_ }'),
247 << 'EOX', 'BEGIN{die} does not suppress diagnostics';
248 panic: gremlins at -e line 1.
249 BEGIN failed--compilation aborted at -e line 1 (#1)
250 (P) An internal error.
252 Uncaught exception from user code:
253 panic: gremlins at -e line 1.
254 BEGIN failed--compilation aborted at -e line 1.