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 10BEGIN { 11 chdir 't' if -d 't'; 12 require './test.pl'; 13 set_up_inc('../lib'); 14} 15 16use strict; 17 18my (%should_warn, %should_not); 19++$should_warn{$_} foreach qw(* / x & ** << >>); 20++$should_not{$_} foreach qw(+ - . | ^ && ||); 21 22my %integer; 23$integer{$_} = 0 foreach qw(* / % + -); 24 25sub TIESCALAR { my $x; bless \$x } 26sub FETCH { ${$_[0]} } 27sub STORE { ${$_[0]} = $_[1] } 28 29sub test_op { 30 my ($tie, $int, $op_seq, $warn) = @_; 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"); 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} 46 47# go through all tests once normally and once with tied $x 48for my $tie ("", ", tied") { 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) { 54 test_op($tie, '', "\$x $_= 1", $should_warn{$_}); 55 next unless exists $integer{$_}; 56 test_op($tie, ', int', "\$x $_= 1", $should_warn{$_}); 57 } 58 59 foreach (qw(| ^ &)) { 60 test_op($tie, '', "\$x $_= 'x'", $should_warn{$_}); 61 } 62} 63 64done_testing(); 65