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
|
#!/usr/bin/perl
use strict;
use warnings;
use Test::More tests => 36;
use Test::Exception;
BEGIN {
use_ok('Class::MOP');
}
# make sure the Class::MOP::Class->meta does the right thing
my $meta = Class::MOP::Class->meta();
isa_ok($meta, 'Class::MOP::Class');
my $new_meta = $meta->new_object(':package' => 'Class::MOP::Class');
isa_ok($new_meta, 'Class::MOP::Class');
is($new_meta, $meta, '... it still creates the singleton');
my $cloned_meta = $meta->clone_object($meta);
isa_ok($cloned_meta, 'Class::MOP::Class');
is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it');
# make sure other metaclasses do the right thing
{
package Foo;
use metaclass;
}
my $foo_meta = Foo->meta;
isa_ok($foo_meta, 'Class::MOP::Class');
is($meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton');
is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton');
# make sure subclassed of Class::MOP::Class do the right thing
{
package MyMetaClass;
use base 'Class::MOP::Class';
}
my $my_meta = MyMetaClass->meta;
isa_ok($my_meta, 'Class::MOP::Class');
my $new_my_meta = $my_meta->new_object(':package' => 'MyMetaClass');
isa_ok($new_my_meta, 'Class::MOP::Class');
is($new_my_meta, $my_meta, '... even subclasses still create the singleton');
my $cloned_my_meta = $meta->clone_object($my_meta);
isa_ok($cloned_my_meta, 'Class::MOP::Class');
is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it');
is($my_meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)');
is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)');
# now create a metaclass for real
my $bar_meta = $my_meta->new_object(':package' => 'Bar');
isa_ok($bar_meta, 'Class::MOP::Class');
is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass');
is($bar_meta->version, undef, '... Bar does not exists, so it has no version');
$bar_meta->superclasses('Foo');
# check with MyMetaClass
{
package Baz;
use metaclass 'MyMetaClass';
}
my $baz_meta = Baz->meta;
isa_ok($baz_meta, 'Class::MOP::Class');
isa_ok($baz_meta, 'MyMetaClass');
is($my_meta->new_object(':package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton');
is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton');
$baz_meta->superclasses('Bar');
# now create a regular objects for real
my $foo = $foo_meta->new_object();
isa_ok($foo, 'Foo');
my $bar = $bar_meta->new_object();
isa_ok($bar, 'Bar');
isa_ok($bar, 'Foo');
my $baz = $baz_meta->new_object();
isa_ok($baz, 'Baz');
isa_ok($baz, 'Bar');
isa_ok($baz, 'Foo');
my $cloned_foo = $foo_meta->clone_object($foo);
isa_ok($cloned_foo, 'Foo');
isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo');
# check some errors
dies_ok {
$foo_meta->clone_object($meta);
} '... this dies as expected';
# test stuff
{
package FooBar;
use metaclass;
FooBar->meta->add_attribute('test');
}
my $attr = FooBar->meta->get_attribute('test');
isa_ok($attr, 'Class::MOP::Attribute');
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
isnt($attr, $attr_clone, '... we successfully cloned our attributes');
is($attr->associated_class,
$attr_clone->associated_class,
'... we successfully did not clone our associated metaclass');
|
