t/031-clone.t

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