Commit | Line | Data |
---|---|---|
d24f2be2 | 1 | #!./perl -w |
8ebc5c01 | 2 | |
3 | # | |
4 | # Verify which OP= operators warn if their targets are undefined. | |
5 | # Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com> | |
abb363a1 | 6 | # -- Robin Barker |
8ebc5c01 | 7 | # |
d24f2be2 | 8 | # Now almost completely rewritten. |
8ebc5c01 | 9 | |
10 | BEGIN { | |
11 | chdir 't' if -d 't'; | |
20822f61 | 12 | @INC = '../lib'; |
198cd045 | 13 | require './test.pl'; |
8ebc5c01 | 14 | } |
15 | ||
16 | use strict; | |
17 | ||
d24f2be2 NC |
18 | my (%should_warn, %should_not); |
19 | ++$should_warn{$_} foreach qw(* / x & ** << >>); | |
20 | ++$should_not{$_} foreach qw(+ - . | ^ && ||); | |
21 | ||
22 | my %todo_as_tie = reverse (add => '+', subtract => '-', | |
23 | bit_or => '|', bit_xor => '^'); | |
24 | ||
25 | my %integer = reverse (i_add => '+', i_subtract => '-'); | |
26 | $integer{$_} = 0 foreach qw(* / %); | |
8ebc5c01 | 27 | |
198cd045 YST |
28 | sub TIESCALAR { my $x; bless \$x } |
29 | sub FETCH { ${$_[0]} } | |
30 | sub STORE { ${$_[0]} = $_[1] } | |
198cd045 | 31 | |
d24f2be2 NC |
32 | sub test_op { |
33 | my ($tie, $int, $op_seq, $warn, $todo) = @_; | |
34 | my $code = "sub {\n"; | |
35 | $code .= "use integer;" if $int; | |
36 | $code .= "my \$x;\n"; | |
37 | $code .= "tie \$x, 'main';\n" if $tie; | |
38 | $code .= "$op_seq;\n}\n"; | |
39 | ||
40 | my $sub = eval $code; | |
41 | is($@, '', "Can eval code for $op_seq"); | |
42 | local $::TODO; | |
43 | $::TODO = "[perl #17809] pp_$todo" if $todo; | |
44 | if ($warn) { | |
45 | warning_like($sub, qr/^Use of uninitialized value/, | |
46 | "$op_seq$tie$int warns"); | |
47 | } else { | |
48 | warning_is($sub, undef, "$op_seq$tie$int does not warn"); | |
49 | } | |
50 | } | |
198cd045 YST |
51 | |
52 | # go through all tests once normally and once with tied $x | |
53 | for my $tie ("", ", tied") { | |
d24f2be2 NC |
54 | foreach my $integer ('', ', int') { |
55 | test_op($tie, $integer, $_, 0) foreach qw($x++ $x-- ++$x --$x); | |
56 | } | |
57 | ||
58 | foreach (keys %should_warn, keys %should_not) { | |
59 | test_op($tie, '', "\$x $_= 1", $should_warn{$_}, $tie && $todo_as_tie{$_}); | |
60 | next unless exists $integer{$_}; | |
61 | test_op($tie, ', int', "\$x $_= 1", $should_warn{$_}, $tie && $integer{$_}); | |
62 | } | |
63 | ||
64 | foreach (qw(| ^ &)) { | |
65 | test_op($tie, '', "\$x $_= 'x'", $should_warn{$_}, $tie && $todo_as_tie{$_}); | |
66 | } | |
198cd045 | 67 | } |
8ebc5c01 | 68 | |
d24f2be2 | 69 | done_testing(); |