« back to all changes in this revision
Viewing changes to t/base.t
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Krzysztof Krzyzaniak (eloy)
- Date: 2006-01-03 17:29:20 UTC
- Revision ID: james.westby@ubuntu.com-20060103172920-h94p8qrrav90bzq0
Tags: upstream-0.52
Import upstream version 0.52
- files added:
- lib
- lib/Class
- lib/Class/Meta
- lib/Class/Meta/AccessorBuilder
- lib/Class/Meta/Types
- t
added
removed
t/base.t
1
#!perl -w
2
3
# $Id: base.t 1889 2005-07-13 01:31:50Z curtis $
4
5
##############################################################################
6
# Set up the tests.
7
##############################################################################
8
9
use strict;
10
#use Test::More tests => 130;
11
use Test::More 'no_plan';
12
13
##############################################################################
14
# Create a simple class.
15
##############################################################################
16
17
package Class::Meta::TestPerson;
18
use strict;
19
20
BEGIN {
21
main::use_ok('Class::Meta');
22
main::use_ok('Class::Meta::Types::Numeric');
23
main::use_ok('Class::Meta::Types::String');
24
}
25
26
BEGIN {
27
my $c = Class::Meta->new(
28
key => 'person',
29
package => __PACKAGE__,
30
name => 'Class::Meta::TestPerson Class',
31
desc => 'Special person class just for testing Class::Meta.',
32
);
33
34
# Add a constructor.
35
$c->add_constructor( name => 'new',
36
create => 1 );
37
38
# Add a couple of attributes with created methods.
39
$c->add_attribute( name => 'id',
40
view => Class::Meta::PUBLIC,
41
authz => Class::Meta::READ,
42
create => Class::Meta::GET,
43
type => 'integer',
44
label => 'ID',
45
desc => "The person object's ID.",
46
required => 1,
47
default => 12,
48
);
49
$c->add_attribute( name => 'name',
50
view => Class::Meta::PUBLIC,
51
authz => Class::Meta::RDWR,
52
create => Class::Meta::GETSET,
53
type => 'string',
54
label => 'Name',
55
desc => "The person's name.",
56
required => 1,
57
default => '',
58
);
59
$c->add_attribute( name => 'age',
60
view => Class::Meta::PUBLIC,
61
authz => Class::Meta::RDWR,
62
create => Class::Meta::GETSET,
63
type => 'integer',
64
label => 'Age',
65
desc => "The person's age.",
66
required => 0,
67
default => undef,
68
);
69
70
# Our custom accessor for goop.
71
sub goop { shift->{goop} }
72
73
# Add an attribute for which we will create the accessor method.
74
$c->add_attribute( name => 'goop',
75
view => Class::Meta::PUBLIC,
76
authz => Class::Meta::READ,
77
create => Class::Meta::NONE,
78
type => 'string',
79
label => 'Goop',
80
desc => "The person's gooposity.",
81
required => 0,
82
default => 'very',
83
);
84
85
# Add a class attribute.
86
$c->add_attribute( name => 'count',
87
type => 'integer',
88
label => 'Count',
89
context => Class::Meta::CLASS,
90
default => 0,
91
);
92
93
# Add a couple of custom methods.
94
$c->add_method( name => 'chk_pass',
95
view => Class::Meta::PUBLIC,
96
args => ['string', 'string'],
97
returns => 'bool',
98
);
99
100
$c->add_method( name => 'shame',
101
view => Class::Meta::PUBLIC,
102
returns => 'person',
103
);
104
105
$c->build;
106
107
my $d = Class::Meta->new(
108
key => 'green_monkey',
109
package => 'Class::Meta::GreenMonkey',
110
name => 'Class::Meta::GreenMonkey Class',
111
desc => 'Special monkey class just for testing Class::Meta.',
112
);
113
114
# Add a constructor.
115
$d->add_constructor( name => 'new',
116
create => 1 );
117
118
# Add a couple of attributes with created methods.
119
$d->add_attribute( name => 'id',
120
view => Class::Meta::PUBLIC,
121
authz => Class::Meta::READ,
122
create => Class::Meta::GET,
123
type => 'integer',
124
label => 'ID',
125
desc => "The monkey object's ID.",
126
required => 1,
127
default => 12,
128
);
129
$d->build;
130
}
131
132
sub chk_pass {
133
my ($self, $un, $pw) = @_;
134
return $un eq 'larry' && $pw eq 'yrral' ? 1 : 0;
135
}
136
137
sub shame { shift }
138
139
##############################################################################
140
# Do the tests.
141
##############################################################################
142
143
package main;
144
# Instantiate a base class object and test its accessors.
145
ok( my $t = Class::Meta::TestPerson->new, 'Class::Meta::TestPerson->new');
146
is( $t->id, 12, 'id is 12');
147
eval { $t->id(1) };
148
149
# Test string.
150
ok( $t->name('David'), 'name to "David"' );
151
is( $t->name, 'David', 'name is "David"' );
152
eval { $t->name([]) };
153
ok( my $err = $@, 'name to array ref croaks' );
154
like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
155
156
# Grab its metadata object.
157
ok( my $class = $t->my_class, "Get Class::Meta::Class object" );
158
159
# Test the is_a() method.
160
ok( $class->is_a('Class::Meta::TestPerson'), 'Class is_a TestPerson');
161
162
# Test the key methods.
163
is( $class->key, 'person', 'Key is correct');
164
165
# Test the package methods.
166
is($class->package, 'Class::Meta::TestPerson', 'package()');
167
168
# Test the name methods.
169
is( $class->name, 'Class::Meta::TestPerson Class', "Name is correct");
170
171
# Test the description methods.
172
is( $class->desc, 'Special person class just for testing Class::Meta.',
173
"Description is correct");
174
175
# Test attributes().
176
ok(my @attributes = $class->attributes, "Get attributes from attributes()" );
177
is( scalar @attributes, 5, "Five attributes from attributes()" );
178
isa_ok($attributes[0], 'Class::Meta::Attribute',
179
"First object is a attribute object" );
180
isa_ok($attributes[1], 'Class::Meta::Attribute',
181
"Second object is a attribute object" );
182
isa_ok($attributes[2], 'Class::Meta::Attribute',
183
"Third object is a attribute object" );
184
isa_ok($attributes[3], 'Class::Meta::Attribute',
185
"Fourth object is a attribute object" );
186
is( $attributes[0]->class, $class, "Check attribute class" );
187
188
# Get specific attributes.
189
ok( @attributes = $class->attributes(qw(age name)), 'Get specific attributes' );
190
is( scalar @attributes, 2, "Two specific attributes from attributes()" );
191
isa_ok($attributes[0], 'Class::Meta::Attribute', "Attribute object type" );
192
193
is( $attributes[0]->name, 'age', 'First attr name' );
194
is( $attributes[1]->name, 'name', 'Second attr name' );
195
196
# Check the attributes of the "ID" attribute object.
197
ok( my $p = $class->attributes('id'), "Get ID attribute object" );
198
is( $p->name, 'id', 'ID name' );
199
is( $p->desc, "The person object's ID.", 'ID description' );
200
is( $p->view, Class::Meta::PUBLIC, 'ID view' );
201
is( $p->authz, Class::Meta::READ, 'ID authorization' );
202
is( $p->type, 'integer', 'ID type' );
203
is( $p->label, 'ID', 'ID label' );
204
ok( $p->required, "ID required" );
205
is( $p->default, 12, "ID default" );
206
207
# Test the attribute accessors.
208
is( $p->get($t), 12, 'ID is 12' );
209
# ID is READ, so we shouldn't be able to set it.
210
eval { $p->set($t, 10) };
211
ok( $err = $@, "Set val failure" );
212
like( $err, qr/Cannot set attribute 'id/, 'set val exception' );
213
214
# Check the attributes of the "Name" attribute object.
215
ok( $p = $class->attributes('name'), "Get name attribute" );
216
is( $p->name, 'name', 'Name name' );
217
is( $p->desc, "The person's name.", 'Name description' );
218
is( $p->view, Class::Meta::PUBLIC, 'Name view' );
219
is( $p->authz, Class::Meta::RDWR, 'Name authorization' );
220
is( $p->type, 'string', 'Name type' );
221
is( $p->label, 'Name', 'Name label' );
222
ok( $p->required, "Name required" );
223
is( $p->default, '', "Name default" );
224
225
# Test the attribute accessors.
226
is( $p->get($t), 'David', 'Name get' );
227
ok( $p->set($t, 'Larry'), 'Name set' );
228
is( $p->get($t), 'Larry', 'New Name get' );
229
is( $t->name, 'Larry', 'Object name');
230
ok( $t->name('Damian'), 'Object name' );
231
is( $p->get($t), 'Damian', 'Final Name get' );
232
233
# Check the attributes of the "Age" attribute object.
234
ok( $p = $class->attributes('age'), "Get age attribute" );
235
is( $p->name, 'age', 'Age name' );
236
is( $p->desc, "The person's age.", 'Age description' );
237
is( $p->view, Class::Meta::PUBLIC, 'Age view' );
238
is( $p->authz, Class::Meta::RDWR, 'Age authorization' );
239
is( $p->type, 'integer', 'Age type' );
240
is( $p->label, 'Age', 'Age label' );
241
ok( $p->required == 0, "Age required" );
242
is( $p->default, undef, "Age default" );
243
244
# Test the age attribute accessors.
245
ok( ! defined $p->get($t), 'Age get' );
246
ok( $p->set($t, 10), 'Age set' );
247
is( $p->get($t), 10, 'New Age get' );
248
ok( $t->age == 10, 'Object age');
249
ok( $t->age(22), 'Object age' );
250
is( $p->get($t), 22, 'Final Age get' );
251
252
# Check the attributes of the "Count" attribute object.
253
ok( $p = $class->attributes('count'), "Get count attribute" );
254
is( $p->name, 'count', 'Count name' );
255
is( $p->desc, undef, 'Count description' );
256
is( $p->view, Class::Meta::PUBLIC, 'Count view' );
257
is( $p->authz, Class::Meta::RDWR, 'Count authorization' );
258
is( $p->type, 'integer', 'Count type' );
259
is( $p->label, 'Count', 'Count label' );
260
is( $p->required, 0, "Count required" );
261
is( $p->default, 0, "Count default" );
262
263
# Test the count attribute accessors.
264
is( $p->get($t), 0, 'Count get' );
265
ok( $p->set($t, 10), 'Count set' );
266
is( $p->get($t), 10, 'New Count get' );
267
is( $t->count, 10, 'Object count');
268
ok( $t->count(22), 'Set object count' );
269
is( $p->get($t), 22, 'Final Count get' );
270
271
# Make sure they also work as class attributes.
272
is( Class::Meta::TestPerson->count, 22, 'Class count' );
273
ok( Class::Meta::TestPerson->count(35), 'Set class count' );
274
is( Class::Meta::TestPerson->count, 35, 'Class count again' );
275
is( $t->count, 35, 'Object count after class');
276
is( $p->get($t), 35, 'Final Count get after class' );
277
278
# Test goop attribute accessor.
279
is( $t->goop, 'very', "Got goop" );
280
$t->goop('feh');
281
is( $t->goop, 'very', "Still got goop" );
282
ok( $p = $class->attributes('goop'), "Get goop attribute object" );
283
is( $p->get($t), 'very', "Got attribute goop" );
284
eval { $p->set($t, 'feh') };
285
ok( $@, "Can't set goop" );
286
is( $p->get($t), 'very', "Still got attribute goop" );
287
288
# Test methods().
289
ok( my @methods = $class->methods, "Get method objects" );
290
is( scalar @methods, 2, 'Number of methods from methods()' );
291
isa_ok($methods[0], 'Class::Meta::Method',
292
"First object is a method object" );
293
isa_ok($methods[1], 'Class::Meta::Method',
294
"Second object is a method object" );
295
296
# Check the order in which they're returned.
297
is( $methods[0]->name, 'chk_pass', 'First method' );
298
is( $methods[1]->name, 'shame', 'Second method' );
299
is( $methods[0]->class, $class, "Check method class" );
300
is_deeply( $methods[0]->args, ['string', 'string'], "Check method args" );
301
is( $methods[0]->returns, 'bool', "Check method returns" );
302
is( $methods[1]->args, undef, 'Second specific method args' );
303
is( $methods[1]->returns, 'person', 'Second specific method returns' );
304
305
# Get a few specific methods.
306
ok( @methods = $class->methods(qw(shame chk_pass)),
307
'Grab specific methods.');
308
is( scalar @methods, 2, 'Two methods from methods()' );
309
is( $methods[0]->name, 'shame', 'First specific method' );
310
is( $methods[1]->name, 'chk_pass', 'Second specific method' );
311
312
# Check out the chk_pass method.
313
ok( my $m = $class->methods('chk_pass'), "Get chk_pass method object" );
314
is( $m->name, 'chk_pass', 'chk_pass name' );
315
ok( $m->call($t, 'larry', 'yrral') == 1, 'Call chk_pass returns true' );
316
ok( $m->call($t, 'larry', 'foo') == 0, 'Call chk_pass returns false' );
317
318
# Test constructors().
319
ok( my @constructors = $class->constructors, "Get constructor objects" );
320
is( scalar @constructors, 1, 'Number of constructors from constructors()' );
321
isa_ok($constructors[0], 'Class::Meta::Constructor',
322
"First object is a constructor object" );
323
324
# Check the order in which they're returned.
325
is( $constructors[0]->name, 'new', 'Check new constructor name' );
326
is( $constructors[0]->class, $class, "Check constructor class" );
327
328
# Get a few specific constructors.
329
ok( @constructors = $class->constructors(qw(new)),
330
'Grab specific constructor.');
331
is( scalar @constructors, 1, 'Two constructors from constructors()' );
332
is( $constructors[0]->name, 'new', 'Check specific constructor' );
333
334
# Try getting the class object via the for_key() class method.
335
is( Class::Meta->for_key($class->key), $class, "for_key returns class" );
336
337
# Try getting a list of all class object keys
338
can_ok( 'Class::Meta', 'keys' );
339
ok( my $keys = Class::Meta->keys, 'Calling keys in scalar context should succeed');
340
is( ref $keys, 'ARRAY', 'And it should return an array ref');
341
@$keys = sort @$keys;
342
is_deeply($keys, [qw/green_monkey person/], 'And keys should return the correct keys');
343
344
ok( my @keys = Class::Meta->keys, 'Calling keys in list context should succeed');
345
is(scalar @keys, 2, 'And it should return the correct number of keys');
346
@keys = sort @keys;
347
is_deeply(\@keys, [qw/green_monkey person/], 'And keys should return the correct keys');
348
349
# try deleting the class object classes
350
can_ok('Class::Meta', 'clear');
351
Class::Meta->clear('green_monkey');
352
@keys = Class::Meta->keys;
353
is_deeply(\@keys, ['person'], 'And it should delete a key if provided with one');
354
355
Class::Meta->clear('no_such_key');
356
@keys = Class::Meta->keys;
357
is_deeply(\@keys, ['person'], 'But deleting a non-existent key should be a no-op');
358
359
Class::Meta->clear;
360
@keys = Class::Meta->keys;
361
is_deeply(\@keys, [], 'And calling it without arguments should remove all keys');
362
__END__
Loggerhead is a web-based interface for Breezy
Version: 2.0.1