X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F031-clone.t;h=cc39e22b565b366dd305524cab3316431861c589;hb=926290ac173b77f0ff0027dcbd95277c9cc2be54;hp=1f5cc50ae13392a3b2239be8fab782e87ec83824;hpb=1a0f0802dbe504e1b31f9227a86f32ccda74de61;p=gitmo%2FMouse.git diff --git a/t/031-clone.t b/t/031-clone.t index 1f5cc50..cc39e22 100644 --- a/t/031-clone.t +++ b/t/031-clone.t @@ -1,9 +1,10 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 6; +use Test::More tests => 12; use Test::Exception; +my %triggered; do { package Foo; use Mouse; @@ -19,21 +20,45 @@ do { is => "rw", ); + has baz => ( + is => 'rw', + init_arg => undef, + ); + + has quux => ( + is => 'rw', + init_arg => 'quuux', + trigger => sub{ + my($self, $value) = @_; + $triggered{$self} = $value; + }, + ); + sub clone { my ($self, @args) = @_; $self->meta->clone_object($self, @args); } }; -my $foo = Foo->new(bar => [ 1, 2, 3 ]); +my $foo = Foo->new(bar => [ 1, 2, 3 ], quuux => "indeed"); is($foo->foo, "foo", "attr 1",); +is($foo->quux, "indeed", "init_arg respected"); + +is $triggered{$foo}, "indeed"; + is_deeply($foo->bar, [ 1 .. 3 ], "attr 2"); +$foo->baz("foo"); -my $clone = $foo->clone(foo => "dancing"); +my $clone = $foo->clone(foo => "dancing", baz => "bar", quux => "nope", quuux => "yes"); + +is $triggered{$foo}, "indeed"; +is $triggered{$clone}, "yes", 'clone_object() invokes triggers'; is($clone->foo, "dancing", "overridden attr"); is_deeply($clone->bar, [ 1 .. 3 ], "clone attr"); +is($clone->baz, "foo", "init_arg=undef means the attr is ignored"); +is($clone->quux, "yes", "clone uses init_arg and not attribute name"); throws_ok { Foo->meta->clone_object("constant"); @@ -41,5 +66,6 @@ throws_ok { throws_ok { Foo->meta->clone_object(Foo->meta) -} qr/You must pass an instance of the metaclass \(Foo\), not \(Mo.se::Meta::Class=HASH\(\w+\)\)/; +} qr/You must pass an instance of the metaclass \(Foo\), not \(Mouse::Meta::Class=HASH\(\w+\)\)/; +