Upgrade version from version 0.9916 to 0.9917
[perl.git] / lib / diagnostics.t
1 #!./perl -w
2
3 BEGIN {
4     chdir '..' if -d '../pod' && -d '../t';
5     @INC = 'lib';
6     require './t/test.pl';
7     plan(31);
8 }
9
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 }
16
17 require base;
18
19 eval {
20     'base'->import(qw(I::do::not::exist));
21 };
22
23 like( $@, qr/^Base class package "I::do::not::exist" is empty/,
24          'diagnostics not tripped up by "use base qw(Dont::Exist)"');
25
26 open *whatever, ">", \my $warning
27     or die "Couldn't redirect STDERR to var: $!";
28 my $old_stderr = *STDERR{IO};
29 *STDERR = *whatever{IO};
30
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';
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';
46 like $warning, qr/lex_stuff_pvn or similar/, 'L<foo|bar/baz>';
47
48 # Multiple messages with the same description
49 seek STDERR, 0,0;
50 $warning = '';
51 warn 'Deep recursion on anonymous subroutine';
52 like $warning, qr/W recursion/,
53    'Message sharing its description with the following message';
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';
59
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';
65
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';
71
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
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
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<>';
89
90 # Errors ending with dots
91 seek STDERR, 0,0;
92 $warning = '';
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';
103
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,
109     qr/Named Unicode character escapes/s,
110     'multi-line entries in perldiag.pod match';
111
112 # ; at end of entry in perldiag.pod
113 seek STDERR, 0,0;
114 $warning = '';
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/";
116 like $warning,
117     qr/You used a regular expression with case-insensitive matching/s,
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
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
144 {
145 # Find last warning in perldiag.pod, and last items if any
146     my $lw;
147     my $over_level = 0;
148     my $inlast;
149     my $item;
150     my $items_not_in_overs = 0;
151
152     open(my $f, '<', "pod/perldiag.pod")
153         or die "failed to open pod/perldiag.pod for reading: $!";
154
155     while (<$f>) {
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--;
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
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");
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 }
201
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
245 like runperl(
246       @runperl_args,
247       prog => $subs =~
248          s[q _panic: gremlins_]
249           [qq _Attempt to reload foo aborted.\\nCompilation failed in require_]r,
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';
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