1#!./perl -w 2 3BEGIN { 4 chdir '..' if -d '../pod' && -d '../t'; 5 @INC = 'lib'; 6 require './t/test.pl'; 7 plan(31); 8} 9 10BEGIN { 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 17require base; 18 19eval { 20 'base'->import(qw(I::do::not::exist)); 21}; 22 23like( $@, qr/^Base class package "I::do::not::exist" is empty/, 24 'diagnostics not tripped up by "use base qw(Dont::Exist)"'); 25 26open *whatever, ">", \my $warning 27 or die "Couldn't redirect STDERR to var: $!"; 28my $old_stderr = *STDERR{IO}; 29*STDERR = *whatever{IO}; 30 31# Test for %.0f patterns in perldiag, added in 5.11.0 32warn('gmtime(nan) too large'); 33like $warning, qr/\(W overflow\) You called/, '%0.f patterns'; 34 35# L<foo/bar> links 36seek STDERR, 0,0; 37$warning = ''; 38warn("accept() on closed socket spanner"); 39like $warning, qr/"accept" in perlfunc/, 'L<foo/bar> links'; 40 41# L<foo|bar/baz> links 42seek STDERR, 0,0; 43$warning = ''; 44warn 45 'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input'; 46like $warning, qr/lex_stuff_pvn or similar/, 'L<foo|bar/baz>'; 47 48# Multiple messages with the same description 49seek STDERR, 0,0; 50$warning = ''; 51warn 'Deep recursion on anonymous subroutine'; 52like $warning, qr/W recursion/, 53 'Message sharing its description with the following message'; 54seek STDERR, 0,0; 55$warning = ''; 56warn 'Deep recursion on subroutine "foo"'; 57like $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 61seek STDERR, 0,0; 62$warning = ''; 63warn "Execution of -e aborted due to compilation errors.\n"; 64like $warning, qr/The final summary message/, 'Periods at end of line'; 65 66# Test for %d/%u 67seek STDERR, 0,0; 68$warning = ''; 69warn "Bad arg length for us, is 4, should be 42"; 70like $warning, qr/In C parlance/, '%u works'; 71 72# Test for %X 73seek STDERR, 0,0; 74$warning = ''; 75warn "Unicode surrogate U+C0FFEE is illegal in UTF-8"; 76like $warning, qr/You had a UTF-16 surrogate/, '%X'; 77 78# Test for %p 79seek STDERR, 0,0; 80$warning = ''; 81warn "Slab leaked from cv fadedc0ffee"; 82like $warning, qr/bookkeeping of op trees/, '%p'; 83 84# Strip S<> 85seek STDERR, 0,0; 86$warning = ''; 87warn "syntax error"; 88like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>'; 89 90# Errors ending with dots 91seek STDERR, 0,0; 92$warning = ''; 93warn "I had compilation errors.\n"; 94like $warning, qr/final summary message/, 'dotty errors'; 95 96# Multiline errors 97seek STDERR, 0,0; 98$warning = ''; 99warn "Attempt to reload weapon aborted.\nCompilation failed in require"; 100like $warning, 101 qr/You tried to load a file.*Perl could not compile/s, 102 'multiline errors'; 103 104# Multiline entry in perldiag.pod 105seek STDERR, 0,0; 106$warning = ''; 107warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/"; 108like $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 113seek STDERR, 0,0; 114$warning = ''; 115warn "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/"; 116like $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?) 121seek STDERR, 0,0; 122$warning = ''; 123warn "Assignment to both a list and a scalar\n"; 124like $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 129seek STDERR, 0,0; 130$warning = ''; 131warn "perl: warning: Setting locale failed.\n"; 132like $warning, 133 qr/The whole warning/s, 134 'spaces in warnings with periods at the end are matched lightly'; 135 136# Wrapped links 137seek STDERR, 0,0; 138$warning = ''; 139warn "Argument \"%s\" treated as 0 in increment (++)"; 140like $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()"; 213is runperl(@runperl_args, prog => $subs), 214 << 'EOT', 'internal error with backtrace'; 215panic: gremlins at -e line 1 (#1) 216 (P) An internal error. 217 218Uncaught 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 223EOT 224is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r), 225 << 'EOU', 'user error with backtrace'; 226Uncaught 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 231EOU 232is runperl(@runperl_args, prog => 'die q _panic: gremlins_'), 233 << 'EOV', 'no backtrace from top-level internal error'; 234panic: gremlins at -e line 1 (#1) 235 (P) An internal error. 236 237Uncaught exception from user code: 238 panic: gremlins at -e line 1. 239EOV 240is runperl(@runperl_args, prog => 'die q _panick: gremlins_'), 241 << 'EOW', 'no backtrace from top-level user error'; 242Uncaught exception from user code: 243 panick: gremlins at -e line 1. 244EOW 245like 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'; 258is runperl(@runperl_args, prog => 'BEGIN { die q _panic: gremlins_ }'), 259 << 'EOX', 'BEGIN{die} does not suppress diagnostics'; 260panic: gremlins at -e line 1. 261BEGIN failed--compilation aborted at -e line 1 (#1) 262 (P) An internal error. 263 264Uncaught exception from user code: 265 panic: gremlins at -e line 1. 266 BEGIN failed--compilation aborted at -e line 1. 267EOX 268