Make the watch { } wrapper properly apply context

diff --git a/t/30-scalar.t b/t/30-scalar.t
index dfd88bd91e3b1e5b3a12c26cb02f45b31bdced4e..bc9004f0fc6628a20a6727193c58b149e501d34c 100644 (file)
--- a/t/30-scalar.t
+++ b/t/30-scalar.t
@@ -5,7 +5,7 @@ use warnings;
 
 use Config qw<%Config>;
 
-use Test::More tests => (2 * 14 + 2) + 2 * (2 * 8 + 4) + 3 + 1;
+use Test::More tests => (2 * 14 + 2) + 2 * (2 * 8 + 4) + 5 + 1;
 
 use Variable::Magic qw<wizard cast dispell>;
 
@@ -33,15 +33,15 @@ is $b, "X${n}Y", 'scalar: interpolate correctly';
 
 $b = watch { \$a } { }, 'reference';
 
-watch { $a = 123; () } { set => 1 }, 'assign to';
+watch { $a = 123 } { set => 1 }, 'assign to';
 
-watch { ++$a; () } { get => 1, set => 1 }, 'increment';
+watch { ++$a } { get => 1, set => 1 }, 'increment';
 
-watch { --$a; () } { get => 1, set => 1 }, 'decrement';
+watch { --$a } { get => 1, set => 1 }, 'decrement';
 
-watch { $a *= 1.5; () } { get => 1, set => 1 }, 'multiply in place';
+watch { $a *= 1.5 } { get => 1, set => 1 }, 'multiply in place';
 
