1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
#!./perl -w
BEGIN {
chdir '..' if -d '../pod' && -d '../t';
@INC = 'lib';
require './t/test.pl';
plan(18);
}
BEGIN {
my $w;
$SIG{__WARN__} = sub { $w = shift };
use_ok('diagnostics');
is $w, undef, 'no warnings when loading diagnostics.pm';
}
require base;
eval {
'base'->import(qw(I::do::not::exist));
};
like( $@, qr/^Base class package "I::do::not::exist" is empty/);
open *whatever, ">", \my $warning
or die "Couldn't redirect STDERR to var: $!";
my $old_stderr = *STDERR{IO};
*STDERR = *whatever{IO};
# Test for %.0f patterns in perldiag, added in 5.11.0
warn('gmtime(nan) too large');
like $warning, qr/\(W overflow\) You called/, '%0.f patterns';
# L<foo/bar> links
seek STDERR, 0,0;
$warning = '';
warn("accept() on closed socket spanner");
like $warning, qr/"accept" in perlfunc/, 'L<foo/bar> links';
# L<foo|bar/baz> links
seek STDERR, 0,0;
$warning = '';
warn
'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input';
like $warning, qr/using lex_stuff_pvn or similar/, 'L<foo|bar/baz>';
# Multiple messages with the same description
seek STDERR, 0,0;
$warning = '';
warn 'Code point 0xBEE5 is not Unicode, may not be portable';
like $warning, qr/W utf8/,
'Message sharing its description with the following message';
# Periods at end of entries in perldiag.pod get matched correctly
seek STDERR, 0,0;
$warning = '';
warn "Execution of -e aborted due to compilation errors.\n";
like $warning, qr/The final summary message/, 'Periods at end of line';
# Test for %d/%u
seek STDERR, 0,0;
$warning = '';
warn "Bad arg length for us, is 4, should be 42";
like $warning, qr/In C parlance/, '%u works';
# Test for %X
seek STDERR, 0,0;
$warning = '';
warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
like $warning, qr/You had a UTF-16 surrogate/, '%X';
# Strip S<>
seek STDERR, 0,0;
$warning = '';
warn "syntax error";
like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>';
# Errors ending with dots
seek STDERR, 0,0;
$warning = '';
warn "I had compilation errors.\n";
like $warning, qr/final summary message/, 'dotty errors';
# Multiline errors
seek STDERR, 0,0;
$warning = '';
warn "Attempt to reload weapon aborted.\nCompilation failed in require";
like $warning,
qr/You tried to load a file.*Perl could not compile/s,
'multiline errors';
*STDERR = $old_stderr;
# These tests use a panic under the hope that the description is not likely
# to change.
@runperl_args = (
switches => [ '-Ilib', '-Mdiagnostics' ],
stderr => 1,
nolib => 1, # -I../lib would go outside the build dir
);
$subs =
"sub foo{bar()}sub bar{baz()}sub baz{die q _panic: gremlins_}foo()";
is runperl(@runperl_args, prog => $subs),
<< 'EOT', 'internal error with backtrace';
panic: gremlins at -e line 1 (#1)
(P) An internal error.
Uncaught exception from user code:
panic: gremlins at -e line 1.
main::baz() called at -e line 1
main::bar() called at -e line 1
main::foo() called at -e line 1
EOT
is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r),
<< 'EOU', 'user error with backtrace';
Uncaught exception from user code:
panick: gremlins at -e line 1.
main::baz() called at -e line 1
main::bar() called at -e line 1
main::foo() called at -e line 1
EOU
is runperl(@runperl_args, prog => 'die q _panic: gremlins_'),
<< 'EOV', 'no backtrace from top-level internal error';
panic: gremlins at -e line 1 (#1)
(P) An internal error.
Uncaught exception from user code:
panic: gremlins at -e line 1.
EOV
is runperl(@runperl_args, prog => 'die q _panick: gremlins_'),
<< 'EOW', 'no backtrace from top-level user error';
Uncaught exception from user code:
panick: gremlins at -e line 1.
EOW
like runperl(
@runperl_args,
prog => $subs =~
s[q _panic: gremlins_]
[qq _Attempt to reload foo aborted.\\nCompilation failed in require_]r,
),
qr/Uncaught exception from user code:
Attempt to reload foo aborted\.
Compilation failed in require at -e line \d+\.
main::baz\(\) called at -e line \d+
main::bar\(\) called at -e line \d+
main::foo\(\) called at -e line \d+
/, 'backtrace from multiline error';
|
