Commit | Line | Data |
c3398f5b |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
3aa1e09a |
4 | use Test::More tests => 24; |
7b133c92 |
5 | use Test::Exception; |
c3398f5b |
6 | |
7 | do { |
8 | package Person; |
9 | |
10 | sub new { |
11 | my $class = shift; |
12 | my %args = @_; |
13 | |
14 | bless \%args, $class; |
15 | } |
16 | |
17 | sub name { $_[0]->{name} = $_[1] if @_ > 1; $_[0]->{name} } |
18 | sub age { $_[0]->{age} = $_[1] if @_ > 1; $_[0]->{age} } |
19 | |
20 | package Class; |
21 | use Mouse; |
22 | |
23 | has person => ( |
24 | is => 'rw', |
25 | lazy => 1, |
26 | default => sub { Person->new(age => 37, name => "Chuck") }, |
27 | predicate => 'has_person', |
28 | handles => { |
29 | person_name => 'name', |
30 | person_age => 'age', |
31 | }, |
32 | ); |
33 | |
34 | has me => ( |
35 | is => 'rw', |
36 | default => sub { Person->new(age => 21, name => "Shawn") }, |
37 | predicate => 'quid', |
38 | handles => [qw/name age/], |
39 | ); |
c3398f5b |
40 | }; |
41 | |
42 | can_ok(Class => qw(person has_person person_name person_age name age quid)); |
43 | |
44 | my $object = Class->new; |
45 | ok(!$object->has_person, "don't have a person yet"); |
46 | $object->person_name("Todd"); |
47 | ok($object->has_person, "calling person_name instantiated person"); |
48 | ok($object->person, "we really do have a person"); |
49 | |
50 | is($object->person_name, "Todd", "handles method"); |
51 | is($object->person->name, "Todd", "traditional lookup"); |
52 | is($object->person_age, 37, "handles method"); |
53 | is($object->person->age, 37, "traditional lookup"); |
54 | |
55 | my $object2 = Class->new(person => Person->new(name => "Philbert")); |
56 | ok($object2->has_person, "we have a person from the constructor"); |
57 | is($object2->person_name, "Philbert", "handles method"); |
58 | is($object2->person->name, "Philbert", "traditional lookup"); |
59 | is($object2->person_age, undef, "no age because we didn't use the default"); |
60 | is($object2->person->age, undef, "no age because we didn't use the default"); |
61 | |
62 | |
63 | ok($object->quid, "we have a Shawn"); |
64 | is($object->name, "Shawn", "name handle"); |
65 | is($object->age, 21, "age handle"); |
66 | is($object->me->name, "Shawn", "me->name"); |
67 | is($object->me->age, 21, "me->age"); |
68 | |
69 | is_deeply( |
70 | $object->meta->get_attribute('me')->handles, |
c3cc3642 |
71 | [ 'name', 'age' ], |
c3398f5b |
72 | "correct handles layout for 'me'", |
73 | ); |
74 | |
75 | is_deeply( |
76 | $object->meta->get_attribute('person')->handles, |
77 | { person_name => 'name', person_age => 'age' }, |
78 | "correct handles layout for 'person'", |
79 | ); |
80 | |
912fa381 |
81 | |
82 | { |
912fa381 |
83 | throws_ok{ |
84 | $object->person(undef); |
85 | $object->person_name(); |
86 | } qr/Cannot delegate person_name to name because the value of person is not defined/; |
87 | |
88 | throws_ok{ |
89 | $object->person([]); |
90 | $object->person_age(); |
91 | } qr/Cannot delegate person_age to age because the value of person is not an object/; |
92 | } |
93 | |
94 | eval{ |
7b133c92 |
95 | $object->person(undef); |
96 | $object->person_name(); |
912fa381 |
97 | }; |
98 | like $@, qr/Cannot delegate person_name to name because the value of person is not defined/; |
7b133c92 |
99 | |
912fa381 |
100 | eval{ |
7b133c92 |
101 | $object->person([]); |
102 | $object->person_age(); |
912fa381 |
103 | }; |
104 | like $@, qr/Cannot delegate person_age to age because the value of person is not an object/; |
105 | |
7b133c92 |
106 | |