t/046-rebless.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 36;
   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
  46 $foo->meta->rebless_instance($foo, "LeftField");
  47 is(blessed($foo), 'LeftField', "rebless_instance doesn't have to work on subclasses");
  48 is($foo->whoami, "leftfield", "reblessed->whoami gives leftfield");
  49 is($foo->myhax, "areleet", "new method works fine");
  50 dies_ok { $foo->parent } "LeftField->parent method doesn't exist";
  51 dies_ok { $foo->child  } "LeftField->child method doesn't exist";
  52
  53 $foo->meta->rebless_instance($foo, "NonExistent");
  54 is(blessed($foo), 'NonExistent', "rebless_instance doesn't require an already-existing package");
  55 ok($foo->isa('NonExistent'), "still have a blessed reference");
  56 dies_ok { $foo->whoami } "NonExistent->whoami method doesn't exist";
  57 dies_ok { $foo->myhax  } "NonExistent->myhax method doesn't exist";
  58 dies_ok { $foo->parent } "NonExistent->parent method doesn't exist";
  59 dies_ok { $foo->child  } "NonExistent->child method doesn't exist";
  60
  61 # make sure our ->meta is still sane
  62 my $bar = Parent->new;
  63 is(blessed($bar), 'Parent', "sanity check");
  64 is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
  65 is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent");
  66
  67 ok($bar->meta->has_method('new'), 'metaclass has "new" method');
  68 ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
  69 ok($bar->meta->has_method('parent'), 'metaclass has "parent" method');
  70
  71 is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent');
  72
  73 $bar->meta->rebless_instance($bar, "Child");
  74 is(blessed($bar), 'Child', "rebless really reblessed");
  75 is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class");
  76 is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child");
  77
  78 ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method');
  79 ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method');
  80 ok(!$bar->meta->has_method('new'), 'no "new" method in this class');
  81 ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class');
  82 ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method');
  83 ok($bar->meta->has_method('child'), 'metaclass has "child" method');
  84
  85 is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
  86