Commit | Line | Data |
3d9e4646 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
9b71b643 |
6 | use Test::More tests => 27; |
3d9e4646 |
7 | use Test::Exception; |
8 | use Scalar::Util 'blessed'; |
9 | |
10 | { |
11 | package Parent; |
12 | use metaclass; |
13 | |
14 | sub new { bless {} => shift } |
15 | sub whoami { "parent" } |
16 | sub parent { "parent" } |
17 | |
18 | package Child; |
19 | use metaclass; |
20 | use base qw/Parent/; |
21 | |
22 | sub whoami { "child" } |
23 | sub child { "child" } |
24 | |
25 | package LeftField; |
26 | use metaclass; |
27 | |
28 | sub new { bless {} => shift } |
29 | sub whoami { "leftfield" } |
30 | sub myhax { "areleet" } |
31 | } |
32 | |
33 | # basic tests |
34 | my $foo = Parent->new; |
35 | is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); |
36 | is($foo->whoami, "parent", 'Parent->whoami gives parent'); |
37 | is($foo->parent, "parent", 'Parent->parent gives parent'); |
38 | dies_ok { $foo->child } "Parent->child method doesn't exist"; |
39 | |
40 | $foo->meta->rebless_instance($foo, "Child"); |
41 | is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance'); |
42 | is($foo->whoami, "child", 'reblessed->whoami gives child'); |
43 | is($foo->parent, "parent", 'reblessed->parent gives parent'); |
44 | is($foo->child, "child", 'reblessed->child gives child'); |
45 | |
9b71b643 |
46 | throws_ok { $foo->meta->rebless_instance($foo, "LeftField") } qr/You may rebless only into a subclass. \(LeftField\) is not a subclass of \(Child\)\./; |
47 | throws_ok { $foo->meta->rebless_instance($foo, "NonExistent") } qr/You may rebless only into a subclass. \(NonExistent\) is not a subclass of \(Child\)\./; |
3d9e4646 |
48 | |
49 | # make sure our ->meta is still sane |
50 | my $bar = Parent->new; |
51 | is(blessed($bar), 'Parent', "sanity check"); |
52 | is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); |
53 | is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); |
54 | |
55 | ok($bar->meta->has_method('new'), 'metaclass has "new" method'); |
56 | ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); |
57 | ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); |
58 | |
59 | is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); |
60 | |
61 | $bar->meta->rebless_instance($bar, "Child"); |
62 | is(blessed($bar), 'Child', "rebless really reblessed"); |
63 | is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); |
64 | is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child"); |
65 | |
66 | ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method'); |
67 | ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method'); |
68 | ok(!$bar->meta->has_method('new'), 'no "new" method in this class'); |
69 | ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class'); |
70 | ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); |
71 | ok($bar->meta->has_method('child'), 'metaclass has "child" method'); |
72 | |
73 | is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child'); |
74 | |