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 25c414de770ef6c05102c3b50405541b3c6e4923..a308df598ddbadafc4bcfea44add9d89a51f5a88 100644 (file)
--- 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 80b3bc95c5212ab1c3c2cd99d2e8cfbcaa5ab418..63a5289aed048306f689094214744b55abc545a4 100644 (file)
--- 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 30d7f525e20b5d4e9651d88759d3148bd4067af4..8333ca042cd48d88ece4598dd3ad04279d090585 100644 (file)
--- 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 eb10bb5311ee897634b591b1081b341ee5bc7cda..4620e42bd9ce0073f9c32186a05830c3d1dd72ee 100644 (file)
--- 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 3397ceb639f1de5e6b0cfcb0972b7c9d74b0c829..1c8f03731700c89cb097c1c0452608e5dcd55c1e 100644 (file)
--- 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 164c6ed51091e97a18b9ad2e8f836fc8ff38f079..8803e35ac39c63d179bc95ff2df18892f92dbaf7 100644 (file)
--- 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 a8b5297d11ece058169c62ad8e76c943762080ab..672ae12599e92946a99d6bc74e604ed7a9d87bf6 100644 (file)
--- 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;