X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d23f020529b1cb2636f0fbed24f1fc13fd63eac2..928480e1f38a257c36460dc5cbc8d2c8af177686:/lib/diagnostics.t diff --git a/lib/diagnostics.t b/lib/diagnostics.t index 486f8f6..6521df2 100644 --- a/lib/diagnostics.t +++ b/lib/diagnostics.t @@ -1,13 +1,18 @@ -#!./perl +#!./perl -w BEGIN { chdir '..' if -d '../pod' && -d '../t'; @INC = 'lib'; + require './t/test.pl'; + plan(31); } -use Test::More tests => 2; - -BEGIN { use_ok('diagnostics') } +BEGIN { + my $w; + $SIG{__WARN__} = sub { $w = shift }; + use_ok('diagnostics'); + is $w, undef, 'no warnings when loading diagnostics.pm'; +} require base; @@ -15,4 +20,248 @@ eval { 'base'->import(qw(I::do::not::exist)); }; -is( $@, '', 'diagnostics not tripped up by "use base qw(Dont::Exist)"' ); +like( $@, qr/^Base class package "I::do::not::exist" is empty/, + 'diagnostics not tripped up by "use base qw(Dont::Exist)"'); + +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 links +seek STDERR, 0,0; +$warning = ''; +warn("accept() on closed socket spanner"); +like $warning, qr/"accept" in perlfunc/, 'L links'; + +# L links +seek STDERR, 0,0; +$warning = ''; +warn + 'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input'; +like $warning, qr/lex_stuff_pvn or similar/, 'L'; + +# Multiple messages with the same description +seek STDERR, 0,0; +$warning = ''; +warn 'Deep recursion on anonymous subroutine'; +like $warning, qr/W recursion/, + 'Message sharing its description with the following message'; +seek STDERR, 0,0; +$warning = ''; +warn 'Deep recursion on subroutine "foo"'; +like $warning, qr/W recursion/, + 'Message sharing its description with the preceding 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'; + +# Test for %p +seek STDERR, 0,0; +$warning = ''; +warn "Slab leaked from cv fadedc0ffee"; +like $warning, qr/bookkeeping of op trees/, '%p'; + +# 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'; + +# Multiline entry in perldiag.pod +seek STDERR, 0,0; +$warning = ''; +warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/"; +like $warning, + qr/Named Unicode character escapes/s, + 'multi-line entries in perldiag.pod match'; + +# ; at end of entry in perldiag.pod +seek STDERR, 0,0; +$warning = ''; +warn "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/"; +like $warning, + qr/You used a regular expression with case-insensitive matching/s, + '; works at the end of entries in perldiag.pod'; + +# Differences in spaces in warnings (Why not be nice and accept them?) +seek STDERR, 0,0; +$warning = ''; +warn "Assignment to both a list and a scalar\n"; +like $warning, + qr/2nd and 3rd/s, + 'spaces in warnings are matched lightly'; + +# Differences in spaces in warnings with a period at the end +seek STDERR, 0,0; +$warning = ''; +warn "perl: warning: Setting locale failed.\n"; +like $warning, + qr/The whole warning/s, + 'spaces in warnings with periods at the end are matched lightly'; + +# Wrapped links +seek STDERR, 0,0; +$warning = ''; +warn "Argument \"%s\" treated as 0 in increment (++)"; +like $warning, + qr/Auto-increment.*Auto-decrement/s, + 'multiline links are not truncated'; + +{ +# Find last warning in perldiag.pod, and last items if any + my $lw; + my $over_level = 0; + my $inlast; + my $item; + my $items_not_in_overs = 0; + + open(my $f, '<', "pod/perldiag.pod") + or die "failed to open pod/perldiag.pod for reading: $!"; + + while (<$f>) { + + # We only look for entries (=item lines) in the first level of =overs + + if ( /^=over\b/) { + $over_level++; + } elsif ( /^=item\s+(.*)/) { + if ($over_level < 1) { + $items_not_in_overs++; + } + elsif ($over_level == 1) { + $lw = $1; + } + } elsif (/^=back\b/) { + $inlast = 1 if $over_level == 1; + $over_level--; + } elsif ($inlast) { + # Skip headings + next if /^=/; + + # Strip specials + $_ =~ s/\w<(.*?)>/$1/g; + + # And whitespace + $_ =~ s/(^\s+|\s+$)//g; + + if ($_) { + $item = $_; + + last; + } + } + } + close($f); + + is($over_level, 0, "(sanity...) =over balanced with =back (off by $over_level)"); + is($items_not_in_overs, 0, "(sanity...) all =item lines are within =over..=back blocks"); + ok($item, "(sanity...) found an item to check with ($item)"); + seek STDERR, 0,0; + $warning = ''; + warn $lw; + ok($warning, '(sanity...) got a warning'); + unlike $warning, + qr/\Q$item\E/, + "Junk after =back doesn't show up in last warning"; +} + +*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'; +is runperl(@runperl_args, prog => 'BEGIN { die q _panic: gremlins_ }'), + << 'EOX', 'BEGIN{die} does not suppress diagnostics'; +panic: gremlins at -e line 1. +BEGIN failed--compilation aborted at -e line 1 (#1) + (P) An internal error. + +Uncaught exception from user code: + panic: gremlins at -e line 1. + BEGIN failed--compilation aborted at -e line 1. +EOX