| 1 | #!./perl -w |
| 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> |
| 6 | # -- Robin Barker |
| 7 | # |
| 8 | # Now almost completely rewritten. |
| 9 | |
| 10 | BEGIN { |
| 11 | chdir 't' if -d 't'; |
| 12 | @INC = '../lib'; |
| 13 | require './test.pl'; |
| 14 | } |
| 15 | |
| 16 | use strict; |
| 17 | |
| 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(* / %); |
| 27 | |
| 28 | sub TIESCALAR { my $x; bless \$x } |
| 29 | sub FETCH { ${$_[0]} } |
| 30 | sub STORE { ${$_[0]} = $_[1] } |
| 31 | |
| 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 | } |
| 51 | |
| 52 | # go through all tests once normally and once with tied $x |
| 53 | for my $tie ("", ", tied") { |
| 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 | } |
| 67 | } |
| 68 | |
| 69 | done_testing(); |