From d24f2be20d9e792f53054fb12a5633633ad04ca5 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 13 Mar 2011 23:18:58 +0000
Subject: [PATCH] Refactor t/op/assignwarn.t to generate all the tested code
 from data structures

---
 t/op/assignwarn.t | 112 +++++++++++++++++++++---------------------------------
 1 file changed, 44 insertions(+), 68 deletions(-)

diff --git a/t/op/assignwarn.t b/t/op/assignwarn.t
index a78e96a..8d5487a 100644
--- a/t/op/assignwarn.t
+++ b/t/op/assignwarn.t
@@ -1,10 +1,11 @@
-#!./perl
+#!./perl -w
 
 #
 # Verify which OP= operators warn if their targets are undefined.
 # Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
 #	-- Robin Barker 
 #
+# Now almost completely rewritten.
 
 BEGIN {
     chdir 't' if -d 't';
@@ -13,81 +14,56 @@ BEGIN {
 }
 
 use strict;
-use warnings;
 
-my $warn = "";
-$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) };
+my (%should_warn, %should_not);
+++$should_warn{$_} foreach qw(* / x & ** << >>);
+++$should_not{$_} foreach qw(+ - . | ^ && ||);
+
+my %todo_as_tie = reverse (add => '+', subtract => '-',
+			   bit_or => '|', bit_xor => '^');
+
+my %integer = reverse (i_add => '+', i_subtract => '-');
+$integer{$_} = 0 foreach qw(* / %);
 
-sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; }
-sub tiex { tie $_[0], 'main' }
 sub TIESCALAR { my $x; bless \$x }
 sub FETCH { ${$_[0]} }
 sub STORE { ${$_[0]} = $_[1] }
-our $TODO;
 
-print "1..63\n";
+sub test_op {
+    my ($tie, $int, $op_seq, $warn, $todo) = @_;
+    my $code = "sub {\n";
+    $code .= "use integer;" if $int;
+    $code .= "my \$x;\n";
+    $code .= "tie \$x, 'main';\n" if $tie;
+    $code .= "$op_seq;\n}\n";
+
+    my $sub = eval $code;
+    is($@, '', "Can eval code for $op_seq");
+    local $::TODO;
+    $::TODO = "[perl #17809] pp_$todo" if $todo;
+    if ($warn) {
+	warning_like($sub, qr/^Use of uninitialized value/,
+		     "$op_seq$tie$int warns");
+    } else {
+	warning_is($sub, undef, "$op_seq$tie$int does not warn");
+    }
+}
 
 # go through all tests once normally and once with tied $x
 for my $tie ("", ", tied") {
-
-{ my $x; tiex $x if $tie; $x ++;     ok ! uninitialized, "postinc$tie"; }
-{ my $x; tiex $x if $tie; $x --;     ok ! uninitialized, "postdec$tie"; }
-{ my $x; tiex $x if $tie; ++ $x;     ok ! uninitialized, "preinc$tie"; }
-{ my $x; tiex $x if $tie; -- $x;     ok ! uninitialized, "predec$tie"; }
-
-{ my $x; tiex $x if $tie; $x **= 1;  ok uninitialized,   "**=$tie"; }
-
-{ local $TODO = $tie && '[perl #17809] pp_add & pp_subtract';
-    { my $x; tiex $x if $tie; $x += 1;   ok ! uninitialized, "+=$tie"; }
-    { my $x; tiex $x if $tie; $x -= 1;   ok ! uninitialized, "-=$tie"; }
-}
-
-{ my $x; tiex $x if $tie; $x .= 1;   ok ! uninitialized, ".=$tie"; }
-
-{ my $x; tiex $x if $tie; $x *= 1;   ok uninitialized,   "*=$tie"; }
-{ my $x; tiex $x if $tie; $x /= 1;   ok uninitialized,   "/=$tie"; }
-{ my $x; tiex $x if $tie; $x %= 1;   ok uninitialized,   "\%=$tie"; }
-
-{ my $x; tiex $x if $tie; $x x= 1;   ok uninitialized, "x=$tie"; }
-
-{ my $x; tiex $x if $tie; $x &= 1;   ok uninitialized, "&=$tie"; }
-
-{ local $TODO = $tie && '[perl #17809] pp_bit_or & pp_bit_xor';
-    { my $x; tiex $x if $tie; $x |= 1;   ok ! uninitialized, "|=$tie"; }
-    { my $x; tiex $x if $tie; $x ^= 1;   ok ! uninitialized, "^=$tie"; }
+    foreach my $integer ('', ', int') {
+	test_op($tie, $integer, $_, 0) foreach qw($x++ $x-- ++$x --$x);
+    }
+
+    foreach (keys %should_warn, keys %should_not) {
+	test_op($tie, '', "\$x $_= 1", $should_warn{$_}, $tie && $todo_as_tie{$_});
+	next unless exists $integer{$_};
+	test_op($tie, ', int', "\$x $_= 1", $should_warn{$_}, $tie && $integer{$_});
+    }
+
+    foreach (qw(| ^ &)) {
+	test_op($tie, '', "\$x $_= 'x'", $should_warn{$_}, $tie && $todo_as_tie{$_});
+    }
 }
 
-{ my $x; tiex $x if $tie; $x &&= 1;  ok ! uninitialized, "&&=$tie"; }
-{ my $x; tiex $x if $tie; $x ||= 1;  ok ! uninitialized, "||=$tie"; }
-
-{ my $x; tiex $x if $tie; $x <<= 1;  ok uninitialized, "<<=$tie"; }
-{ my $x; tiex $x if $tie; $x >>= 1;  ok uninitialized, ">>=$tie"; }
-
-{ my $x; tiex $x if $tie; $x &= "x"; ok uninitialized, "&=$tie, string"; }
-
-{ local $TODO = $tie && '[perl #17809] pp_bit_or & pp_bit_xor';
-    { my $x; tiex $x if $tie; $x |= "x"; ok ! uninitialized, "|=$tie, string"; }
-    { my $x; tiex $x if $tie; $x ^= "x"; ok ! uninitialized, "^=$tie, string"; }
-}
-
-{ use integer;
-
-{ local $TODO = $tie && '[perl #17809] pp_i_add & pp_i_subtract';
-    { my $x; tiex $x if $tie; $x += 1; ok ! uninitialized, "+=$tie, int"; }
-    { my $x; tiex $x if $tie; $x -= 1; ok ! uninitialized, "-=$tie, int"; }
-}
-
-{ my $x; tiex $x if $tie; $x *= 1; ok uninitialized, "*=$tie, int"; }
-{ my $x; tiex $x if $tie; $x /= 1; ok uninitialized, "/=$tie, int"; }
-{ my $x; tiex $x if $tie; $x %= 1; ok uninitialized, "\%=$tie, int"; }
-
-{ my $x; tiex $x if $tie; $x ++;   ok ! uninitialized, "postinc$tie, int"; }
-{ my $x; tiex $x if $tie; $x --;   ok ! uninitialized, "postdec$tie, int"; }
-{ my $x; tiex $x if $tie; ++ $x;   ok ! uninitialized, "preinc$tie, int"; }
-{ my $x; tiex $x if $tie; -- $x;   ok ! uninitialized, "predec$tie, int"; }
-
-} # end of use integer;
-
-} # end of for $tie
-
-is $warn, '', "no spurious warnings";
+done_testing();
-- 
2.7.4