Changes to work with (and require) Moose 0.73_01
[gitmo/MooseX-ClassAttribute.git] / t / lib / SharedTests.pm
1 package SharedTests;
2
3 use strict;
4 use warnings;
5
6 use Scalar::Util qw( isweak );
7 use Test::More;
8
9
10 {
11     package HasClassAttribute;
12
13     use Moose qw( has );
14     use MooseX::ClassAttribute;
15     use MooseX::AttributeHelpers;
16
17     use vars qw($Lazy);
18     $Lazy = 0;
19
20     class_has 'ObjectCount' =>
21         ( is        => 'rw',
22           isa       => 'Int',
23           default   => 0,
24         );
25
26     class_has 'WeakAttribute' =>
27         ( is        => 'rw',
28           isa       => 'Object',
29           weak_ref  => 1,
30         );
31
32     class_has 'LazyAttribute' =>
33         ( is      => 'rw',
34           isa     => 'Int',
35           lazy    => 1,
36           # The side effect is used to test that this was called
37           # lazily.
38           default => sub { $Lazy = 1 },
39         );
40
41     class_has 'ReadOnlyAttribute' =>
42         ( is      => 'ro',
43           isa     => 'Int',
44           default => 10,
45         );
46
47     class_has 'ManyNames' =>
48         ( is        => 'rw',
49           isa       => 'Int',
50           reader    => 'M',
51           writer    => 'SetM',
52           clearer   => 'ClearM',
53           predicate => 'HasM',
54         );
55
56     class_has 'Delegatee' =>
57         ( is      => 'rw',
58           isa     => 'Delegatee',
59           handles => [ 'units', 'color' ],
60           # if it's not lazy it makes a new object before we define
61           # Delegatee's attributes.
62           lazy    => 1,
63           default => sub { Delegatee->new() },
64         );
65
66     class_has 'Mapping' =>
67         ( metaclass => 'Collection::Hash',
68           is        => 'rw',
69           isa       => 'HashRef[Str]',
70           default   => sub { {} },
71           provides  =>
72           { exists => 'ExistsInMapping',
73             keys   => 'IdsInMapping',
74             get    => 'GetMapping',
75             set    => 'SetMapping',
76           },
77         );
78
79     has 'size' =>
80         ( is      => 'rw',
81           isa     => 'Int',
82           default => 5,
83         );
84
85     no Moose;
86
87     sub BUILD
88     {
89         my $self = shift;
90
91         $self->ObjectCount( $self->ObjectCount() + 1 );
92     }
93
94     sub make_immutable
95     {
96         my $class = shift;
97
98         $class->meta()->make_immutable();
99         Delegatee->meta()->make_immutable();
100     }
101 }
102
103 {
104     package Delegatee;
105
106     use Moose;
107
108     has 'units' =>
109         ( is      => 'ro',
110           default => 5,
111         );
112
113     has 'color' =>
114         ( is      => 'ro',
115           default => 'blue',
116         );
117
118     no Moose;
119 }
120
121 {
122     package Child;
123
124     use Moose;
125     use MooseX::ClassAttribute;
126
127     extends 'HasClassAttribute';
128
129     class_has '+ReadOnlyAttribute' =>
130         ( default => 30 );
131
132     class_has 'YetAnotherAttribute' =>
133         ( is      => 'ro',
134           default => 'thing',
135         );
136
137     no Moose;
138 }
139
140 sub run_tests
141 {
142     plan tests => 24;
143
144     local $Test::Builder::Level = $Test::Builder::Level + 1;
145
146     {
147         is( HasClassAttribute->ObjectCount(), 0,
148             'ObjectCount() is 0' );
149
150         my $hca1 = HasClassAttribute->new();
151         is( $hca1->size(), 5,
152             'size is 5 - object attribute works as expected' );
153         is( HasClassAttribute->ObjectCount(), 1,
154             'ObjectCount() is 1' );
155
156         my $hca2 = HasClassAttribute->new( size => 10 );
157         is( $hca2->size(), 10,
158             'size is 10 - object attribute can be set via constructor' );
159         is( HasClassAttribute->ObjectCount(), 2,
160             'ObjectCount() is 2' );
161         is( $hca2->ObjectCount(), 2,
162             'ObjectCount() is 2 - can call class attribute accessor on object' );
163     }
164
165     {
166         my $hca3 = HasClassAttribute->new( ObjectCount => 20 );
167         is( $hca3->ObjectCount(), 3,
168             'class attributes passed to the constructor do not get set in the object' );
169         is( HasClassAttribute->ObjectCount(), 3,
170             'class attributes are not affected by constructor params' );
171     }
172
173     {
174         my $object = bless {}, 'Thing';
175
176         HasClassAttribute->WeakAttribute($object);
177
178         undef $object;
179
180         ok( ! defined HasClassAttribute->WeakAttribute(),
181             'weak class attributes are weak' );
182     }
183
184     {
185         is( $HasClassAttribute::Lazy, 0,
186             '$HasClassAttribute::Lazy is 0' );
187
188         is( HasClassAttribute->LazyAttribute(), 1,
189             'HasClassAttribute->LazyAttribute() is 1' );
190
191         is( $HasClassAttribute::Lazy, 1,
192             '$HasClassAttribute::Lazy is 1 after calling LazyAttribute' );
193     }
194
195     {
196         eval { HasClassAttribute->ReadOnlyAttribute(20) };
197         like( $@, qr/\QCannot assign a value to a read-only accessor/,
198               'cannot set read-only class attribute' );
199     }
200
201     {
202         is( Child->ReadOnlyAttribute(), 30,
203             q{Child class can extend parent's class attribute} );
204     }
205
206     {
207         ok( ! HasClassAttribute->HasM(),
208             'HasM() returns false before M is set' );
209
210         HasClassAttribute->SetM(22);
211
212         ok( HasClassAttribute->HasM(),
213             'HasM() returns true after M is set' );
214         is( HasClassAttribute->M(), 22,
215             'M() returns 22' );
216
217         HasClassAttribute->ClearM();
218
219         ok( ! HasClassAttribute->HasM(),
220             'HasM() returns false after M is cleared' );
221     }
222
223     {
224         isa_ok( HasClassAttribute->Delegatee(), 'Delegatee',
225                 'has a Delegetee object' );
226         is( HasClassAttribute->units(), 5,
227             'units() delegates to Delegatee and returns 5' );
228     }
229
230     {
231         my @ids = HasClassAttribute->IdsInMapping();
232         is( scalar @ids, 0,
233             'there are no keys in the mapping yet' );
234
235         ok( ! HasClassAttribute->ExistsInMapping('a'),
236             'key does not exist in mapping' );
237
238         HasClassAttribute->SetMapping( a => 20 );
239
240         ok( HasClassAttribute->ExistsInMapping('a'),
241             'key does exist in mapping' );
242
243         is( HasClassAttribute->GetMapping('a'), 20,
244             'value for a in mapping is 20' );
245     }
246 }
247
248
249 1;