t/001_mouse/031-clone.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 12;
   5 use Test::Exception;
   6
   7 my %triggered;
   8 do {
   9     package Foo;
  10     use Mouse;
  11
  12     has foo => (
  13         isa => "Str",
  14         is  => "rw",
  15         default => "foo",
  16     );
  17
  18     has bar => (
  19         isa => "ArrayRef",
  20         is  => "rw",
  21     );
  22
  23     has baz => (
  24         is => 'rw',
  25         init_arg => undef,
  26     );
  27
  28     has quux => (
  29         is => 'rw',
  30         init_arg => 'quuux',
  31         trigger => sub{
  32             my($self, $value) = @_;
  33             $triggered{$self} = $value;
  34         },
  35     );
  36
  37     sub clone {
  38         my ($self, @args) = @_;
  39         $self->meta->clone_object($self, @args);
  40     }
  41 };
  42
  43 my $foo = Foo->new(bar => [ 1, 2, 3 ], quuux => "indeed");
  44
  45 is($foo->foo, "foo", "attr 1",);
  46 is($foo->quux, "indeed", "init_arg respected");
  47
  48 is $triggered{$foo}, "indeed";
  49
  50 is_deeply($foo->bar, [ 1 .. 3 ], "attr 2");
  51 $foo->baz("foo");
  52
  53 my $clone = $foo->clone(foo => "dancing", baz => "bar", quux => "nope", quuux => "yes");
  54
  55 is $triggered{$foo},   "indeed";
  56 is $triggered{$clone}, "yes", 'clone_object() invokes triggers';
  57
  58 is($clone->foo, "dancing", "overridden attr");
  59 is_deeply($clone->bar, [ 1 .. 3 ], "clone attr");
  60 is($clone->baz, "foo", "init_arg=undef means the attr is ignored");
  61 is($clone->quux, "yes", "clone uses init_arg and not attribute name");
  62
  63 throws_ok {
  64     Foo->meta->clone_object("constant");
  65 } qr/You must pass an instance of the metaclass \(Foo\), not \(constant\)/;
  66
  67 throws_ok {
  68     Foo->meta->clone_object(Foo->meta)
  69 } qr/You must pass an instance of the metaclass \(Foo\), not \(Mouse::Meta::Class=HASH\(\w+\)\)/;
  70
  71