Commit | Line | Data |
1a0f0802 |
1 | #!/usr/bin/env perl |
7a59f4e8 |
2 | use strict; |
3 | use warnings; |
cb6a9721 |
4 | use Test::More; |
eab81545 |
5 | use Test::Exception; |
7a59f4e8 |
6 | |
926290ac |
7 | my %triggered; |
cb6a9721 |
8 | { |
7a59f4e8 |
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 | |
4661ee61 |
23 | has baz => ( |
24 | is => 'rw', |
25 | init_arg => undef, |
26 | ); |
27 | |
28 | has quux => ( |
29 | is => 'rw', |
30 | init_arg => 'quuux', |
926290ac |
31 | trigger => sub{ |
32 | my($self, $value) = @_; |
33 | $triggered{$self} = $value; |
34 | }, |
4661ee61 |
35 | ); |
36 | |
7a59f4e8 |
37 | sub clone { |
1a0f0802 |
38 | my ($self, @args) = @_; |
39 | $self->meta->clone_object($self, @args); |
7a59f4e8 |
40 | } |
cb6a9721 |
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 | } |
1a0f0802 |
59 | |
4661ee61 |
60 | my $foo = Foo->new(bar => [ 1, 2, 3 ], quuux => "indeed"); |
1a0f0802 |
61 | |
62 | is($foo->foo, "foo", "attr 1",); |
4661ee61 |
63 | is($foo->quux, "indeed", "init_arg respected"); |
926290ac |
64 | |
65 | is $triggered{$foo}, "indeed"; |
66 | |
1a0f0802 |
67 | is_deeply($foo->bar, [ 1 .. 3 ], "attr 2"); |
4661ee61 |
68 | $foo->baz("foo"); |
7a59f4e8 |
69 | |
4661ee61 |
70 | my $clone = $foo->clone(foo => "dancing", baz => "bar", quux => "nope", quuux => "yes"); |
7a59f4e8 |
71 | |
926290ac |
72 | is $triggered{$foo}, "indeed"; |
73 | is $triggered{$clone}, "yes", 'clone_object() invokes triggers'; |
74 | |
1a0f0802 |
75 | is($clone->foo, "dancing", "overridden attr"); |
76 | is_deeply($clone->bar, [ 1 .. 3 ], "clone attr"); |
4661ee61 |
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"); |
7a59f4e8 |
79 | |
cb6a9721 |
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 | |
1a0f0802 |
87 | throws_ok { |
88 | Foo->meta->clone_object("constant"); |
89 | } qr/You must pass an instance of the metaclass \(Foo\), not \(constant\)/; |
7a59f4e8 |
90 | |
1a0f0802 |
91 | throws_ok { |
92 | Foo->meta->clone_object(Foo->meta) |
926290ac |
93 | } qr/You must pass an instance of the metaclass \(Foo\), not \(Mouse::Meta::Class=HASH\(\w+\)\)/; |
7a59f4e8 |
94 | |
cb6a9721 |
95 | done_testing; |