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(18);
   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
  25 open *whatever, ">", \my $warning
  26     or die "Couldn't redirect STDERR to var: $!";
  27 my $old_stderr = *STDERR{IO};
  28 *STDERR = *whatever{IO};
  29
  30 # Test for %.0f patterns in perldiag, added in 5.11.0
  31 warn('gmtime(nan) too large');
  32 like $warning, qr/\(W overflow\) You called/, '%0.f patterns';
  33
  34 # L<foo/bar> links
  35 seek STDERR, 0,0;
  36 $warning = '';
  37 warn("accept() on closed socket spanner");
  38 like $warning, qr/"accept" in perlfunc/, 'L<foo/bar> links';
  39
  40 # L<foo|bar/baz> links
  41 seek STDERR, 0,0;
  42 $warning = '';
  43 warn
  44  'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input';
  45 like $warning, qr/using lex_stuff_pvn or similar/, 'L<foo|bar/baz>';
  46
  47 # Multiple messages with the same description
  48 seek STDERR, 0,0;
  49 $warning = '';
  50 warn 'Code point 0xBEE5 is not Unicode, may not be portable';
  51 like $warning, qr/W utf8/,
  52    'Message sharing its description with the following message';
  53
  54 # Periods at end of entries in perldiag.pod get matched correctly
  55 seek STDERR, 0,0;
  56 $warning = '';
  57 warn "Execution of -e aborted due to compilation errors.\n";
  58 like $warning, qr/The final summary message/, 'Periods at end of line';
  59
  60 # Test for %d/%u
  61 seek STDERR, 0,0;
  62 $warning = '';
  63 warn "Bad arg length for us, is 4, should be 42";
  64 like $warning, qr/In C parlance/, '%u works';
  65
  66 # Test for %X
  67 seek STDERR, 0,0;
  68 $warning = '';
  69 warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
  70 like $warning, qr/You had a UTF-16 surrogate/, '%X';
  71
  72 # Strip S<>
  73 seek STDERR, 0,0;
  74 $warning = '';
  75 warn "syntax error";
  76 like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>';
  77
  78 # Errors ending with dots
  79 seek STDERR, 0,0;
  80 $warning = '';
  81 warn "I had compilation errors.\n";
  82 like $warning, qr/final summary message/, 'dotty errors';
  83
  84 # Multiline errors
  85 seek STDERR, 0,0;
  86 $warning = '';
  87 warn "Attempt to reload weapon aborted.\nCompilation failed in require";
  88 like $warning,
  89      qr/You tried to load a file.*Perl could not compile/s,
  90     'multiline errors';
  91
  92 *STDERR = $old_stderr;
  93
  94 # These tests use a panic under the hope that the description is not likely
  95 # to change.
  96 @runperl_args = (
  97         switches => [ '-Ilib', '-Mdiagnostics' ],
  98         stderr => 1,
  99         nolib => 1, # -I../lib would go outside the build dir
 100 );
 101 $subs =
 102  "sub foo{bar()}sub bar{baz()}sub baz{die q _panic: gremlins_}foo()";
 103 is runperl(@runperl_args, prog => $subs),
 104    << 'EOT', 'internal error with backtrace';
 105 panic: gremlins at -e line 1 (#1)
 106     (P) An internal error.
 107
 108 Uncaught exception from user code:
 109         panic: gremlins at -e line 1.
 110         main::baz() called at -e line 1
 111         main::bar() called at -e line 1
 112         main::foo() called at -e line 1
 113 EOT
 114 is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r),
 115    << 'EOU', 'user error with backtrace';
 116 Uncaught exception from user code:
 117         panick: gremlins at -e line 1.
 118         main::baz() called at -e line 1
 119         main::bar() called at -e line 1
 120         main::foo() called at -e line 1
 121 EOU
 122 is runperl(@runperl_args, prog => 'die q _panic: gremlins_'),
 123    << 'EOV', 'no backtrace from top-level internal error';
 124 panic: gremlins at -e line 1 (#1)
 125     (P) An internal error.
 126
 127 Uncaught exception from user code:
 128         panic: gremlins at -e line 1.
 129 EOV
 130 is runperl(@runperl_args, prog => 'die q _panick: gremlins_'),
 131    << 'EOW', 'no backtrace from top-level user error';
 132 Uncaught exception from user code:
 133         panick: gremlins at -e line 1.
 134 EOW
 135 like runperl(
 136       @runperl_args,
 137       prog => $subs =~
 138          s[q _panic: gremlins_]
 139           [qq _Attempt to reload foo aborted.\\nCompilation failed in require_]r,
 140      ),
 141      qr/Uncaught exception from user code:
 142         Attempt to reload foo aborted\.
 143         Compilation failed in require at -e line \d+\.
 144         main::baz\(\) called at -e line \d+
 145         main::bar\(\) called at -e line \d+
 146         main::foo\(\) called at -e line \d+
 147 /,  'backtrace from multiline error';