From: Vincent Pit <vince@profvince.com>
Date: Sat, 21 Mar 2009 23:44:33 +0000 (+0100)
Subject: Test when magic actions take place
X-Git-Tag: v0.33~8
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=b9df7824d4619174e28f9b1b5856c4a228d9cc7b;p=perl%2Fmodules%2FVariable-Magic.git

Test when magic actions take place
---

diff --git a/MANIFEST b/MANIFEST
index 3680990..d64a464 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -43,4 +43,5 @@ t/92-pod-coverage.t
 t/95-portability-files.t
 t/99-kwalitee.t
 t/lib/Variable/Magic/TestDieRequired.pm
+t/lib/Variable/Magic/TestValue.pm
 t/lib/Variable/Magic/TestWatcher.pm
diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 9e24440..b588e88 100644
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -72,8 +72,8 @@ You attach it to variables, not values (as for blessed references).
 
 It doesn't replace the original semantics.
 
-Magic callbacks trigger before the original action take place, and can't prevent it to happen.
-This makes catching individual events easier than with C<tie>, where you have to provide fallbacks methods for all actions by usually inheriting from the correct C<Tie::Std*> class and overriding individual methods in your own class.
+Magic callbacks usually trigger before the original action take place, and can't prevent it to happen.
+This also makes catching individual events easier than with C<tie>, where you have to provide fallbacks methods for all actions by usually inheriting from the correct C<Tie::Std*> class and overriding individual methods in your own class.
 
 =item *
 
diff --git a/t/20-get.t b/t/20-get.t
index 7548e15..6590070 100644
--- a/t/20-get.t
+++ b/t/20-get.t
@@ -3,12 +3,13 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 4 + 2 + 1;
+use Test::More tests => (2 * 4 + 2) + (2 * 2) + 1;
 
 use Variable::Magic qw/cast/;
 
 use lib 't/lib';
 use Variable::Magic::TestWatcher;
+use Variable::Magic::TestValue;
 
 my $wiz = init_watcher 'get', 'get';
 
@@ -24,3 +25,11 @@ is $b, $n, 'get: assign to correctly';
 
 $b = watch { "X${a}Y" } { get => 1 }, 'interpolate';
 is $b, "X${n}Y", 'get: interpolate correctly';
+
+{
+ my $val = 0;
+
+ init_value $val, 'get', 'get';
+
+ value { my $x = $val } \0;
+}
diff --git a/t/21-set.t b/t/21-set.t
index 5ed992f..25535e2 100644
--- a/t/21-set.t
+++ b/t/21-set.t
@@ -3,12 +3,13 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 5 + 3 + 1;
+use Test::More tests => (2 * 5 + 3) + (2 * 2 + 1);
 
 use Variable::Magic qw/cast/;
 
 use lib 't/lib';
 use Variable::Magic::TestWatcher;
+use Variable::Magic::TestValue;
 
 my $wiz = init_watcher 'set', 'set';
 
@@ -26,3 +27,11 @@ is $a, $n + 1, 'set: increment correctly';
 
 watch { --$a } { set => 1 }, 'decrement';
 is $a, $n, 'set: decrement correctly';
+
+{
+ my $val = 0;
+
+ init_value $val, 'set', 'set';
+
+ value { $val = 1 } \1;
+}
diff --git a/t/22-len.t b/t/22-len.t
index 3b8039e..7025e7b 100644
--- a/t/22-len.t
+++ b/t/22-len.t
@@ -3,9 +3,12 @@
 use strict;
 use warnings;
 
-use Test::More tests => 33;
+use Test::More tests => 33 + (2 * 2 + 1);
 
-use Variable::Magic qw/wizard cast VMG_COMPAT_SCALAR_LENGTH_NOLEN/;
+use Variable::Magic qw/wizard cast dispell VMG_COMPAT_SCALAR_LENGTH_NOLEN/;
+
+use lib 't/lib';
+use Variable::Magic::TestValue;
 
 my $c = 0;
 
@@ -124,3 +127,14 @@ SKIP: {
  is $d, 5,  'len: get utf8 scalar length have correct default length';
  is $b, $d, 'len: get utf8 scalar length correctly';
 }
+
+{
+ my @val = (4 .. 6);
+
+ my $wv = init_value @val, 'len', 'len';
+
+ value { $val[-1] = 8 } [ 4, 5, 6 ];
+
+ dispell @val, $wv;
+ is_deeply \@val, [ 4, 5, 8 ], 'len: after value';
+}
diff --git a/t/23-clear.t b/t/23-clear.t
index 3f7f57e..a3aad82 100644
--- a/t/23-clear.t
+++ b/t/23-clear.t
@@ -3,12 +3,13 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 5 + 2 + 1;
+use Test::More tests => (2 * 5 + 2) + (2 * 2 + 1) + 1;
 
-use Variable::Magic qw/cast/;
+use Variable::Magic qw/cast dispell/;
 
 use lib 't/lib';
 use Variable::Magic::TestWatcher;
+use Variable::Magic::TestValue;
 
 my $wiz = init_watcher 'clear', 'clear';
 
@@ -25,3 +26,14 @@ watch { cast %h, $wiz } { }, 'cast hash';
 
 watch { %h = () } { clear => 1 }, 'clear hash';
 is_deeply \%h, { }, 'clear: clear hash correctly';
+
+{
+ my @val = (4 .. 6);
+
+ my $wv = init_value @val, 'clear', 'clear';
+
+ value { @val = () } [ 4 .. 6 ];
+
+ dispell @val, $wv;
+ is_deeply \@val, [ ], 'clear: value after';
+}
diff --git a/t/25-copy.t b/t/25-copy.t
index 5ebcbe0..98fbf22 100644
--- a/t/25-copy.t
+++ b/t/25-copy.t
@@ -5,22 +5,24 @@ use warnings;
 
 use Test::More;
 
