From: Vincent Pit <vince@profvince.com>
Date: Sat, 24 Jan 2009 15:06:26 +0000 (+0100)
Subject: Don't assign results in check blocks
X-Git-Tag: v0.28~4
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=c78c1790ebe43372ca405385d4cc053121b53ba0;hp=1b88e230428d6cc4f3ff364fbcfd7f5c1a40fedc;p=perl%2Fmodules%2FVariable-Magic.git

Don't assign results in check blocks

If the block croaks, the result won't be reset, which makes the interpretation of the test results more difficult. This requires check() to correctly forward scalar context to the block.
---

diff --git a/t/20-get.t b/t/20-get.t
index 25c414d..a308df5 100644
--- a/t/20-get.t
+++ b/t/20-get.t
@@ -17,9 +17,8 @@ my $a = $n;
 
 check { cast $a, $wiz } { }, 'cast';
 
-my $b;
-check { $b = $a } { get => 1 }, 'assign to';
+my $b = check { $a } { get => 1 }, 'assign to';
 is $b, $n, 'get: assign to correctly';
 
-check { $b = "X${a}Y" } { get => 1 }, 'interpolate';
+$b = check { "X${a}Y" } { get => 1 }, 'interpolate';
 is $b, "X${n}Y", 'get: interpolate correctly';
