t/001_mouse/031-clone.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Exception;
   6
   7 my %triggered;
   8 {
   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 {
  44     package Bar;
  45     use Mouse;
  46
  47     has id => (
  48         is  => 'ro',
  49         isa => 'Str',
  50
  51         required => 1,
  52     );
  53
  54     sub clone {
  55         my ($self, @args) = @_;
  56         $self->meta->clone_object($self, @args);
  57     }
  58 }
  59
  60 my $foo = Foo->new(bar => [ 1, 2, 3 ], quuux => "indeed");
  61
  62 is($foo->foo, "foo", "attr 1",);
  63 is($foo->quux, "indeed", "init_arg respected");
  64
  65 is $triggered{$foo}, "indeed";
  66
  67 is_deeply($foo->bar, [ 1 .. 3 ], "attr 2");
  68 $foo->baz("foo");
  69
  70 my $clone = $foo->clone(foo => "dancing", baz => "bar", quux => "nope", quuux => "yes");
  71
  72 is $triggered{$foo},   "indeed";
  73 is $triggered{$clone}, "yes", 'clone_object() invokes triggers';
  74
  75 is($clone->foo, "dancing", "overridden attr");
  76 is_deeply($clone->bar, [ 1 .. 3 ], "clone attr");
  77 is($clone->baz, "foo", "init_arg=undef means the attr is ignored");
  78 is($clone->quux, "yes", "clone uses init_arg and not attribute name");
  79
  80 lives_and {
  81     my $bar = Bar->new(id => 'xyz');
  82     my $c   = $bar->clone;
  83
  84     is_deeply $bar, $c, "clone() with required attributes";
  85 };
  86
  87 throws_ok {
  88     Foo->meta->clone_object("constant");
  89 } qr/You must pass an instance of the metaclass \(Foo\), not \(constant\)/;
  90
  91 throws_ok {
  92     Foo->meta->clone_object(Foo->meta)
  93 } qr/You must pass an instance of the metaclass \(Foo\), not \(Mouse::Meta::Class=HASH\(\w+\)\)/;
  94
  95 done_testing;