Add another MOOSE_TEST_MD option, MooseX
[gitmo/Moose.git] / t / cmop / rebless_instance.t
CommitLineData
38bf2a25 1use strict;
2use warnings;
3
4use Test::More;
5use Test::Fatal;
6use Scalar::Util 'blessed';
7
8{
9 package Parent;
10 use metaclass;
11
12 sub new { bless {} => shift }
13 sub whoami { "parent" }
14 sub parent { "parent" }
15
16 package Child;
17 use metaclass;
18 use base qw/Parent/;
19
20 sub whoami { "child" }
21 sub child { "child" }
22
23 package LeftField;
24 use metaclass;
25
26 sub new { bless {} => shift }
27 sub whoami { "leftfield" }
28 sub myhax { "areleet" }
29}
30
31# basic tests
32my $foo = Parent->new;
33is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
34is($foo->whoami, "parent", 'Parent->whoami gives parent');
35is($foo->parent, "parent", 'Parent->parent gives parent');
36isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" );
37
38Child->meta->rebless_instance($foo);
39is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance');
40is($foo->whoami, "child", 'reblessed->whoami gives child');
41is($foo->parent, "parent", 'reblessed->parent gives parent');
42is($foo->child, "child", 'reblessed->child gives child');
43
44like( exception { LeftField->meta->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./ );
45
46like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./ );
47
48Parent->meta->rebless_instance_back($foo);
49is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
50is($foo->whoami, "parent", 'Parent->whoami gives parent');
51is($foo->parent, "parent", 'Parent->parent gives parent');
52isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" );
53
54like( exception { LeftField->meta->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./ );
55
56like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./ );
57
58# make sure our ->meta is still sane
59my $bar = Parent->new;
60is(blessed($bar), 'Parent', "sanity check");
61is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
62is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
63
64ok($bar->meta->has_method('new'), 'metaclass has "new" method');
65ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
66ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
67
68is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
69
70Child->meta->rebless_instance($bar);
71is(blessed($bar), 'Child', "rebless really reblessed");
72is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
73is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child");
74
75ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method');
76ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method');
77ok(!$bar->meta->has_method('new'), 'no "new" method in this class');
78ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class');
79ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
80ok($bar->meta->has_method('child'), 'metaclass has "child" method');
81
82is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
83
84Parent->meta->rebless_instance_back($bar);
85is(blessed($bar), 'Parent', "sanity check");
86is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
87is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
88
89ok($bar->meta->has_method('new'), 'metaclass has "new" method');
90ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
91ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
92
93is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
94
95done_testing;