X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F031-clone.t;h=be9cfa17d1776df2b4e9faa9db97732815a64318;hb=90fe520e5db8715b510a2ca3bef0847c4503e037;hp=44b9ce0c6ddae985f5a7fa487762effbede236c4;hpb=7a59f4e85d2dadb67b6ce3112a9066cb8696611a;p=gitmo%2FMouse.git diff --git a/t/031-clone.t b/t/031-clone.t index 44b9ce0..be9cfa1 100644 --- a/t/031-clone.t +++ b/t/031-clone.t @@ -1,11 +1,10 @@ -#!/usr/bin/perl - +#!/usr/bin/env perl use strict; use warnings; +use Test::More tests => 9; +use Test::Exception; -use Test::More 'no_plan'; - -{ +do { package Foo; use Mouse; @@ -20,19 +19,42 @@ use Test::More 'no_plan'; is => "rw", ); + has baz => ( + is => 'rw', + init_arg => undef, + ); + + has quux => ( + is => 'rw', + init_arg => 'quuux', + ); + sub clone { - my ( $self, @args ) = @_; - $self->meta->clone_object( $self, @args ); + my ($self, @args) = @_; + $self->meta->clone_object($self, @args); } -} +}; + +my $foo = Foo->new(bar => [ 1, 2, 3 ], quuux => "indeed"); + +is($foo->foo, "foo", "attr 1",); +is($foo->quux, "indeed", "init_arg respected"); +is_deeply($foo->bar, [ 1 .. 3 ], "attr 2"); +$foo->baz("foo"); + +my $clone = $foo->clone(foo => "dancing", baz => "bar", quux => "nope", quuux => "yes"); -my $foo = Foo->new( bar => [ 1, 2, 3 ] ); +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"); -is( $foo->foo, "foo", "attr 1", ); -is_deeply( $foo->bar, [ 1 .. 3 ], "attr 2" ); +throws_ok { + Foo->meta->clone_object("constant"); +} qr/You must pass an instance of the metaclass \(Foo\), not \(constant\)/; -my $clone = $foo->clone( foo => "dancing" ); +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+\)\)/; -is( $clone->foo, "dancing", "overridden attr" ); -is_deeply( $clone->bar, [ 1 .. 3 ], "clone attr" );