t/046_rebless_instance.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Exception;
   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 dies_ok { $foo->child } "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 throws_ok { LeftField->meta->rebless_instance($foo) }
  45           qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./;
  46
  47 throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }
  48           qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./;
  49
  50 Parent->meta->rebless_instance_back($foo);
  51 is(blessed($foo), 'Parent', 'Parent->new gives a Parent');
  52 is($foo->whoami, "parent", 'Parent->whoami gives parent');
  53 is($foo->parent, "parent", 'Parent->parent gives parent');
  54 dies_ok { $foo->child } "Parent->child method doesn't exist";
  55
  56 throws_ok { LeftField->meta->rebless_instance_back($foo) }
  57           qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./;
  58
  59 throws_ok { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }
  60           qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./;
  61
  62 # make sure our ->meta is still sane
  63 my $bar = Parent->new;
  64 is(blessed($bar), 'Parent', "sanity check");
  65 is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
  66 is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
  67
  68 ok($bar->meta->has_method('new'), 'metaclass has "new" method');
  69 ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
  70 ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
  71
  72 is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
  73
  74 Child->meta->rebless_instance($bar);
  75 is(blessed($bar), 'Child', "rebless really reblessed");
  76 is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
  77 is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child");
  78
  79 ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method');
  80 ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method');
  81 ok(!$bar->meta->has_method('new'), 'no "new" method in this class');
  82 ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class');
  83 ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
  84 ok($bar->meta->has_method('child'), 'metaclass has "child" method');
  85
  86 is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
  87
  88 Parent->meta->rebless_instance_back($bar);
  89 is(blessed($bar), 'Parent', "sanity check");
  90 is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
  91 is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
  92
  93 ok($bar->meta->has_method('new'), 'metaclass has "new" method');
  94 ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
  95 ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
  96
  97 is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
  98
  99 done_testing;