This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a7e31e110f45c21be5a5b85f33a3d836d2d7ea8a
[perl5.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(25);
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 'Code point 0xBEE5 is not Unicode, may not be portable';
52 like $warning, qr/S utf8/,
53    'Message sharing its description with the following message';
54
55 # Periods at end of entries in perldiag.pod get matched correctly
56 seek STDERR, 0,0;
57 $warning = '';
58 warn "Execution of -e aborted due to compilation errors.\n";
59 like $warning, qr/The final summary message/, 'Periods at end of line';
60
61 # Test for %d/%u
62 seek STDERR, 0,0;
63 $warning = '';
64 warn "Bad arg length for us, is 4, should be 42";
65 like $warning, qr/In C parlance/, '%u works';
66
67 # Test for %X
68 seek STDERR, 0,0;
69 $warning = '';
70 warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
71 like $warning, qr/You had a UTF-16 surrogate/, '%X';
72
73 # Test for %p
74 seek STDERR, 0,0;
75 $warning = '';
76 warn "Slab leaked from cv fadedc0ffee";
77 like $warning, qr/bookkeeping of op trees/, '%p';
78
79 # Strip S<>
80 seek STDERR, 0,0;
81 $warning = '';
82 warn "syntax error";
83 like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>';
84
85 # Errors ending with dots
86 seek STDERR, 0,0;
87 $warning = '';
88 warn "I had compilation errors.\n";
89 like $warning, qr/final summary message/, 'dotty errors';
90
91 # Multiline errors
92 seek STDERR, 0,0;
93 $warning = '';
94 warn "Attempt to reload weapon aborted.\nCompilation failed in require";
95 like $warning,
96      qr/You tried to load a file.*Perl could not compile/s,
97     'multiline errors';
98
99 # Multiline entry in perldiag.pod
100 seek STDERR, 0,0;
101 $warning = '';
102 warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/";
103 like $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
108 seek STDERR, 0,0;
109 $warning = '';
110 warn "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/";
111 like $warning,
112     qr/You used a regular expression with case-insensitive matching/s,
113     '; works at the end of entries in perldiag.pod';
114
115 # Differences in spaces in warnings (Why not be nice and accept them?)
116 seek STDERR, 0,0;
117 $warning = '';
118 warn "Assignment     to both a list and a scalar\n";
119 like $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
124 seek STDERR, 0,0;
125 $warning = '';
126 warn "perl: warning: Setting locale failed.\n";
127 like $warning,
128     qr/The whole warning/s,
129     'spaces in warnings with periods at the end are matched lightly';
130
131 # Wrapped links
132 seek STDERR, 0,0;
133 $warning = '';
134 warn "Argument \"%s\" treated as 0 in increment (++)";
135 like $warning,
136     qr/Auto-increment.*Auto-decrement/s,
137     'multiline links are not truncated';
138
139
140 *STDERR = $old_stderr;
141
142 # These tests use a panic under the hope that the description is not likely
143 # to change.
144 @runperl_args = (
145         switches => [ '-Ilib', '-Mdiagnostics' ],
146         stderr => 1,
147         nolib => 1, # -I../lib would go outside the build dir
148 );
149 $subs =
150  "sub foo{bar()}sub bar{baz()}sub baz{die q _panic: gremlins_}foo()";
151 is runperl(@runperl_args, prog => $subs),
152    << 'EOT', 'internal error with backtrace';
153 panic: gremlins at -e line 1 (#1)
154     (P) An internal error.
155     
156 Uncaught exception from user code:
157         panic: gremlins at -e line 1.
158         main::baz() called at -e line 1
159         main::bar() called at -e line 1
160         main::foo() called at -e line 1
161 EOT
162 is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r),
163    << 'EOU', 'user error with backtrace';
164 Uncaught exception from user code:
165         panick: gremlins at -e line 1.
166         main::baz() called at -e line 1
167         main::bar() called at -e line 1
168         main::foo() called at -e line 1
169 EOU
170 is runperl(@runperl_args, prog => 'die q _panic: gremlins_'),
171    << 'EOV', 'no backtrace from top-level internal error';
172 panic: gremlins at -e line 1 (#1)
173     (P) An internal error.
174     
175 Uncaught exception from user code:
176         panic: gremlins at -e line 1.
177 EOV
178 is runperl(@runperl_args, prog => 'die q _panick: gremlins_'),
179    << 'EOW', 'no backtrace from top-level user error';
180 Uncaught exception from user code:
181         panick: gremlins at -e line 1.
182 EOW
183 like runperl(
184       @runperl_args,
185       prog => $subs =~
186          s[q _panic: gremlins_]
187           [qq _Attempt to reload foo aborted.\\nCompilation failed in require_]r,
188      ),
189      qr/Uncaught exception from user code:
190         Attempt to reload foo aborted\.
191         Compilation failed in require at -e line \d+\.
192         main::baz\(\) called at -e line \d+
193         main::bar\(\) called at -e line \d+
194         main::foo\(\) called at -e line \d+
195 /,  'backtrace from multiline error';
196 is runperl(@runperl_args, prog => 'BEGIN { die q _panic: gremlins_ }'),
197    << 'EOX', 'BEGIN{die} does not suppress diagnostics';
198 panic: gremlins at -e line 1.
199 BEGIN failed--compilation aborted at -e line 1 (#1)
200     (P) An internal error.
201     
202 Uncaught exception from user code:
203         panic: gremlins at -e line 1.
204         BEGIN failed--compilation aborted at -e line 1.
205 EOX