From: Vincent Pit Date: Wed, 26 Oct 2011 18:45:00 +0000 (+0200) Subject: Make the watch { } wrapper properly apply context X-Git-Tag: v0.47~7 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=b34eec5b227be170f3cf8efdb8aaae400370960b Make the watch { } wrapper properly apply context --- diff --git a/t/30-scalar.t b/t/30-scalar.t index dfd88bd..bc9004f 100644 --- 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; @@ -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 ], 'delete from tied array'; + watch { delete $a[0] } [ qw ], + 'delete from tied array in void context'; + + $b = watch { delete $a[1] } [ qw ], + 'delete from tied array in scalar context'; } diff --git a/t/31-array.t b/t/31-array.t index 20ab356..3613dba 100644 --- 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 c1e0831..5cc5e1f 100644 --- 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; @@ -40,18 +40,22 @@ is_deeply \@b, [ @n{qw} ], '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; } - +{ (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 4592f4b..90821c5 100644 --- a/t/34-glob.t +++ b/t/34-glob.t @@ -8,7 +8,7 @@ use Test::More; BEGIN { local $@; if (eval "use Symbol qw; 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 ] } +{ %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 ] } $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 ] } $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 f9ba0ea..98a4b08 100644 --- 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->() };