diff --git a/t/25-copy.t b/t/25-copy.t
index 80b3bc9..63a5289 100644
--- a/t/25-copy.t
+++ b/t/25-copy.t
@@ -31,11 +31,10 @@ SKIP: {
 
  check { $a[3] = 13 } { copy => 1 }, 'tied array store';
 
- my $s;
- check { $s = $a[3] } { copy => 1 }, 'tied array fetch';
+ my $s = check { $a[3] } { copy => 1 }, 'tied array fetch';
  is $s, 13, 'copy: tied array fetch correctly';
 
- check { $s = exists $a[3] } { copy => 1 }, 'tied array exists';
+ $s = check { exists $a[3] } { copy => 1 }, 'tied array exists';
  ok $s, 'copy: tied array exists correctly';
 
  check { undef @a } { }, 'tied array undef';
@@ -54,24 +53,21 @@ SKIP: {
 
  check { $h{b} = 7 } { copy => 1 }, 'tied hash store';
 
- my $s;
- check { $s = $h{c} } { copy => 1 }, 'tied hash fetch';
+ my $s = check { $h{c} } { copy => 1 }, 'tied hash fetch';
  is $s, 3, 'copy: tied hash fetch correctly';
 
- check { $s = exists $h{a} } { copy => 1 }, 'tied hash exists';
+ $s = check { exists $h{a} } { copy => 1 }, 'tied hash exists';
  ok $s, 'copy: tied hash exists correctly';
 
- check { $s = delete $h{b} } { copy => 1 }, 'tied hash delete';
+ $s = check { delete $h{b} } { copy => 1 }, 'tied hash delete';
  is $s, 7, 'copy: tied hash delete correctly';
 
  check { my ($k, $v) = each %h } { copy => 1 }, 'tied hash each';
 
- my @k;
- check { @k = keys %h } { }, 'tied hash keys';
+ my @k = check { keys %h } { }, 'tied hash keys';
  is_deeply [ sort @k ], [ qw/a c/ ], 'copy: tied hash keys correctly';
 
- my @v;
- check { @v = values %h } { copy => 2 }, 'tied hash values';
+ my @v = check { values %h } { copy => 2 }, 'tied hash values';
  is_deeply [ sort { $a <=> $b } @v ], [ 1, 3 ], 'copy: tied hash values correctly';
 
  check { undef %h } { }, 'tied hash undef';
diff --git a/t/28-uvar.t b/t/28-uvar.t
index 30d7f52..8333ca0 100644
--- a/t/28-uvar.t
+++ b/t/28-uvar.t
@@ -23,41 +23,39 @@ my %h = (a => 1, b => 2, c => 3);
 my $res = check { cast %h, $wiz } { }, 'cast';
 ok $res, 'uvar: cast succeeded';
 
-my $x;
-
-check { $x = $h{a} } { fetch => 1 }, 'fetch directly';
+my $x = check { $h{a} } { fetch => 1 }, 'fetch directly';
 is $x, 1, 'uvar: fetch directly correctly';
 
-check { $x = "$h{b}" } { fetch => 1 }, 'fetch by interpolation';
+$x = check { "$h{b}" } { fetch => 1 }, 'fetch by interpolation';
 is $x, 2, 'uvar: fetch by interpolation correctly';
 
 check { $h{c} = 4 } { store => 1 }, 'store directly';
 
-check { $x = $h{c} = 5 } { store => 1 }, 'fetch and store';
+$x = check { $h{c} = 5 } { store => 1 }, 'fetch and store';
 is $x, 5, 'uvar: fetch and store correctly';
 
-check { $x = exists $h{c} } { exists => 1 }, 'exists';
+$x = check { exists $h{c} } { exists => 1 }, 'exists';
 ok $x, 'uvar: exists correctly';
 
-check { $x = delete $h{c} } { delete => 1 }, 'delete existing key';
+$x = check { delete $h{c} } { delete => 1 }, 'delete existing key';
 is $x, 5, 'uvar: delete existing key correctly';
 
-check { $x = delete $h{z} } { delete => 1 }, 'delete non-existing key';
+$x = check { delete $h{z} } { delete => 1 }, 'delete non-existing key';
 ok !defined $x, 'uvar: delete non-existing key correctly';
 
 my $wiz2 = wizard get => sub { 0 };
 cast %h, $wiz2;
 
-check { $x = $h{a} } { fetch => 1 }, 'fetch directly with also non uvar magic';
+$x = check { $h{a} } { fetch => 1 }, 'fetch directly with also non uvar magic';
 is $x, 1, 'uvar: fetch directly with also non uvar magic correctly';
 
 $wiz2 = wizard fetch => sub { 0 };
 my %h2 = (a => 37, b => 2, c => 3);
 cast %h2, $wiz2;
 
-eval {
+$x = eval {
  local $SIG{__WARN__} = sub { die };
- $x = $h2{a};
+ $h2{a};
 };
 is $@, '', 'uvar: fetch with incomplete magic doesn\'t croak';
 is $x, 37, 'uvar: fetch with incomplete magic correctly';
diff --git a/t/30-scalar.t b/t/30-scalar.t
index eb10bb5..4620e42 100644
--- a/t/30-scalar.t
+++ b/t/30-scalar.t
@@ -19,14 +19,13 @@ my $a = $n;
 
 check { cast $a, $wiz } { }, 'cast';
 
-my $b;
-check { $b = $a } { get => 1 }, 'assign to';
+my $b = check { $a } { get => 1 }, 'assign to';
 is $b, $n, 'scalar: assign to correctly';
 
-check { $b = "X${a}Y" } { get => 1 }, 'interpolate';
+$b = check { "X${a}Y" } { get => 1 }, 'interpolate';
 is $b, "X${n}Y", 'scalar: interpolate correctly';
 
-check { $b = \$a } { }, 'reference';
+$b = check { \$a } { }, 'reference';
 
 check { $a = 123; () } { set => 1 }, 'assign to';
 
diff --git a/t/31-array.t b/t/31-array.t
index 3397ceb..1c8f037 100644
--- a/t/31-array.t
+++ b/t/31-array.t
@@ -19,20 +19,18 @@ my @a = @n;
 
 check { cast @a, $wiz } { }, 'cast';
 
-my $b;
-check { $b = $a[2] } { }, 'assign element to';
+my $b = check { $a[2] } { }, 'assign element to';
 is $b, $n[2], 'array: assign element to correctly';
 
-my @b;
-check { @b = @a } { len => 1 }, 'assign to';
+my @b = check { @a } { len => 1 }, 'assign to';
 is_deeply \@b, \@n, 'array: assign to correctly';
 
-check { $b = "X@{a}Y" } { len => 1 }, 'interpolate';
+$b = check { "X@{a}Y" } { len => 1 }, 'interpolate';
 is $b, "X@{n}Y", 'array: interpolate correctly';
 
-check { $b = \@a } { }, 'reference';
+$b = check { \@a } { }, 'reference';
 
-check { @b = @a[2 .. 4] } { }, 'slice';
+@b = check { @a[2 .. 4] } { }, 'slice';
 is_deeply \@b, [ @n[2 .. 4] ], 'array: slice correctly';
 
 check { @a = qw/a b d/ } { set => 3, clear => 1 }, 'assign';
@@ -43,30 +41,30 @@ check { $a[3] = 'd' } { set => 1 }, 'assign new element';
 
 check { push @a, 'x'; () }
           { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_PUSH_NOLEN },'push (void)';
-check { $b = push @a, 'y' }
+$b = check { push @a, 'y' }
        { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_PUSH_NOLEN }, 'push (scalar)';
 
-check { $b = pop @a } { set => 1, len => 1 }, 'pop';
+$b = check { pop @a } { set => 1, len => 1 }, 'pop';
 is $b, 'y', 'array: pop correctly';
 
 check { unshift @a, 'z'; () }
                 { set => 1, (len => 1) x !VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID },
                 'unshift (void)';
 
-check { $b = unshift @a, 't' } { set => 1, len => 1 }, 'unshift (scalar)';
+$b = check { unshift @a, 't' } { set => 1, len => 1 }, 'unshift (scalar)';
 
-check { $b = shift @a } { set => 1, len => 1 }, 'shift';
+$b = check { shift @a } { set => 1, len => 1 }, 'shift';
 is $b, 't', 'array: shift correctly';
 
-check { $b = @a } { len => 1 }, 'length @';
+$b = check { @a } { len => 1 }, 'length @';
 is $b, 6, 'array: length @ correctly';
 
-check { $b = $#a } { len => 1 }, 'length $#';
+$b = check { $#a } { len => 1 }, 'length $#';
 is $b, 5, 'array: length $# correctly';
 
 check { my $i; @a = map ++$i, @a; () } { set => 6, len => 1, clear => 1}, 'map';
 
-check { @b = grep { $_ >= 4 } @a } { len => 1 }, 'grep';
+@b = check { grep { $_ >= 4 } @a } { len => 1 }, 'grep';
 is_deeply \@b, [ 4 .. 6 ], 'array: grep correctly';
 
 check { 1 for @a } { len => 6 + 1 }, 'for';
diff --git a/t/32-hash.t b/t/32-hash.t
index 164c6ed..8803e35 100644
--- a/t/32-hash.t
+++ b/t/32-hash.t
@@ -19,8 +19,7 @@ my %h = %n;
 
 check { cast %h, $wiz } { }, 'cast';
 
-my $s;
-check { $s = $h{foo} } +{ (fetch => 1) x VMG_UVAR },
+my $s = check { $h{foo} } +{ (fetch => 1) x VMG_UVAR },
                        # (copy => 1) x MGf_COPY # if clear magic
                        'assign element to';
 is $s, $n{foo}, 'hash: assign element to correctly';
@@ -32,10 +31,9 @@ my %b;
 check { %b = %h } { }, 'assign to';
 is_deeply \%b, \%n, 'hash: assign to correctly';
 
-check { $s = \%h } { }, 'reference';
+$s = check { \%h } { }, 'reference';
 
-my @b;
-check { @b = @h{qw/bar qux/} }
+my @b = check { @h{qw/bar qux/} }
                   +{ (fetch => 2) x VMG_UVAR }, 'slice';
                   # (copy => 2) x MGf_COPY # if clear magic
 is_deeply \@b, [ @n{qw/bar qux/} ], 'hash: slice correctly';
@@ -56,12 +54,12 @@ check { $h{d} = 2; () } +{ (store => 1) x VMG_UVAR },
 check { $h{c} = 3; () } +{ (store => 1, copy => 1) x VMG_UVAR },
                     'assign new element';
 
-check { $s = %h } { }, 'buckets';
+$s = check { %h } { }, 'buckets';
 
-check { @b = keys %h } { }, 'keys';
+@b = check { keys %h } { }, 'keys';
 is_deeply [ sort @b ], [ qw/a b c d/ ], 'hash: keys correctly';
 
-check { @b = values %h } { }, 'values';
+@b = check { values %h } { }, 'values';
 is_deeply [ sort { $a <=> $b } @b ], [ 1, 1, 2, 3 ], 'hash: values correctly';
 
 check { while (my ($k, $v) = each %h) { } } { }, 'each';
diff --git a/t/lib/Variable/Magic/TestWatcher.pm b/t/lib/Variable/Magic/TestWatcher.pm
index a8b5297..672ae12 100644
--- a/t/lib/Variable/Magic/TestWatcher.pm
+++ b/t/lib/Variable/Magic/TestWatcher.pm
@@ -41,12 +41,18 @@ sub check (&;$$) {
  my $code = shift;
  my $exp  = _types shift;
  my $desc = shift;
+ my $want = wantarray;
+ my @ret;
  local %mg = ();
  local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
- my @ret = eval { $code->() };
+ if (defined $want and not $want) { # scalar context
+  $ret[0] = eval { $code->() };
+ } else {
+  @ret = eval { $code->() };
+ }
  is        $@,   '',   $prefix . $desc . ' doesn\'t croak';
  is_deeply \%mg, $exp, $prefix . $desc . ' triggers magic correctly';
- return @ret;
+ return $want ? @ret : $ret[0];
 }
 
 our $mg_end;