Commit | Line | Data |
c3398f5b |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
3fab876a |
4 | use Test::More tests => 27; |
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 | ); |
40 | |
6fbbcaf4 |
41 | TODO: { |
1ea948d1 |
42 | local our $TODO = "Mouse lacks this"; |
6fbbcaf4 |
43 | eval { |
44 | has error => ( |
45 | handles => "string", |
46 | ); |
47 | }; |
1ea948d1 |
48 | ::ok(!$@, "handles => role"); |
6fbbcaf4 |
49 | } |
c3398f5b |
50 | |
6fbbcaf4 |
51 | TODO: { |
1ea948d1 |
52 | local our $TODO = "Mouse lacks this"; |
6fbbcaf4 |
53 | eval { |
54 | has error2 => ( |
55 | handles => \"ref_to_string", |
56 | ); |
57 | }; |
1ea948d1 |
58 | ::ok(!$@, "handles => \\str"); |
6fbbcaf4 |
59 | } |
c3398f5b |
60 | |
6fbbcaf4 |
61 | TODO: { |
1ea948d1 |
62 | local our $TODO = "Mouse lacks this"; |
6fbbcaf4 |
63 | eval { |
6fbbcaf4 |
64 | has error4 => ( |
65 | handles => sub { "code" }, |
66 | ); |
67 | }; |
1ea948d1 |
68 | ::ok(!$@, "handles => sub { code }"); |
6fbbcaf4 |
69 | } |
c3398f5b |
70 | }; |
71 | |
72 | can_ok(Class => qw(person has_person person_name person_age name age quid)); |
73 | |
74 | my $object = Class->new; |
75 | ok(!$object->has_person, "don't have a person yet"); |
76 | $object->person_name("Todd"); |
77 | ok($object->has_person, "calling person_name instantiated person"); |
78 | ok($object->person, "we really do have a person"); |
79 | |
80 | is($object->person_name, "Todd", "handles method"); |
81 | is($object->person->name, "Todd", "traditional lookup"); |
82 | is($object->person_age, 37, "handles method"); |
83 | is($object->person->age, 37, "traditional lookup"); |
84 | |
85 | my $object2 = Class->new(person => Person->new(name => "Philbert")); |
86 | ok($object2->has_person, "we have a person from the constructor"); |
87 | is($object2->person_name, "Philbert", "handles method"); |
88 | is($object2->person->name, "Philbert", "traditional lookup"); |
89 | is($object2->person_age, undef, "no age because we didn't use the default"); |
90 | is($object2->person->age, undef, "no age because we didn't use the default"); |
91 | |
92 | |
93 | ok($object->quid, "we have a Shawn"); |
94 | is($object->name, "Shawn", "name handle"); |
95 | is($object->age, 21, "age handle"); |
96 | is($object->me->name, "Shawn", "me->name"); |
97 | is($object->me->age, 21, "me->age"); |
98 | |
99 | is_deeply( |
100 | $object->meta->get_attribute('me')->handles, |
c3cc3642 |
101 | [ 'name', 'age' ], |
c3398f5b |
102 | "correct handles layout for 'me'", |
103 | ); |
104 | |
105 | is_deeply( |
106 | $object->meta->get_attribute('person')->handles, |
107 | { person_name => 'name', person_age => 'age' }, |
108 | "correct handles layout for 'person'", |
109 | ); |
110 | |
912fa381 |
111 | |
112 | { |
284ca75b |
113 | local $TODO = "failed on some environment, but I don't know why it happens (gfx)"; |
912fa381 |
114 | throws_ok{ |
115 | $object->person(undef); |
116 | $object->person_name(); |
117 | } qr/Cannot delegate person_name to name because the value of person is not defined/; |
118 | |
119 | throws_ok{ |
120 | $object->person([]); |
121 | $object->person_age(); |
122 | } qr/Cannot delegate person_age to age because the value of person is not an object/; |
123 | } |
124 | |
125 | eval{ |
7b133c92 |
126 | $object->person(undef); |
127 | $object->person_name(); |
912fa381 |
128 | }; |
129 | like $@, qr/Cannot delegate person_name to name because the value of person is not defined/; |
7b133c92 |
130 | |
912fa381 |
131 | eval{ |
7b133c92 |
132 | $object->person([]); |
133 | $object->person_age(); |
912fa381 |
134 | }; |
135 | like $@, qr/Cannot delegate person_age to age because the value of person is not an object/; |
136 | |
7b133c92 |
137 | |