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