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