t/23-magic-uvar.t

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