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 | ||
6b349a5c FC |
22 | my %integer; |
23 | $integer{$_} = 0 foreach qw(* / % + -); | |
8ebc5c01 | 24 | |
198cd045 YST |
25 | sub TIESCALAR { my $x; bless \$x } |
26 | sub FETCH { ${$_[0]} } | |
27 | sub STORE { ${$_[0]} = $_[1] } | |
198cd045 | 28 | |
d24f2be2 | 29 | sub test_op { |
f09f972b | 30 | my ($tie, $int, $op_seq, $warn) = @_; |
d24f2be2 NC |
31 | my $code = "sub {\n"; |
32 | $code .= "use integer;" if $int; | |
33 | $code .= "my \$x;\n"; | |
34 | $code .= "tie \$x, 'main';\n" if $tie; | |
35 | $code .= "$op_seq;\n}\n"; | |
36 | ||
37 | my $sub = eval $code; | |
38 | is($@, '', "Can eval code for $op_seq"); | |
d24f2be2 NC |
39 | if ($warn) { |
40 | warning_like($sub, qr/^Use of uninitialized value/, | |
41 | "$op_seq$tie$int warns"); | |
42 | } else { | |
43 | warning_is($sub, undef, "$op_seq$tie$int does not warn"); | |
44 | } | |
45 | } | |
198cd045 YST |
46 | |
47 | # go through all tests once normally and once with tied $x | |
48 | for my $tie ("", ", tied") { | |
d24f2be2 NC |
49 | foreach my $integer ('', ', int') { |
50 | test_op($tie, $integer, $_, 0) foreach qw($x++ $x-- ++$x --$x); | |
51 | } | |
52 | ||
53 | foreach (keys %should_warn, keys %should_not) { | |
f09f972b | 54 | test_op($tie, '', "\$x $_= 1", $should_warn{$_}); |
d24f2be2 | 55 | next unless exists $integer{$_}; |
f09f972b | 56 | test_op($tie, ', int', "\$x $_= 1", $should_warn{$_}); |
d24f2be2 NC |
57 | } |
58 | ||
59 | foreach (qw(| ^ &)) { | |
f09f972b | 60 | test_op($tie, '', "\$x $_= 'x'", $should_warn{$_}); |
d24f2be2 | 61 | } |
198cd045 | 62 | } |
8ebc5c01 | 63 | |
d24f2be2 | 64 | done_testing(); |