Commit | Line | Data |
---|---|---|
ad6edfcb JH |
1 | #!./perl -w |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
dd58e686 MP |
8 | # |
9 | # A couple of simple classes to use as struct elements. | |
10 | # | |
ad6edfcb | 11 | package aClass; |
ad6edfcb | 12 | sub new { bless {}, shift } |
ad6edfcb JH |
13 | sub meth { 42 } |
14 | ||
f8aada62 | 15 | package RecClass; |
f8aada62 JH |
16 | sub new { bless {}, shift } |
17 | ||
dd58e686 MP |
18 | # |
19 | # The first of our Class::Struct based objects. | |
20 | # | |
ad6edfcb | 21 | package MyObj; |
22633ac4 JH |
22 | use Class::Struct; |
23 | use Class::Struct 'struct'; # test out both forms | |
ad6edfcb JH |
24 | use Class::Struct SomeClass => { SomeElem => '$' }; |
25 | ||
26 | struct( s => '$', a => '@', h => '%', c => 'aClass' ); | |
27 | ||
dd58e686 MP |
28 | # |
29 | # The second Class::Struct objects: | |
30 | # test the 'compile-time without package name' feature. | |
31 | # | |
32 | package MyOther; | |
33 | use Class::Struct s => '$', a => '@', h => '%', c => 'aClass'; | |
ad6edfcb | 34 | |
dd58e686 | 35 | # |
61dc4abc RB |
36 | # test overriden accessors |
37 | # | |
38 | package OverrideAccessor; | |
39 | use Class::Struct; | |
40 | ||
188f5f27 RB |
41 | { |
42 | no warnings qw(Class::Struct); | |
43 | struct( 'OverrideAccessor', { count => '$' } ); | |
44 | } | |
61dc4abc RB |
45 | |
46 | sub count { | |
47 | my ($self,$count) = @_; | |
48 | ||
49 | if ( @_ >= 2 ) { | |
50 | $self->{'OverrideAccessor::count'} = $count + 9; | |
51 | } | |
52 | ||
53 | return $self->{'OverrideAccessor::count'}; | |
54 | } | |
55 | ||
56 | # | |
dd58e686 MP |
57 | # back to main... |
58 | # | |
59 | package main; | |
ad6edfcb | 60 | |
1b992933 | 61 | use Test::More; |
ad6edfcb | 62 | |
dd58e686 MP |
63 | my $obj = MyObj->new; |
64 | isa_ok $obj, 'MyObj'; | |
ad6edfcb | 65 | |
dd58e686 MP |
66 | $obj->s('foo'); |
67 | is $obj->s(), 'foo'; | |
ad6edfcb | 68 | |
dd58e686 | 69 | isa_ok $obj->a, 'ARRAY'; |
ad6edfcb | 70 | $obj->a(2, 'secundus'); |
dd58e686 | 71 | is $obj->a(2), 'secundus'; |
ad6edfcb | 72 | |
dd58e686 MP |
73 | $obj->a([4,5,6]); |
74 | is $obj->a(1), 5; | |
ad6edfcb | 75 | |
dd58e686 | 76 | isa_ok $obj->h, 'HASH'; |
ad6edfcb | 77 | $obj->h('x', 10); |
dd58e686 | 78 | is $obj->h('x'), 10; |
ad6edfcb | 79 | |
dd58e686 MP |
80 | $obj->h({h=>7,r=>8,f=>9}); |
81 | is $obj->h('r'), 8; | |
ad6edfcb | 82 | |
dd58e686 | 83 | is $obj->c, undef; |
ad6edfcb | 84 | |
f8aada62 | 85 | $obj = MyObj->new( c => aClass->new ); |
dd58e686 MP |
86 | isa_ok $obj->c, 'aClass'; |
87 | is $obj->c->meth(), 42; | |
ad6edfcb | 88 | |
f8aada62 | 89 | |
8af2e859 | 90 | $obj = MyOther->new; |
dd58e686 | 91 | isa_ok $obj, 'MyOther'; |
ad6edfcb | 92 | |
dd58e686 MP |
93 | $obj->s('foo'); |
94 | is $obj->s(), 'foo'; | |
ad6edfcb | 95 | |
dd58e686 MP |
96 | isa_ok $obj->a, 'ARRAY'; |
97 | $obj->a(2, 'secundus'); | |
98 | is $obj->a(2), 'secundus'; | |
ad6edfcb | 99 | |
726cfeaf | 100 | $obj->a([4,5,6]); |
dd58e686 | 101 | is $obj->a(1), 5; |
726cfeaf | 102 | |
dd58e686 MP |
103 | isa_ok $obj->h, 'HASH'; |
104 | $obj->h('x', 10); | |
105 | is $obj->h('x'), 10; | |
726cfeaf JH |
106 | |
107 | $obj->h({h=>7,r=>8,f=>9}); | |
dd58e686 | 108 | is $obj->h('r'), 8; |
726cfeaf | 109 | |
dd58e686 MP |
110 | is $obj->c, undef; |
111 | ||
112 | $obj = MyOther->new( c => aClass->new ); | |
113 | isa_ok $obj->c, 'aClass'; | |
114 | is $obj->c->meth(), 42; | |
115 | ||
116 | ||
117 | ||
118 | my $obk = SomeClass->new(); | |
119 | $obk->SomeElem(123); | |
120 | is $obk->SomeElem(), 123; | |
f8aada62 | 121 | |
dd58e686 MP |
122 | my $recobj = RecClass->new(); |
123 | isa_ok $recobj, 'RecClass'; | |
726cfeaf | 124 | |
61dc4abc RB |
125 | my $override_obj = OverrideAccessor->new( count => 3 ); |
126 | is $override_obj->count, 12; | |
127 | ||
128 | $override_obj->count( 1 ); | |
129 | is $override_obj->count, 10; | |
130 | ||
1b992933 NC |
131 | |
132 | use Class::Struct Kapow => { z_zwap => 'Regexp', sploosh => 'MyObj' }; | |
133 | ||
134 | is eval { main->new(); }, undef, | |
135 | 'No new method injected into current package'; | |
136 | ||
137 | my $obj3 = Kapow->new(); | |
138 | ||
139 | isa_ok $obj3, 'Kapow'; | |
140 | is $obj3->z_zwap, undef, 'No z_zwap member by default'; | |
141 | is $obj3->sploosh, undef, 'No sploosh member by default'; | |
142 | $obj3->z_zwap(qr//); | |
143 | isa_ok $obj3->z_zwap, 'Regexp', 'Can set z_zwap member'; | |
144 | $obj3->sploosh(MyObj->new(s => 'pie')); | |
145 | isa_ok $obj3->sploosh, 'MyObj', | |
146 | 'Can set sploosh member to object of correct class'; | |
147 | is $obj3->sploosh->s, 'pie', 'Can set sploosh member to correct object'; | |
148 | ||
149 | my $obj4 = Kapow->new( z_zwap => qr//, sploosh => MyObj->new(a => ['Good']) ); | |
150 | ||
151 | isa_ok $obj4, 'Kapow'; | |
152 | isa_ok $obj4->z_zwap, 'Regexp', 'Initialised z_zwap member'; | |
153 | isa_ok $obj4->sploosh, 'MyObj', 'Initialised sploosh member'; | |
154 | is_deeply $obj4->sploosh->a, ['Good'], 'with correct object'; | |
155 | ||
156 | my $obj5 = Kapow->new( sploosh => { h => {perl => 'rules'} } ); | |
157 | ||
158 | isa_ok $obj5, 'Kapow'; | |
159 | is $obj5->z_zwap, undef, 'No z_zwap member by default'; | |
160 | isa_ok $obj5->sploosh, 'MyObj', 'Initialised sploosh member from hash'; | |
161 | is_deeply $obj5->sploosh->h, { perl => 'rules'} , 'with correct object'; | |
162 | ||
6d034728 NC |
163 | is eval { |
164 | package MyObj; | |
165 | struct( s => '$', a => '@', h => '%', c => 'aClass' ); | |
166 | }, undef, 'Calling struct a second time fails'; | |
167 | ||
168 | like $@, qr/^function 'new' already defined in package MyObj/, | |
169 | 'fails with the expected error'; | |
170 | ||
171 | is eval { MyObj->new( a => {} ) }, undef, | |
172 | 'Using a hash where an array reference is expected'; | |
173 | like $@, qr/^Initializer for a must be array reference/, | |
174 | 'fails with the expected error'; | |
175 | ||
176 | is eval { MyObj->new( h => [] ) }, undef, | |
177 | 'Using an array where a hash reference is expected'; | |
178 | like $@, qr/^Initializer for h must be hash reference/, | |
179 | 'fails with the expected error'; | |
180 | ||
181 | is eval { Kapow->new( sploosh => { h => [perl => 'rules'] } ); }, undef, | |
182 | 'Using an array where a hash reference is expected in an initialiser list'; | |
183 | like $@, qr/^Initializer for h must be hash reference/, | |
184 | 'fails with the expected error'; | |
185 | ||
186 | is eval { Kapow->new( sploosh => [ h => {perl => 'rules'} ] ); }, undef, | |
187 | "Using an array for a member object's initialiser list"; | |
188 | like $@, qr/^Initializer for sploosh must be hash or MyObj reference/, | |
189 | 'fails with the expected error'; | |
190 | ||
191 | is eval { | |
192 | package Crraack; | |
193 | use Class::Struct 'struct'; | |
194 | struct( 'pow' => '@$%!' ); | |
195 | }, undef, 'Bad type fails'; | |
196 | like $@, qr/^'\@\$\%\!' is not a valid struct element type/, | |
197 | 'with the expected error'; | |
198 | ||
199 | is eval { | |
200 | $obj3->sploosh(MyOther->new(s => 3.14)); | |
201 | }, undef, 'Setting member to the wrong class of object fails'; | |
202 | like $@, qr/^sploosh argument is wrong class/, | |
203 | 'with the expected error'; | |
204 | is $obj3->sploosh->s, 'pie', 'Object is unchanged'; | |
205 | ||
206 | is eval { | |
207 | $obj3->sploosh(MyObj->new(s => 3.14), 'plop'); | |
208 | }, undef, 'Too many arguments to setter fails'; | |
209 | like $@, qr/^Too many args to sploosh/, | |
210 | 'with the expected error'; | |
211 | is $obj3->sploosh->s, 'pie', 'Object is unchanged'; | |
212 | ||
213 | is eval { | |
214 | package Blurp; | |
215 | use Class::Struct 'struct'; | |
216 | struct( Blurp => {}, 'Bonus!' ); | |
217 | }, undef, 'hash based class with extra argument fails'; | |
218 | like $@, qr/\Astruct usage error.*\n.*\n/, | |
219 | 'with the expected confession'; | |
220 | ||
221 | is eval { | |
222 | package Zamm; | |
223 | use Class::Struct 'struct'; | |
224 | struct( Zamm => [], 'Bonus!' ); | |
225 | }, undef, 'array based class with extra argument fails'; | |
226 | like $@, qr/\Astruct usage error.*\n.*\n/, | |
227 | 'with the expected confession'; | |
228 | ||
229 | is eval { | |
230 | package Thwapp; | |
231 | use Class::Struct 'struct'; | |
232 | struct( Thwapp => ['Bonus!'] ); | |
233 | }, undef, 'array based class with extra constructor argument fails'; | |
234 | like $@, qr/\Astruct usage error.*\n.*\n/, | |
235 | 'with the expected confession'; | |
236 | ||
237 | is eval { | |
238 | package Rakkk; | |
239 | use Class::Struct 'struct'; | |
240 | struct( z_zwap => 'Regexp', sploosh => 'MyObj', 'Bonus' ); | |
241 | }, undef, 'default array based class with extra constructor argument fails'; | |
242 | like $@, qr/\Astruct usage error.*\n.*\n/, | |
243 | 'with the expected confession'; | |
244 | ||
245 | is eval { | |
246 | package Awk; | |
247 | use parent -norequire, 'Urkkk'; | |
248 | use Class::Struct 'struct'; | |
249 | struct( beer => 'foamy' ); | |
250 | }, undef, '@ISA is not allowed'; | |
251 | like $@, qr/^struct class cannot be a subclass \(\@ISA not allowed\)/, | |
252 | 'with the expected error'; | |
253 | ||
1b992933 | 254 | done_testing; |