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