This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RT-119817 - Treat =back as the end of a warning description.
[perl5.git] / lib / diagnostics.t
CommitLineData
00680da2 1#!./perl -w
f5ad5489
GS
2
3BEGIN {
7b903762
RGS
4 chdir '..' if -d '../pod' && -d '../t';
5 @INC = 'lib';
f63ff350 6 require './t/test.pl';
f1deee33 7 plan(28);
f5ad5489
GS
8}
9
00680da2
FC
10BEGIN {
11 my $w;
12 $SIG{__WARN__} = sub { $w = shift };
13 use_ok('diagnostics');
14 is $w, undef, 'no warnings when loading diagnostics.pm';
15}
f5ad5489 16
d23f0205 17require base;
f5ad5489 18
d23f0205
MS
19eval {
20 'base'->import(qw(I::do::not::exist));
21};
f5ad5489 22
d142a076
FC
23like( $@, qr/^Base class package "I::do::not::exist" is empty/,
24 'diagnostics not tripped up by "use base qw(Dont::Exist)"');
8b56d6ff 25
2dde0467 26open *whatever, ">", \my $warning
8b56d6ff 27 or die "Couldn't redirect STDERR to var: $!";
2dde0467
FC
28my $old_stderr = *STDERR{IO};
29*STDERR = *whatever{IO};
30
31# Test for %.0f patterns in perldiag, added in 5.11.0
8b56d6ff
FC
32warn('gmtime(nan) too large');
33like $warning, qr/\(W overflow\) You called/, '%0.f patterns';
4b056c06
FC
34
35# L<foo/bar> links
36seek STDERR, 0,0;
37$warning = '';
38warn("accept() on closed socket spanner");
39like $warning, qr/"accept" in perlfunc/, 'L<foo/bar> links';
40
41# L<foo|bar/baz> links
42seek STDERR, 0,0;
43$warning = '';
44warn
45 'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input';
3d6c5fec 46like $warning, qr/lex_stuff_pvn or similar/, 'L<foo|bar/baz>';
f4739a71
FC
47
48# Multiple messages with the same description
49seek STDERR, 0,0;
50$warning = '';
b6a06234 51warn 'Code point 0xBEE5 is not Unicode, may not be portable';
989843c8 52like $warning, qr/S utf8/,
f4739a71
FC
53 'Message sharing its description with the following message';
54
c0d3a21f
MH
55# Periods at end of entries in perldiag.pod get matched correctly
56seek STDERR, 0,0;
57$warning = '';
58warn "Execution of -e aborted due to compilation errors.\n";
59like $warning, qr/The final summary message/, 'Periods at end of line';
e958e573 60
e958e573
MH
61# Test for %d/%u
62seek STDERR, 0,0;
63$warning = '';
64warn "Bad arg length for us, is 4, should be 42";
65like $warning, qr/In C parlance/, '%u works';
524e9188 66
b6a06234
FC
67# Test for %X
68seek STDERR, 0,0;
69$warning = '';
70warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
71like $warning, qr/You had a UTF-16 surrogate/, '%X';
72
01bfea8b
FC
73# Test for %p
74seek STDERR, 0,0;
75$warning = '';
76warn "Slab leaked from cv fadedc0ffee";
77like $warning, qr/bookkeeping of op trees/, '%p';
78
524e9188
MH
79# Strip S<>
80seek STDERR, 0,0;
81$warning = '';
82warn "syntax error";
83like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>';
2dde0467 84
33327ed8
FC
85# Errors ending with dots
86seek STDERR, 0,0;
87$warning = '';
0a437bc9
FC
88warn "I had compilation errors.\n";
89like $warning, qr/final summary message/, 'dotty errors';
90
91# Multiline errors
92seek STDERR, 0,0;
93$warning = '';
94warn "Attempt to reload weapon aborted.\nCompilation failed in require";
95like $warning,
96 qr/You tried to load a file.*Perl could not compile/s,
97 'multiline errors';
33327ed8 98
6fbc9859
MH
99# Multiline entry in perldiag.pod
100seek STDERR, 0,0;
101$warning = '';
102warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/";
103like $warning,
104 qr/A charnames handler may return a sequence/s,
105 'multi-line entries in perldiag.pod match';
106
107# ; at end of entry in perldiag.pod
108seek STDERR, 0,0;
109$warning = '';
b33c0c71 110warn "Perl folding rules are not up-to-date for 0xA; please use the perlbug utility to report; in regex; marked by <-- HERE in m/\ <-- HERE q/";
6fbc9859 111like $warning,
80f78131 112 qr/You used a regular expression with case-insensitive matching/s,
6fbc9859
MH
113 '; works at the end of entries in perldiag.pod';
114
115# Differences in spaces in warnings (Why not be nice and accept them?)
116seek STDERR, 0,0;
117$warning = '';
118warn "Assignment to both a list and a scalar\n";
119like $warning,
120 qr/2nd and 3rd/s,
121 'spaces in warnings are matched lightly';
122
123# Differences in spaces in warnings with a period at the end
124seek STDERR, 0,0;
125$warning = '';
126warn "perl: warning: Setting locale failed.\n";
127like $warning,
128 qr/The whole warning/s,
129 'spaces in warnings with periods at the end are matched lightly';
130
e4e60719
FC
131# Wrapped links
132seek STDERR, 0,0;
133$warning = '';
134warn "Argument \"%s\" treated as 0 in increment (++)";
135like $warning,
136 qr/Auto-increment.*Auto-decrement/s,
137 'multiline links are not truncated';
138
f1deee33
MH
139{
140# Find last warning in perldiag.pod, and last items if any
141 my $lw;
142 my $inlast;
143 my $item;
144
145 open(my $f, '<', "pod/perldiag.pod")
146 or die "failed to open pod/perldiag.pod for reading: $!";
147
148 while (<$f>) {
149 if ( /^=item\s+(.*)/) {
150 $lw = $1;
151 } elsif (/^=back/) {
152 $inlast = 1;
153 } elsif ($inlast) {
154 # Skip headings
155 next if /^=/;
156
157 # Strip specials
158 $_ =~ s/\w<(.*?)>/$1/g;
159
160 # And whitespace
161 $_ =~ s/(^\s+|\s+$)//g;
162
163 if ($_) {
164 $item = $_;
165
166 last;
167 }
168 }
169 }
170 close($f);
171
172 ok($item, "(sanity...) found an item to check with ($item)");
173 seek STDERR, 0,0;
174 $warning = '';
175 warn $lw;
176 ok($warning, '(sanity...) got a warning');
177 unlike $warning,
178 qr/\Q$item\E/,
179 "Junk after =back doesn't show up in last warning";
180}
6fbc9859 181
2dde0467
FC
182*STDERR = $old_stderr;
183
184# These tests use a panic under the hope that the description is not likely
185# to change.
186@runperl_args = (
187 switches => [ '-Ilib', '-Mdiagnostics' ],
188 stderr => 1,
189 nolib => 1, # -I../lib would go outside the build dir
190);
191$subs =
192 "sub foo{bar()}sub bar{baz()}sub baz{die q _panic: gremlins_}foo()";
193is runperl(@runperl_args, prog => $subs),
194 << 'EOT', 'internal error with backtrace';
195panic: gremlins at -e line 1 (#1)
196 (P) An internal error.
197
198Uncaught exception from user code:
199 panic: gremlins at -e line 1.
200 main::baz() called at -e line 1
201 main::bar() called at -e line 1
202 main::foo() called at -e line 1
203EOT
204is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r),
205 << 'EOU', 'user error with backtrace';
206Uncaught exception from user code:
207 panick: 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
211EOU
212is runperl(@runperl_args, prog => 'die q _panic: gremlins_'),
213 << 'EOV', 'no backtrace from top-level internal error';
214panic: gremlins at -e line 1 (#1)
215 (P) An internal error.
216
217Uncaught exception from user code:
218 panic: gremlins at -e line 1.
219EOV
220is runperl(@runperl_args, prog => 'die q _panick: gremlins_'),
221 << 'EOW', 'no backtrace from top-level user error';
222Uncaught exception from user code:
223 panick: gremlins at -e line 1.
224EOW
245e6c67
FC
225like runperl(
226 @runperl_args,
227 prog => $subs =~
f5aea3e0
NC
228 s[q _panic: gremlins_]
229 [qq _Attempt to reload foo aborted.\\nCompilation failed in require_]r,
245e6c67
FC
230 ),
231 qr/Uncaught exception from user code:
232 Attempt to reload foo aborted\.
233 Compilation failed in require at -e line \d+\.
234 main::baz\(\) called at -e line \d+
235 main::bar\(\) called at -e line \d+
236 main::foo\(\) called at -e line \d+
237/, 'backtrace from multiline error';
d271dac9
FC
238is runperl(@runperl_args, prog => 'BEGIN { die q _panic: gremlins_ }'),
239 << 'EOX', 'BEGIN{die} does not suppress diagnostics';
240panic: gremlins at -e line 1.
241BEGIN failed--compilation aborted at -e line 1 (#1)
242 (P) An internal error.
243
244Uncaught exception from user code:
245 panic: gremlins at -e line 1.
246 BEGIN failed--compilation aborted at -e line 1.
247EOX