| 1 | #!./perl -w |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir '..' if -d '../pod' && -d '../t'; |
| 5 | @INC = 'lib'; |
| 6 | } |
| 7 | |
| 8 | use Test::More tests => 10; |
| 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 | # Test for %.0f patterns in perldiag, added in 5.11.0 |
| 26 | close STDERR; |
| 27 | open STDERR, ">", \my $warning |
| 28 | or die "Couldn't redirect STDERR to var: $!"; |
| 29 | warn('gmtime(nan) too large'); |
| 30 | like $warning, qr/\(W overflow\) You called/, '%0.f patterns'; |
| 31 | |
| 32 | # L<foo/bar> links |
| 33 | seek STDERR, 0,0; |
| 34 | $warning = ''; |
| 35 | warn("accept() on closed socket spanner"); |
| 36 | like $warning, qr/"accept" in perlfunc/, 'L<foo/bar> links'; |
| 37 | |
| 38 | # L<foo|bar/baz> links |
| 39 | seek STDERR, 0,0; |
| 40 | $warning = ''; |
| 41 | warn |
| 42 | 'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input'; |
| 43 | like $warning, qr/using lex_stuff_pvn or similar/, 'L<foo|bar/baz>'; |
| 44 | |
| 45 | # Multiple messages with the same description |
| 46 | seek STDERR, 0,0; |
| 47 | $warning = ''; |
| 48 | warn 'Code point 0x%X is not Unicode, may not be portable'; |
| 49 | like $warning, qr/W utf8/, |
| 50 | 'Message sharing its description with the following message'; |
| 51 | |
| 52 | # Periods at end of entries in perldiag.pod get matched correctly |
| 53 | seek STDERR, 0,0; |
| 54 | $warning = ''; |
| 55 | warn "Execution of -e aborted due to compilation errors.\n"; |
| 56 | like $warning, qr/The final summary message/, 'Periods at end of line'; |
| 57 | |
| 58 | # Test for %d/%u |
| 59 | seek STDERR, 0,0; |
| 60 | $warning = ''; |
| 61 | warn "Bad arg length for us, is 4, should be 42"; |
| 62 | like $warning, qr/In C parlance/, '%u works'; |
| 63 | |
| 64 | # Strip S<> |
| 65 | seek STDERR, 0,0; |
| 66 | $warning = ''; |
| 67 | warn "syntax error"; |
| 68 | like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>'; |