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