Commit | Line | Data |
---|---|---|
1930e939 TP |
1 | #!./perl |
2 | ||
1930e939 TP |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
1930e939 TP |
6 | } |
7 | ||
90dc8f2b | 8 | use strict; |
9f1b1f2d | 9 | use warnings; |
90dc8f2b | 10 | |
1930e939 TP |
11 | use vars qw{ @warnings }; |
12 | ||
13 | BEGIN { | |
1930e939 TP |
14 | $SIG{'__WARN__'} = sub { push @warnings, @_ }; |
15 | $| = 1; | |
10c8fecd | 16 | print "1..9\n"; |
1930e939 TP |
17 | } |
18 | ||
19 | END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings } | |
20 | ||
21 | sub test ($$;$) { | |
22 | my($num, $bool, $diag) = @_; | |
23 | if ($bool) { | |
24 | print "ok $num\n"; | |
25 | return; | |
26 | } | |
27 | print "not ok $num\n"; | |
28 | return unless defined $diag; | |
29 | $diag =~ s/\Z\n?/\n/; # unchomp | |
30 | print map "# $num : $_", split m/^/m, $diag; | |
31 | } | |
32 | ||
33 | sub test_warning ($$$) { | |
34 | my($num, $got, $expected) = @_; | |
35 | my($pattern, $ok); | |
36 | if (($pattern) = ($expected =~ m#^/(.+)/$#s) or | |
37 | (undef, $pattern) = ($expected =~ m#^m([^\w\s])(.+)\1$#s)) { | |
38 | # it's a regexp | |
39 | $ok = ($got =~ /$pattern/); | |
40 | test $num, $ok, "Expected pattern /$pattern/, got '$got'\n"; | |
41 | } else { | |
42 | $ok = ($got eq $expected); | |
43 | test $num, $ok, "Expected string '$expected', got '$got'\n"; | |
44 | } | |
45 | # print "# $num: $got\n"; | |
46 | } | |
47 | ||
48 | my $odd_msg = '/^Odd number of elements in hash/'; | |
49 | my $ref_msg = '/^Reference found where even-sized list expected/'; | |
50 | ||
51 | { | |
52 | my %hash = (1..3); | |
53 | test_warning 1, shift @warnings, $odd_msg; | |
54 | ||
55 | %hash = 1; | |
56 | test_warning 2, shift @warnings, $odd_msg; | |
57 | ||
58 | %hash = { 1..3 }; | |
59 | test_warning 3, shift @warnings, $odd_msg; | |
60 | test_warning 4, shift @warnings, $ref_msg; | |
61 | ||
62 | %hash = [ 1..3 ]; | |
63 | test_warning 5, shift @warnings, $ref_msg; | |
64 | ||
65 | %hash = sub { print "ok" }; | |
66 | test_warning 6, shift @warnings, $odd_msg; | |
67 | ||
10c8fecd GS |
68 | my $avhv = [{x=>1,y=>2}]; |
69 | %$avhv = (x=>13,'y'); | |
70 | test_warning 7, shift @warnings, $odd_msg; | |
71 | ||
72 | %$avhv = 'x'; | |
73 | test_warning 8, shift @warnings, $odd_msg; | |
74 | ||
1930e939 | 75 | $_ = { 1..10 }; |
10c8fecd | 76 | test 9, ! @warnings, "Unexpected warning"; |
1930e939 | 77 | } |