t/006_new_and_clone_metaclasses.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 32;
   7 use Test::Exception;
   8
   9 BEGIN {
  10     use_ok('Class::MOP');
  11 }
  12
  13 # make sure the Class::MOP::Class->meta does the right thing
  14
  15 my $meta = Class::MOP::Class->meta();
  16 isa_ok($meta, 'Class::MOP::Class');
  17
  18 my $new_meta = $meta->new_object(':package' => 'Class::MOP::Class');
  19 isa_ok($new_meta, 'Class::MOP::Class');
  20 is($new_meta, $meta, '... it still creates the singleton');
  21
  22 my $cloned_meta = $meta->clone_object($meta);
  23 isa_ok($cloned_meta, 'Class::MOP::Class');
  24 is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it');
  25
  26 # make sure other metaclasses do the right thing
  27
  28 {
  29     package Foo;
  30     use metaclass;
  31 }
  32
  33 my $foo_meta = Foo->meta;
  34 isa_ok($foo_meta, 'Class::MOP::Class');
  35
  36 is($meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton');
  37 is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton');
  38
  39 # make sure subclassed of Class::MOP::Class do the right thing
  40
  41 {
  42     package MyMetaClass;
  43     use base 'Class::MOP::Class';
  44 }
  45
  46 my $my_meta = MyMetaClass->meta;
  47 isa_ok($my_meta, 'Class::MOP::Class');
  48
  49 my $new_my_meta = $my_meta->new_object(':package' => 'MyMetaClass');
  50 isa_ok($new_my_meta, 'Class::MOP::Class');
  51 is($new_my_meta, $my_meta, '... even subclasses still create the singleton');
  52
  53 my $cloned_my_meta = $meta->clone_object($my_meta);
  54 isa_ok($cloned_my_meta, 'Class::MOP::Class');
  55 is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it');
  56
  57 is($my_meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)');
  58 is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)');
  59
  60 # now create a metaclass for real
  61
  62 my $bar_meta = $my_meta->new_object(':package' => 'Bar');
  63 isa_ok($bar_meta, 'Class::MOP::Class');
  64
  65 is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass');
  66 is($bar_meta->version, undef, '... Bar does not exists, so it has no version');
  67
  68 $bar_meta->superclasses('Foo');
  69
  70 # check with MyMetaClass
  71
  72 {
  73     package Baz;
  74     use metaclass 'MyMetaClass';
  75 }
  76
  77 my $baz_meta = Baz->meta;
  78 isa_ok($baz_meta, 'Class::MOP::Class');
  79 isa_ok($baz_meta, 'MyMetaClass');
  80
  81 is($my_meta->new_object(':package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton');
  82 is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton');
  83
  84 $baz_meta->superclasses('Bar');
  85
  86 # now create a regular objects for real
  87
  88 my $foo = $foo_meta->new_object();
  89 isa_ok($foo, 'Foo');
  90
  91 my $bar = $bar_meta->new_object();
  92 isa_ok($bar, 'Bar');
  93 isa_ok($bar, 'Foo');
  94
  95 my $baz = $baz_meta->new_object();
  96 isa_ok($baz, 'Baz');
  97 isa_ok($baz, 'Bar');
  98 isa_ok($baz, 'Foo');
  99
 100 my $cloned_foo = $foo_meta->clone_object($foo);
 101 isa_ok($cloned_foo, 'Foo');
 102
 103 isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo');
 104
 105 # check some errors
 106
 107 dies_ok {
 108     $foo_meta->clone_object($meta);
 109 } '... this dies as expected';
 110