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