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
|
#!/usr/bin/perl
use strict;
use warnings;
use Test::More tests => 28;
use Test::Exception;
BEGIN {
use_ok('Class::MOP');
}
{
package Point;
use metaclass;
Point->meta->add_attribute('$.x' => (
reader => 'x',
init_arg => 'x'
));
Point->meta->add_attribute('$.y' => (
accessor => 'y',
init_arg => 'y'
));
sub new {
my $class = shift;
bless $class->meta->construct_instance(@_) => $class;
}
sub clear {
my $self = shift;
$self->{'$.x'} = 0;
$self->{'$.y'} = 0;
}
package Point3D;
our @ISA = ('Point');
Point3D->meta->add_attribute('$:z' => (
default => 123
));
sub clear {
my $self = shift;
$self->{'$:z'} = 0;
$self->SUPER::clear();
}
}
isa_ok(Point->meta, 'Class::MOP::Class');
isa_ok(Point3D->meta, 'Class::MOP::Class');
# ... test the classes themselves
my $point = Point->new('x' => 2, 'y' => 3);
isa_ok($point, 'Point');
can_ok($point, 'x');
can_ok($point, 'y');
can_ok($point, 'clear');
{
my $meta = $point->meta;
is($meta, Point->meta(), '... got the meta from the instance too');
}
is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject');
$point->y(42);
is($point->y, 42, '... the $.y attribute was set properly with the accessor');
is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject');
dies_ok {
$point->x(42);
} '... cannot write to a read-only accessor';
is($point->x, 2, '... the $.x attribute was not altered');
$point->clear();
is($point->y, 0, '... the $.y attribute was cleared correctly');
is($point->x, 0, '... the $.x attribute was cleared correctly');
my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3);
isa_ok($point3d, 'Point3D');
isa_ok($point3d, 'Point');
{
my $meta = $point3d->meta;
is($meta, Point3D->meta(), '... got the meta from the instance too');
}
can_ok($point3d, 'x');
can_ok($point3d, 'y');
can_ok($point3d, 'clear');
is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject');
is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject');
is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject');
{
my $point3d = Point3D->new();
isa_ok($point3d, 'Point3D');
is($point3d->x, undef, '... the $.x attribute was not initialized');
is($point3d->y, undef, '... the $.y attribute was not initialized');
is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject');
}
|
