t/23-magic-uvar.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 use lib 't/lib';
   9 use VPIT::TestHelpers;
  10
  11 BEGIN {
  12  load_or_skip('Variable::Magic', '0.35', [ ], 'required to test uvar magic');
  13  plan skip_all => 'perl 5.10 required to test uvar magic'
  14                                              unless Variable::Magic::VMG_UVAR();
  15 }
  16
  17 {
  18  package Lexical::Types::Test::Ref;
  19
  20  use Variable::Magic qw<wizard cast>;
  21
  22  our $wiz;
  23  BEGIN {
  24   $wiz = wizard data  => sub { +{ } },
  25                 fetch => sub { ++$_[1]->{fetch}; () },
  26                 store => sub { ++$_[1]->{store}; () };
  27  }
  28
  29  sub TYPEDSCALAR {
  30   my %h = ("_\L$_[2]" => (caller(0))[2]);
  31   cast %h, $wiz;
  32   $_[1] = \%h;
  33   ();
  34  }
  35 }
  36
  37 { package Ref; }
  38
  39 BEGIN {
  40  plan tests => 2 * 11;
  41 }
  42
  43 use Lexical::Types as => 'Lexical::Types::Test';
  44
  45 sub check (&$$;$) {
  46  my $got = Variable::Magic::getdata(%{$_[1]}, $Lexical::Types::Test::Ref::wiz);
  47  my ($test, $exp, $desc) = @_[0, 2, 3];
  48  my $want = wantarray;
  49  my @ret;
  50  {
  51   local @{$got}{qw<fetch store>};
  52   delete @{$got}{qw<fetch store>};
  53   if ($want) {
  54    @ret = eval { $test->() };
  55   } elsif (defined $want) {
  56    $ret[0] = eval { $test->() };
  57   } else {
  58    eval { $test->() };
  59   }
  60   local $Test::Builder::Level = $Test::Builder::Level + 1;
  61   is_deeply $got, $exp, $desc;
  62  }
  63  return $want ? @ret : $ret[0];
  64 }
  65
  66 for (1 .. 2) {
  67  my Ref $x; my $lx = __LINE__;
  68
  69  my $y = check { $x->{_ref} } $x, { fetch => 1 }, 'fetch';
  70  is $y, $lx, 'fetch correctly';
  71
  72  check { $x->{wat} = __LINE__ } $x, { store => 1 }, 'store'; my $l0 = __LINE__;
  73  is $x->{wat}, $l0, 'store correctly';
  74
  75  my Ref $z = $x; my $lz = __LINE__;
  76
  77  $y = check { $x->{_ref} } $x, { fetch => 1 }, 'fetch after being assigned';
  78  is $y, $lx, 'fetch after being assigned correctly';
  79
  80  $y = check { $z->{_ref} } $z, { fetch => 1 }, 'fetch after being assigned to';
  81  is $y, $lx, 'fetch after being assigned to correctly';
  82
  83  check { $z->{wat} = $x->{wat} + __LINE__ - $l0 } $z, { fetch => 1, store => 1 }, 'fetch/store';
  84  is $z->{wat}, __LINE__-1, 'fetch/store correctly';
  85  is $x->{wat}, __LINE__-2, 'fetch/store correctly';
  86 }