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
|
use strict;
use warnings;
use Test::More;
use Test::Exception;
use Scalar::Util 'blessed';
{
package Parent;
use metaclass;
sub new { bless {} => shift }
sub whoami { "parent" }
sub parent { "parent" }
package Child;
use metaclass;
use base qw/Parent/;
sub whoami { "child" }
sub child { "child" }
package LeftField;
use metaclass;
sub new { bless {} => shift }
sub whoami { "leftfield" }
sub myhax { "areleet" }
}
# basic tests
my $foo = Parent->new;
is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
is($foo->whoami, "parent", 'Parent->whoami gives parent');
is($foo->parent, "parent", 'Parent->parent gives parent');
dies_ok { $foo->child } "Parent->child method doesn't exist";
Child->meta->rebless_instance($foo);
is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance');
is($foo->whoami, "child", 'reblessed->whoami gives child');
is($foo->parent, "parent", 'reblessed->parent gives parent');
is($foo->child, "child", 'reblessed->child gives child');
throws_ok { LeftField->meta->rebless_instance($foo) }
qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./;
throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }
qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./;
Parent->meta->rebless_instance_back($foo);
is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
is($foo->whoami, "parent", 'Parent->whoami gives parent');
is($foo->parent, "parent", 'Parent->parent gives parent');
dies_ok { $foo->child } "Parent->child method doesn't exist";
throws_ok { LeftField->meta->rebless_instance_back($foo) }
qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./;
throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }
qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./;
# make sure our ->meta is still sane
my $bar = Parent->new;
is(blessed($bar), 'Parent', "sanity check");
is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
ok($bar->meta->has_method('new'), 'metaclass has "new" method');
ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
Child->meta->rebless_instance($bar);
is(blessed($bar), 'Child', "rebless really reblessed");
is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child");
ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method');
ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method');
ok(!$bar->meta->has_method('new'), 'no "new" method in this class');
ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class');
ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
ok($bar->meta->has_method('child'), 'metaclass has "child" method');
is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
Parent->meta->rebless_instance_back($bar);
is(blessed($bar), 'Parent', "sanity check");
is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
ok($bar->meta->has_method('new'), 'metaclass has "new" method');
ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
done_testing;
|
