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