File: base.t

package info (click to toggle)
libclass-meta-perl 0.66-2.1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye
  • size: 660 kB
  • sloc: perl: 5,886; makefile: 2
file content (357 lines) | stat: -rw-r--r-- 13,708 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
#!perl -w

##############################################################################
# Set up the tests.
##############################################################################

use strict;
use Test::More tests => 132;

##############################################################################
# Create a simple class.
##############################################################################

package Class::Meta::TestPerson;
use strict;

BEGIN {
    main::use_ok('Class::Meta');
}

BEGIN {
    my $c = Class::Meta->new(
        key     => 'person',
        package => __PACKAGE__,
        name    => 'Class::Meta::TestPerson Class',
        desc    => 'Special person class just for testing Class::Meta.',
    );

    # Add a constructor.
    $c->add_constructor( name => 'new',
                         create  => 1 );

    # Add a couple of attributes with created methods.
    $c->add_attribute( name     => 'id',
                       view     => Class::Meta::PUBLIC,
                       authz    => Class::Meta::READ,
                       create   => Class::Meta::GET,
                       type     => 'integer',
                       label    => 'ID',
                       desc     => "The person object's ID.",
                       required => 1,
                       default  => 12,
                   );
    $c->add_attribute( name     => 'name',
                       view     => Class::Meta::PUBLIC,
                       authz    => Class::Meta::RDWR,
                       create   => Class::Meta::GETSET,
                       type     => 'string',
                       label    => 'Name',
                       desc     => "The person's name.",
                       required => 1,
                       default  => '',
                   );
    $c->add_attribute( name     => 'age',
                       view     => Class::Meta::PUBLIC,
                       authz    => Class::Meta::RDWR,
                       create   => Class::Meta::GETSET,
                       type     => 'integer',
                       label    => 'Age',
                       desc     => "The person's age.",
                       required => 0,
                       default  => undef,
                   );

    # Our custom accessor for goop.
    sub goop { shift->{goop} }

    # Add an attribute for which we will create the accessor method.
    $c->add_attribute( name     => 'goop',
                       view     => Class::Meta::PUBLIC,
                       authz    => Class::Meta::READ,
                       create   => Class::Meta::NONE,
                       type     => 'string',
                       label    => 'Goop',
                       desc     => "The person's gooposity.",
                       required => 0,
                       default  => 'very',
                   );

    # Add a class attribute.
    $c->add_attribute( name     => 'count',
                       type     => 'integer',
                       label    => 'Count',
                       context  => Class::Meta::CLASS,
                       default  => 0,
                   );

    # Add a couple of custom methods.
    $c->add_method( name    => 'chk_pass',
                    view    => Class::Meta::PUBLIC,
                    args    => ['string', 'string'],
                    returns => 'bool',
                );

    $c->add_method( name    => 'shame',
                    view    => Class::Meta::PUBLIC,
                    returns => 'person',
                );

    $c->build;

    my $d = Class::Meta->new(
        key     => 'green_monkey',
        package => 'Class::Meta::GreenMonkey',
        name    => 'Class::Meta::GreenMonkey Class',
        desc    => 'Special monkey class just for testing Class::Meta.',
    );

    # Add a constructor.
    $d->add_constructor( name => 'new',
                         create  => 1 );

    # Add a couple of attributes with created methods.
    $d->add_attribute( name     => 'id',
                       view     => Class::Meta::PUBLIC,
                       authz    => Class::Meta::READ,
                       create   => Class::Meta::GET,
                       type     => 'integer',
                       label    => 'ID',
                       desc     => "The monkey object's ID.",
                       required => 1,
                       default  => 12,
                   );
    $d->build;
}

sub chk_pass {
    my ($self, $un, $pw) = @_;
    return $un eq 'larry' && $pw eq 'yrral' ? 1 : 0;
}

sub shame { shift }

##############################################################################
# Do the tests.
##############################################################################

package main;
# Instantiate a base class object and test its accessors.
ok( my $t = Class::Meta::TestPerson->new, 'Class::Meta::TestPerson->new');
is( $t->id, 12, 'id is 12');
eval { $t->id(1) };

# Test string.
ok( $t->name('David'), 'name to "David"' );
is( $t->name, 'David', 'name is "David"' );
eval { $t->name([]) };
ok( my $err = $@, 'name to array ref croaks' );
like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );

# Grab its metadata object.
ok( my $class = $t->my_class, "Get Class::Meta::Class object" );

# Test the is_a() method.
ok( $class->is_a('Class::Meta::TestPerson'), 'Class is_a TestPerson');

# Test the key methods.
is( $class->key, 'person', 'Key is correct');

