Commit | Line | Data |
38bf2a25 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use Test::Fatal; |
6 | use 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 |
32 | my $foo = Parent->new; |
33 | is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); |
34 | is($foo->whoami, "parent", 'Parent->whoami gives parent'); |
35 | is($foo->parent, "parent", 'Parent->parent gives parent'); |
36 | isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); |
37 | |
38 | Child->meta->rebless_instance($foo); |
39 | is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance'); |
40 | is($foo->whoami, "child", 'reblessed->whoami gives child'); |
41 | is($foo->parent, "parent", 'reblessed->parent gives parent'); |
42 | is($foo->child, "child", 'reblessed->child gives child'); |
43 | |
44 | like( exception { LeftField->meta->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./ ); |
45 | |
46 | like( 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 | |
48 | Parent->meta->rebless_instance_back($foo); |
49 | is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); |
50 | is($foo->whoami, "parent", 'Parent->whoami gives parent'); |
51 | is($foo->parent, "parent", 'Parent->parent gives parent'); |
52 | isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); |
53 | |
54 | like( exception { LeftField->meta->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./ ); |
55 | |
56 | like( 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 |
59 | my $bar = Parent->new; |
60 | is(blessed($bar), 'Parent', "sanity check"); |
61 | is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); |
62 | is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); |
63 | |
64 | ok($bar->meta->has_method('new'), 'metaclass has "new" method'); |
65 | ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); |
66 | ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); |
67 | |
68 | is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); |
69 | |
70 | Child->meta->rebless_instance($bar); |
71 | is(blessed($bar), 'Child', "rebless really reblessed"); |
72 | is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); |
73 | is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child"); |
74 | |
75 | ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method'); |
76 | ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method'); |
77 | ok(!$bar->meta->has_method('new'), 'no "new" method in this class'); |
78 | ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class'); |
79 | ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); |
80 | ok($bar->meta->has_method('child'), 'metaclass has "child" method'); |
81 | |
82 | is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child'); |
83 | |
84 | Parent->meta->rebless_instance_back($bar); |
85 | is(blessed($bar), 'Parent', "sanity check"); |
86 | is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); |
87 | is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); |
88 | |
89 | ok($bar->meta->has_method('new'), 'metaclass has "new" method'); |
90 | ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); |
91 | ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); |
92 | |
93 | is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); |
94 | |
95 | done_testing; |