-watch { $a /= 1.5; () } { get => 1, set => 1 }, 'divide in place';
+watch { $a /= 1.5 } { get => 1, set => 1 }, 'divide in place';
 
 watch {
  my $b = $n;
@@ -58,7 +58,7 @@ my @a = (7, 8, 9);
 
 watch { cast $a[1], $wiz } { }, 'array element: cast';
 
-watch { $a[1] = 6; () } { set => 1 }, 'array element: set';
+watch { $a[1] = 6 } { set => 1 }, 'array element: set';
 
 $b = watch { $a[1] } { get => ($is_5130_release ? 2 : 1) },'array element: get';
 is $b, 6, 'scalar: array element: get correctly';
@@ -84,7 +84,7 @@ my %h = (a => 7, b => 8);
 
 watch { cast $h{b}, $wiz } { }, 'hash element: cast';
 
-watch { $h{b} = 6; () } { set => 1 }, 'hash element: set';
+watch { $h{b} = 6 } { set => 1 }, 'hash element: set';
 
 $b = watch { $h{b} } { get => ($is_5130_release ? 2 : 1) }, 'hash element: get';
 is $b, 6, 'scalar: hash element: get correctly';
@@ -104,17 +104,22 @@ watch { $h{b} = 4 } { }, 'hash element: set after delete';
 
 SKIP: {
  unless (do { local $@; eval { require Tie::Array; 1 } }) {
-  skip 'Tie::Array required to test clear magic on tied array values' => 3;
+  skip 'Tie::Array required to test clear magic on tied array values' => 5;
  }
  defined and diag "Using Tie::Array $_" for $Tie::Array::VERSION;
 
  tie my @a, 'Tie::StdArray';
  $a[0] = $$;
+ $a[1] = -$$;
 
  eval {
   cast @a, wizard copy => sub { cast $_[3], $wiz; () };
  };
  is $@, '', 'cast copy magic on tied array';
 
- watch { delete $a[0] } [ qw<get clear free> ], 'delete from tied array';
+ watch { delete $a[0] } [ qw<clear free> ],
+                        'delete from tied array in void context';
+
+ $b = watch { delete $a[1] } [ qw<get clear free> ],
+                             'delete from tied array in scalar context';
 }

diff --git a/t/31-array.t b/t/31-array.t
index 20ab356034198e2baadf081b6832fb5ed9c71faa..3613dba460618f33ac1e085e713c065c67c54b47 100644 (file)
--- a/t/31-array.t
+++ b/t/31-array.t
@@ -57,7 +57,7 @@ is $b, 3, 'array: length @ correctly';
 watch { $b = $#a } { len => 1 }, 'length $#';
 is $b, 2, 'array: length $# correctly';
 
-watch { push @a, 'x'; () }
+watch { push @a, 'x'; () } # push looks at the static context
                    { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID },
                    'push (void)';
 
@@ -69,7 +69,7 @@ is $b, 5, 'array: push (scalar) correctly';
 $b = watch { pop @a } { set => 1, len => 1 }, 'pop';
 is $b, 'y', 'array: pop correctly';
 
-watch { unshift @a, 'z'; () }
+watch { unshift @a, 'z'; () } # unshift looks at the static context
                 { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID },
                 'unshift (void)';
 
@@ -79,7 +79,7 @@ is $b, 6, 'unshift (scalar) correctly';
 $b = watch { shift @a } { set => 1, len => 1 }, 'shift';
 is $b, 't', 'array: shift correctly';
 
-watch { my $i; @a = map ++$i, @a; () } { set => 5, len => 1, clear => 1}, 'map';
+watch { my $i; @a = map ++$i, @a } { set => 5, len => 1, clear => 1}, 'map';
 
 @b = watch { grep { $_ >= 4 } @a } { len => 1 }, 'grep';
 is_deeply \@b, [ 4 .. 5 ], 'array: grep correctly';

diff --git a/t/32-hash.t b/t/32-hash.t
index c1e0831229813ecb303f7b97506745a9c073f22e..5cc5e1f2a6ad4ce9c322344c7cd26646176d01f1 100644 (file)
--- a/t/32-hash.t
+++ b/t/32-hash.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => (2 * 21 + 7) + (2 * 5 + 5) + 1;
+use Test::More tests => (2 * 22 + 7) + (2 * 5 + 5) + 1;
 
 use Variable::Magic qw<cast dispell VMG_UVAR>;
 
@@ -40,18 +40,22 @@ is_deeply \@b, [ @n{qw<bar qux>} ], 'hash: slice correctly';
 
 watch { %h = () } { clear => 1 }, 'empty in list context';
 
-watch { %h = (a => 1, d => 3); () }
+watch { %h = (a => 1, d => 3) }
                +{ (store => 2, copy => 2) x VMG_UVAR, clear => 1 },
                'assign from list in void context';
 
+@b = watch { %h = (a => 1, d => 3) }
+               +{ (exists => 2, store => 2, copy => 2) x VMG_UVAR, clear => 1 },
+               'assign from list in void context';
+
 watch { %h = map { $_ => 1 } qw<a b d>; }
-               +{ (exists => 3, store => 3, copy => 3) x VMG_UVAR, clear => 1 },
-               'assign from map in list context';
+               +{ (store => 3, copy => 3) x VMG_UVAR, clear => 1 },
+               'assign from map in void context';
 
-watch { $h{d} = 2; () } +{ (store => 1) x VMG_UVAR },
+watch { $h{d} = 2 } +{ (store => 1) x VMG_UVAR },
                     'assign old element';
 
-watch { $h{c} = 3; () } +{ (store => 1, copy => 1) x VMG_UVAR },
+watch { $h{c} = 3 } +{ (store => 1, copy => 1) x VMG_UVAR },
                     'assign new element';
 
 $s = watch { %h } { }, 'buckets';

diff --git a/t/34-glob.t b/t/34-glob.t
index 4592f4be904a63242805deaecbaf78847bdd8577..90821c5bf31498cef6049ef0486d85a6079b6fd7 100644 (file)
--- a/t/34-glob.t
+++ b/t/34-glob.t
@@ -8,7 +8,7 @@ use Test::More;
 BEGIN {
  local $@;
  if (eval "use Symbol qw<gensym>; 1") {
-  plan tests => 2 * 12 + 1;
+  plan tests => 2 * 17 + 1;
   defined and diag "Using Symbol $_" for $Symbol::VERSION;
  } else {
   plan skip_all => "Symbol::gensym required for testing magic for globs";
@@ -32,12 +32,31 @@ watch { cast *a, $wiz } +{ }, 'cast';
 
 watch { local *b = *a } +{ %get }, 'assign to';
 
-watch { *a = \1 }          +{ %get, set => 1 }, 'assign scalar slot';
-watch { *a = [ qw<x y> ] } +{ %get, set => 1 }, 'assign array slot';
-watch { *a = { u => 1 } }  +{ %get, set => 1 }, 'assign hash slot';
-watch { *a = sub { } }     +{ %get, set => 1 }, 'assign code slot';
+SKIP: {
+ skip 'This failed temporarily between perls 5.13.1 and 5.13.8 (included)'
+                            => 5 * 2 if "$]" >= 5.013_001 and "$]" <= 5.013_008;
 
-watch { *a = gensym() }    +{ %get, set => 1 }, 'assign glob';
+ my $cxt = 'void contex';
+ my $exp = { set => 1 };
+
+ watch { *a = \1 }          $exp, "assign scalar slot in $cxt";
+ watch { *a = [ qw<x y> ] } $exp, "assign array slot in $cxt";
+ watch { *a = { u => 1 } }  $exp, "assign hash slot in $cxt";
+ watch { *a = sub { } }     $exp, "assign code slot in $cxt";
+ watch { *a = gensym() }    $exp, "assign glob in $cxt";
+}
+
+{
+ my $cxt = 'scalar context';
+ my $exp = { %get, set => 1 };
+ my $v;
+
+ $v = watch { *a = \1 }          $exp, "assign scalar slot in $cxt";
+ $v = watch { *a = [ qw<x y> ] } $exp, "assign array slot in $cxt";
+ $v = watch { *a = { u => 1 } }  $exp, "assign hash slot in $cxt";
+ $v = watch { *a = sub { } }     $exp, "assign code slot in $cxt";
+ $v = watch { *a = gensym() }    $exp, "assign glob in $cxt";
+}
 
 watch {
  local *b = gensym();

diff --git a/t/lib/Variable/Magic/TestWatcher.pm b/t/lib/Variable/Magic/TestWatcher.pm
index f9ba0ea1a91df2e4ddfad993b731ee04ec0330d8..98a4b08b85d279ac1e64fd9cd8936519c13fb792 100644 (file)
--- a/t/lib/Variable/Magic/TestWatcher.pm
+++ b/t/lib/Variable/Magic/TestWatcher.pm
@@ -45,7 +45,10 @@ sub watch (&;$$) {
  my @ret;
  local %mg = ();
  local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
- if (defined $want and not $want) { # scalar context
+ local $@;
+ if (not defined $want) { # void context
+  eval { $code->() };
+ } elsif (not $want) { # scalar context
   $ret[0] = eval { $code->() };
  } else {
   @ret = eval { $code->() };