This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f3bd9f07aec4ab5d7471b60f184b83ad71d6d4c2
[perl5.git] / lib / warnings / register.t
1 #!./perl
2
3 BEGIN {
4         chdir 't' if -d 't';
5         @INC = '../lib';
6 }
7
8 # this package has to be compiled first
9 package WarnTest;
10
11 use warnings;
12 use warnings::register;
13
14 my $status;
15 sub report {
16         $status = warnings::enabled() ? 1 : 0;
17 }
18
19 sub odd_even {
20         my $num = shift;
21         warnings::warn('Odd number') if warnings::enabled() and $num % 2;
22 }
23
24 sub odd_even_strict {
25         warnings::warnif('numeric', 'Odd number') if $_[0] % 2;
26 }
27
28 sub disabled {
29         ! warnings::enabled();
30 }
31
32 sub category {
33         warnings::warnif('closure', 'closures are neat');
34         warnings::warnif('misc', 'Larry was here');
35         warnings::warnif('void', '3.2 kilograms');
36 }
37
38 package main;
39
40 use Test::More tests => 10;
41
42 use_ok( 'warnings', 'WarnTest' );
43 use_ok( 'warnings::register' );
44
45 my $err;
46
47 # it's nice to trap these
48 local $SIG{__WARN__} = sub {
49         $err = $_[0];
50 };
51
52 # try to trigger warning condition, first should not warn, second should
53 WarnTest::odd_even(2);
54 is( $err, '', 'no unexpected warning' );
55 WarnTest::odd_even(3);
56 like( $err, qr/^Odd number/, 'expected warning' );
57
58 $err = '';
59
60 # now disable warnings
61 no warnings 'WarnTest';
62 WarnTest::odd_even(5);
63 is( $err, '', 'no unexpected warning with disabled warnings' );
64
65 # check to see if warnings really are disabled
66 ok( WarnTest::disabled(), 'yep, warnings really are disabled' );
67
68 # now let's check lexical warnings
69 no warnings;
70 use warnings 'numeric';
71
72 # enable only one category
73 {
74         use warnings 'misc';
75         WarnTest::category();
76         like( $err, qr/^Larry/, 'warning category works' );
77
78         # now enable this category, it should overwrite the Larry warning
79         use warnings 'void';
80         WarnTest::category();
81         like( $err, qr/^3.2 kilograms/, 'warning category still works' );
82 }
83
84 # and outside of the block, we should only get the odd_even warning
85 WarnTest::odd_even_strict(7);
86 WarnTest::category();
87 like( $err, qr/^Odd number/, 'warning scope appears to work' );
88
89 # and finally, fatal warnings
90 use warnings FATAL => 'WarnTest';
91 eval { WarnTest::odd_even(9) };
92 like( $@, qr/^Odd number/, 'fatal warnings work too' );
93