-use Variable::Magic qw/cast MGf_COPY/;
+use Variable::Magic qw/cast dispell MGf_COPY/;
 
 if (MGf_COPY) {
- plan tests => 2 + (2 * 5 + 3) + (2 * 9 + 6) + 1;
+ plan tests => 2 + ((2 * 5 + 3) + (2 * 2 + 1)) + (2 * 9 + 6) + 1;
 } else {
  plan skip_all => 'No copy magic for this perl';
 }
 
 use lib 't/lib';
 use Variable::Magic::TestWatcher;
+use Variable::Magic::TestValue;
 
 my $wiz = init_watcher 'copy', 'copy';
 
 SKIP: {
  eval "use Tie::Array";
- skip 'Tie::Array required to test copy magic on arrays', 2 * 5 + 3 if $@;
+ skip 'Tie::Array required to test copy magic on arrays'
+                                             => (2 * 5 + 3) + (2 * 2 + 1) if $@;
  diag "Using Tie::Array $Tie::Array::VERSION" if defined $Tie::Array::VERSION;
 
  tie my @a, 'Tie::StdArray';
@@ -38,6 +40,18 @@ SKIP: {
  ok $s, 'copy: tied array exists correctly';
 
  watch { undef @a } { }, 'tied array undef';
+
+ {
+  tie my @val, 'Tie::StdArray';
+  @val = (4 .. 6);
+
+  my $wv = init_value @val, 'copy', 'copy';
+
+  value { $val[3] = 8 } [ 4 .. 6 ];
+
+  dispell @val, $wv;
+  is_deeply \@val, [ 4 .. 6, 8 ], 'copy: value after';
+ }
 }
 
 SKIP: {
diff --git a/t/28-uvar.t b/t/28-uvar.t
index 65f685b..b0114ad 100644
--- a/t/28-uvar.t
+++ b/t/28-uvar.t
@@ -8,13 +8,14 @@ use Test::More;
 use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
 
 if (VMG_UVAR) {
- plan tests => 2 * 15 + 12 + 14 + 1;
+ plan tests => 2 * 15 + 12 + 14 + (4 * 2 * 2 + 1 + 1) + 1;
 } else {
  plan skip_all => 'No nice uvar magic for this perl';
 }
 
 use lib 't/lib';
 use Variable::Magic::TestWatcher;
+use Variable::Magic::TestValue;
 
 my $wiz = init_watcher [ qw/fetch store exists delete/ ], 'uvar';
 
@@ -109,3 +110,41 @@ for my $i (1 .. 2) {
  is_deeply \%h3, { a => 3, b => 5, c => 5 + $i },
                         "uvar: change readonly key in store correcty ($i)";
 }
+
+{
+ my %val = (apple => 1);
+
+ init_value %val, 'fetch', 'uvar';
+
+ value { my $x = $val{apple} } { apple => 1 }, 'value store';
+}
+
+{
+ my %val = (apple => 1);
+
+ my $wv = init_value %val, 'store', 'uvar';
+
+ value { $val{apple} = 2 } { apple => 1 }, 'value store';
+
+ dispell %val, $wv;
+ is_deeply \%val, { apple => 2 }, 'uvar: value after store';
+}
+
+{
+ my %val = (apple => 1);
+
+ init_value %val, 'exists', 'uvar';
+
+ value { my $x = exists $val{apple} } { apple => 1 }, 'value exists';
+}
+
+{
+ my %val = (apple => 1, banana => 2);
+
+ my $wv = init_value %val, 'delete', 'uvar';
+
+ value { delete $val{apple} } { apple => 1, banana => 2 }, 'value delete';
+
+ dispell %val, $wv;
+ is_deeply \%val, { banana => 2 }, 'uvar: value after delete';
+}
diff --git a/t/lib/Variable/Magic/TestValue.pm b/t/lib/Variable/Magic/TestValue.pm
new file mode 100644
index 0000000..491055f
--- /dev/null
+++ b/t/lib/Variable/Magic/TestValue.pm
@@ -0,0 +1,55 @@
+package Variable::Magic::TestValue;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use Variable::Magic qw/wizard cast/;
+
+use base qw/Exporter/;
+
+our @EXPORT = qw/init_value value/;
+
+our ($exp, $prefix, $desc);
+
+sub value_cb {
+ my $data = $_[1];
+ return if $data->{guard};
+ local $data->{guard} = 1;
+ local $Test::Builder::Level = ($Test::Builder::Level || 0) + 3;
+ is_deeply $_[0], $exp, $desc;
+ ()
+}
+
+sub init_value (\[$@%&*]$;$) {
+ my $type = $_[1];
+ $prefix  = (defined) ? "$_: " : '' for $_[2];
+ my $wiz  = eval "wizard data => sub { +{ guard => 0 } }, $type => \\&value_cb";
+ is $@, '', $prefix . 'wizard() doesn\'t croak';
+ eval { &cast($_[0], $wiz, $prefix) };
+ is $@, '', $prefix . 'cast() doesn\'t croak';
+ return $wiz;
+}
+
+sub value (&$;$) {
+ my ($code, $_exp, $_desc) = @_;
+ my $want = wantarray;
+ $_desc = 'value' unless defined $desc;
+ $_desc = $prefix . $_desc;
+ my @ret;
+ {
+  local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
+  local $exp  = $_exp;
+  local $desc = $_desc;
+  if (defined $want and not $want) { # scalar context
+   $ret[0] = eval { $code->() };
+  } else {
+   @ret = eval { $code->() };
+  }
+  is $@, '', $desc . ' doesn\'t croak';
+ }
+ return $want ? @ret : $ret[0];
+}
+
+1;