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(24);
   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 'Code point 0xBEE5 is not Unicode, may not be portable';
  52 like $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
  56 seek STDERR, 0,0;
  57 $warning = '';
  58 warn "Execution of -e aborted due to compilation errors.\n";
  59 like $warning, qr/The final summary message/, 'Periods at end of line';
  60
  61 # Test for %d/%u
  62 seek STDERR, 0,0;
  63 $warning = '';
  64 warn "Bad arg length for us, is 4, should be 42";
  65 like $warning, qr/In C parlance/, '%u works';
  66
  67 # Test for %X
  68 seek STDERR, 0,0;
  69 $warning = '';
  70 warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
  71 like $warning, qr/You had a UTF-16 surrogate/, '%X';
  72
  73 # Test for %p
  74 seek STDERR, 0,0;
  75 $warning = '';
  76 warn "Slab leaked from cv fadedc0ffee";
  77 like $warning, qr/bookkeeping of op trees/, '%p';
  78
  79 # Strip S<>
  80 seek STDERR, 0,0;
  81 $warning = '';
  82 warn "syntax error";
  83 like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>';
  84
  85 # Errors ending with dots
  86 seek STDERR, 0,0;
  87 $warning = '';
  88 warn "I had compilation errors.\n";
  89 like $warning, qr/final summary message/, 'dotty errors';
  90
  91 # Multiline errors
  92 seek STDERR, 0,0;
  93 $warning = '';
  94 warn "Attempt to reload weapon aborted.\nCompilation failed in require";
  95 like $warning,
  96      qr/You tried to load a file.*Perl could not compile/s,
  97     'multiline errors';
  98
  99 # Multiline entry in perldiag.pod
 100 seek STDERR, 0,0;
 101 $warning = '';
 102 warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/";
 103 like $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
 108 seek STDERR, 0,0;
 109 $warning = '';
 110 warn "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/";
 111 like $warning,
 112     qr/You used a regular expression with case-insensitive matching/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?)
 116 seek STDERR, 0,0;
 117 $warning = '';
 118 warn "Assignment     to both a list and a scalar\n";
 119 like $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
 124 seek STDERR, 0,0;
 125 $warning = '';
 126 warn "perl: warning: Setting locale failed.\n";
 127 like $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()";
 143 is runperl(@runperl_args, prog => $subs),
 144    << 'EOT', 'internal error with backtrace';
 145 panic: gremlins at -e line 1 (#1)
 146     (P) An internal error.
 147
 148 Uncaught 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
 153 EOT
 154 is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r),
 155    << 'EOU', 'user error with backtrace';
 156 Uncaught 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
 161 EOU
 162 is runperl(@runperl_args, prog => 'die q _panic: gremlins_'),
 163    << 'EOV', 'no backtrace from top-level internal error';
 164 panic: gremlins at -e line 1 (#1)
 165     (P) An internal error.
 166
 167 Uncaught exception from user code:
 168         panic: gremlins at -e line 1.
 169 EOV
 170 is runperl(@runperl_args, prog => 'die q _panick: gremlins_'),
 171    << 'EOW', 'no backtrace from top-level user error';
 172 Uncaught exception from user code:
 173         panick: gremlins at -e line 1.
 174 EOW
 175 like 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';
 188 is runperl(@runperl_args, prog => 'BEGIN { die q _panic: gremlins_ }'),
 189    << 'EOX', 'BEGIN{die} does not suppress diagnostics';
 190 panic: gremlins at -e line 1.
 191 BEGIN failed--compilation aborted at -e line 1 (#1)
 192     (P) An internal error.
 193
 194 Uncaught exception from user code:
 195         panic: gremlins at -e line 1.
 196         BEGIN failed--compilation aborted at -e line 1.
 197 EOX