3
# $Id: types.t 802 2004-10-28 23:21:10Z theory $
5
##############################################################################
7
##############################################################################
10
use Test::More tests => 58;
12
##############################################################################
13
# Create a simple class.
14
##############################################################################
16
package Class::Meta::TestTypes;
20
$SIG{__DIE__} = \&Carp::confess;
21
main::use_ok( 'Class::Meta');
22
main::use_ok( 'Class::Meta::Type');
23
main::use_ok( 'Class::Meta::Types::Numeric');
24
main::use_ok( 'Class::Meta::Types::Perl');
25
main::use_ok( 'Class::Meta::Types::String');
26
main::use_ok( 'Class::Meta::Types::Boolean');
27
@Bart::ISA = qw(Simpson);
31
# Add the new data type.
32
Class::Meta::Type->add( key => 'simpson',
34
desc => 'An Simpson object.',
38
my $c = Class::Meta->new(package => __PACKAGE__,
40
name => 'Class::Meta::TestTypes Class',
41
desc => 'Just for testing Class::Meta.'
43
$c->add_constructor(name => 'new');
45
$c->add_attribute( name => 'name',
46
view => Class::Meta::PUBLIC,
51
desc => "The person's name.",
54
create => Class::Meta::GETSET
56
$c->add_attribute( name => 'age',
57
view => Class::Meta::PUBLIC,
61
desc => "The person's age.",
64
create => Class::Meta::GETSET
66
$c->add_attribute( name => 'alive',
67
view => Class::Meta::PUBLIC,
71
desc => "Is the person alive?",
75
$c->add_attribute( name => 'whole',
76
view => Class::Meta::PUBLIC,
78
label => 'A whole number.',
80
desc => "A whole number.",
83
create => Class::Meta::GETSET
85
$c->add_attribute( name => 'dec',
86
view => Class::Meta::PUBLIC,
88
label => 'A decimal number.',
90
desc => "A decimal number.",
93
create => Class::Meta::GETSET
95
$c->add_attribute( name => 'real',
96
view => Class::Meta::PUBLIC,
98
label => 'A real number.',
100
desc => "A real number.",
103
create => Class::Meta::GETSET
105
$c->add_attribute( name => 'float',
106
view => Class::Meta::PUBLIC,
110
desc => "A floating point number.",
113
create => Class::Meta::GETSET
115
$c->add_attribute( name => 'scalar',
116
view => Class::Meta::PUBLIC,
118
label => 'A scalar.',
120
desc => "A scalar reference.",
123
create => Class::Meta::GETSET
125
$c->add_attribute( name => 'array',
126
view => Class::Meta::PUBLIC,
130
desc => "A array reference.",
133
create => Class::Meta::GETSET
135
$c->add_attribute( name => 'hash',
136
view => Class::Meta::PUBLIC,
140
desc => "A hash reference.",
143
create => Class::Meta::GETSET
145
$c->add_attribute( name => 'simpson',
146
view => Class::Meta::PUBLIC,
148
label => 'A Simpson Object',
150
desc => 'A Simpson object.',
152
default => sub { bless {}, 'Simpson' },
153
create => Class::Meta::GETSET
160
##############################################################################
162
##############################################################################
165
# Instantiate a base class object and test its accessors.
166
ok( my $t = Class::Meta::TestTypes->new, 'Class::Meta::TestTypes->new');
168
# Grab its metadata object.
169
ok( my $class = $t->my_class, "Get the Class::Meta::Class object" );
171
# Test the is_a() method.
172
ok( $class->is_a('Class::Meta::TestTypes'), 'Class isa TestTypes');
174
# Test the key methods.
175
is( $class->key, 'types', 'Key is correct');
177
# Test the name method.
178
is( $class->name, 'Class::Meta::TestTypes Class', "Name is correct");
180
# Test the description methods.
181
is( $class->desc, 'Just for testing Class::Meta.',
182
"Description is correct");
185
ok( $t->name('David'), 'name to "David"' );
186
is( $t->name, 'David', 'name is "David"' );
187
eval { $t->name([]) };
188
ok( my $err = $@, 'name to array ref croaks' );
189
like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
192
ok( $t->alive, 'alive true');
193
is( $t->alive(0), 0, 'alive off');
194
ok( !$t->alive, 'alive false');
195
ok( $t->alive(1), 'alive on' );
196
ok( $t->alive, 'alive true again');
197
ok( my $alive = $class->attributes('alive'), "Get alive attribute object" );
198
is( $alive->type, 'boolean', "Check that the alias was converted" );
201
eval { $t->whole(0) };
202
ok( $err = $@, 'whole to 0 croaks' );
203
like( $err, qr/^Value '0' is not a valid whole number/,
204
'correct whole number exception' );
205
ok( $t->whole(1), 'whole to 1.');
208
eval { $t->age(0.5) };
209
ok( $err = $@, 'age to 0.5 croaks');
210
like( $err, qr/^Value '0\.5' is not a valid integer/,
211
'correct integer exception' );
212
ok( $t->age(10), 'age to 10.');
215
eval { $t->dec('+') };
216
ok( $err = $@, 'dec to "+" croaks');
217
like( $err, qr/^Value '\+' is not a valid decimal number/,
218
'correct decimal exception' );
219
ok( $t->dec(3.14), 'dec to 3.14.');
222
eval { $t->real('+') };
223
ok( $err = $@, 'real to "+" croaks');
224
like( $err, qr/^Value '\+' is not a valid real number/,
225
'correct real exception' );
226
ok( $t->real(123.4567), 'real to 123.4567.');
227
ok( $t->real(-123.4567), 'real to -123.4567.');
230
eval { $t->float('+') };
231
ok( $err = $@, 'float to "+" croaks');
232
like( $err, qr/^Value '\+' is not a valid floating point number/,
233
'correct float exception' );
234
ok( $t->float(1.23e99), 'float to 1.23e99.');
236
# Test OBJECT with default specifying object type.
237
ok( my $simpson = $t->simpson, 'simpson' );
238
isa_ok($simpson, 'Simpson');
239
eval { $t->simpson('foo') };
240
ok( $err = $@, 'simpson to "foo" croaks' );
241
like( $err, qr/^Value 'foo' is not a valid Simpson/,
242
'correct object exception' );
244
# Try a wrong object.
245
eval { $t->simpson($t) };
246
ok( $err = $@, 'simpson to \$fh croaks' );
247
like( $err, qr/^Value '.*' is not a valid Simpson/,
248
'correct object exception' );
249
ok( $t->simpson($simpson), 'simpson to \$simpson.');
252
my $bart = bless {}, 'Bart';
253
ok( $t->simpson($bart), "Set simpson to a subclass." );
254
isa_ok($t->simpson, 'Bart', "Check subclass" );
255
ok( $t->simpson($simpson), 'simpson to \$simpson.');
258
eval { $t->scalar('foo') };
259
ok( $err = $@, 'scalar to "foo" croaks' );
260
like( $err, qr/^Value 'foo' is not a valid Scalar Reference/,
261
'correct scalar exception' );
262
ok( $t->scalar(\"foo"), 'scalar to \\"foo".');
265
eval { $t->array('foo') };
266
ok( $err = $@, 'array to "foo" croaks' );
267
like( $err, qr/^Value 'foo' is not a valid Array Reference/,
268
'correct array exception' );
269
ok( $t->array(["foo"]), 'array to ["foo"].');
272
eval { $t->hash('foo') };
273
ok( $err = $@, 'hash to "foo" croaks' );
274
like( $err, qr/^Value 'foo' is not a valid Hash Reference/,
275
'correct hash exception' );
276
ok( $t->hash({ foo => 1 }), 'hash to { foo => 1 }.');