# Test the package methods.
is($class->package, 'Class::Meta::TestPerson', 'package()');

# Test the name methods.
is( $class->name, 'Class::Meta::TestPerson Class', "Name is correct");

# Test the description methods.
is( $class->desc, 'Special person class just for testing Class::Meta.',
    "Description is correct");

# Test attributes().
ok(my @attributes = $class->attributes, "Get attributes from attributes()" );
is( scalar @attributes, 5, "Five attributes from attributes()" );
isa_ok($attributes[0], 'Class::Meta::Attribute',
       "First object is a attribute object" );
isa_ok($attributes[1], 'Class::Meta::Attribute',
       "Second object is a attribute object" );
isa_ok($attributes[2], 'Class::Meta::Attribute',
       "Third object is a attribute object" );
isa_ok($attributes[3], 'Class::Meta::Attribute',
       "Fourth object is a attribute object" );
is( $attributes[0]->class, $class, "Check attribute class" );

# Get specific attributes.
ok( @attributes = $class->attributes(qw(age name)), 'Get specific attributes' );
is( scalar @attributes, 2, "Two specific attributes from attributes()" );
isa_ok($attributes[0], 'Class::Meta::Attribute', "Attribute object type" );

is( $attributes[0]->name, 'age', 'First attr name' );
is( $attributes[1]->name, 'name', 'Second attr name' );

# Check the attributes of the "ID" attribute object.
ok( my $p = $class->attributes('id'), "Get ID attribute object" );
is( $p->name, 'id', 'ID name' );
is( $p->desc, "The person object's ID.", 'ID description' );
is( $p->view, Class::Meta::PUBLIC, 'ID view' );
is( $p->authz, Class::Meta::READ, 'ID authorization' );
is( $p->type, 'integer', 'ID type' );
is( $p->label, 'ID', 'ID label' );
ok( $p->required, "ID required" );
is( $p->default, 12, "ID default" );

