3
# $Id: types_semi_affordance.t 682 2004-09-28 05:59:10Z theory $
5
##############################################################################
7
##############################################################################
10
use Test::More tests => 56;
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', 'semi-affordance');
24
main::use_ok( 'Class::Meta::Types::Perl', 'semi-affordance');
25
main::use_ok( 'Class::Meta::Types::String', 'semi-affordance');
26
main::use_ok( 'Class::Meta::Types::Boolean', 'semi-affordance');
27
@Bart::ISA = qw(Simpson);
31
# Add the new data type.
32
Class::Meta::Type->add( key => 'simpson',
34
desc => 'An Simpson object.',
36
builder => 'semi-affordance',
39
my $c = Class::Meta->new(package => __PACKAGE__,
41
name => 'Class::Meta::TestTypes Class',
42
desc => 'Just for testing Class::Meta.'
44
$c->add_constructor(name => 'new');
46
$c->add_attribute( name => 'name',
47
view => Class::Meta::PUBLIC,
52
desc => "The person's name.",
55
create => Class::Meta::GETSET
57
$c->add_attribute( name => 'age',
58
view => Class::Meta::PUBLIC,
62
desc => "The person's age.",
65
create => Class::Meta::GETSET
67
$c->add_attribute( name => 'alive',
68
view => Class::Meta::PUBLIC,
72
desc => "Is the person alive?",
76
$c->add_attribute( name => 'whole',
77
view => Class::Meta::PUBLIC,
79
label => 'A whole number.',
81
desc => "A whole number.",
84
create => Class::Meta::GETSET
86
$c->add_attribute( name => 'dec',
87
view => Class::Meta::PUBLIC,
89
label => 'A decimal number.',
91
desc => "A decimal number.",
94
create => Class::Meta::GETSET
96
$c->add_attribute( name => 'real',
97
view => Class::Meta::PUBLIC,
99
label => 'A real number.',
101
desc => "A real number.",
104
create => Class::Meta::GETSET
106
$c->add_attribute( name => 'float',
107
view => Class::Meta::PUBLIC,
111
desc => "A floating point number.",
114
create => Class::Meta::GETSET
116
$c->add_attribute( name => 'scalar',
117
view => Class::Meta::PUBLIC,
119
label => 'A scalar.',
121
desc => "A scalar reference.",
124
create => Class::Meta::GETSET
126
$c->add_attribute( name => 'array',
127
view => Class::Meta::PUBLIC,
131
desc => "A array reference.",
134
create => Class::Meta::GETSET
136
$c->add_attribute( name => 'hash',
137
view => Class::Meta::PUBLIC,
141
desc => "A hash reference.",
144
create => Class::Meta::GETSET
146
$c->add_attribute( name => 'simpson',
147
view => Class::Meta::PUBLIC,
149
label => 'A Simpson Object',
151
desc => 'A Simpson object.',
153
default => sub { bless {}, 'Simpson' },
154
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->set_name('David'), 'set_name to "David"' );
186
is( $t->name, 'David', 'name is "David"' );
187
eval { $t->set_name([]) };
188
ok( my $err = $@, 'set_name to array ref croaks' );
189
like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
192
ok( $t->is_alive, 'is_alive true');
193
is( $t->set_alive_off, 0, 'set_alive_off');
194
ok( !$t->is_alive, 'is_alive false');
195
ok( $t->set_alive_on, 'set_alive_on' );
196
ok( $t->is_alive, 'is_alive true again');
199
eval { $t->set_whole(0) };
200
ok( $err = $@, 'set_whole to 0 croaks' );
201
like( $err, qr/^Value '0' is not a valid whole number/,
202
'correct whole number exception' );
203
ok( $t->set_whole(1), 'set_whole to 1.');
206
eval { $t->set_age(0.5) };
207
ok( $err = $@, 'set_age to 0.5 croaks');
208
like( $err, qr/^Value '0\.5' is not a valid integer/,
209
'correct integer exception' );
210
ok( $t->set_age(10), 'set_age to 10.');
213
eval { $t->set_dec('+') };
214
ok( $err = $@, 'set_dec to "+" croaks');
215
like( $err, qr/^Value '\+' is not a valid decimal number/,
216
'correct decimal exception' );
217
ok( $t->set_dec(3.14), 'set_dec to 3.14.');
220
eval { $t->set_real('+') };
221
ok( $err = $@, 'set_real to "+" croaks');
222
like( $err, qr/^Value '\+' is not a valid real number/,
223
'correct real exception' );
224
ok( $t->set_real(123.4567), 'set_real to 123.4567.');
225
ok( $t->set_real(-123.4567), 'set_real to -123.4567.');
228
eval { $t->set_float('+') };
229
ok( $err = $@, 'set_float to "+" croaks');
230
like( $err, qr/^Value '\+' is not a valid floating point number/,
231
'correct float exception' );
232
ok( $t->set_float(1.23e99), 'set_float to 1.23e99.');
234
# Test OBJECT with default specifying object type.
235
ok( my $simpson = $t->simpson, 'simpson' );
236
isa_ok($simpson, 'Simpson');
237
eval { $t->set_simpson('foo') };
238
ok( $err = $@, 'set_simpson to "foo" croaks' );
239
like( $err, qr/^Value 'foo' is not a valid Simpson/,
240
'correct object exception' );
242
# Try a wrong object.
243
eval { $t->set_simpson($t) };
244
ok( $err = $@, 'set_simpson to \$fh croaks' );
245
like( $err, qr/^Value '.*' is not a valid Simpson/,
246
'correct object exception' );
247
ok( $t->set_simpson($simpson), 'set_simpson to \$simpson.');
250
my $bart = bless {}, 'Bart';
251
ok( $t->set_simpson($bart), "Set simpson to a subclass." );
252
isa_ok($t->simpson, 'Bart', "Check subclass" );
253
ok( $t->set_simpson($simpson), 'set_simpson to \$simpson.');
256
eval { $t->set_scalar('foo') };
257
ok( $err = $@, 'set_scalar to "foo" croaks' );
258
like( $err, qr/^Value 'foo' is not a valid Scalar Reference/,
259
'correct scalar exception' );
260
ok( $t->set_scalar(\"foo"), 'set_scalar to \\"foo".');
263
eval { $t->set_array('foo') };
264
ok( $err = $@, 'set_array to "foo" croaks' );
265
like( $err, qr/^Value 'foo' is not a valid Array Reference/,
266
'correct array exception' );
267
ok( $t->set_array(["foo"]), 'set_array to ["foo"].');
270
eval { $t->set_hash('foo') };
271
ok( $err = $@, 'set_hash to "foo" croaks' );
272
like( $err, qr/^Value 'foo' is not a valid Hash Reference/,
273
'correct hash exception' );
274
ok( $t->set_hash({ foo => 1 }), 'set_hash to { foo => 1 }.');