t/006_new_and_clone_metaclasses.t

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