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
|
use strict;
use warnings;
use FindBin;
use File::Spec::Functions;
use Test::More;
use Test::Exception;
use Class::MOP;
use lib catdir($FindBin::Bin, 'lib');
# 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
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');
done_testing;
|
