Workaround a Test::Builder2 (2.00_06)'s threading issue.
[gitmo/Mouse.git] / 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;