| 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'; |