Commit | Line | Data |
38bf2a25 |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More; |
5 | use Class::MOP; |
6 | |
7 | my @calls; |
8 | |
9 | do { |
10 | package My::Meta::Class; |
11 | use base 'Class::MOP::Class'; |
12 | |
13 | sub rebless_instance_away { |
14 | push @calls, [@_]; |
15 | shift->SUPER::rebless_instance_away(@_); |
16 | } |
17 | }; |
18 | |
19 | do { |
20 | package Parent; |
21 | use metaclass 'My::Meta::Class'; |
22 | |
23 | package Child; |
24 | use metaclass 'My::Meta::Class'; |
25 | use base 'Parent'; |
26 | }; |
27 | |
28 | my $person = Parent->meta->new_object; |
29 | Child->meta->rebless_instance($person); |
30 | |
31 | is(@calls, 1, "one call to rebless_instance_away"); |
32 | is($calls[0][0]->name, 'Parent', 'rebless_instance_away is called on the old metaclass'); |
33 | is($calls[0][1], $person, 'with the instance'); |
34 | is($calls[0][2]->name, 'Child', 'and the new metaclass'); |
35 | splice @calls; |
36 | |
37 | Child->meta->rebless_instance($person, foo => 1); |
38 | is($calls[0][0]->name, 'Child'); |
39 | is($calls[0][1], $person); |
40 | is($calls[0][2]->name, 'Child'); |
41 | is($calls[0][3], 'foo'); |
42 | is($calls[0][4], 1); |
43 | splice @calls; |
44 | |
45 | done_testing; |