# Test the attribute accessors.
is( $p->get($t), 12, 'ID is 12' );
# ID is READ, so we shouldn't be able to set it.
eval { $p->set($t, 10) };
ok( $err = $@, "Set val failure" );
like( $err, qr/Cannot set attribute 'id/, 'set val exception' );

# Check the attributes of the "Name" attribute object.
ok( $p = $class->attributes('name'), "Get name attribute" );
is( $p->name, 'name', 'Name name' );
is( $p->desc, "The person's name.", 'Name description' );
is( $p->view, Class::Meta::PUBLIC, 'Name view' );
is( $p->authz, Class::Meta::RDWR, 'Name authorization' );
is( $p->type, 'string', 'Name type' );
is( $p->label, 'Name', 'Name label' );
ok( $p->required, "Name required" );
is( $p->default, '', "Name default" );

# Test the attribute accessors.
is( $p->get($t), 'David', 'Name get' );
ok( $p->set($t, 'Larry'), 'Name set' );
is( $p->get($t), 'Larry', 'New Name get' );
is( $t->name, 'Larry', 'Object name');
ok( $t->name('Damian'), 'Object name' );
is( $p->get($t), 'Damian', 'Final Name get' );

# Check the attributes of the "Age" attribute object.
ok( $p = $class->attributes('age'), "Get age attribute" );
is( $p->name, 'age', 'Age name' );
is( $p->desc, "The person's age.", 'Age description' );
is( $p->view, Class::Meta::PUBLIC, 'Age view' );
is( $p->authz, Class::Meta::RDWR, 'Age authorization' );
is( $p->type, 'integer', 'Age type' );
is( $p->label, 'Age', 'Age label' );
ok( $p->required == 0, "Age required" );
is( $p->default, undef, "Age default" );

# Test the age attribute accessors.
ok( ! defined $p->get($t), 'Age get' );
ok( $p->set($t, 10), 'Age set' );
is( $p->get($t), 10, 'New Age get' );
ok( $t->age == 10, 'Object age');
ok( $t->age(22), 'Object age' );
is( $p->get($t), 22, 'Final Age get' );

# Check the attributes of the "Count" attribute object.
ok( $p = $class->attributes('count'), "Get count attribute" );
is( $p->name, 'count', 'Count name' );
is( $p->desc, undef, 'Count description' );
is( $p->view, Class::Meta::PUBLIC, 'Count view' );
is( $p->authz, Class::Meta::RDWR, 'Count authorization' );
is( $p->type, 'integer', 'Count type' );
is( $p->label, 'Count', 'Count label' );
is( $p->required, 0, "Count required" );
is( $p->default, 0, "Count default" );

# Test the count attribute accessors.
is( $p->get($t), 0, 'Count get' );
ok( $p->set($t, 10), 'Count set' );
is( $p->get($t), 10, 'New Count get' );
is( $t->count, 10, 'Object count');
ok( $t->count(22), 'Set object count' );
is( $p->get($t), 22, 'Final Count get' );

# Make sure they also work as class attributes.
is( Class::Meta::TestPerson->count, 22, 'Class count' );
ok( Class::Meta::TestPerson->count(35), 'Set class count' );
is( Class::Meta::TestPerson->count, 35, 'Class count again' );
is( $t->count, 35, 'Object count after class');
is( $p->get($t), 35, 'Final Count get after class' );

# Test goop attribute accessor.
is( $t->goop, 'very', "Got goop" );
$t->goop('feh');
is( $t->goop, 'very', "Still got goop" );
ok( $p = $class->attributes('goop'), "Get goop attribute object" );
is( $p->get($t), 'very', "Got attribute goop" );
eval { $p->set($t, 'feh') };
ok( $@, "Can't set goop" );
is( $p->get($t), 'very', "Still got attribute goop" );

# Test methods().
ok( my @methods = $class->methods, "Get method objects" );
is( scalar @methods, 2, 'Number of methods from methods()' );
isa_ok($methods[0], 'Class::Meta::Method',
       "First object is a method object" );
isa_ok($methods[1], 'Class::Meta::Method',
       "Second object is a method object" );

# Check the order in which they're returned.
is( $methods[0]->name, 'chk_pass', 'First method' );
is( $methods[1]->name, 'shame', 'Second method' );
is( $methods[0]->class, $class, "Check method class" );
is_deeply( $methods[0]->args, ['string', 'string'], "Check method args" );
is( $methods[0]->returns, 'bool', "Check method returns" );
is( $methods[1]->args, undef, 'Second specific method args' );
is( $methods[1]->returns, 'person', 'Second specific method returns' );

# Get a few specific methods.
ok( @methods = $class->methods(qw(shame chk_pass)),
    'Grab specific methods.');
is( scalar @methods, 2, 'Two methods from methods()' );
is( $methods[0]->name, 'shame', 'First specific method' );
is( $methods[1]->name, 'chk_pass', 'Second specific method' );

# Check out the chk_pass method.
ok( my $m = $class->methods('chk_pass'), "Get chk_pass method object" );
is( $m->name, 'chk_pass', 'chk_pass name' );
ok( $m->call($t, 'larry', 'yrral') == 1, 'Call chk_pass returns true' );
ok( $m->call($t, 'larry', 'foo') == 0, 'Call chk_pass returns false' );

# Test constructors().
ok( my @constructors = $class->constructors, "Get constructor objects" );
is( scalar @constructors, 1, 'Number of constructors from constructors()' );
isa_ok($constructors[0], 'Class::Meta::Constructor',
       "First object is a constructor object" );

# Check the order in which they're returned.
is( $constructors[0]->name, 'new', 'Check new constructor name' );
is( $constructors[0]->class, $class, "Check constructor class" );

# Get a few specific constructors.
ok( @constructors = $class->constructors(qw(new)),
    'Grab specific constructor.');
is( scalar @constructors, 1, 'Two constructors from constructors()' );
is( $constructors[0]->name, 'new', 'Check specific constructor' );

# Try getting the class object via the for_key() class method.
is( Class::Meta->for_key($class->key), $class, "for_key returns class" );

# Try getting a list of all class object keys
can_ok( 'Class::Meta', 'keys' );
ok( my $keys = Class::Meta->keys, 'Calling keys in scalar context should succeed');
is( ref $keys, 'ARRAY', 'And it should return an array ref');
@$keys = sort @$keys;
is_deeply($keys, [qw/green_monkey person/], 'And keys should return the correct keys');

ok( my @keys = Class::Meta->keys, 'Calling keys in list context should succeed');
is(scalar @keys, 2, 'And it should return the correct number of keys');
@keys = sort @keys;
is_deeply(\@keys, [qw/green_monkey person/], 'And keys should return the correct keys');

# try deleting the class object classes
can_ok('Class::Meta', 'clear');
Class::Meta->clear('green_monkey');
@keys = Class::Meta->keys;
is_deeply(\@keys, ['person'], 'And it should delete a key if provided with one');

Class::Meta->clear('no_such_key');
@keys = Class::Meta->keys;
is_deeply(\@keys, ['person'], 'But deleting a non-existent key should be a no-op');

Class::Meta->clear;
@keys = Class::Meta->keys;
is_deeply(\@keys, [], 'And calling it without arguments should remove all keys');
__END__