From: Vincent Pit <vince@profvince.com>
Date: Sun, 1 Mar 2009 15:01:16 +0000 (+0100)
Subject: Test uvar magic
X-Git-Tag: v0.03~5
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=commitdiff_plain;h=b231c8a43aba9af5993d8cb5484ca1480709c05b

Test uvar magic
---

diff --git a/MANIFEST b/MANIFEST
index 83c16a6..669aa72 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -16,6 +16,7 @@ t/15-constants.t
 t/20-object.t
 t/21-tie.t
 t/22-magic.t
+t/23-magic-uvar.t
 t/30-threads.t
 t/90-boilerplate.t
 t/91-pod.t
diff --git a/t/23-magic-uvar.t b/t/23-magic-uvar.t
new file mode 100644
index 0000000..8849161
--- /dev/null
+++ b/t/23-magic-uvar.t
@@ -0,0 +1,80 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ plan skip_all => 'Variable::Magic 0.08 on 5.10 required to test uvar magic'
+              unless eval "use Variable::Magic 0.08; Variable::Magic::VMG_UVAR";
+}
+
+{
+ package Lexical::Types::Test::Ref;
+
+ use Variable::Magic qw/wizard cast/;
+
+ our $wiz;
+ BEGIN {
+  $wiz = wizard data  => sub { +{ } },
+                fetch => sub { ++$_[1]->{fetch}; () },
+                store => sub { ++$_[1]->{store}; () };
+ }
+
+ sub TYPEDSCALAR {
+  my %h = ("_\L$_[2]" => (caller(0))[2]);
+  cast %h, $wiz;
+  $_[1] = \%h;
+  ();
+ }
+}
+
+{ package Ref; }
+
+BEGIN {
+ plan tests => 2 * 11;
+}
+
+use Lexical::Types as => 'Lexical::Types::Test';
+
+sub check (&$$;$) {
+ my $got = Variable::Magic::getdata(%{$_[1]}, $Lexical::Types::Test::Ref::wiz);
+ my ($test, $exp, $desc) = @_[0, 2, 3];
+ my $want = wantarray;
+ my @ret;
+ {
+  local @{$got}{qw/fetch store/}; delete @{$got}{qw/fetch store/};
+  if ($want) {
+   @ret = eval { $test->() };
+  } elsif (defined $want) {
+   $ret[0] = eval { $test->() };
+  } else {
+   eval { $test->() };
+  }
+  is_deeply $got, $exp, $desc;
+ }
+ return $want ? @ret : $ret[0];
+}
+
+for (1 .. 2) {
+ my Ref $x; my $lx = __LINE__;
+
+ my $y = check { $x->{_ref} } $x, { fetch => 1 }, 'fetch';
+ is $y, $lx, 'fetch correctly';
+
+ check { $x->{wat} = __LINE__ } $x, { store => 1 }, 'store'; my $l0 = __LINE__;
+ is $x->{wat}, $l0, 'store correctly';
+
+ my Ref $z = $x; my $lz = __LINE__;
+
+ $y = check { $x->{_ref} } $x, { fetch => 1 }, 'fetch after being assigned';
+ is $y, $lx, 'fetch after being assigned correctly';
+
+ $y = check { $z->{_ref} } $z, { fetch => 1 }, 'fetch after being assigned to';
+ is $y, $lx, 'fetch after being assigned to correctly';
+
+ check { $z->{wat} = $x->{wat} + __LINE__ - $l0 } $z, { fetch => 1, store => 1 }, 'fetch/store';
+ is $z->{wat}, __LINE__-1, 'fetch/store correctly';
+ is $x->{wat}, __LINE__-2, 'fetch/store correctly';
+}