t/001_mouse/021-weak-ref.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4
   5 use Test::More tests => 31;
   6 use Test::Exception;
   7
   8 my %destroyed;
   9
  10 do {
  11     do {
  12         package Class;
  13         use Mouse;
  14
  15         has self => (
  16             is       => 'rw',
  17             weak_ref => 1,
  18         );
  19
  20         has type => (
  21             is => 'rw',
  22         );
  23
  24         sub DEMOLISH {
  25             my $self = shift;
  26             $destroyed{ $self->type }++;
  27         }
  28     };
  29 };
  30
  31 sub do_test{
  32     my $self = Class->new(type => 'accessor');
  33     $self->self($self);
  34
  35     my $self2 = Class->new(type => 'middle');
  36     my $self3 = Class->new(type => 'constructor', self => $self2);
  37     $self2->self($self3);
  38
  39     for my $object ($self, $self2, $self3) {
  40         ok(Scalar::Util::isweak($object->{self}), "weak reference");
  41         ok($object->self->self->self->self, "we've got circularity");
  42     }
  43 }
  44
  45 do_test();
  46
  47 is($destroyed{accessor}, 1, "destroyed from the accessor");
  48 is($destroyed{constructor}, 1, "destroyed from the constructor");
  49 is($destroyed{middle}, 1, "casuality of war");
  50
  51 Class->meta->make_immutable();
  52 ok(Class->meta->is_immutable, 'make_immutable made it immutable');
  53 do_test();
  54
  55 is($destroyed{accessor}, 2, "destroyed from the accessor (after make_immutable)");
  56 is($destroyed{constructor}, 2, "destroyed from the constructor (after make_immutable)");
  57 is($destroyed{middle}, 2, "casuality of war (after make_immutable)");
  58
  59
  60 ok(!Class->meta->get_attribute('type')->is_weak_ref, "type is not a weakref");
  61 ok(Class->meta->get_attribute('self')->is_weak_ref, "self IS a weakref");
  62
  63 do {
  64     package Class2;
  65     use Mouse;
  66
  67     has value => (
  68         is => 'rw',
  69         default => 10,
  70         weak_ref => 1,
  71     );
  72 };
  73
  74 ok(Class2->meta->get_attribute('value')->is_weak_ref, "value IS a weakref");
  75
  76 lives_ok {
  77     my $obj = Class2->new;
  78     is($obj->value, 10, "weak_ref doesn't apply to non-refs");
  79 };
  80
  81 my $obj2 = Class2->new;
  82 lives_ok {
  83     $obj2->value({});
  84 };
  85
  86 is_deeply($obj2->value, undef, "weakened the reference even with a nonref default");
  87
  88 do {
  89     package Class3;
  90     use Mouse;
  91
  92     has hashref => (
  93         is        => 'rw',
  94         default   => sub { {} },
  95         weak_ref  => 1,
  96         predicate => 'has_hashref',
  97     );
  98 };
  99
 100 my $obj = Class3->new;
 101 is($obj->hashref, undef, "hashref collected immediately because refcount=0");
 102 ok($obj->has_hashref, 'attribute is turned into undef, not deleted from instance');
 103
 104 $obj->hashref({1 => 1});
 105 is($obj->hashref, undef, "hashref collected between set and get because refcount=0");
 106 ok($obj->has_hashref, 'attribute is turned into undef, not deleted from instance');
 107
 108 ok(Class3->meta->get_attribute('hashref')->is_weak_ref, "hashref IS a weakref");