Test when magic actions take place

[perl/modules/Variable-Magic.git] / t / lib / Variable / Magic / TestValue.pm

diff --git a/t/lib/Variable/Magic/TestValue.pm b/t/lib/Variable/Magic/TestValue.pm
new file mode 100644 (file)
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;