t/accessor-weaken.t

   1 use strictures 1;
   2 use Test::More;
   3 use Moo::_Utils;
   4
   5 ok(Moo::_Utils::lt_5_8_3, "pretending to be pre-5.8.3")
   6     if $ENV{MOO_TEST_PRE_583};
   7
   8 {
   9   package Foo;
  10
  11   use Moo;
  12
  13   has one => (is => 'rw', weak_ref => 1);
  14
  15   package Foo2;
  16
  17   use Moo;
  18
  19   our $preexist = {};
  20   has one => (is => 'rw', lazy => 1, weak_ref => 1, default => sub { $preexist });
  21   has two => (is => 'rw', lazy => 1, weak_ref => 1, default => sub { {} });
  22 }
  23
  24 my $ref = {};
  25 my $foo = Foo->new(one => $ref);
  26 is($foo->one, $ref, 'value present');
  27 ok(Scalar::Util::isweak($foo->{one}), 'value weakened');
  28 undef $ref;
  29 ok(!defined $foo->{one}, 'weak value gone');
  30
  31 my $foo2 = Foo2->new;
  32 ok(my $ref2 = $foo2->one, 'external value returned');
  33 is($foo2->one, $ref2, 'value maintained');
  34 ok(Scalar::Util::isweak($foo2->{one}), 'value weakened');
  35 is($foo2->one($ref2), $ref2, 'value returned from setter');
  36 undef $ref2;
  37 ok(!defined $foo->{one}, 'weak value gone');
  38
  39 is($foo2->two, undef, 'weak+lazy ref not returned');
  40 is($foo2->{two}, undef, 'internal value not set');
  41 my $ref3 = {};
  42 is($foo2->two($ref3), $ref3, 'value returned from setter');
  43 undef $ref3;
  44 ok(!defined $foo->{two}, 'weak value gone');
  45
  46
  47 # test readonly SVs
  48 sub mk_ref { \ 'yay' };
  49 my $foo_ro = eval { Foo->new(one => mk_ref()) };
  50 if ($] < 5.008003) {
  51   like(
  52     $@,
  53     qr/\QReference to readonly value in "one" can not be weakened on Perl < 5.8.3/,
  54     'Expected exception thrown on old perls'
  55   );
  56 }
  57 elsif ($^O eq 'cygwin' and $] < 5.012000) {
  58   SKIP: { skip 'Static coderef reaping seems nonfunctional on cygwin < 5.12', 1 }
  59 }
  60 else {
  61   is(${$foo_ro->one},'yay', 'value present');
  62   ok(Scalar::Util::isweak($foo_ro->{one}), 'value weakened');
  63
  64   { no warnings 'redefine'; *mk_ref = sub {} }
  65   ok (!defined $foo_ro->{one}, 'optree reaped, ro static value gone');
  66 }
  67
  68 done_testing;