t/086_rebless_instance_away.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 9;
   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