t/020_attributes/036_clone_weak.t

   1 use strict;
   2 use warnings;
   3 use Test::More;
   4
   5 {
   6     package Foo;
   7     use Mouse;
   8
   9     has bar => (
  10         is       => 'ro',
  11         weak_ref => 1,
  12     );
  13 }
  14
  15 {
  16     package MyScopeGuard;
  17
  18     sub new {
  19         my ($class, $cb) = @_;
  20         bless { cb => $cb }, $class;
  21     }
  22
  23     sub DESTROY { shift->{cb}->() }
  24 }
  25
  26 {
  27     my $destroyed = 0;
  28
  29     my $foo = do {
  30         my $bar = MyScopeGuard->new(sub { $destroyed++ });
  31         my $foo = Foo->new({ bar => $bar });
  32         my $clone = $foo->meta->clone_object($foo);
  33
  34         is $destroyed, 0;
  35
  36         $clone;
  37     };
  38
  39     isa_ok($foo, 'Foo');
  40     is $foo->bar, undef;
  41     is $destroyed, 1;
  42 }
  43
  44 {
  45     my $clone;
  46     {
  47         my $anon = Mouse::Meta::Class->create_anon_class;
  48
  49         my $foo = $anon->new_object;
  50         isa_ok($foo, $anon->name);
  51         ok(Mouse::Util::class_of($foo), "has a metaclass");
  52
  53         $clone = $anon->clone_object($foo);
  54         isa_ok($clone, $anon->name);
  55         ok(Mouse::Util::class_of($clone), "has a metaclass");
  56     }
  57
  58     ok(Mouse::Util::class_of($clone), "still has a metaclass");
  59 }
  60
  61 =pod
  62
  63 {
  64     package Foo::Meta::Attr::Trait;
  65     use Mouse::Role;
  66
  67     has value_slot => (
  68         is      => 'ro',
  69         isa     => 'Str',
  70         lazy    => 1,
  71         default => sub { shift->name },
  72     );
  73
  74     has count_slot => (
  75         is      => 'ro',
  76         isa     => 'Str',
  77         lazy    => 1,
  78         default => sub { '<<COUNT>>' . shift->name },
  79     );
  80
  81     sub slots {
  82         my $self = shift;
  83         return ($self->value_slot, $self->count_slot);
  84     }
  85
  86     sub _set_count {
  87         my $self = shift;
  88         my ($instance) = @_;
  89         my $mi = $self->associated_class->get_meta_instance;
  90         $mi->set_slot_value(
  91             $instance,
  92             $self->count_slot,
  93             ($mi->get_slot_value($instance, $self->count_slot) || 0) + 1,
  94         );
  95     }
  96
  97     sub _clear_count {
  98         my $self = shift;
  99         my ($instance) = @_;
 100         $self->associated_class->get_meta_instance->deinitialize_slot(
 101             $instance, $self->count_slot
 102         );
 103     }
 104
 105     sub has_count {
 106         my $self = shift;
 107         my ($instance) = @_;
 108         $self->associated_class->get_meta_instance->has_slot_value(
 109             $instance, $self->count_slot
 110         );
 111     }
 112
 113     sub count {
 114         my $self = shift;
 115         my ($instance) = @_;
 116         $self->associated_class->get_meta_instance->get_slot_value(
 117             $instance, $self->count_slot
 118         );
 119     }
 120
 121     after set_initial_value => sub {
 122         shift->_set_count(@_);
 123     };
 124
 125     after set_value => sub {
 126         shift->_set_count(@_);
 127     };
 128
 129     around _inline_instance_set => sub {
 130         my $orig = shift;
 131         my $self = shift;
 132         my ($instance) = @_;
 133
 134         my $mi = $self->associated_class->get_meta_instance;
 135
 136         return 'do { '
 137                  . $mi->inline_set_slot_value(
 138                        $instance,
 139                        $self->count_slot,
 140                        $mi->inline_get_slot_value(
 141                            $instance, $self->count_slot
 142                        ) . ' + 1'
 143                    ) . ';'
 144                  . $self->$orig(@_)
 145              . '}';
 146     };
 147
 148     after clear_value => sub {
 149         shift->_clear_count(@_);
 150     };
 151 }
 152
 153 {
 154     package Bar;
 155     use Mouse;
 156     Mouse::Util::MetaRole::apply_metaroles(
 157         for => __PACKAGE__,
 158         class_metaroles => {
 159             attribute => ['Foo::Meta::Attr::Trait'],
 160         },
 161     );
 162
 163     has baz => ( is => 'rw' );
 164 }
 165
 166 {
 167     my $attr = Bar->meta->find_attribute_by_name('baz');
 168
 169     my $bar = Bar->new(baz => 1);
 170     is($attr->count($bar), 1, "right count");
 171
 172     $bar->baz(2);
 173     is($attr->count($bar), 2, "right count");
 174
 175     my $clone = $bar->meta->clone_object($bar);
 176     is($attr->count($clone), $attr->count($bar), "right count");
 177 }
 178
 179 =cut
 180
 181 done_testing;