diff options
Diffstat (limited to 't/cmop')
97 files changed, 10994 insertions, 0 deletions
diff --git a/t/cmop/ArrayBasedStorage_test.t b/t/cmop/ArrayBasedStorage_test.t new file mode 100644 index 0000000..a654879 --- /dev/null +++ b/t/cmop/ArrayBasedStorage_test.t @@ -0,0 +1,203 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util 'reftype'; +use Class::MOP; + +use lib 't/cmop/lib'; +use ArrayBasedStorage; + +{ + package Foo; + + use strict; + use warnings; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + clearer => 'clear_foo', + predicate => 'has_foo', + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + use metaclass ( + 'instance_metaclass' => 'ArrayBasedStorage::Instance', + ); + + use strict; + use warnings; + + use parent -norequire => 'Bar', 'Baz'; +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(reftype($foo), 'ARRAY', '... Foo is made with ARRAY'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); +can_ok($foo, 'clear_foo'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->clear_foo; + +ok(!$foo->has_foo, '... Foo::foo is not defined anymore'); +is($foo->foo(), undef, '... Foo::foo is not defined anymore'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is(reftype($foo2), 'ARRAY', '... Foo is made with ARRAY'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is(reftype($bar), 'ARRAY', '... Bar is made with ARRAY'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +is(reftype($baz), 'ARRAY', '... Bar::Baz is made with ARRAY'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +Foo->meta->add_attribute( forgotten => is => "rw" ); + +my $new_baz = Bar::Baz->new; + +cmp_ok( scalar(@$new_baz), ">", scalar(@$baz), "additional slot due to refreshed meta instance" ); + +done_testing; diff --git a/t/cmop/AttributesWithHistory_test.t b/t/cmop/AttributesWithHistory_test.t new file mode 100644 index 0000000..3b28a12 --- /dev/null +++ b/t/cmop/AttributesWithHistory_test.t @@ -0,0 +1,118 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; +use AttributesWithHistory; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'get_foo_history'); +can_ok($foo, 'set_bar'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'get_bar_history'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is($foo->foo, undef, '... foo is not yet defined'); +is_deeply( + [ $foo->get_foo_history() ], + [ ], + '... got correct empty history for foo'); + +is($foo2->foo, undef, '... foo2 is not yet defined'); +is_deeply( + [ $foo2->get_foo_history() ], + [ ], + '... got correct empty history for foo2'); + +$foo->foo(42); +is($foo->foo, 42, '... foo == 42'); +is_deeply( + [ $foo->get_foo_history() ], + [ 42 ], + '... got correct history for foo'); + +is($foo2->foo, undef, '... foo2 is still not yet defined'); +is_deeply( + [ $foo2->get_foo_history() ], + [ ], + '... still got correct empty history for foo2'); + +$foo2->foo(100); +is($foo->foo, 42, '... foo is still == 42'); +is_deeply( + [ $foo->get_foo_history() ], + [ 42 ], + '... still got correct history for foo'); + +is($foo2->foo, 100, '... foo2 == 100'); +is_deeply( + [ $foo2->get_foo_history() ], + [ 100 ], + '... got correct empty history for foo2'); + +$foo->foo(43); +$foo->foo(44); +$foo->foo(45); +$foo->foo(46); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... got correct history for foo'); + +is($foo->get_bar, undef, '... bar is not yet defined'); +is_deeply( + [ $foo->get_bar_history() ], + [ ], + '... got correct empty history for foo'); + + +$foo->set_bar("FOO"); +is($foo->get_bar, "FOO", '... bar == "FOO"'); +is_deeply( + [ $foo->get_bar_history() ], + [ "FOO" ], + '... got correct history for foo'); + +$foo->set_bar("BAR"); +$foo->set_bar("BAZ"); + +is_deeply( + [ $foo->get_bar_history() ], + [ qw/FOO BAR BAZ/ ], + '... got correct history for bar'); + +is_deeply( + [ $foo->get_foo_history() ], + [ 42, 43, 44, 45, 46 ], + '... still have the correct history for foo'); + +done_testing; diff --git a/t/cmop/BinaryTree_test.t b/t/cmop/BinaryTree_test.t new file mode 100644 index 0000000..91831dc --- /dev/null +++ b/t/cmop/BinaryTree_test.t @@ -0,0 +1,329 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::Load qw( is_class_loaded load_class ); + +use lib 't/cmop/lib'; + +## ---------------------------------------------------------------------------- +## These are all tests which are derived from the Tree::Binary test suite +## ---------------------------------------------------------------------------- + +ok(!is_class_loaded('BinaryTree'), '... the binary tree class is not loaded'); + +is( exception { + load_class('BinaryTree'); +}, undef, '... loaded the BinaryTree class without dying' ); + +ok(is_class_loaded('BinaryTree'), '... the binary tree class is now loaded'); + +## ---------------------------------------------------------------------------- +## t/10_Tree_Binary_test.t + +can_ok("BinaryTree", 'new'); +can_ok("BinaryTree", 'setLeft'); +can_ok("BinaryTree", 'setRight'); + +my $btree = BinaryTree->new("/") + ->setLeft( + BinaryTree->new("+") + ->setLeft( + BinaryTree->new("2") + ) + ->setRight( + BinaryTree->new("2") + ) + ) + ->setRight( + BinaryTree->new("*") + ->setLeft( + BinaryTree->new("4") + ) + ->setRight( + BinaryTree->new("5") + ) + ); +isa_ok($btree, 'BinaryTree'); + +## informational methods + +can_ok($btree, 'isRoot'); +ok($btree->isRoot(), '... this is the root'); + +can_ok($btree, 'isLeaf'); +ok(!$btree->isLeaf(), '... this is not a leaf node'); +ok($btree->getLeft()->getLeft()->isLeaf(), '... this is a leaf node'); + +can_ok($btree, 'hasLeft'); +ok($btree->hasLeft(), '... this has a left node'); + +can_ok($btree, 'hasRight'); +ok($btree->hasRight(), '... this has a right node'); + +## accessors + +can_ok($btree, 'getUID'); + +{ + my $UID = $btree->getUID(); + is(("$btree" =~ /\((.*?)\)$/)[0], $UID, '... our UID is derived from the stringified object'); +} + +can_ok($btree, 'getNodeValue'); +is($btree->getNodeValue(), '/', '... got what we expected'); + +{ + can_ok($btree, 'getLeft'); + my $left = $btree->getLeft(); + + isa_ok($left, 'BinaryTree'); + + is($left->getNodeValue(), '+', '... got what we expected'); + + can_ok($left, 'getParent'); + + my $parent = $left->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +{ + can_ok($btree, 'getRight'); + my $right = $btree->getRight(); + + isa_ok($right, 'BinaryTree'); + + is($right->getNodeValue(), '*', '... got what we expected'); + + can_ok($right, 'getParent'); + + my $parent = $right->getParent(); + isa_ok($parent, 'BinaryTree'); + + is($parent, $btree, '.. got what we expected'); +} + +## mutators + +can_ok($btree, 'setUID'); +$btree->setUID("Our UID for this tree"); + +is($btree->getUID(), 'Our UID for this tree', '... our UID is not what we expected'); + +can_ok($btree, 'setNodeValue'); +$btree->setNodeValue('*'); + +is($btree->getNodeValue(), '*', '... got what we expected'); + + +{ + can_ok($btree, 'removeLeft'); + my $left = $btree->removeLeft(); + isa_ok($left, 'BinaryTree'); + + ok(!$btree->hasLeft(), '... we dont have a left node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setLeft($left); + + ok($btree->hasLeft(), '... we have our left node again'); + is($btree->getLeft(), $left, '... and it is what we told it to be'); +} + +{ + # remove left leaf + my $left_leaf = $btree->getLeft()->removeLeft(); + isa_ok($left_leaf, 'BinaryTree'); + + ok($left_leaf->isLeaf(), '... our left leaf is a leaf'); + + ok(!$btree->getLeft()->hasLeft(), '... we dont have a left leaf node anymore'); + + $btree->getLeft()->setLeft($left_leaf); + + ok($btree->getLeft()->hasLeft(), '... we have our left leaf node again'); + is($btree->getLeft()->getLeft(), $left_leaf, '... and it is what we told it to be'); +} + +{ + can_ok($btree, 'removeRight'); + my $right = $btree->removeRight(); + isa_ok($right, 'BinaryTree'); + + ok(!$btree->hasRight(), '... we dont have a right node anymore'); + ok(!$btree->isLeaf(), '... and we are not a leaf node'); + + $btree->setRight($right); + + ok($btree->hasRight(), '... we have our right node again'); + is($btree->getRight(), $right, '... and it is what we told it to be') +} + +{ + # remove right leaf + my $right_leaf = $btree->getRight()->removeRight(); + isa_ok($right_leaf, 'BinaryTree'); + + ok($right_leaf->isLeaf(), '... our right leaf is a leaf'); + + ok(!$btree->getRight()->hasRight(), '... we dont have a right leaf node anymore'); + + $btree->getRight()->setRight($right_leaf); + + ok($btree->getRight()->hasRight(), '... we have our right leaf node again'); + is($btree->getRight()->getRight(), $right_leaf, '... and it is what we told it to be'); +} + +# some of the recursive informational methods + +{ + + my $btree = BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ->setRight( + BinaryTree->new("o") + ->setLeft( + BinaryTree->new("o") + ) + ->setRight( + BinaryTree->new("o") + ) + ) + ) + ->setRight( + BinaryTree->new("o") + ->setRight(BinaryTree->new("o")) + ) + ); + isa_ok($btree, 'BinaryTree'); + + can_ok($btree, 'size'); + cmp_ok($btree->size(), '==', 14, '... we have 14 nodes in the tree'); + + can_ok($btree, 'height'); + cmp_ok($btree->height(), '==', 6, '... the tree is 6 nodes tall'); + +} + +## ---------------------------------------------------------------------------- +## t/13_Tree_Binary_mirror_test.t + +sub inOrderTraverse { + my $tree = shift; + my @results; + my $_inOrderTraverse = sub { + my ($tree, $traversal_function) = @_; + $traversal_function->($tree->getLeft(), $traversal_function) if $tree->hasLeft(); + push @results => $tree->getNodeValue(); + $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight(); + }; + $_inOrderTraverse->($tree, $_inOrderTraverse); + @results; +} + +# test it on a simple well balanaced tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(2) + ->setLeft( + BinaryTree->new(1) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ) + ->setRight( + BinaryTree->new(7) + ) + ); + isa_ok($btree, 'BinaryTree'); + + is_deeply( + [ inOrderTraverse($btree) ], + [ 1 .. 7 ], + '... check that our tree starts out correctly'); + + can_ok($btree, 'mirror'); + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(1 .. 7) ], + '... check that our tree ends up correctly'); +} + +# test is on a more chaotic tree +{ + my $btree = BinaryTree->new(4) + ->setLeft( + BinaryTree->new(20) + ->setLeft( + BinaryTree->new(1) + ->setRight( + BinaryTree->new(10) + ->setLeft( + BinaryTree->new(5) + ) + ) + ) + ->setRight( + BinaryTree->new(3) + ) + ) + ->setRight( + BinaryTree->new(6) + ->setLeft( + BinaryTree->new(5) + ->setRight( + BinaryTree->new(7) + ->setLeft( + BinaryTree->new(90) + ) + ->setRight( + BinaryTree->new(91) + ) + ) + ) + ); + isa_ok($btree, 'BinaryTree'); + + my @results = inOrderTraverse($btree); + + $btree->mirror(); + + is_deeply( + [ inOrderTraverse($btree) ], + [ reverse(@results) ], + '... this should be the reverse of the original'); +} + +done_testing; diff --git a/t/cmop/C3MethodDispatchOrder_test.t b/t/cmop/C3MethodDispatchOrder_test.t new file mode 100644 index 0000000..65e0e83 --- /dev/null +++ b/t/cmop/C3MethodDispatchOrder_test.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Algorithm::C3'; # skip all if not installed + +use Class::MOP; + +use lib 't/cmop/lib'; +use C3MethodDispatchOrder; + +{ + package Diamond_A; + use metaclass 'C3MethodDispatchOrder'; + + sub hello { 'Diamond_A::hello' } + + package Diamond_B; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_A'); + + package Diamond_C; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_A'); + + sub hello { 'Diamond_C::hello' } + + package Diamond_D; + use metaclass 'C3MethodDispatchOrder'; + __PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C'); +} + +is_deeply( + [ Diamond_D->meta->class_precedence_list ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order'); +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); + +done_testing; diff --git a/t/cmop/ClassEncapsulatedAttributes_test.t b/t/cmop/ClassEncapsulatedAttributes_test.t new file mode 100644 index 0000000..d5ee50b --- /dev/null +++ b/t/cmop/ClassEncapsulatedAttributes_test.t @@ -0,0 +1,106 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; +use ClassEncapsulatedAttributes; + +{ + package Foo; + + use metaclass 'ClassEncapsulatedAttributes'; + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in FOO' + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in FOO' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + our @ISA = ('Foo'); + + Bar->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in BAR' + )); + + Bar->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in BAR' + )); + + sub SUPER_foo { (shift)->SUPER::foo(@_) } + sub SUPER_has_foo { (shift)->SUPER::foo(@_) } + sub SUPER_get_bar { (shift)->SUPER::get_bar() } + sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) } + +} + +{ + my $foo = Foo->new(); + isa_ok($foo, 'Foo'); + + can_ok($foo, 'foo'); + can_ok($foo, 'has_foo'); + can_ok($foo, 'get_bar'); + can_ok($foo, 'set_bar'); + + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($foo->has_foo, '... Foo::has_foo == 1'); + ok($bar->has_foo, '... Bar::has_foo == 1'); + + is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo'); + is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo'); + + is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo'); + + $bar->SUPER_foo(undef); + + is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo'); + ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0'); + + ok($foo->has_foo, '... Foo::has_foo (is still) 1'); +} + +{ + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($bar->has_foo, '... Bar::has_foo == 1'); + ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1'); + + is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo'); + is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo'); +} + +done_testing; diff --git a/t/cmop/Class_C3_compatibility.t b/t/cmop/Class_C3_compatibility.t new file mode 100644 index 0000000..81ebabc --- /dev/null +++ b/t/cmop/Class_C3_compatibility.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use Test::More; + +=pod + +This tests that Class::MOP works correctly +with Class::C3 and it's somewhat insane +approach to method resolution. + +=cut + +use Class::MOP; + +{ + package Diamond_A; + use mro 'c3'; + use metaclass; # everyone will just inherit this now :) + + sub hello { 'Diamond_A::hello' } +} +{ + package Diamond_B; + use mro 'c3'; + use parent -norequire => 'Diamond_A'; +} +{ + package Diamond_C; + use mro 'c3'; + use parent -norequire => 'Diamond_A'; + + sub hello { 'Diamond_C::hello' } +} +{ + package Diamond_D; + use mro 'c3'; + use parent -norequire => 'Diamond_B', 'Diamond_C'; +} + +# we have to manually initialize +# Class::C3 since we potentially +# skip this test if it is not present +Class::C3::initialize(); + +is_deeply( +# [ Class::C3::calculateMRO('Diamond_D') ], + [ Diamond_D->meta->class_precedence_list ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +ok(Diamond_A->meta->has_method('hello'), '... A has a method hello'); +ok(!Diamond_B->meta->has_method('hello'), '... B does not have a method hello'); + +ok(Diamond_C->meta->has_method('hello'), '... C has a method hello'); +ok(!Diamond_D->meta->has_method('hello'), '... D does not have a method hello'); + +SKIP: { + skip "C3 does not make aliases on 5.9.5+", 2 if $] > 5.009_004; + ok(defined &Diamond_B::hello, '... B does have an alias to the method hello'); + ok(defined &Diamond_D::hello, '... D does have an alias to the method hello'); +} + +done_testing; diff --git a/t/cmop/InsideOutClass_test.t b/t/cmop/InsideOutClass_test.t new file mode 100644 index 0000000..d54568c --- /dev/null +++ b/t/cmop/InsideOutClass_test.t @@ -0,0 +1,223 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util 'reftype'; + +use lib 't/cmop/lib'; +require InsideOutClass; + +{ + package Foo; + + use strict; + use warnings; + + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + Foo->meta->add_attribute('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + )); + + Foo->meta->add_attribute('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'FOO is BAR' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + use strict; + use warnings; + + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('baz' => ( + accessor => 'baz', + predicate => 'has_baz', + )); + + package Baz; + + use strict; + use warnings; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + Baz->meta->add_attribute('bling' => ( + accessor => 'bling', + default => 'Baz::bling' + )); + + package Bar::Baz; + use metaclass ( + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' + ); + + use strict; + use warnings; + + use parent -norequire => 'Bar', 'Baz'; +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(reftype($foo), 'SCALAR', '... Foo is made with SCALAR'); + +can_ok($foo, 'foo'); +can_ok($foo, 'has_foo'); +can_ok($foo, 'get_bar'); +can_ok($foo, 'set_bar'); + +ok(!$foo->has_foo, '... Foo::foo is not defined yet'); +is($foo->foo(), undef, '... Foo::foo is not defined yet'); +is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); + +$foo->foo('This is Foo'); + +ok($foo->has_foo, '... Foo::foo is defined now'); +is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); + +$foo->set_bar(42); +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +my $foo2 = Foo->new(); +isa_ok($foo2, 'Foo'); + +is(reftype($foo2), 'SCALAR', '... Foo is made with SCALAR'); + +ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); +is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); +is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); + +$foo2->set_bar('DONT PANIC'); +is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); + +is($foo->get_bar(), 42, '... Foo::bar == 42'); + +# now Bar ... + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is(reftype($bar), 'SCALAR', '... Bar is made with SCALAR'); + +can_ok($bar, 'foo'); +can_ok($bar, 'has_foo'); +can_ok($bar, 'get_bar'); +can_ok($bar, 'set_bar'); +can_ok($bar, 'baz'); +can_ok($bar, 'has_baz'); + +ok(!$bar->has_foo, '... Bar::foo is not defined yet'); +is($bar->foo(), undef, '... Bar::foo is not defined yet'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); +ok(!$bar->has_baz, '... Bar::baz is not defined yet'); +is($bar->baz(), undef, '... Bar::baz is not defined yet'); + +$bar->foo('This is Bar::foo'); + +ok($bar->has_foo, '... Bar::foo is defined now'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +$bar->baz('This is Bar::baz'); + +ok($bar->has_baz, '... Bar::baz is defined now'); +is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); +is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); +is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); + +# now Baz ... + +my $baz = Bar::Baz->new(); +isa_ok($baz, 'Bar::Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); +isa_ok($baz, 'Baz'); + +is(reftype($baz), 'SCALAR', '... Bar::Baz is made with SCALAR'); + +can_ok($baz, 'foo'); +can_ok($baz, 'has_foo'); +can_ok($baz, 'get_bar'); +can_ok($baz, 'set_bar'); +can_ok($baz, 'baz'); +can_ok($baz, 'has_baz'); +can_ok($baz, 'bling'); + +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); +is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); +ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); +is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); + +$baz->foo('This is Bar::Baz::foo'); + +ok($baz->has_foo, '... Bar::Baz::foo is defined now'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +$baz->baz('This is Bar::Baz::baz'); + +ok($baz->has_baz, '... Bar::Baz::baz is defined now'); +is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); +is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); +is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); +is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); + +{ + no strict 'refs'; + + ok(*{'Foo::foo'}{HASH}, '... there is a foo package variable in Foo'); + ok(*{'Foo::bar'}{HASH}, '... there is a bar package variable in Foo'); + + is(scalar(keys(%{'Foo::foo'})), 4, '... got the right number of entries for Foo::foo'); + is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar'); + + ok(!*{'Bar::foo'}{HASH}, '... no foo package variable in Bar'); + ok(!*{'Bar::bar'}{HASH}, '... no bar package variable in Bar'); + ok(*{'Bar::baz'}{HASH}, '... there is a baz package variable in Bar'); + + is(scalar(keys(%{'Bar::foo'})), 0, '... got the right number of entries for Bar::foo'); + is(scalar(keys(%{'Bar::bar'})), 0, '... got the right number of entries for Bar::bar'); + is(scalar(keys(%{'Bar::baz'})), 2, '... got the right number of entries for Bar::baz'); + + ok(*{'Baz::bling'}{HASH}, '... there is a bar package variable in Baz'); + + is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling'); + + ok(!*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz'); + ok(!*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz'); + ok(!*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz'); + ok(!*{'Bar::Baz::bling'}{HASH}, '... no bar package variable in Baz::Baz'); + + is(scalar(keys(%{'Bar::Baz::foo'})), 0, '... got the right number of entries for Bar::Baz::foo'); + is(scalar(keys(%{'Bar::Baz::bar'})), 0, '... got the right number of entries for Bar::Baz::bar'); + is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz'); + is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling'); +} + +done_testing; diff --git a/t/cmop/InstanceCountingClass_test.t b/t/cmop/InstanceCountingClass_test.t new file mode 100644 index 0000000..e7acc22 --- /dev/null +++ b/t/cmop/InstanceCountingClass_test.t @@ -0,0 +1,57 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use InstanceCountingClass; + +=pod + +This is a trivial and contrived example of how to +make a metaclass which will count all the instances +created. It is not meant to be anything more than +a simple demonstration of how to make a metaclass. + +=cut + +{ + package Foo; + + use metaclass 'InstanceCountingClass'; + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + + our @ISA = ('Foo'); +} + +is(Foo->meta->get_count(), 0, '... our Foo count is 0'); +is(Bar->meta->get_count(), 0, '... our Bar count is 0'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is(Foo->meta->get_count(), 1, '... our Foo count is now 1'); +is(Bar->meta->get_count(), 0, '... our Bar count is still 0'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); + +is(Foo->meta->get_count(), 1, '... our Foo count is still 1'); +is(Bar->meta->get_count(), 1, '... our Bar count is now 1'); + +for (2 .. 10) { + Foo->new(); +} + +is(Foo->meta->get_count(), 10, '... our Foo count is now 10'); +is(Bar->meta->get_count(), 1, '... our Bar count is still 1'); + +done_testing; diff --git a/t/cmop/LazyClass_test.t b/t/cmop/LazyClass_test.t new file mode 100644 index 0000000..35db374 --- /dev/null +++ b/t/cmop/LazyClass_test.t @@ -0,0 +1,81 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use LazyClass; + +{ + package BinaryTree; + + use metaclass ( + 'attribute_metaclass' => 'LazyClass::Attribute', + 'instance_metaclass' => 'LazyClass::Instance', + ); + + BinaryTree->meta->add_attribute('node' => ( + accessor => 'node', + init_arg => 'node' + )); + + BinaryTree->meta->add_attribute('left' => ( + reader => 'left', + default => sub { BinaryTree->new() } + )); + + BinaryTree->meta->add_attribute('right' => ( + reader => 'right', + default => sub { BinaryTree->new() } + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } +} + +my $root = BinaryTree->new('node' => 0); +isa_ok($root, 'BinaryTree'); + +ok(exists($root->{'node'}), '... node attribute has been initialized yet'); +ok(!exists($root->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->{'right'}), '... right attribute has not been initialized yet'); + +isa_ok($root->left, 'BinaryTree'); +isa_ok($root->right, 'BinaryTree'); + +ok(exists($root->{'left'}), '... left attribute has now been initialized'); +ok(exists($root->{'right'}), '... right attribute has now been initialized'); + +ok(!exists($root->left->{'node'}), '... node attribute has not been initialized yet'); +ok(!exists($root->left->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->left->{'right'}), '... right attribute has not been initialized yet'); + +ok(!exists($root->right->{'node'}), '... node attribute has not been initialized yet'); +ok(!exists($root->right->{'left'}), '... left attribute has not been initialized yet'); +ok(!exists($root->right->{'right'}), '... right attribute has not been initialized yet'); + +is($root->left->node(), undef, '... the left node is uninitialized'); + +ok(exists($root->left->{'node'}), '... node attribute has now been initialized'); + +$root->left->node(1); +is($root->left->node(), 1, '... the left node == 1'); + +ok(!exists($root->left->{'left'}), '... left attribute still has not been initialized yet'); +ok(!exists($root->left->{'right'}), '... right attribute still has not been initialized yet'); + +is($root->right->node(), undef, '... the right node is uninitialized'); + +ok(exists($root->right->{'node'}), '... node attribute has now been initialized'); + +$root->right->node(2); +is($root->right->node(), 2, '... the right node == 1'); + +ok(!exists($root->right->{'left'}), '... left attribute still has not been initialized yet'); +ok(!exists($root->right->{'right'}), '... right attribute still has not been initialized yet'); + +done_testing; diff --git a/t/cmop/Perl6Attribute_test.t b/t/cmop/Perl6Attribute_test.t new file mode 100644 index 0000000..9b3d73f --- /dev/null +++ b/t/cmop/Perl6Attribute_test.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +use lib 't/cmop/lib'; +use Perl6Attribute; + +{ + package Foo; + + use metaclass; + + Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); + Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); + Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } +} + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +can_ok($foo, 'foo'); +can_ok($foo, 'bar'); +can_ok($foo, 'baz'); + +is($foo->foo, undef, '... Foo.foo == undef'); + +$foo->foo(42); +is($foo->foo, 42, '... Foo.foo == 42'); + +is_deeply($foo->bar, [], '... Foo.bar == []'); +is_deeply($foo->baz, {}, '... Foo.baz == {}'); + +done_testing; diff --git a/t/cmop/RT_27329_fix.t b/t/cmop/RT_27329_fix.t new file mode 100644 index 0000000..0c8ee6a --- /dev/null +++ b/t/cmop/RT_27329_fix.t @@ -0,0 +1,47 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +=pod + +This tests a bug sent via RT #27329 + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('foo' => ( + init_arg => 'foo', + reader => 'get_foo', + default => 'BAR', + )); + +} + +my $foo = Foo->meta->new_object; +isa_ok($foo, 'Foo'); + +is($foo->get_foo, 'BAR', '... got the right default value'); + +{ + my $clone = $foo->meta->clone_object($foo, foo => 'BAZ'); + isa_ok($clone, 'Foo'); + isnt($clone, $foo, '... and it is a clone'); + + is($clone->get_foo, 'BAZ', '... got the right cloned value'); +} + +{ + my $clone = $foo->meta->clone_object($foo, foo => undef); + isa_ok($clone, 'Foo'); + isnt($clone, $foo, '... and it is a clone'); + + ok(!defined($clone->get_foo), '... got the right cloned value'); +} + +done_testing; diff --git a/t/cmop/RT_39001_fix.t b/t/cmop/RT_39001_fix.t new file mode 100644 index 0000000..a3575e8 --- /dev/null +++ b/t/cmop/RT_39001_fix.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +=pod + +This tests a bug sent via RT #39001 + +=cut + +{ + package Foo; + use metaclass; +} + +like( exception { + Foo->meta->superclasses('Foo'); +}, qr/^Recursive inheritance detected/, "error occurs when extending oneself" ); + +{ + package Bar; + use metaclass; +} + +# reset @ISA, so that calling methods like ->isa won't die (->meta does this +# if DEBUG_NO_META is set) +@Foo::ISA = (); + +is( exception { + Foo->meta->superclasses('Bar'); +}, undef, "regular subclass" ); + +like( exception { + Bar->meta->superclasses('Foo'); +}, qr/^Recursive inheritance detected/, "error occurs when Bar extends Foo, when Foo is a Bar" ); + +done_testing; diff --git a/t/cmop/RT_41255.t b/t/cmop/RT_41255.t new file mode 100644 index 0000000..101d358 --- /dev/null +++ b/t/cmop/RT_41255.t @@ -0,0 +1,51 @@ +use strict; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package BaseClass; + sub m1 { 1 } + sub m2 { 2 } + sub m3 { 3 } + sub m4 { 4 } + sub m5 { 5 } + + package Derived; + use parent -norequire => 'BaseClass'; + + sub m1; + sub m2 (); + sub m3 :method; + sub m4; m4() if 0; + sub m5; our $m5;; +} + +my $meta = Class::MOP::Class->initialize('Derived'); +my %methods = map { $_ => $meta->find_method_by_name($_) } 'm1' .. 'm5'; + +while (my ($name, $meta_method) = each %methods) { + is $meta_method->fully_qualified_name, "Derived::${name}"; + like( exception { $meta_method->execute }, qr/Undefined subroutine .* called at/ ); +} + +{ + package Derived; + eval <<'EOC'; + + sub m1 { 'affe' } + sub m2 () { 'apan' } + sub m3 :method { 'tiger' } + sub m4 { 'birne' } + sub m5 { 'apfel' } + +EOC +} + +while (my ($name, $meta_method) = each %methods) { + is $meta_method->fully_qualified_name, "Derived::${name}"; + is( exception { $meta_method->execute }, undef ); +} + +done_testing; diff --git a/t/cmop/add_attribute_alternate.t b/t/cmop/add_attribute_alternate.t new file mode 100644 index 0000000..f7ecde1 --- /dev/null +++ b/t/cmop/add_attribute_alternate.t @@ -0,0 +1,109 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Point; + use metaclass; + + Point->meta->add_attribute('x' => ( + reader => 'x', + init_arg => 'x' + )); + + Point->meta->add_attribute('y' => ( + accessor => 'y', + init_arg => 'y' + )); + + sub new { + my $class = shift; + bless $class->meta->new_object(@_) => $class; + } + + sub clear { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + + package Point3D; + our @ISA = ('Point'); + + Point3D->meta->add_attribute('z' => ( + default => 123 + )); + + sub clear { + my $self = shift; + $self->{'z'} = 0; + $self->SUPER::clear(); + } +} + +isa_ok(Point->meta, 'Class::MOP::Class'); +isa_ok(Point3D->meta, 'Class::MOP::Class'); + +# ... test the classes themselves + +my $point = Point->new('x' => 2, 'y' => 3); +isa_ok($point, 'Point'); + +can_ok($point, 'x'); +can_ok($point, 'y'); +can_ok($point, 'clear'); + +{ + my $meta = $point->meta; + is($meta, Point->meta(), '... got the meta from the instance too'); +} + +is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); + +$point->y(42); +is($point->y, 42, '... the y attribute was set properly with the accessor'); + +is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); + +isnt( exception { + $point->x(42); +}, undef, '... cannot write to a read-only accessor' ); +is($point->x, 2, '... the x attribute was not altered'); + +$point->clear(); + +is($point->y, 0, '... the y attribute was cleared correctly'); +is($point->x, 0, '... the x attribute was cleared correctly'); + +my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); +isa_ok($point3d, 'Point3D'); +isa_ok($point3d, 'Point'); + +{ + my $meta = $point3d->meta; + is($meta, Point3D->meta(), '... got the meta from the instance too'); +} + +can_ok($point3d, 'x'); +can_ok($point3d, 'y'); +can_ok($point3d, 'clear'); + +is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); +is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); +is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); + +{ + my $point3d = Point3D->new(); + isa_ok($point3d, 'Point3D'); + + is($point3d->x, undef, '... the x attribute was not initialized'); + is($point3d->y, undef, '... the y attribute was not initialized'); + is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); + +} + +done_testing; diff --git a/t/cmop/add_method_debugmode.t b/t/cmop/add_method_debugmode.t new file mode 100644 index 0000000..152b990 --- /dev/null +++ b/t/cmop/add_method_debugmode.t @@ -0,0 +1,140 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Class::MOP::Mixin::HasMethods; + +# When the Perl debugger is enabled, %DB::sub tracks method information +# (line numbers and originating file). However, the reinitialize() +# functionality for classes and roles can sometimes clobber this information, +# causing to reference internal MOP files/lines instead. +# These tests check to make sure the the reinitialize() functionality +# preserves the correct debugging information when it (re)adds methods +# back into a class or role. + +BEGIN { + $^P = 831; # Enable debug mode +} + +# Empty debugger +sub DB::DB {} + +my ($foo_role_start, $foo_role_end, $foo_start_1, $foo_end_1, $foo_start_2, $foo_end_2); + +# Simple Moose Role +{ + package FooRole; + use Moose::Role; + + $foo_role_start = __LINE__ + 1; + sub foo_role { + return 'FooRole::foo_role'; + } + $foo_role_end = __LINE__ - 1; +} + +# Simple Moose package +{ + package Foo; + use Moose; + + with 'FooRole'; + + # Track the start/end line numbers of method foo(), for comparison later + $foo_start_1 = __LINE__ + 1; + sub foo { + return 'foo'; + } + $foo_end_1 = __LINE__ - 1; + + no Moose; +} + +# Extend our simple Moose package, with overriding method +{ + package Bar; + use Moose; + + extends 'Foo'; + + # Track the start/end line numbers of method foo(), for comparison later + $foo_start_2 = __LINE__ + 1; + sub foo { + return 'bar'; + } + $foo_end_2 = __LINE__ - 1; + + no Moose; +} + +# Check that Foo and Bar classes were set up correctly +my $bar_object = Bar->new(); +isa_ok(Foo->meta->get_method('foo'), 'Moose::Meta::Method'); +isa_ok(Bar->meta->get_method('foo'), 'Moose::Meta::Method'); +isa_ok(Foo->meta->get_method('foo_role'), 'Moose::Meta::Method'); +is($bar_object->foo_role(), 'FooRole::foo_role', 'Bar object has access to foo_role method'); + +# Run tests against Bar meta class... + +my $bar_meta = Bar->meta; +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (initial)"); + +# Run _restore_metamethods_from directly (part of the reinitialize() process) +$bar_meta->_restore_metamethods_from($bar_meta); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after _restore)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after _restore)"); + +# Call reinitialize explicitly, which triggers HasMethods::add_method +is( exception { + $bar_meta = $bar_meta->reinitialize('Bar'); +}, undef ); +isa_ok(Bar->meta->get_method('foo'), 'Moose::Meta::Method'); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after reinitialize)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after reinitialize)"); + +# Add a method to Bar; this triggers reinitialize as well +# Check that method line numbers are still listed as part of this file, and not a MOP file +$bar_meta->add_method('foo2' => sub { return 'new method foo2'; }); +like($DB::sub{"Foo::foo"}, qr/add_method_debugmode\.t:($foo_start_1)-($foo_end_1)/, "Check line numbers for Foo::foo (after add_method)"); +like($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t:($foo_start_2)-($foo_end_2)/, "Check line numbers for Bar::foo (after add_method)"); +like($DB::sub{"Bar::foo2"}, qr/(.*):(\d+)-(\d+)/, "Check for existence of Bar::foo2"); + +# Clobber Bar::foo by adding a method with the same name +$bar_meta->add_method( + 'foo' => $bar_meta->method_metaclass->wrap( + package_name => $bar_meta->name, + name => 'foo', + body => sub { return 'clobbered Bar::foo'; } + ) +); +unlike($DB::sub{"Bar::foo"}, qr/add_method_debugmode\.t/, "Check that source file for Bar::foo has changed"); + +# Run tests against FooRole meta role ... + +my $foorole_meta = FooRole->meta; +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (initial)"); + +# Call _restore_metamethods_from directly +$foorole_meta->_restore_metamethods_from($foorole_meta); +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (after _restore)"); + +# Call reinitialize +# Check that method line numbers are still listed as part of this file +is( exception { + $foorole_meta->reinitialize('FooRole'); +}, undef ); +isa_ok(FooRole->meta->get_method('foo_role'), 'Moose::Meta::Method'); +like($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t:($foo_role_start)-($foo_role_end)/, "Check line numbers for FooRole::foo_role (after reinitialize)"); + +# Clobber foo_role method +$foorole_meta->add_method( + 'foo_role' => $foorole_meta->method_metaclass->wrap( + package_name => $foorole_meta->name, + name => 'foo_role', + body => sub { return 'clobbered FooRole::foo_role'; } + ) +); +unlike($DB::sub{"FooRole::foo_role"}, qr/add_method_debugmode\.t/, "Check that source file for FooRole::foo_role has changed"); + +done_testing; diff --git a/t/cmop/add_method_modifier.t b/t/cmop/add_method_modifier.t new file mode 100644 index 0000000..b2f4a6c --- /dev/null +++ b/t/cmop/add_method_modifier.t @@ -0,0 +1,135 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + + package BankAccount; + + use strict; + use warnings; + use metaclass; + + use Carp 'confess'; + + BankAccount->meta->add_attribute( + 'balance' => ( + accessor => 'balance', + init_arg => 'balance', + default => 0 + ) + ); + + sub new { (shift)->meta->new_object(@_) } + + sub deposit { + my ( $self, $amount ) = @_; + $self->balance( $self->balance + $amount ); + } + + sub withdraw { + my ( $self, $amount ) = @_; + my $current_balance = $self->balance(); + ( $current_balance >= $amount ) + || confess "Account overdrawn"; + $self->balance( $current_balance - $amount ); + } + + package CheckingAccount; + + use strict; + use warnings; + use metaclass; + + use parent -norequire => 'BankAccount'; + + CheckingAccount->meta->add_attribute( + 'overdraft_account' => ( + accessor => 'overdraft_account', + init_arg => 'overdraft', + ) + ); + + CheckingAccount->meta->add_before_method_modifier( + 'withdraw' => sub { + my ( $self, $amount ) = @_; + my $overdraft_amount = $amount - $self->balance(); + if ( $overdraft_amount > 0 ) { + $self->overdraft_account->withdraw($overdraft_amount); + $self->deposit($overdraft_amount); + } + } + ); + + ::like( + ::exception{ CheckingAccount->meta->add_before_method_modifier( + 'does_not_exist' => sub { } + ); + }, + qr/\QThe method 'does_not_exist' was not found in the inheritance hierarchy for CheckingAccount/ + ); + + ::ok( CheckingAccount->meta->has_method('withdraw'), + '... checking account now has a withdraw method' ); + ::isa_ok( CheckingAccount->meta->get_method('withdraw'), + 'Class::MOP::Method::Wrapped' ); + ::isa_ok( BankAccount->meta->get_method('withdraw'), + 'Class::MOP::Method' ); + + CheckingAccount->meta->add_method( foo => sub { 'foo' } ); + CheckingAccount->meta->add_before_method_modifier( foo => sub { 'wrapped' } ); + ::isa_ok( CheckingAccount->meta->get_method('foo'), + 'Class::MOP::Method::Wrapped' ); +} + +my $savings_account = BankAccount->new( balance => 250 ); +isa_ok( $savings_account, 'BankAccount' ); + +is( $savings_account->balance, 250, '... got the right savings balance' ); +is( exception { + $savings_account->withdraw(50); +}, undef, '... withdrew from savings successfully' ); +is( $savings_account->balance, 200, + '... got the right savings balance after withdrawal' ); +isnt( exception { + $savings_account->withdraw(250); +}, undef, '... could not withdraw from savings successfully' ); + +$savings_account->deposit(150); +is( $savings_account->balance, 350, + '... got the right savings balance after deposit' ); + +my $checking_account = CheckingAccount->new( + balance => 100, + overdraft => $savings_account +); +isa_ok( $checking_account, 'CheckingAccount' ); +isa_ok( $checking_account, 'BankAccount' ); + +is( $checking_account->overdraft_account, $savings_account, + '... got the right overdraft account' ); + +is( $checking_account->balance, 100, '... got the right checkings balance' ); + +is( exception { + $checking_account->withdraw(50); +}, undef, '... withdrew from checking successfully' ); +is( $checking_account->balance, 50, + '... got the right checkings balance after withdrawal' ); +is( $savings_account->balance, 350, + '... got the right savings balance after checking withdrawal (no overdraft)' +); + +is( exception { + $checking_account->withdraw(200); +}, undef, '... withdrew from checking successfully' ); +is( $checking_account->balance, 0, + '... got the right checkings balance after withdrawal' ); +is( $savings_account->balance, 200, + '... got the right savings balance after overdraft withdrawal' ); + +done_testing; diff --git a/t/cmop/advanced_methods.t b/t/cmop/advanced_methods.t new file mode 100644 index 0000000..6cd0d02 --- /dev/null +++ b/t/cmop/advanced_methods.t @@ -0,0 +1,168 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; +use Class::MOP::Class; + +=pod + +The following class hierarhcy is very contrived +and totally horrid (it won't work under C3 even), +but it tests a number of aspect of this module. + +A more real-world example would be a nice addition :) + +=cut + +{ + package Foo; + + sub BUILD { 'Foo::BUILD' } + sub foo { 'Foo::foo' } + + package Bar; + our @ISA = ('Foo'); + + sub BUILD { 'Bar::BUILD' } + sub bar { 'Bar::bar' } + + package Baz; + our @ISA = ('Bar'); + + sub baz { 'Baz::baz' } + sub foo { 'Baz::foo' } + + package Foo::Bar; + our @ISA = ('Foo', 'Bar'); + + sub BUILD { 'Foo::Bar::BUILD' } + sub foobar { 'Foo::Bar::foobar' } + + package Foo::Bar::Baz; + our @ISA = ('Foo', 'Bar', 'Baz'); + + sub BUILD { 'Foo::Bar::Baz::BUILD' } + sub bar { 'Foo::Bar::Baz::bar' } + sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' } +} + +ok(!defined(Class::MOP::Class->initialize('Foo')->find_next_method_by_name('BUILD')), + '... Foo::BUILD has not next method'); + +is(Class::MOP::Class->initialize('Bar')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Bar::BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Baz')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + '... Baz->BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Foo::Bar')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Foo::Bar->BUILD does have a next method'); + +is(Class::MOP::Class->initialize('Foo::Bar::Baz')->find_next_method_by_name('BUILD'), + Class::MOP::Class->initialize('Foo')->get_method('BUILD'), + '... Foo::Bar::Baz->BUILD does have a next method'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Foo')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Foo')->get_method('BUILD') , + Class::MOP::Class->initialize('Foo')->get_method('foo'), + ], + '... got the right list of applicable methods for Foo'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Bar')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Foo')->get_method('foo'), + ], + '... got the right list of applicable methods for Bar'); + + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Baz')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Baz')->get_method('baz'), + Class::MOP::Class->initialize('Baz')->get_method('foo'), + ], + '... got the right list of applicable methods for Baz'); + +is_deeply( + [ + sort { $a->name cmp $b->name } + grep { $_->package_name ne 'UNIVERSAL' } + Class::MOP::Class->initialize('Foo::Bar')->get_all_methods() + ], + [ + Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD'), + Class::MOP::Class->initialize('Bar')->get_method('bar'), + Class::MOP::Class->initialize('Foo')->get_method('foo'), + Class::MOP::Class->initialize('Foo::Bar')->get_method('foobar'), + ], + '... got the right list of applicable methods for Foo::Bar'); + +## find_all_methods_by_name + +is_deeply( + [ Class::MOP::Class->initialize('Foo::Bar')->find_all_methods_by_name('BUILD') ], + [ + { + name => 'BUILD', + class => 'Foo::Bar', + code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Foo', + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Bar', + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') + } + ], + '... got the right list of BUILD methods for Foo::Bar'); + +is_deeply( + [ Class::MOP::Class->initialize('Foo::Bar::Baz')->find_all_methods_by_name('BUILD') ], + [ + { + name => 'BUILD', + class => 'Foo::Bar::Baz', + code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Foo', + code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') + }, + { + name => 'BUILD', + class => 'Bar', + code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') + }, + ], + '... got the right list of BUILD methods for Foo::Bar::Baz'); + +done_testing; diff --git a/t/cmop/anon_class.t b/t/cmop/anon_class.t new file mode 100644 index 0000000..19681e1 --- /dev/null +++ b/t/cmop/anon_class.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use strict; + use warnings; + use metaclass; + + sub bar { 'Foo::bar' } +} + +my $anon_class_id; +{ + my $instance; + { + my $anon_class = Class::MOP::Class->create_anon_class(); + isa_ok($anon_class, 'Class::MOP::Class'); + + ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/); + + ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists'); + like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name'); + + is_deeply( + [$anon_class->superclasses], + [], + '... got an empty superclass list'); + is( exception { + $anon_class->superclasses('Foo'); + }, undef, '... can add a superclass to anon class' ); + is_deeply( + [$anon_class->superclasses], + [ 'Foo' ], + '... got the right superclass list'); + + ok(!$anon_class->has_method('foo'), '... no foo method'); + is( exception { + $anon_class->add_method('foo' => sub { "__ANON__::foo" }); + }, undef, '... added a method to my anon-class' ); + ok($anon_class->has_method('foo'), '... we have a foo method now'); + + $instance = $anon_class->new_object(); + isa_ok($instance, $anon_class->name); + isa_ok($instance, 'Foo'); + + is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method'); + is($instance->bar, 'Foo::bar', '... got the right return value of our bar method'); + } + + ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package still exists'); +} + +local $TODO = "anon class doesn't get GCed under Devel::Cover" if $INC{'Devel/Cover.pm'}; + +ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists'); + +# but it breaks down when we try to create another one ... + +my $instance_2 = bless {} => ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id); +isa_ok($instance_2, ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id)); +ok(!$instance_2->isa('Foo'), '... but the new instance is not a Foo'); +ok(!$instance_2->can('foo'), '... and it can no longer call the foo method'); + +done_testing; diff --git a/t/cmop/anon_class_create_init.t b/t/cmop/anon_class_create_init.t new file mode 100644 index 0000000..a35a1eb --- /dev/null +++ b/t/cmop/anon_class_create_init.t @@ -0,0 +1,150 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package MyMeta; + use parent 'Class::MOP::Class'; + sub initialize { + my $class = shift; + my ( $package, %options ) = @_; + ::cmp_ok( $options{foo}, 'eq', 'this', + 'option passed to initialize() on create_anon_class()' ); + return $class->SUPER::initialize( @_ ); + } + +} + +{ + my $anon = MyMeta->create_anon_class( foo => 'this' ); + isa_ok( $anon, 'MyMeta' ); +} + +my $instance; + +{ + my $meta = Class::MOP::Class->create_anon_class; + $instance = $meta->new_object; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away"); +} + +{ + my $meta = Class::MOP::Class->create_anon_class; + $meta->make_immutable; + $instance = $meta->name->new; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances (immutable)"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away (immutable)"); +} + +{ + $instance = Class::MOP::Class->create('Foo')->new_object; + my $meta = Class::MOP::Class->create_anon_class(superclasses => ['Foo']); + $meta->rebless_instance($instance); +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "anon class is collected once instances go away"); +} + +{ + { + my $meta = Class::MOP::Class->create_anon_class; + { + my $submeta = Class::MOP::Class->create_anon_class( + superclasses => [$meta->name] + ); + $instance = $submeta->new_object; + } + { + my $submeta = Class::MOP::class_of($instance); + Scalar::Util::weaken($submeta); + ok($submeta, "anon class is kept alive by existing instances"); + + $meta->rebless_instance_back($instance); + ok(!$submeta, "reblessing away loses the metaclass"); + } + } + + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "anon class is kept alive by existing instances"); +} + +{ + my $submeta = Class::MOP::Class->create_anon_class( + superclasses => [Class::MOP::Class->create_anon_class->name], + ); + my @superclasses = $submeta->superclasses; + ok(Class::MOP::class_of($superclasses[0]), + "superclasses are kept alive by their subclasses"); +} + +{ + my $meta_name; + { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => ['Class::MOP::Class'], + ); + $meta_name = $meta->name; + ok(Class::MOP::metaclass_is_weak($meta_name), + "default is for anon metaclasses to be weakened"); + } + ok(!Class::MOP::class_of($meta_name), + "and weak metaclasses go away when all refs do"); + { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => ['Class::MOP::Class'], + weaken => 0, + ); + $meta_name = $meta->name; + ok(!Class::MOP::metaclass_is_weak($meta_name), + "anon classes can be told not to weaken"); + } + ok(Class::MOP::class_of($meta_name), "metaclass still exists"); + { + my $bar_meta; + is( exception { + $bar_meta = $meta_name->initialize('Bar'); + }, undef, "we can use the name on its own" ); + isa_ok($bar_meta, $meta_name); + } +} + +{ + my $meta = Class::MOP::Class->create( + 'Baz', + weaken => 1, + ); + $instance = $meta->new_object; +} +{ + my $meta = Class::MOP::class_of($instance); + Scalar::Util::weaken($meta); + ok($meta, "weak class is kept alive by existing instances"); + + undef $instance; + ok(!$meta, "weak class is collected once instances go away"); +} + +done_testing; diff --git a/t/cmop/anon_class_keep_alive.t b/t/cmop/anon_class_keep_alive.t new file mode 100644 index 0000000..ace95d8 --- /dev/null +++ b/t/cmop/anon_class_keep_alive.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my $anon_class_name; +my $anon_meta_name; +{ + package Foo; + use strict; + use warnings; + use metaclass; + + sub make_anon_instance{ + my $self = shift; + my $class = ref $self || $self; + + my $anon_class = Class::MOP::Class->create_anon_class(superclasses => [$class]); + $anon_class_name = $anon_class->name; + $anon_meta_name = Scalar::Util::blessed($anon_class); + $anon_class->add_attribute( $_, reader => $_ ) for qw/bar baz/; + + my $obj = $anon_class->new_object(bar => 'a', baz => 'b'); + return $obj; + } + + sub foo{ 'foo' } + + 1; +} + +my $instance = Foo->make_anon_instance; + +isa_ok($instance, $anon_class_name); +isa_ok($instance->meta, $anon_meta_name); +isa_ok($instance, 'Foo', '... Anonymous instance isa Foo'); + +ok($instance->can('foo'), '... Anonymous instance can foo'); +ok($instance->meta->find_method_by_name('foo'), '... Anonymous instance has method foo'); + +ok($instance->meta->has_attribute('bar'), '... Anonymous instance still has attribute bar'); +ok($instance->meta->has_attribute('baz'), '... Anonymous instance still has attribute baz'); +is($instance->bar, 'a', '... Anonymous instance still has correct bar value'); +is($instance->baz, 'b', '... Anonymous instance still has correct baz value'); + +is_deeply([$instance->meta->class_precedence_list], + [$anon_class_name, 'Foo'], + '... Anonymous instance has class precedence list', + ); + +done_testing; diff --git a/t/cmop/anon_class_leak.t b/t/cmop/anon_class_leak.t new file mode 100644 index 0000000..0a292fc --- /dev/null +++ b/t/cmop/anon_class_leak.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::LeakTrace'; # skip all if not installed + +BEGIN { + plan skip_all => 'Leak tests fail under Devel::Cover' if $INC{'Devel/Cover.pm'}; +} + +use Class::MOP; + +# 5.10.0 has a bug on weaken($hash_ref) which leaks an AV. +my $expected = ( $] == 5.010_000 ? 1 : 0 ); + +leaks_cmp_ok { + Class::MOP::Class->create_anon_class(); +} +'<=', $expected, 'create_anon_class()'; + +leaks_cmp_ok { + Class::MOP::Class->create_anon_class( superclasses => [qw(Exporter)] ); +} +'<=', $expected, 'create_anon_class(superclass => [...])'; + +done_testing; diff --git a/t/cmop/anon_class_removal.t b/t/cmop/anon_class_removal.t new file mode 100644 index 0000000..9d0313a --- /dev/null +++ b/t/cmop/anon_class_removal.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; + +{ + my $class; + { + my $meta = Class::MOP::Class->create_anon_class( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $class = $meta->name; + can_ok($class, 'foo'); + is($class->foo, 'FOO'); + } + ok(!$class->can('foo')); +} + +{ + my $class; + { + my $meta = Class::MOP::Class->create_anon_class( + methods => { + foo => sub { 'FOO' }, + }, + ); + + $class = $meta->name; + can_ok($class, 'foo'); + is($class->foo, 'FOO'); + Class::MOP::remove_metaclass_by_name($class); + } + ok(!$class->can('foo')); +} + +done_testing; diff --git a/t/cmop/anon_packages.t b/t/cmop/anon_packages.t new file mode 100644 index 0000000..3e5df88 --- /dev/null +++ b/t/cmop/anon_packages.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + my $name; + { + my $anon = Class::MOP::Package->create_anon; + $name = $anon->name; + $anon->add_package_symbol('&foo' => sub {}); + can_ok($name, 'foo'); + ok($anon->is_anon, "is anon"); + } + + ok(!$name->can('foo'), "!$name->can('foo')"); +} + +{ + my $name; + { + my $anon = Class::MOP::Package->create_anon(weaken => 0); + $name = $anon->name; + $anon->add_package_symbol('&foo' => sub {}); + can_ok($name, 'foo'); + ok($anon->is_anon, "is anon"); + } + + can_ok($name, 'foo'); +} + +{ + like(exception { Class::MOP::Package->create_anon(cache => 1) }, + qr/^Packages are not cacheable/, + "can't cache anon packages"); +} + +done_testing; diff --git a/t/cmop/attribute.t b/t/cmop/attribute.t new file mode 100644 index 0000000..f23a434 --- /dev/null +++ b/t/cmop/attribute.t @@ -0,0 +1,248 @@ +use strict; +use warnings; + +use Scalar::Util 'reftype', 'blessed'; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Attribute; +use Class::MOP::Method; + + +isnt( exception { Class::MOP::Attribute->name }, undef, q{... can't call name() as a class method} ); + + +{ + my $attr = Class::MOP::Attribute->new('$foo'); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '$foo', '... $attr init_arg is the name'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + ok(!$attr->has_default, '... $attr does not have an default'); + ok(!$attr->has_builder, '... $attr does not have a builder'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is a plain old sub'); + ok(!blessed($writer), '... it is a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $class = Class::MOP::Class->initialize('Foo'); + isa_ok($class, 'Class::MOP::Class'); + + is( exception { + $attr->attach_to_class($class); + }, undef, '... attached a class successfully' ); + + is($attr->associated_class, $class, '... the class was associated correctly'); + + ok(!$attr->get_read_method, '... $attr does not have an read method'); + ok(!$attr->get_write_method, '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(blessed($reader), '... it is a plain old sub'); + ok(blessed($writer), '... it is a plain old sub'); + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, $class, '... the associated classes are the same though'); + is($attr_clone->associated_class, $class, '... the associated classes are the same though'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + ok(!$attr->has_builder, '... $attr does not have a builder'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + + ok(!$attr->get_read_method, '... $attr does not have an read method'); + ok(!$attr->get_write_method, '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is a plain old sub'); + ok(!blessed($writer), '... it is a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, undef, '... the associated class is actually undef'); + is($attr_clone->associated_class, undef, '... the associated class is actually undef'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_accessor, '... $attr does have an accessor'); + is($attr->accessor, 'foo', '... $attr->accessor == foo'); + + ok(!$attr->has_reader, '... $attr does not have an reader'); + ok(!$attr->has_writer, '... $attr does not have an writer'); + + is($attr->get_read_method, 'foo', '... $attr does not have an read method'); + is($attr->get_write_method, 'foo', '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is not a plain old sub'); + ok(!blessed($writer), '... it is not a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', ( + reader => 'get_foo', + writer => 'set_foo', + init_arg => '-foo', + default => 'BAR' + )); + isa_ok($attr, 'Class::MOP::Attribute'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); + ok($attr->has_default, '... $attr does have an default'); + is($attr->default, 'BAR', '... $attr->default == BAR'); + + ok($attr->has_reader, '... $attr does have an reader'); + is($attr->reader, 'get_foo', '... $attr->reader == get_foo'); + ok($attr->has_writer, '... $attr does have an writer'); + is($attr->writer, 'set_foo', '... $attr->writer == set_foo'); + + ok(!$attr->has_accessor, '... $attr does not have an accessor'); + + is($attr->get_read_method, 'get_foo', '... $attr does not have an read method'); + is($attr->get_write_method, 'set_foo', '... $attr does not have an write method'); + + { + my $reader = $attr->get_read_method_ref; + my $writer = $attr->get_write_method_ref; + + ok(!blessed($reader), '... it is not a plain old sub'); + ok(!blessed($writer), '... it is not a plain old sub'); + + is(reftype($reader), 'CODE', '... it is a plain old sub'); + is(reftype($writer), 'CODE', '... it is a plain old sub'); + } + + my $attr_clone = $attr->clone(); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + is_deeply($attr, $attr_clone, '... but they are the same inside'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo'); + isa_ok($attr, 'Class::MOP::Attribute'); + + my $attr_clone = $attr->clone('name' => '$bar'); + isa_ok($attr_clone, 'Class::MOP::Attribute'); + isnt($attr, $attr_clone, '... but they are different instances'); + + isnt($attr->name, $attr_clone->name, '... we changes the name parameter'); + + is($attr->name, '$foo', '... $attr->name == $foo'); + is($attr_clone->name, '$bar', '... $attr_clone->name == $bar'); +} + +{ + my $attr = Class::MOP::Attribute->new('$foo', (builder => 'foo_builder')); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok(!$attr->has_default, '... $attr does not have a default'); + ok($attr->has_builder, '... $attr does have a builder'); + is($attr->builder, 'foo_builder', '... $attr->builder == foo_builder'); + +} + +{ + for my $value ({}, bless({}, 'Foo')) { + like( exception { + Class::MOP::Attribute->new('$foo', default => $value); + }, qr/References are not allowed as default values/ ); + } +} + +{ + my $attr; + is( exception { + my $meth = Class::MOP::Method->wrap(sub {shift}, name => 'foo', package_name => 'bar'); + $attr = Class::MOP::Attribute->new('$foo', default => $meth); + }, undef, 'Class::MOP::Methods accepted as default' ); + + is($attr->default(42), 42, 'passthrough for default on attribute'); +} + +done_testing; diff --git a/t/cmop/attribute_duplication.t b/t/cmop/attribute_duplication.t new file mode 100644 index 0000000..4c4073f --- /dev/null +++ b/t/cmop/attribute_duplication.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Scalar::Util; + +use Test::More; + +use Class::MOP; + +=pod + +This tests that when an attribute of the same name +is added to a class, that it will remove the old +one first. + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + ::can_ok('Foo', 'get_bar'); + ::can_ok('Foo', 'set_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); + + my $bar_attr = Foo->meta->get_attribute('bar'); + + ::is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); + ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); + ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + + Foo->meta->add_attribute('bar' => + reader => 'assign_bar' + ); + + ::ok(!Foo->can('get_bar'), '... Foo no longer has the get_bar method'); + ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method'); + ::can_ok('Foo', 'assign_bar'); + ::ok(Foo->meta->has_attribute('bar'), '... Foo still has the attribute bar'); + + my $bar_attr2 = Foo->meta->get_attribute('bar'); + + ::isnt($bar_attr, $bar_attr2, '... this is a new bar attribute'); + ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta'); + + ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta'); + + ::isnt($bar_attr2->reader, 'get_bar', '... the bar attribute no longer has the reader get_bar'); + ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar'); + ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar'); +} + +done_testing; diff --git a/t/cmop/attribute_errors_and_edge_cases.t b/t/cmop/attribute_errors_and_edge_cases.t new file mode 100644 index 0000000..e4a87d6 --- /dev/null +++ b/t/cmop/attribute_errors_and_edge_cases.t @@ -0,0 +1,232 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Attribute; + +# most values are static + +{ + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => qr/hello (.*)/ + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => [] + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => {} + )); + }, undef, '... no refs for defaults' ); + + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => \(my $var) + )); + }, undef, '... no refs for defaults' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + default => bless {} => 'Foo' + )); + }, undef, '... no refs for defaults' ); + +} + +{ + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => qr/hello (.*)/ + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => [] + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => {} + )); + }, undef, '... no refs for builders' ); + + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => \(my $var) + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => bless {} => 'Foo' + )); + }, undef, '... no refs for builders' ); + + isnt( exception { + Class::MOP::Attribute->new('$test' => ( + builder => 'Foo', default => 'Foo' + )); + }, undef, '... no default AND builder' ); + + my $undef_attr; + is( exception { + $undef_attr = Class::MOP::Attribute->new('$test' => ( + default => undef, + predicate => 'has_test', + )); + }, undef, '... undef as a default is okay' ); + ok($undef_attr->has_default, '... and it counts as an actual default'); + ok(!Class::MOP::Attribute->new('$test')->has_default, + '... but attributes with no default have no default'); + + Class::MOP::Class->create( + 'Foo', + attributes => [$undef_attr], + ); + { + my $obj = Foo->meta->new_object; + ok($obj->has_test, '... and the default is populated'); + is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); + } + is( exception { Foo->meta->make_immutable }, undef, '... and it can be inlined' ); + { + my $obj = Foo->new; + ok($obj->has_test, '... and the default is populated'); + is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); + } + +} + + +{ # bad construtor args + isnt( exception { + Class::MOP::Attribute->new(); + }, undef, '... no name argument' ); + + # These are no longer errors + is( exception { + Class::MOP::Attribute->new(''); + }, undef, '... bad name argument' ); + + is( exception { + Class::MOP::Attribute->new(0); + }, undef, '... bad name argument' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test'); + isnt( exception { + $attr->attach_to_class(); + }, undef, '... attach_to_class died as expected' ); + + isnt( exception { + $attr->attach_to_class('Fail'); + }, undef, '... attach_to_class died as expected' ); + + isnt( exception { + $attr->attach_to_class(bless {} => 'Fail'); + }, undef, '... attach_to_class died as expected' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test' => ( + reader => [ 'whoops, this wont work' ] + )); + + $attr->attach_to_class(Class::MOP::Class->initialize('Foo')); + + isnt( exception { + $attr->install_accessors; + }, undef, '... bad reader format' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test'); + + isnt( exception { + $attr->_process_accessors('fail', 'my_failing_sub'); + }, undef, '... cannot find "fail" type generator' ); +} + + +{ + { + package My::Attribute; + our @ISA = ('Class::MOP::Attribute'); + sub generate_reader_method { eval { die } } + } + + my $attr = My::Attribute->new('$test' => ( + reader => 'test' + )); + + isnt( exception { + $attr->install_accessors; + }, undef, '... failed to generate accessors correctly' ); +} + +{ + my $attr = Class::MOP::Attribute->new('$test' => ( + predicate => 'has_test' + )); + + my $Bar = Class::MOP::Class->create('Bar'); + isa_ok($Bar, 'Class::MOP::Class'); + + $Bar->add_attribute($attr); + + can_ok('Bar', 'has_test'); + + is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute'); + + ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method'); +} + + +{ + # NOTE: + # the next three tests once tested that + # the code would fail, but we lifted the + # restriction so you can have an accessor + # along with a reader/writer pair (I mean + # why not really). So now they test that + # it works, which is kinda silly, but it + # tests the API change, so I keep it. + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + )); + }, undef, '... can create accessors with reader/writers' ); + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + writer => 'set_foo', + )); + }, undef, '... can create accessors with reader/writers' ); + + is( exception { + Class::MOP::Attribute->new('$foo', ( + accessor => 'foo', + reader => 'get_foo', + writer => 'set_foo', + )); + }, undef, '... can create accessors with reader/writers' ); +} + +done_testing; diff --git a/t/cmop/attribute_get_read_write.t b/t/cmop/attribute_get_read_write.t new file mode 100644 index 0000000..9f621a6 --- /dev/null +++ b/t/cmop/attribute_get_read_write.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Scalar::Util 'blessed', 'reftype'; + +use Test::More; + +use Class::MOP; + +=pod + +This checks the get_read/write_method +and get_read/write_method_ref methods + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + Foo->meta->add_attribute('baz' => + accessor => 'baz', + ); + + Foo->meta->add_attribute('gorch' => + reader => { 'get_gorch', => sub { (shift)->{gorch} } } + ); + + package Bar; + use metaclass; + Bar->meta->superclasses('Foo'); + + Bar->meta->add_attribute('quux' => + accessor => 'quux', + ); +} + +can_ok('Foo', 'get_bar'); +can_ok('Foo', 'set_bar'); +can_ok('Foo', 'baz'); +can_ok('Foo', 'get_gorch'); + +ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); +ok(Foo->meta->has_attribute('baz'), '... Foo has the attribute baz'); +ok(Foo->meta->has_attribute('gorch'), '... Foo has the attribute gorch'); + +my $bar_attr = Foo->meta->get_attribute('bar'); +my $baz_attr = Foo->meta->get_attribute('baz'); +my $gorch_attr = Foo->meta->get_attribute('gorch'); + +is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); +is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); +is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + +is($bar_attr->get_read_method, 'get_bar', '... $attr does have an read method'); +is($bar_attr->get_write_method, 'set_bar', '... $attr does have an write method'); + +{ + my $reader = $bar_attr->get_read_method_ref; + my $writer = $bar_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader->fully_qualified_name, 'Foo::get_bar', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::set_bar', '... it is the sub we are looking for'); + + is(reftype($reader->body), 'CODE', '... it is a plain old sub'); + is(reftype($writer->body), 'CODE', '... it is a plain old sub'); +} + +is($baz_attr->accessor, 'baz', '... the bar attribute has the accessor baz'); +is($baz_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); + +is($baz_attr->get_read_method, 'baz', '... $attr does have an read method'); +is($baz_attr->get_write_method, 'baz', '... $attr does have an write method'); + +{ + my $reader = $baz_attr->get_read_method_ref; + my $writer = $baz_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader, $writer, '... they are the same method'); + + is($reader->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); +} + +is(ref($gorch_attr->reader), 'HASH', '... the gorch attribute has the reader get_gorch (HASH ref)'); +is($gorch_attr->associated_class, Foo->meta, '... and the gorch attribute is associated with Foo->meta'); + +is($gorch_attr->get_read_method, 'get_gorch', '... $attr does have an read method'); +ok(!$gorch_attr->get_write_method, '... $attr does not have an write method'); + +{ + my $reader = $gorch_attr->get_read_method_ref; + my $writer = $gorch_attr->get_write_method_ref; + + isa_ok($reader, 'Class::MOP::Method'); + ok(blessed($writer), '... it is not a plain old sub'); + isa_ok($writer, 'Class::MOP::Method'); + + is($reader->fully_qualified_name, 'Foo::get_gorch', '... it is the sub we are looking for'); + is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for'); +} + +done_testing; diff --git a/t/cmop/attribute_initializer.t b/t/cmop/attribute_initializer.t new file mode 100644 index 0000000..7d8ca32 --- /dev/null +++ b/t/cmop/attribute_initializer.t @@ -0,0 +1,50 @@ +use strict; +use warnings; + +use Scalar::Util 'reftype'; +use Test::More; +use Class::MOP; + +=pod + +This checks that the initializer is used to set the initial value. + +=cut + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Class::MOP::Attribute'); + ::is($attr->name, 'bar', '... the attribute is our own'); + + $callback->($value * 2); + }, + ); +} + +can_ok('Foo', 'get_bar'); +can_ok('Foo', 'set_bar'); + +my $foo = Foo->meta->new_object(bar => 10); +is($foo->get_bar, 20, "... initial argument was doubled as expected"); + +$foo->set_bar(30); + +is($foo->get_bar, 30, "... and setter works correctly"); + +# meta tests ... + +my $bar = Foo->meta->get_attribute('bar'); +isa_ok($bar, 'Class::MOP::Attribute'); + +ok($bar->has_initializer, '... bar has an initializer'); +is(reftype $bar->initializer, 'CODE', '... the initializer is a CODE ref'); + +done_testing; diff --git a/t/cmop/attribute_introspection.t b/t/cmop/attribute_introspection.t new file mode 100644 index 0000000..dc99492 --- /dev/null +++ b/t/cmop/attribute_introspection.t @@ -0,0 +1,131 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +{ + my $attr = Class::MOP::Attribute->new('$test'); + is( $attr->meta, Class::MOP::Attribute->meta, + '... instance and class both lead to the same meta' ); +} + +{ + my $meta = Class::MOP::Attribute->meta(); + isa_ok( $meta, 'Class::MOP::Class' ); + + my @methods = qw( + new + clone + + initialize_instance_slot + _set_initial_slot_value + _make_initializer_writer_callback + + name + has_accessor accessor + has_writer writer + has_write_method get_write_method get_write_method_ref + has_reader reader + has_read_method get_read_method get_read_method_ref + has_predicate predicate + has_clearer clearer + has_builder builder + has_init_arg init_arg + has_default default is_default_a_coderef + has_initializer initializer + has_insertion_order insertion_order _set_insertion_order + + definition_context + + slots + get_value + set_value + get_raw_value + set_raw_value + set_initial_value + has_value + clear_value + + associated_class + attach_to_class + detach_from_class + + accessor_metaclass + + associated_methods + associate_method + + _process_accessors + _accessor_description + install_accessors + remove_accessors + + _inline_get_value + _inline_set_value + _inline_has_value + _inline_clear_value + _inline_instance_get + _inline_instance_set + _inline_instance_has + _inline_instance_clear + + _new + ); + + is_deeply( + [ + sort Class::MOP::Mixin::AttributeCore->meta->get_method_list, + $meta->get_method_list + ], + [ sort @methods ], + '... our method list matches' + ); + + foreach my $method_name (@methods) { + ok( $meta->find_method_by_name($method_name), + '... Class::MOP::Attribute->find_method_by_name(' . $method_name . ')' ); + } + + my @attributes = ( + 'name', + 'accessor', + 'reader', + 'writer', + 'predicate', + 'clearer', + 'builder', + 'init_arg', + 'initializer', + 'definition_context', + 'default', + 'associated_class', + 'associated_methods', + 'insertion_order', + ); + + is_deeply( + [ + sort Class::MOP::Mixin::AttributeCore->meta->get_attribute_list, + $meta->get_attribute_list + ], + [ sort @attributes ], + '... our attribute list matches' + ); + + foreach my $attribute_name (@attributes) { + ok( $meta->find_attribute_by_name($attribute_name), + '... Class::MOP::Attribute->find_attribute_by_name(' + . $attribute_name + . ')' ); + } + + # We could add some tests here to make sure that + # the attribute have the appropriate + # accessor/reader/writer/predicate combinations, + # but that is getting a little excessive so I + # wont worry about it for now. Maybe if I get + # bored I will do it. +} + +done_testing; diff --git a/t/cmop/attribute_non_alpha_name.t b/t/cmop/attribute_non_alpha_name.t new file mode 100644 index 0000000..98e411e --- /dev/null +++ b/t/cmop/attribute_non_alpha_name.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Class::MOP; + +use Test::More; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute( '@foo', accessor => 'foo' ); + Foo->meta->add_attribute( '!bar', reader => 'bar' ); + Foo->meta->add_attribute( '%baz', reader => 'baz' ); +} + +{ + my $meta = Foo->meta; + + for my $name ( '@foo', '!bar', '%baz' ) { + ok( + $meta->has_attribute($name), + "Foo has $name attribute" + ); + + my $meth = substr $name, 1; + ok( $meta->has_method($meth), 'Foo has $meth method' ); + } + + $meta->make_immutable, redo + unless $meta->is_immutable; +} + +done_testing; diff --git a/t/cmop/attributes.t b/t/cmop/attributes.t new file mode 100644 index 0000000..a6df570 --- /dev/null +++ b/t/cmop/attributes.t @@ -0,0 +1,262 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $FOO_ATTR = Class::MOP::Attribute->new('$foo'); +my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => ( + accessor => 'bar' +)); +my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( + reader => 'get_baz', + writer => 'set_baz', +)); + +my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar'); + +my $FOO_ATTR_2 = Class::MOP::Attribute->new('$foo' => ( + accessor => 'foo', + builder => 'build_foo' +)); + +is($FOO_ATTR->name, '$foo', '... got the attributes name correctly'); +is($BAR_ATTR->name, '$bar', '... got the attributes name correctly'); +is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); + +{ + package Foo; + use metaclass; + + my $meta = Foo->meta; + ::is( ::exception { + $meta->add_attribute($FOO_ATTR); + }, undef, '... we added an attribute to Foo successfully' ); + ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute'); + ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo'); + + ::ok(!$meta->has_method('foo'), '... no accessor created'); + + ::is( ::exception { + $meta->add_attribute($BAR_ATTR_2); + }, undef, '... we added an attribute to Foo successfully' ); + ::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute'); + ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo'); + + ::ok(!$meta->has_method('bar'), '... no accessor created'); +} +{ + package Bar; + our @ISA = ('Foo'); + + my $meta = Bar->meta; + ::is( ::exception { + $meta->add_attribute($BAR_ATTR); + }, undef, '... we added an attribute to Bar successfully' ); + ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute'); + ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar'); + + my $attr = $meta->get_attribute('$bar'); + ::is($attr->get_read_method, 'bar', '... got the right read method for Bar'); + ::is($attr->get_write_method, 'bar', '... got the right write method for Bar'); + + ::ok($meta->has_method('bar'), '... an accessor has been created'); + ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor'); +} +{ + package Baz; + our @ISA = ('Bar'); + + my $meta = Baz->meta; + ::is( ::exception { + $meta->add_attribute($BAZ_ATTR); + }, undef, '... we added an attribute to Baz successfully' ); + ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute'); + ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz'); + + my $attr = $meta->get_attribute('$baz'); + ::is($attr->get_read_method, 'get_baz', '... got the right read method for Baz'); + ::is($attr->get_write_method, 'set_baz', '... got the right write method for Baz'); + + ::ok($meta->has_method('get_baz'), '... a reader has been created'); + ::ok($meta->has_method('set_baz'), '... a writer has been created'); + + ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor'); + ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor'); +} + +{ + package Foo2; + use metaclass; + + my $meta = Foo2->meta; + $meta->add_attribute( + Class::MOP::Attribute->new( '$foo2' => ( reader => 'foo2' ) ) ); + + ::ok( $meta->has_method('foo2'), '... a reader has been created' ); + + my $attr = $meta->get_attribute('$foo2'); + ::is( $attr->get_read_method, 'foo2', + '... got the right read method for Foo2' ); + ::is( $attr->get_write_method, undef, + '... got undef for the writer with a read-only attribute in Foo2' ); +} + +{ + my $meta = Baz->meta; + isa_ok($meta, 'Class::MOP::Class'); + + is($meta->find_attribute_by_name('$bar'), $BAR_ATTR, '... got the right attribute for "bar"'); + is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"'); + is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"'); + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR, + $BAZ_ATTR, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Bar->meta, Baz->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + my $attr; + is( exception { + $attr = $meta->remove_attribute('$baz'); + }, undef, '... removed the $baz attribute successfully' ); + is($attr, $BAZ_ATTR, '... got the right attribute back for Baz'); + + ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute'); + is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute'); + + ok(!$meta->has_method('get_baz'), '... a reader has been removed'); + ok(!$meta->has_method('set_baz'), '... a writer has been removed'); + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Bar->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + { + my $attr; + is( exception { + $attr = Bar->meta->remove_attribute('$bar'); + }, undef, '... removed the $bar attribute successfully' ); + is($attr, $BAR_ATTR, '... got the right attribute back for Bar'); + + ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute'); + + ok(!Bar->meta->has_method('bar'), '... a accessor has been removed'); + } + + is_deeply( + [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ + $BAR_ATTR_2, + $FOO_ATTR, + ], + '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], + [ Foo->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + + # remove attribute which is not there + my $val; + is( exception { + $val = $meta->remove_attribute('$blammo'); + }, undef, '... attempted to remove the non-existent $blammo attribute' ); + is($val, undef, '... got the right value back (undef)'); + +} + +{ + package Buzz; + use metaclass; + use Scalar::Util qw/blessed/; + + my $meta = Buzz->meta; + ::is( ::exception { + $meta->add_attribute($FOO_ATTR_2); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_attribute( + Class::MOP::Attribute->new( + '$bar' => ( + accessor => 'bar', + predicate => 'has_bar', + clearer => 'clear_bar', + ) + ) + ); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_attribute( + Class::MOP::Attribute->new( + '$bah' => ( + accessor => 'bah', + predicate => 'has_bah', + clearer => 'clear_bah', + default => 'BAH', + ) + ) + ); + }, undef, '... we added an attribute to Buzz successfully' ); + + ::is( ::exception { + $meta->add_method(build_foo => sub{ blessed shift; }); + }, undef, '... we added a method to Buzz successfully' ); +} + + + +for(1 .. 2){ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::is($buzz->foo, 'Buzz', '...foo builder works as expected'); + ::ok(!$buzz->has_bar, '...bar is not set'); + ::is($buzz->bar, undef, '...bar returns undef'); + ::ok(!$buzz->has_bar, '...bar was not autovivified'); + + $buzz->bar(undef); + ::ok($buzz->has_bar, '...bar is set'); + ::is($buzz->bar, undef, '...bar is undef'); + $buzz->clear_bar; + ::ok(!$buzz->has_bar, '...bar is no longerset'); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('$bar' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bar, '...bar is set'); + ::is($buzz2->bar, undef, '...bar is undef'); + + my $buzz3; + ::is( ::exception { $buzz3 = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz3->has_bah, '...bah is set'); + ::is($buzz3->bah, 'BAH', '...bah returns "BAH" '); + + my $buzz4; + ::is( ::exception { $buzz4 = Buzz->meta->new_object('$bah' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz4->has_bah, '...bah is set'); + ::is($buzz4->bah, undef, '...bah is undef'); + + Buzz->meta->make_immutable(); +} + +done_testing; diff --git a/t/cmop/basic.t b/t/cmop/basic.t new file mode 100644 index 0000000..984b251 --- /dev/null +++ b/t/cmop/basic.t @@ -0,0 +1,78 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; +use Class::MOP::Class; + +{ + package Foo; + use metaclass; + our $VERSION = '0.01'; + + package Bar; + our @ISA = ('Foo'); + + our $AUTHORITY = 'cpan:JRANDOM'; +} + +my $Foo = Foo->meta; +isa_ok($Foo, 'Class::MOP::Class'); + +my $Bar = Bar->meta; +isa_ok($Bar, 'Class::MOP::Class'); + +is($Foo->name, 'Foo', '... Foo->name == Foo'); +is($Bar->name, 'Bar', '... Bar->name == Bar'); + +is($Foo->version, '0.01', '... Foo->version == 0.01'); +is($Bar->version, undef, '... Bar->version == undef'); + +is($Foo->authority, undef, '... Foo->authority == undef'); +is($Bar->authority, 'cpan:JRANDOM', '... Bar->authority == cpan:JRANDOM'); + +is($Foo->identifier, 'Foo-0.01', '... Foo->identifier == Foo-0.01'); +is($Bar->identifier, 'Bar-cpan:JRANDOM', '... Bar->identifier == Bar-cpan:JRANDOM'); + +is_deeply([$Foo->superclasses], [], '... Foo has no superclasses'); +is_deeply([$Bar->superclasses], ['Foo'], '... Bar->superclasses == (Foo)'); + +$Foo->superclasses('UNIVERSAL'); + +is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now'); + +is_deeply( + [ $Foo->class_precedence_list ], + [ 'Foo', 'UNIVERSAL' ], + '... Foo->class_precedence_list == (Foo, UNIVERSAL)'); + +is_deeply( + [ $Bar->class_precedence_list ], + [ 'Bar', 'Foo', 'UNIVERSAL' ], + '... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)'); + +# create a class using Class::MOP::Class ... + +my $Baz = Class::MOP::Class->create( + 'Baz' => ( + version => '0.10', + authority => 'cpan:YOMAMA', + superclasses => [ 'Bar' ] + )); +isa_ok($Baz, 'Class::MOP::Class'); +is(Baz->meta, $Baz, '... our metaclasses are singletons'); + +is($Baz->name, 'Baz', '... Baz->name == Baz'); +is($Baz->version, '0.10', '... Baz->version == 0.10'); +is($Baz->authority, 'cpan:YOMAMA', '... Baz->authority == YOMAMA'); + +is($Baz->identifier, 'Baz-0.10-cpan:YOMAMA', '... Baz->identifier == Baz-0.10-cpan:YOMAMA'); + +is_deeply([$Baz->superclasses], ['Bar'], '... Baz->superclasses == (Bar)'); + +is_deeply( + [ $Baz->class_precedence_list ], + [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ], + '... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)'); + +done_testing; diff --git a/t/cmop/before_after_dollar_under.t b/t/cmop/before_after_dollar_under.t new file mode 100644 index 0000000..65f9774 --- /dev/null +++ b/t/cmop/before_after_dollar_under.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Class::MOP; +use Class::MOP::Class; +use Test::More; +use Test::Fatal; + +my %results; + +{ + + package Base; + use metaclass; + sub hey { $results{base}++ } +} + +for my $wrap (qw(before after)) { + my $meta = Class::MOP::Class->create_anon_class( + superclasses => [ 'Base', 'Class::MOP::Object' ] ); + my $alter = "add_${wrap}_method_modifier"; + $meta->$alter( + 'hey' => sub { + $results{wrapped}++; + $_ = 'barf'; # 'barf' would replace the cached wrapper subref + } + ); + + %results = (); + my $o = $meta->get_meta_instance->create_instance; + isa_ok( $o, 'Base' ); + is( exception { + $o->hey; + $o->hey + ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' + }, undef, 'wrapped doesn\'t die when $_ gets changed' ); + is_deeply( + \%results, { base => 2, wrapped => 2 }, + 'saw expected calls to wrappers' + ); +} + +{ + my $meta = Class::MOP::Class->create_anon_class( + superclasses => [ 'Base', 'Class::MOP::Object' ] ); + for my $wrap (qw(before after)) { + my $alter = "add_${wrap}_method_modifier"; + $meta->$alter( + 'hey' => sub { + $results{wrapped}++; + $_ = 'barf'; # 'barf' would replace the cached wrapper subref + } + ); + } + + %results = (); + my $o = $meta->get_meta_instance->create_instance; + isa_ok( $o, 'Base' ); + is( exception { + $o->hey; + $o->hey + ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' + }, undef, 'double-wrapped doesn\'t die when $_ gets changed' ); + is_deeply( + \%results, { base => 2, wrapped => 4 }, + 'saw expected calls to wrappers' + ); +} + +done_testing; diff --git a/t/cmop/class_errors_and_edge_cases.t b/t/cmop/class_errors_and_edge_cases.t new file mode 100644 index 0000000..51810a3 --- /dev/null +++ b/t/cmop/class_errors_and_edge_cases.t @@ -0,0 +1,222 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + isnt( exception { + Class::MOP::Class->initialize(); + }, undef, '... initialize requires a name parameter' ); + + isnt( exception { + Class::MOP::Class->initialize(''); + }, undef, '... initialize requires a name valid parameter' ); + + isnt( exception { + Class::MOP::Class->initialize(bless {} => 'Foo'); + }, undef, '... initialize requires an unblessed parameter' ); +} + +{ + isnt( exception { + Class::MOP::Class->_construct_class_instance(); + }, undef, '... _construct_class_instance requires an :package parameter' ); + + isnt( exception { + Class::MOP::Class->_construct_class_instance(':package' => undef); + }, undef, '... _construct_class_instance requires a defined :package parameter' ); + + isnt( exception { + Class::MOP::Class->_construct_class_instance(':package' => ''); + }, undef, '... _construct_class_instance requires a valid :package parameter' ); +} + + +{ + isnt( exception { + Class::MOP::Class->create(); + }, undef, '... create requires an package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create(undef); + }, undef, '... create requires a defined package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create(''); + }, undef, '... create requires a valid package_name parameter' ); + + isnt( exception { + Class::MOP::Class->create('+++'); + }, qr/^\+\+\+ is not a module name/, '... create requires a valid package_name parameter' ); +} + +{ + isnt( exception { + Class::MOP::Class->clone_object(1); + }, undef, '... can only clone instances' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_method(); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method(''); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method('foo' => 'foo'); + }, undef, '... add_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_method('foo' => []); + }, undef, '... add_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->has_method(); + }, undef, '... has_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_method(''); + }, undef, '... has_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_method(); + }, undef, '... get_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_method(''); + }, undef, '... get_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_method(); + }, undef, '... remove_method dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_method(''); + }, undef, '... remove_method dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->find_all_methods_by_name(); + }, undef, '... find_all_methods_by_name dies as expected' ); + + isnt( exception { + Class::MOP::Class->find_all_methods_by_name(''); + }, undef, '... find_all_methods_by_name dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_attribute(bless {} => 'Foo'); + }, undef, '... add_attribute dies as expected' ); +} + + +{ + isnt( exception { + Class::MOP::Class->has_attribute(); + }, undef, '... has_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_attribute(''); + }, undef, '... has_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_attribute(); + }, undef, '... get_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_attribute(''); + }, undef, '... get_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_attribute(); + }, undef, '... remove_attribute dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_attribute(''); + }, undef, '... remove_attribute dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->add_package_symbol(); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol(''); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol('foo'); + }, undef, '... add_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->add_package_symbol('&foo'); + }, undef, '... add_package_symbol dies as expected' ); + +# throws_ok { +# Class::MOP::Class->meta->add_package_symbol('@-'); +# } qr/^Could not create package variable \(\@\-\) because/, +# '... add_package_symbol dies as expected'; +} + +{ + isnt( exception { + Class::MOP::Class->has_package_symbol(); + }, undef, '... has_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_package_symbol(''); + }, undef, '... has_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->has_package_symbol('foo'); + }, undef, '... has_package_symbol dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->get_package_symbol(); + }, undef, '... get_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_package_symbol(''); + }, undef, '... get_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->get_package_symbol('foo'); + }, undef, '... get_package_symbol dies as expected' ); +} + +{ + isnt( exception { + Class::MOP::Class->remove_package_symbol(); + }, undef, '... remove_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_package_symbol(''); + }, undef, '... remove_package_symbol dies as expected' ); + + isnt( exception { + Class::MOP::Class->remove_package_symbol('foo'); + }, undef, '... remove_package_symbol dies as expected' ); +} + +done_testing; diff --git a/t/cmop/class_is_pristine.t b/t/cmop/class_is_pristine.t new file mode 100644 index 0000000..4ab95c0 --- /dev/null +++ b/t/cmop/class_is_pristine.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Class::MOP; +use Test::More; + +{ + package Foo; + + sub foo { } + sub bar { } +} + +my $meta = Class::MOP::Class->initialize('Foo'); +ok( $meta->is_pristine, 'Foo is still pristine' ); + +$meta->add_method( baz => sub { } ); +ok( $meta->is_pristine, 'Foo is still pristine after add_method' ); + +$meta->add_attribute( name => 'attr', reader => 'get_attr' ); +ok( ! $meta->is_pristine, 'Foo is not pristine after add_attribute' ); + +done_testing; diff --git a/t/cmop/class_precedence_list.t b/t/cmop/class_precedence_list.t new file mode 100644 index 0000000..56ef28f --- /dev/null +++ b/t/cmop/class_precedence_list.t @@ -0,0 +1,160 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; +use Class::MOP::Class; + +=pod + + A + / \ +B C + \ / + D + +=cut + +{ + package My::A; + use metaclass; + package My::B; + our @ISA = ('My::A'); + package My::C; + our @ISA = ('My::A'); + package My::D; + our @ISA = ('My::B', 'My::C'); +} + +is_deeply( + [ My::D->meta->class_precedence_list ], + [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ], + '... My::D->meta->class_precedence_list == (D B A C A)'); + +is_deeply( + [ My::D->meta->linearized_isa ], + [ 'My::D', 'My::B', 'My::A', 'My::C' ], + '... My::D->meta->linearized_isa == (D B A C)'); + +=pod + + A <-+ + | | + B | + | | + C --+ + +=cut + +# 5.9.5+ dies at the moment of +# recursive @ISA definition, not later when +# you try to use the @ISAs. +eval { + { + package My::2::A; + use metaclass; + our @ISA = ('My::2::C'); + + package My::2::B; + our @ISA = ('My::2::A'); + + package My::2::C; + our @ISA = ('My::2::B'); + } + + My::2::B->meta->class_precedence_list +}; +ok($@, '... recursive inheritance breaks correctly :)'); + +=pod + + +--------+ + | A | + | / \ | + +->B C-+ + \ / + D + +=cut + +{ + package My::3::A; + use metaclass; + package My::3::B; + our @ISA = ('My::3::A'); + package My::3::C; + our @ISA = ('My::3::A', 'My::3::B'); + package My::3::D; + our @ISA = ('My::3::B', 'My::3::C'); +} + +is_deeply( + [ My::3::D->meta->class_precedence_list ], + [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ], + '... My::3::D->meta->class_precedence_list == (D B A C A B A)'); + +is_deeply( + [ My::3::D->meta->linearized_isa ], + [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ], + '... My::3::D->meta->linearized_isa == (D B A C B)'); + +=pod + +Test all the class_precedence_lists +using Perl's own dispatcher to check +against. + +=cut + +my @CLASS_PRECEDENCE_LIST; + +{ + package Foo; + use metaclass; + + sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' } + + package Bar; + our @ISA = ('Foo'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Bar'; + $_[0]->SUPER::CPL(); + } + + package Baz; + use metaclass; + our @ISA = ('Bar'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Baz'; + $_[0]->SUPER::CPL(); + } + + package Foo::Bar; + our @ISA = ('Baz'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Foo::Bar'; + $_[0]->SUPER::CPL(); + } + + package Foo::Bar::Baz; + our @ISA = ('Foo::Bar'); + + sub CPL { + push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz'; + $_[0]->SUPER::CPL(); + } + +} + +Foo::Bar::Baz->CPL(); + +is_deeply( + [ Foo::Bar::Baz->meta->class_precedence_list ], + [ @CLASS_PRECEDENCE_LIST ], + '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST'); + +done_testing; diff --git a/t/cmop/constant_codeinfo.t b/t/cmop/constant_codeinfo.t new file mode 100644 index 0000000..b40cc82 --- /dev/null +++ b/t/cmop/constant_codeinfo.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; + +{ + package Foo; + use constant FOO => 'bar'; +} + +my $meta = Class::MOP::Class->initialize('Foo'); + +my $syms = $meta->get_all_package_symbols('CODE'); +is(ref $syms->{FOO}, 'CODE', 'get constant symbol'); + +undef $syms; + +$syms = $meta->get_all_package_symbols('CODE'); +is(ref $syms->{FOO}, 'CODE', 'constant symbol still there, although we dropped our reference'); + +done_testing; diff --git a/t/cmop/create_class.t b/t/cmop/create_class.t new file mode 100644 index 0000000..63a31d4 --- /dev/null +++ b/t/cmop/create_class.t @@ -0,0 +1,113 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $Point = Class::MOP::Class->create('Point' => ( + version => '0.01', + attributes => [ + Class::MOP::Attribute->new('x' => ( + reader => 'x', + init_arg => 'x' + )), + Class::MOP::Attribute->new('y' => ( + accessor => 'y', + init_arg => 'y' + )), + ], + methods => { + 'new' => sub { + my $class = shift; + my $instance = $class->meta->new_object(@_); + bless $instance => $class; + }, + 'clear' => sub { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + } +)); + +my $Point3D = Class::MOP::Class->create('Point3D' => ( + version => '0.01', + superclasses => [ 'Point' ], + attributes => [ + Class::MOP::Attribute->new('z' => ( + default => 123 + )), + ], + methods => { + 'clear' => sub { + my $self = shift; + $self->{'z'} = 0; + $self->SUPER::clear(); + } + } +)); + +isa_ok($Point, 'Class::MOP::Class'); +isa_ok($Point3D, 'Class::MOP::Class'); + +# ... test the classes themselves + +my $point = Point->new('x' => 2, 'y' => 3); +isa_ok($point, 'Point'); + +can_ok($point, 'x'); +can_ok($point, 'y'); +can_ok($point, 'clear'); + +{ + my $meta = $point->meta; + is($meta, Point->meta(), '... got the meta from the instance too'); +} + +is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); + +$point->y(42); +is($point->y, 42, '... the y attribute was set properly with the accessor'); + +is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); + +isnt( exception { + $point->x(42); +}, undef, '... cannot write to a read-only accessor' ); +is($point->x, 2, '... the x attribute was not altered'); + +$point->clear(); + +is($point->y, 0, '... the y attribute was cleared correctly'); +is($point->x, 0, '... the x attribute was cleared correctly'); + +my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); +isa_ok($point3d, 'Point3D'); +isa_ok($point3d, 'Point'); + +{ + my $meta = $point3d->meta; + is($meta, Point3D->meta(), '... got the meta from the instance too'); +} + +can_ok($point3d, 'x'); +can_ok($point3d, 'y'); +can_ok($point3d, 'clear'); + +is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); +is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); +is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); + +{ + my $point3d = Point3D->new(); + isa_ok($point3d, 'Point3D'); + + is($point3d->x, undef, '... the x attribute was not initialized'); + is($point3d->y, undef, '... the y attribute was not initialized'); + is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); + +} + +done_testing; diff --git a/t/cmop/custom_instance.t b/t/cmop/custom_instance.t new file mode 100644 index 0000000..c6aeb6d --- /dev/null +++ b/t/cmop/custom_instance.t @@ -0,0 +1,137 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Class::MOP; + +my $instance; +{ + package Foo; + + sub new { + my $class = shift; + $instance = bless {@_}, $class; + return $instance; + } + + sub foo { shift->{foo} } +} + +{ + package Foo::Sub; + use parent -norequire => 'Foo'; + use metaclass; + + sub new { + my $class = shift; + $class->meta->new_object( + __INSTANCE__ => $class->SUPER::new(@_), + @_, + ); + } + + __PACKAGE__->meta->add_attribute( + bar => ( + reader => 'bar', + initializer => sub { + my $self = shift; + my ($value, $writer, $attr) = @_; + $writer->(uc $value); + }, + ), + ); +} + +undef $instance; +is( exception { + my $foo = Foo::Sub->new; + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(foo => 'FOO'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->foo, 'FOO', "set non-CMOP constructor args"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(bar => 'bar'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->bar, 'BAR', "set CMOP attributes"); +}, undef ); + +undef $instance; +is( exception { + my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); + is($foo, $instance, "used the passed-in instance"); + is($foo->foo, 'FOO', "set non-CMOP constructor arg"); + is($foo->bar, 'BAR', "set correct CMOP attribute"); +}, undef ); + +{ + package BadFoo; + + sub new { + my $class = shift; + $instance = bless {@_}; + return $instance; + } + + sub foo { shift->{foo} } +} + +{ + package BadFoo::Sub; + use parent -norequire => 'BadFoo'; + use metaclass; + + sub new { + my $class = shift; + $class->meta->new_object( + __INSTANCE__ => $class->SUPER::new(@_), + @_, + ); + } + + __PACKAGE__->meta->add_attribute( + bar => ( + reader => 'bar', + initializer => sub { + my $self = shift; + my ($value, $writer, $attr) = @_; + $writer->(uc $value); + }, + ), + ); +} + +like( exception { BadFoo::Sub->new }, qr/BadFoo=HASH.*is not a BadFoo::Sub/, "error with incorrect constructors" ); + +{ + my $meta = Class::MOP::Class->create('Really::Bad::Foo'); + like( exception { + $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class')) + }, qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, "error with completely invalid class" ); +} + +{ + my $meta = Class::MOP::Class->create('Really::Bad::Foo::2'); + for my $invalid ('foo', 1, 0, '') { + like( exception { + $meta->new_object(__INSTANCE__ => $invalid) + }, qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, "error with unblessed thing" ); + } +} + +done_testing; diff --git a/t/cmop/deprecated.t b/t/cmop/deprecated.t new file mode 100644 index 0000000..b29649b --- /dev/null +++ b/t/cmop/deprecated.t @@ -0,0 +1,31 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +use lib 't/cmop/lib'; + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + Class::MOP::load_class('BinaryTree'); + like($warnings, qr/^Class::MOP::load_class is deprecated/); + ok(Class::MOP::does_metaclass_exist('BinaryTree')); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + ok(Class::MOP::is_class_loaded('BinaryTree')); + like($warnings, qr/^Class::MOP::is_class_loaded is deprecated/); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + is(Class::MOP::load_first_existing_class('this::class::probably::doesnt::exist', 'MyMetaClass'), 'MyMetaClass'); + like($warnings, qr/^Class::MOP::load_first_existing_class is deprecated/); +} + +done_testing; diff --git a/t/cmop/get_code_info.t b/t/cmop/get_code_info.t new file mode 100644 index 0000000..2770b76 --- /dev/null +++ b/t/cmop/get_code_info.t @@ -0,0 +1,52 @@ +use strict; +use warnings; + +use Test::More; +use Sub::Name 'subname'; + +BEGIN { + $^P &= ~0x200; # Don't munge anonymous sub names +} + +use Class::MOP; + + +sub code_name_is { + my ( $code, $stash, $name ) = @_; + + is_deeply( + [ Class::MOP::get_code_info($code) ], + [ $stash, $name ], + "sub name is ${stash}::$name" + ); +} + +code_name_is( sub {}, main => "__ANON__" ); + +code_name_is( subname("Foo::bar", sub {}), Foo => "bar" ); + +code_name_is( subname("", sub {}), "main" => "" ); + +require Class::MOP::Method; +code_name_is( \&Class::MOP::Method::name, "Class::MOP::Method", "name" ); + +{ + package Foo; + + sub MODIFY_CODE_ATTRIBUTES { + my ($class, $code) = @_; + my @info = Class::MOP::get_code_info($code); + + if ( $] >= 5.011 ) { + ::is_deeply(\@info, ['Foo', 'foo'], "got a name for a code ref in an attr handler"); + } + else { + ::is_deeply(\@info, [], "no name for a coderef that's still compiling"); + } + return (); + } + + sub foo : Bar {} +} + +done_testing; diff --git a/t/cmop/immutable_custom_trait.t b/t/cmop/immutable_custom_trait.t new file mode 100644 index 0000000..24b72b7 --- /dev/null +++ b/t/cmop/immutable_custom_trait.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + + package My::Meta; + + use strict; + use warnings; + + use parent 'Class::MOP::Class'; + + sub initialize { + shift->SUPER::initialize( + @_, + immutable_trait => 'My::Meta::Class::Immutable::Trait', + ); + } +} + +{ + package My::Meta::Class::Immutable::Trait; + + use MRO::Compat; + use parent 'Class::MOP::Class::Immutable::Trait'; + + sub another_method { 42 } + + sub superclasses { + my $orig = shift; + my $self = shift; + $self->$orig(@_); + } +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('foo'); + + __PACKAGE__->meta->make_immutable; +} + +{ + package Bar; + + use strict; + use warnings; + use metaclass 'My::Meta'; + + use parent -norequire => 'Foo'; + + __PACKAGE__->meta->add_attribute('bar'); + + ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'can safely make a class immutable when it has a custom metaclass and immutable trait' ); +} + +{ + can_ok( Bar->meta, 'another_method' ); + is( Bar->meta->another_method, 42, 'another_method returns expected value' ); + is_deeply( + [ Bar->meta->superclasses ], ['Foo'], + 'Bar->meta->superclasses returns expected value after immutabilization' + ); +} + +done_testing; diff --git a/t/cmop/immutable_metaclass.t b/t/cmop/immutable_metaclass.t new file mode 100644 index 0000000..e674f34 --- /dev/null +++ b/t/cmop/immutable_metaclass.t @@ -0,0 +1,300 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Foo->meta; + my $original_metaclass_name = ref $meta; + + is_deeply( + { $meta->immutable_options }, {}, + 'immutable_options is empty before a class is made_immutable' + ); + + ok( $meta->make_immutable, 'make_immutable returns true' ); + my $line = __LINE__ - 1; + + ok( $meta->make_immutable, 'make_immutable still returns true' ); + + my $immutable_metaclass = $meta->_immutable_metaclass->meta; + + my $immutable_class_name = $immutable_metaclass->name; + + ok( !$immutable_class_name->is_mutable, '... immutable_metaclass is not mutable' ); + ok( $immutable_class_name->is_immutable, '... immutable_metaclass is immutable' ); + is( $immutable_class_name->meta, $immutable_metaclass, + '... immutable_metaclass meta hack works' ); + + is_deeply( + { $meta->immutable_options }, + { + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + debug => 0, + immutable_trait => 'Class::MOP::Class::Immutable::Trait', + constructor_name => 'new', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => undef, + file => $0, + line => $line, + }, + 'immutable_options is empty before a class is made_immutable' + ); + + isa_ok( $meta, "Class::MOP::Class" ); +} + +{ + my $meta = Foo->meta; + is( $meta->name, 'Foo', '... checking the Foo metaclass' ); + + ok( !$meta->is_mutable, '... our class is not mutable' ); + ok( $meta->is_immutable, '... our class is immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + is( exception { $meta->identifier() }, undef, '... no exception for get_package_symbol special case' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + ['Foo'], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + \@attributes, + [ $meta->get_attribute('bar') ], + '... got the right list of attributes' + ); +} + +{ + my $meta = Bar->meta; + is( $meta->name, 'Bar', '... checking the Bar metaclass' ); + + ok( $meta->is_mutable, '... our class is mutable' ); + ok( !$meta->is_immutable, '... our class is not immutable' ); + + is( exception { + $meta->make_immutable(); + }, undef, '... changed Bar to be immutable' ); + + ok( $meta->make_immutable, '... make immutable returns true' ); + + ok( !$meta->is_mutable, '... our class is no longer mutable' ); + ok( $meta->is_immutable, '... our class is now immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + [ 'Bar', 'Foo' ], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ Foo->meta->get_attribute('bar'), $meta->get_attribute('baz') ], + '... got the right list of attributes' + ); +} + +{ + my $meta = Baz->meta; + is( $meta->name, 'Baz', '... checking the Baz metaclass' ); + + ok( $meta->is_mutable, '... our class is mutable' ); + ok( !$meta->is_immutable, '... our class is not immutable' ); + + is( exception { + $meta->make_immutable(); + }, undef, '... changed Baz to be immutable' ); + + ok( $meta->make_immutable, '... make immutable returns true' ); + + ok( !$meta->is_mutable, '... our class is no longer mutable' ); + ok( $meta->is_immutable, '... our class is now immutable' ); + + isa_ok( $meta, 'Class::MOP::Class' ); + + isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); + + isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); + + my @supers; + is( exception { + @supers = $meta->superclasses; + }, undef, '... got the superclasses okay' ); + + isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); + + my $meta_instance; + is( exception { + $meta_instance = $meta->get_meta_instance; + }, undef, '... got the meta instance okay' ); + isa_ok( $meta_instance, 'Class::MOP::Instance' ); + is( $meta_instance, $meta->get_meta_instance, + '... and we know it is cached' ); + + my @cpl; + is( exception { + @cpl = $meta->class_precedence_list; + }, undef, '... got the class precedence list okay' ); + is_deeply( + \@cpl, + [ 'Baz', 'Bar', 'Foo' ], + '... we just have ourselves in the class precedence list' + ); + + my @attributes; + is( exception { + @attributes = $meta->get_all_attributes; + }, undef, '... got the attribute list okay' ); + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ + $meta->get_attribute('bah'), Foo->meta->get_attribute('bar'), + Bar->meta->get_attribute('baz') + ], + '... got the right list of attributes' + ); +} + +# This test probably needs to go last since it will muck up the Foo class +{ + my $meta = Foo->meta; + + $meta->make_mutable; + $meta->make_immutable( + inline_accessors => 0, + inline_constructor => 0, + constructor_name => 'newer', + ); + my $line = __LINE__ - 5; + + is_deeply( + { $meta->immutable_options }, + { + inline_accessors => 0, + inline_constructor => 0, + inline_destructor => 0, + debug => 0, + immutable_trait => 'Class::MOP::Class::Immutable::Trait', + constructor_name => 'newer', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => undef, + file => $0, + line => $line, + }, + 'custom immutable_options are returned by immutable_options accessor' + ); +} + +done_testing; diff --git a/t/cmop/immutable_w_constructors.t b/t/cmop/immutable_w_constructors.t new file mode 100644 index 0000000..cb95e20 --- /dev/null +++ b/t/cmop/immutable_w_constructors.t @@ -0,0 +1,301 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar' => ( + reader => 'bar', + default => 'BAR', + )); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz' => ( + reader => 'baz', + default => sub { 'BAZ' }, + )); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah' => ( + reader => 'bah', + default => 'BAH', + )); + + package Buzz; + + use strict; + use warnings; + use metaclass; + + + __PACKAGE__->meta->add_attribute('bar' => ( + accessor => 'bar', + predicate => 'has_bar', + clearer => 'clear_bar', + )); + + __PACKAGE__->meta->add_attribute('bah' => ( + accessor => 'bah', + predicate => 'has_bah', + clearer => 'clear_bah', + default => 'BAH' + )); + +} + +{ + my $meta = Foo->meta; + is($meta->name, 'Foo', '... checking the Foo metaclass'); + + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 0, + ); + }, undef, '... changed Foo to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Foo', 'new'); + + { + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAR', '... got the right default value'); + } + + { + my $foo = Foo->new(bar => 'BAZ'); + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAZ', '... got the right parameter value'); + } + + # NOTE: + # check that the constructor correctly handles inheritance + { + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + isa_ok($bar, 'Foo'); + is($bar->bar, 'BAR', '... got the right inherited parameter value'); + is($bar->baz, 'BAZ', '... got the right inherited parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + } +} + +{ + my $meta = Bar->meta; + is($meta->name, 'Bar', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 1, + ); + }, undef, '... changed Bar to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Bar', 'new'); + + { + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAR', '... got the right default value'); + is($bar->baz, 'BAZ', '... got the right default value'); + } + + { + my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!'); + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAZ!', '... got the right parameter value'); + is($bar->baz, 'BAR!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + is( exception { + $meta->make_immutable( + inline_constructor => 0, + inline_accessors => 1, + ); + }, undef, '... changed Bar to be immutable' ); + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + ok(!Baz->meta->has_method('new'), '... no constructor was made'); + + { + my $baz = Baz->meta->new_object; + isa_ok($baz, 'Bar'); + is($baz->bar, 'BAR', '... got the right default value'); + is($baz->baz, 'BAZ', '... got the right default value'); + } + + { + my $baz = Baz->meta->new_object(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!'); + isa_ok($baz, 'Baz'); + is($baz->bar, 'BAZ!', '... got the right parameter value'); + is($baz->baz, 'BAR!', '... got the right parameter value'); + is($baz->bah, 'BAH!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok($bah_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + + +{ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok(!$buzz->has_bar, '...bar is not set'); + ::is($buzz->bar, undef, '...bar returns undef'); + ::ok(!$buzz->has_bar, '...bar was not autovivified'); + + $buzz->bar(undef); + ::ok($buzz->has_bar, '...bar is set'); + ::is($buzz->bar, undef, '...bar is undef'); + $buzz->clear_bar; + ::ok(!$buzz->has_bar, '...bar is no longerset'); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('bar' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bar, '...bar is set'); + ::is($buzz2->bar, undef, '...bar is undef'); + +} + +{ + my $buzz; + ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz->has_bah, '...bah is set'); + ::is($buzz->bah, 'BAH', '...bah returns "BAH"' ); + + my $buzz2; + ::is( ::exception { $buzz2 = Buzz->meta->new_object('bah' => undef) }, undef, '...Buzz instantiated successfully' ); + ::ok($buzz2->has_bah, '...bah is set'); + ::is($buzz2->bah, undef, '...bah is undef'); + +} + +done_testing; diff --git a/t/cmop/immutable_w_custom_metaclass.t b/t/cmop/immutable_w_custom_metaclass.t new file mode 100644 index 0000000..c0b722d --- /dev/null +++ b/t/cmop/immutable_w_custom_metaclass.t @@ -0,0 +1,71 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util; + +use Class::MOP; + +use lib 't/cmop/lib'; + +{ + + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->make_immutable; + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->make_immutable; + + package Baz; + + use strict; + use warnings; + use metaclass 'MyMetaClass'; + + sub mymetaclass_attributes { + shift->meta->mymetaclass_attributes; + } + + ::is( ::exception { Baz->meta->superclasses('Bar') }, undef, '... we survive the metaclass incompatibility test' ); +} + +{ + my $meta = Baz->meta; + ok( $meta->is_mutable, '... Baz is mutable' ); + is( + Scalar::Util::blessed( Foo->meta ), + Scalar::Util::blessed( Bar->meta ), + 'Foo and Bar immutable metaclasses match' + ); + is( Scalar::Util::blessed($meta), 'MyMetaClass', + 'Baz->meta blessed as MyMetaClass' ); + ok( Baz->can('mymetaclass_attributes'), + '... Baz can do method before immutable' ); + ok( $meta->can('mymetaclass_attributes'), + '... meta can do method before immutable' ); + is( exception { $meta->make_immutable }, undef, "Baz is now immutable" ); + ok( $meta->is_immutable, '... Baz is immutable' ); + isa_ok( $meta, 'MyMetaClass', 'Baz->meta' ); + ok( Baz->can('mymetaclass_attributes'), + '... Baz can do method after imutable' ); + ok( $meta->can('mymetaclass_attributes'), + '... meta can do method after immutable' ); + isnt( Scalar::Util::blessed( Baz->meta ), + Scalar::Util::blessed( Bar->meta ), + 'Baz and Bar immutable metaclasses are different' ); + is( exception { $meta->make_mutable }, undef, "Baz is now mutable" ); + ok( $meta->is_mutable, '... Baz is mutable again' ); +} + +done_testing; diff --git a/t/cmop/inline_and_dollar_at.t b/t/cmop/inline_and_dollar_at.t new file mode 100644 index 0000000..80af4c9 --- /dev/null +++ b/t/cmop/inline_and_dollar_at.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + + +{ + package Foo; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $@ = 'dollar at'; + + $meta->make_immutable; + + ::is( $@, 'dollar at', '$@ is untouched after immutablization' ); +} + +done_testing; diff --git a/t/cmop/inline_structor.t b/t/cmop/inline_structor.t new file mode 100644 index 0000000..b22c8a9 --- /dev/null +++ b/t/cmop/inline_structor.t @@ -0,0 +1,291 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires 'Test::Output'; # skip all if not installed + +use Class::MOP; + +{ + package HasConstructor; + + sub new { bless {}, $_[0] } + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining a constructor for HasConstructor since it defines its own constructor.\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to HasConstructor->meta->make_immutable\E/, + 'got a warning that Foo will not have an inlined constructor because it defines its own new method' + ); + + ::is( + $meta->find_method_by_name('new')->body, + HasConstructor->can('new'), + 'HasConstructor->new was untouched' + ); +} + +{ + package My::Constructor; + + use parent 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'Base::Class' } +} + +{ + package No::Constructor; +} + +{ + package My::Constructor2; + + use parent 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'No::Constructor' } +} + +{ + package Base::Class; + + sub new { bless {}, $_[0] } + sub DESTROY { } +} + +{ + package NotMoose; + + sub new { + my $class = shift; + + return bless { not_moose => 1 }, $class; + } +} + +{ + package Foo; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor' ) }, + qr/\QNot inlining 'new' for Foo since it is not inheriting the default Base::Class::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, + 'got a warning that Foo will not have an inlined constructor' + ); + + ::is( + $meta->find_method_by_name('new')->body, + NotMoose->can('new'), + 'Foo->new is inherited from NotMoose' + ); +} + +{ + package Bar; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_is( + sub { $meta->make_immutable( replace_constructor => 1 ) }, + q{}, + 'no warning when replace_constructor is true' + ); + + ::is( + $meta->find_method_by_name('new')->package_name, + 'Bar', + 'Bar->new is inlined, and not inherited from NotMoose' + ); +} + +{ + package Baz; + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable; +} + +{ + package Quux; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('Baz'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package Whatever; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor2' ) }, + qr/\QNot inlining 'new' for Whatever since No::Constructor::new is not defined/, + 'got a warning that Whatever will not have an inlined constructor because its expected inherited method does not exist' + ); +} + +{ + package My::Constructor3; + + use parent 'Class::MOP::Method::Constructor'; +} + +{ + package CustomCons; + + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable( constructor_class => 'My::Constructor3' ); +} + +{ + package Subclass; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('CustomCons'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package ModdedNew; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub new { bless {}, shift } + + $meta->add_before_method_modifier( 'new' => sub { } ); +} + +{ + package ModdedSub; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('ModdedNew'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining 'new' for ModdedSub since it has method modifiers which would be lost if it were inlined/, + 'got a warning that ModdedSub will not have an inlined constructor since it inherited a wrapped new' + ); +} + +{ + package My::Destructor; + + use parent 'Class::MOP::Method::Inlined'; + + sub new { + my $class = shift; + my %options = @_; + + my $self = bless \%options, $class; + $self->_inline_destructor; + + return $self; + } + + sub _inline_destructor { + my $self = shift; + + my $code = $self->_compile_code('sub { }'); + + $self->{body} = $code; + } + + sub is_needed { 1 } + sub associated_metaclass { $_[0]->{metaclass} } + sub body { $_[0]->{body} } + sub _expected_method_class { 'Base::Class' } +} + +{ + package HasDestructor; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining a destructor for HasDestructor since it defines its own destructor./, + 'got a warning when trying to inline a destructor for a class that already defines DESTROY' + ); + + ::is( + $meta->find_method_by_name('DESTROY')->body, + HasDestructor->can('DESTROY'), + 'HasDestructor->DESTROY was untouched' + ); +} + +{ + package HasDestructor2; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + + ::stderr_is( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + }, + q{}, + 'no warning when replace_destructor is true' + ); + + ::isnt( + $meta->find_method_by_name('new')->body, + HasConstructor2->can('new'), + 'HasConstructor2->new was replaced' + ); +} + +{ + package ParentHasDestructor; + + sub DESTROY { } +} + +{ + package DestructorChild; + + use parent -norequire => 'ParentHasDestructor'; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining 'DESTROY' for DestructorChild since it is not inheriting the default Base::Class::DESTROY/, + 'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY' + ); +} + +done_testing; diff --git a/t/cmop/insertion_order.t b/t/cmop/insertion_order.t new file mode 100644 index 0000000..073d3b3 --- /dev/null +++ b/t/cmop/insertion_order.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +my $Point = Class::MOP::Class->create('Point' => ( + version => '0.01', + attributes => [ + Class::MOP::Attribute->new('x' => ( + reader => 'x', + init_arg => 'x' + )), + Class::MOP::Attribute->new('y' => ( + accessor => 'y', + init_arg => 'y' + )), + ], + methods => { + 'new' => sub { + my $class = shift; + my $instance = $class->meta->new_object(@_); + bless $instance => $class; + }, + 'clear' => sub { + my $self = shift; + $self->{'x'} = 0; + $self->{'y'} = 0; + } + } +)); + +is($Point->get_attribute('x')->insertion_order, 0, 'Insertion order of Attribute "x"'); +is($Point->get_attribute('y')->insertion_order, 1, 'Insertion order of Attribute "y"'); + +done_testing; diff --git a/t/cmop/instance.t b/t/cmop/instance.t new file mode 100644 index 0000000..943d6bb --- /dev/null +++ b/t/cmop/instance.t @@ -0,0 +1,137 @@ +use strict; +use warnings; + +use Test::More; + +use Scalar::Util qw/isweak reftype/; + +use Class::MOP::Instance; + +can_ok( "Class::MOP::Instance", $_ ) for qw/ + new + + create_instance + + get_all_slots + + initialize_all_slots + deinitialize_all_slots + + get_slot_value + set_slot_value + initialize_slot + deinitialize_slot + is_slot_initialized + weaken_slot_value + strengthen_slot_value + + inline_get_slot_value + inline_set_slot_value + inline_initialize_slot + inline_deinitialize_slot + inline_is_slot_initialized + inline_weaken_slot_value + inline_strengthen_slot_value +/; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('moosen'); + + package Bar; + use metaclass; + use parent -norequire => 'Foo'; + + Bar->meta->add_attribute('elken'); +} + +my $mi_foo = Foo->meta->get_meta_instance; +isa_ok($mi_foo, "Class::MOP::Instance"); + +is_deeply( + [ $mi_foo->get_all_slots ], + [ "moosen" ], + '... get all slots for Foo'); + +my $mi_bar = Bar->meta->get_meta_instance; +isa_ok($mi_bar, "Class::MOP::Instance"); + +isnt($mi_foo, $mi_bar, '... they are not the same instance'); + +is_deeply( + [ sort $mi_bar->get_all_slots ], + [ "elken", "moosen" ], + '... get all slots for Bar'); + +my $i_foo = $mi_foo->create_instance; +isa_ok($i_foo, "Foo"); + +{ + my $i_foo_2 = $mi_foo->create_instance; + isa_ok($i_foo_2, "Foo"); + isnt($i_foo_2, $i_foo, '... not the same instance'); + is_deeply($i_foo, $i_foo_2, '... but the same structure'); +} + +ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot not initialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); + +$mi_foo->initialize_slot( $i_foo, "moosen" ); + +#Removed becayse slot initialization works differently now (groditi) +#ok($mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot initialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... but no value for slot"); + +$mi_foo->set_slot_value( $i_foo, "moosen", "the value" ); + +is($mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "... get slot value"); +ok(!$i_foo->can('moosen'), '... Foo cant moosen'); + +my $ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); + +ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), $ref, "weak value is fetchable" ); +ok( !isweak($mi_foo->get_slot_value( $i_foo, "moosen" )), "return value not weak" ); + +undef $ref; + +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); + +$ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); + +undef $ref; + +is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "value not weak yet" ); + +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); + +is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); + +$ref = []; + +$mi_foo->set_slot_value( $i_foo, "moosen", $ref ); +$mi_foo->weaken_slot_value( $i_foo, "moosen" ); +ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); +$mi_foo->strengthen_slot_value( $i_foo, "moosen" ); +ok( !isweak($i_foo->{moosen}), '... white box test of weaken' ); + +undef $ref; + +is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "weak value can be strengthened" ); + +$mi_foo->deinitialize_slot( $i_foo, "moosen" ); + +ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot deinitialized"); + +ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); + +done_testing; diff --git a/t/cmop/instance_inline.t b/t/cmop/instance_inline.t new file mode 100644 index 0000000..07f2162 --- /dev/null +++ b/t/cmop/instance_inline.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP::Instance; + +my $C = 'Class::MOP::Instance'; + +{ + my $instance = '$self'; + my $slot_name = 'foo'; + my $value = '$value'; + my $class = '$class'; + + is($C->inline_create_instance($class), + 'bless {} => $class', + '... got the right code for create_instance'); + is($C->inline_get_slot_value($instance, $slot_name), + q[$self->{"foo"}], + '... got the right code for get_slot_value'); + + is($C->inline_set_slot_value($instance, $slot_name, $value), + q[$self->{"foo"} = $value], + '... got the right code for set_slot_value'); + + is($C->inline_initialize_slot($instance, $slot_name), + '', + '... got the right code for initialize_slot'); + + is($C->inline_is_slot_initialized($instance, $slot_name), + q[exists $self->{"foo"}], + '... got the right code for get_slot_value'); + + is($C->inline_weaken_slot_value($instance, $slot_name), + q[Scalar::Util::weaken( $self->{"foo"} )], + '... got the right code for weaken_slot_value'); + + is($C->inline_strengthen_slot_value($instance, $slot_name), + q[$self->{"foo"} = $self->{"foo"}], + '... got the right code for strengthen_slot_value'); + is($C->inline_rebless_instance_structure($instance, $class), + q[bless $self => $class], + '... got the right code for rebless_instance_structure'); +} + +done_testing; diff --git a/t/cmop/instance_metaclass_incompat.t b/t/cmop/instance_metaclass_incompat.t new file mode 100644 index 0000000..43188d0 --- /dev/null +++ b/t/cmop/instance_metaclass_incompat.t @@ -0,0 +1,68 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package Bar::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package FooBar::Meta::Instance; + use parent -norequire => 'Foo::Meta::Instance', 'Bar::Meta::Instance'; +} + +$@ = undef; +eval { + package Foo; + BEGIN { $INC{'Foo.pm'} = __FILE__ } + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + BEGIN { $INC{'Bar.pm'} = __FILE__ } + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + use parent -norequire => 'Foo'; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + use parent -norequire => 'Bar'; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + use parent -norequire => 'Foo'; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + use parent -norequire => 'Bar'; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/instance_metaclass_incompat_dyn.t b/t/cmop/instance_metaclass_incompat_dyn.t new file mode 100644 index 0000000..b648f44 --- /dev/null +++ b/t/cmop/instance_metaclass_incompat_dyn.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package Bar::Meta::Instance; + use parent 'Class::MOP::Instance'; + + package FooBar::Meta::Instance; + use parent -norequire => 'Foo::Meta::Instance', 'Bar::Meta::Instance'; +} + +$@ = undef; +eval { + package Foo; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); + Foo::Foo->meta->superclasses('Foo'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); + Bar::Bar->meta->superclasses('Bar'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); + FooBar->meta->superclasses('Foo'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); + FooBar2->meta->superclasses('Bar'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/lib/ArrayBasedStorage.pm b/t/cmop/lib/ArrayBasedStorage.pm new file mode 100644 index 0000000..3d83a38 --- /dev/null +++ b/t/cmop/lib/ArrayBasedStorage.pm @@ -0,0 +1,132 @@ +package # hide the package from PAUSE + ArrayBasedStorage::Instance; + +use strict; +use warnings; +use Scalar::Util qw/refaddr/; + +use Carp 'confess'; + +our $VERSION = '0.01'; +my $unbound = \'empty-slot-value'; + +use parent 'Class::MOP::Instance'; + +sub new { + my ($class, $meta, @attrs) = @_; + my $self = $class->SUPER::new($meta, @attrs); + my $index = 0; + $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots }; + return $self; +} + +sub create_instance { + my $self = shift; + my $instance = bless [], $self->_class_name; + $self->initialize_all_slots($instance); + return $instance; +} + +sub clone_instance { + my ($self, $instance) = shift; + $self->bless_instance_structure([ @$instance ]); +} + +# operations on meta instance + +sub get_slot_index_map { (shift)->{'slot_index_map'} } + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + +sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + $self->set_slot_value($instance, $slot_name, $unbound); +} + +sub get_all_slots { + my $self = shift; + return sort $self->SUPER::get_all_slots; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; + return $value unless ref $value; + refaddr $value eq refaddr $unbound ? undef : $value; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + # NOTE: maybe use CLOS's *special-unbound-value* for this? + my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; + return 1 unless ref $value; + refaddr $value eq refaddr $unbound ? 0 : 1; +} + +sub is_dependent_on_superclasses { 1 } + +1; + +__END__ + +=pod + +=head1 NAME + +ArrayBasedStorage - An example of an Array based instance storage + +=head1 SYNOPSIS + + package Foo; + + use metaclass ( + ':instance_metaclass' => 'ArrayBasedStorage::Instance' + ); + + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # now you can just use the class as normal + +=head1 DESCRIPTION + +This is a proof of concept using the Instance sub-protocol +which uses ARRAY refs to store the instance data. + +This is very similar now to the InsideOutClass example, and +in fact, they both share the exact same test suite, with +the only difference being the Instance metaclass they use. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 SEE ALSO + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/AttributesWithHistory.pm b/t/cmop/lib/AttributesWithHistory.pm new file mode 100644 index 0000000..4978c99 --- /dev/null +++ b/t/cmop/lib/AttributesWithHistory.pm @@ -0,0 +1,135 @@ +package # hide the package from PAUSE + AttributesWithHistory; + +use strict; +use warnings; + +our $VERSION = '0.05'; + +use parent 'Class::MOP::Attribute'; + +# this is for an extra attribute constructor +# option, which is to be able to create a +# way for the class to access the history +AttributesWithHistory->meta->add_attribute('history_accessor' => ( + reader => 'history_accessor', + init_arg => 'history_accessor', + predicate => 'has_history_accessor', +)); + +# this is a place to store the actual +# history of the attribute +AttributesWithHistory->meta->add_attribute('_history' => ( + accessor => '_history', + default => sub { {} }, +)); + +sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' } + +AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub { + my ($self) = @_; + # and now add the history accessor + $self->associated_class->add_method( + $self->_process_accessors('history_accessor' => $self->history_accessor()) + ) if $self->has_history_accessor(); +}); + +package # hide the package from PAUSE + AttributesWithHistory::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Method::Accessor'; + +# generate the methods + +sub _generate_history_accessor_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\}; + }}; +} + +sub _generate_accessor_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + if (scalar(\@_) == 2) { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + } + \$_[0]->{'$attr_name'}; + }}; +} + +sub _generate_writer_method { + my $attr_name = (shift)->associated_attribute->name; + eval qq{sub { + unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ + \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; + \} + push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; + \$_[0]->{'$attr_name'} = \$_[1]; + }}; +} + +1; + +=pod + +=head1 NAME + +AttributesWithHistory - An example attribute metaclass which keeps a history of changes + +=head1 SYSNOPSIS + + package Foo; + + Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( + accessor => 'foo', + history_accessor => 'get_foo_history', + ))); + + Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + history_accessor => 'get_bar_history', + ))); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + +=head1 DESCRIPTION + +This is an example of an attribute metaclass which keeps a +record of all the values it has been assigned. It stores the +history as a field in the attribute meta-object, and will +autogenerate a means of accessing that history for the class +which these attributes are added too. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/BinaryTree.pm b/t/cmop/lib/BinaryTree.pm new file mode 100644 index 0000000..9a10e2c --- /dev/null +++ b/t/cmop/lib/BinaryTree.pm @@ -0,0 +1,142 @@ +package BinaryTree; + +use strict; +use warnings; +use Carp qw/confess/; + +use metaclass; + +our $VERSION = '0.02'; + +BinaryTree->meta->add_attribute('uid' => ( + reader => 'getUID', + writer => 'setUID', + default => sub { + my $instance = shift; + ("$instance" =~ /\((.*?)\)$/)[0]; + } +)); + +BinaryTree->meta->add_attribute('node' => ( + reader => 'getNodeValue', + writer => 'setNodeValue', + clearer => 'clearNodeValue', + init_arg => ':node' +)); + +BinaryTree->meta->add_attribute('parent' => ( + predicate => 'hasParent', + reader => 'getParent', + writer => 'setParent', + clearer => 'clearParent', +)); + +BinaryTree->meta->add_attribute('left' => ( + predicate => 'hasLeft', + clearer => 'clearLeft', + reader => 'getLeft', + writer => { + 'setLeft' => sub { + my ($self, $tree) = @_; + confess "undef left" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'left'} = $tree; + $self; + } + }, +)); + +BinaryTree->meta->add_attribute('right' => ( + predicate => 'hasRight', + clearer => 'clearRight', + reader => 'getRight', + writer => { + 'setRight' => sub { + my ($self, $tree) = @_; + confess "undef right" unless defined $tree; + $tree->setParent($self) if defined $tree; + $self->{'right'} = $tree; + $self; + } + } +)); + +sub new { + my $class = shift; + $class->meta->new_object(':node' => shift); +} + +sub removeLeft { + my ($self) = @_; + my $left = $self->getLeft(); + $left->clearParent; + $self->clearLeft; + return $left; +} + +sub removeRight { + my ($self) = @_; + my $right = $self->getRight; + $right->clearParent; + $self->clearRight; + return $right; +} + +sub isLeaf { + my ($self) = @_; + return (!$self->hasLeft && !$self->hasRight); +} + +sub isRoot { + my ($self) = @_; + return !$self->hasParent; +} + +sub traverse { + my ($self, $func) = @_; + $func->($self); + $self->getLeft->traverse($func) if $self->hasLeft; + $self->getRight->traverse($func) if $self->hasRight; +} + +sub mirror { + my ($self) = @_; + # swap left for right + if( $self->hasLeft && $self->hasRight) { + my $left = $self->getLeft; + my $right = $self->getRight; + $self->setLeft($right); + $self->setRight($left); + } elsif( $self->hasLeft && !$self->hasRight){ + my $left = $self->getLeft; + $self->clearLeft; + $self->setRight($left); + } elsif( !$self->hasLeft && $self->hasRight){ + my $right = $self->getRight; + $self->clearRight; + $self->setLeft($right); + } + + # and recurse + $self->getLeft->mirror if $self->hasLeft; + $self->getRight->mirror if $self->hasRight; + $self; +} + +sub size { + my ($self) = @_; + my $size = 1; + $size += $self->getLeft->size if $self->hasLeft; + $size += $self->getRight->size if $self->hasRight; + return $size; +} + +sub height { + my ($self) = @_; + my ($left_height, $right_height) = (0, 0); + $left_height = $self->getLeft->height() if $self->hasLeft(); + $right_height = $self->getRight->height() if $self->hasRight(); + return 1 + (($left_height > $right_height) ? $left_height : $right_height); +} + +1; diff --git a/t/cmop/lib/C3MethodDispatchOrder.pm b/t/cmop/lib/C3MethodDispatchOrder.pm new file mode 100644 index 0000000..c156133 --- /dev/null +++ b/t/cmop/lib/C3MethodDispatchOrder.pm @@ -0,0 +1,145 @@ +package # hide from PAUSE + C3MethodDispatchOrder; + +use strict; +use warnings; + +use Carp 'confess'; +use Algorithm::C3; + +our $VERSION = '0.03'; + +use parent 'Class::MOP::Class'; + +my $_find_method = sub { + my ($class, $method) = @_; + foreach my $super ($class->class_precedence_list) { + return $super->meta->get_method($method) + if $super->meta->has_method($method); + } +}; + +C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub { + my $cont = shift; + my $meta = $cont->(@_); + + # we need to look at $AUTOLOAD in the package where the coderef belongs + # if subname works, then it'll be where this AUTOLOAD method was installed + # otherwise, it'll be $C3MethodDispatchOrder::AUTOLOAD. get_code_info + # tells us where AUTOLOAD will look + my $autoload; + $autoload = sub { + my ($package) = Class::MOP::get_code_info($autoload); + my $label = ${ $package->meta->get_package_symbol('$AUTOLOAD') }; + my $method_name = (split /\:\:/ => $label)[-1]; + my $method = $_find_method->($_[0]->meta, $method_name); + (defined $method) || confess "Method ($method_name) not found"; + goto &$method; + }; + + $meta->add_method('AUTOLOAD' => $autoload) + unless $meta->has_method('AUTOLOAD'); + + $meta->add_method('can' => sub { + $_find_method->($_[0]->meta, $_[1]); + }) unless $meta->has_method('can'); + + return $meta; +}); + +sub superclasses { + my $self = shift; + + $self->add_package_symbol('@SUPERS' => []) + unless $self->has_package_symbol('@SUPERS'); + + if (@_) { + my @supers = @_; + @{$self->get_package_symbol('@SUPERS')} = @supers; + } + @{$self->get_package_symbol('@SUPERS')}; +} + +sub class_precedence_list { + my $self = shift; + return map { + $_->name; + } Algorithm::C3::merge($self, sub { + my $class = shift; + map { $_->meta } $class->superclasses; + }); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order + +=head1 SYNOPSIS + + # a classic diamond inheritence graph + # + # <A> + # / \ + # <B> <C> + # \ / + # <D> + + package A; + use metaclass 'C3MethodDispatchOrder'; + + sub hello { return "Hello from A" } + + package B; + use metaclass 'C3MethodDispatchOrder'; + B->meta->superclasses('A'); + + package C; + use metaclass 'C3MethodDispatchOrder'; + C->meta->superclasses('A'); + + sub hello { return "Hello from C" } + + package D; + use metaclass 'C3MethodDispatchOrder'; + D->meta->superclasses('B', 'C'); + + print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A + + # later in other code ... + + print D->hello; # print 'Hello from C' instead of the normal 'Hello from A' + +=head1 DESCRIPTION + +This is an example of how you could change the method dispatch order of a +class using L<Class::MOP>. Using the L<Algorithm::C3> module, this repleces +the normal depth-first left-to-right perl dispatch order with the C3 method +dispatch order (see the L<Algorithm::C3> or L<Class::C3> docs for more +information about this). + +This example could be used as a template for other method dispatch orders +as well, all that is required is to write a the C<class_precedence_list> method +which will return a linearized list of classes to dispatch along. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/ClassEncapsulatedAttributes.pm b/t/cmop/lib/ClassEncapsulatedAttributes.pm new file mode 100644 index 0000000..5fb3a24 --- /dev/null +++ b/t/cmop/lib/ClassEncapsulatedAttributes.pm @@ -0,0 +1,150 @@ +package # hide the package from PAUSE + ClassEncapsulatedAttributes; + +use strict; +use warnings; + +our $VERSION = '0.06'; + +use parent 'Class::MOP::Class'; + +sub initialize { + (shift)->SUPER::initialize(@_, + # use the custom attribute metaclass here + 'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', + ); +} + +sub construct_instance { + my ($class, %params) = @_; + + my $meta_instance = $class->get_meta_instance; + my $instance = $meta_instance->create_instance(); + + # initialize *ALL* attributes, including masked ones (as opposed to applicable) + foreach my $current_class ($class->class_precedence_list()) { + my $meta = $current_class->meta; + foreach my $attr_name ($meta->get_attribute_list()) { + my $attr = $meta->get_attribute($attr_name); + $attr->initialize_instance_slot($meta_instance, $instance, \%params); + } + } + + return $instance; +} + +package # hide the package from PAUSE + ClassEncapsulatedAttributes::Attribute; + +use strict; +use warnings; + +our $VERSION = '0.04'; + +use parent 'Class::MOP::Attribute'; + +# alter the way parameters are specified +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + # if the attr has an init_arg, use that, otherwise, + # use the attributes name itself as the init_arg + my $init_arg = $self->init_arg(); + # try to fetch the init arg from the %params ... + my $class = $self->associated_class; + my $val; + $val = $params->{$class->name}->{$init_arg} + if exists $params->{$class->name} && + exists ${$params->{$class->name}}{$init_arg}; + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if (!defined $val && $self->has_default) { + $val = $self->default($instance); + } + + # now add this to the instance structure + $meta_instance->set_slot_value($instance, $self->name, $val); +} + +sub name { + my $self = shift; + return ($self->associated_class->name . '::' . $self->SUPER::name) +} + +1; + +__END__ + +=pod + +=head1 NAME + +ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes + +=head1 SYNOPSIS + + package Foo; + + use metaclass 'ClassEncapsulatedAttributes'; + + Foo->meta->add_attribute('foo' => ( + accessor => 'Foo_foo', + default => 'init in FOO' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + package Bar; + our @ISA = ('Foo'); + + # duplicate the attribute name here + Bar->meta->add_attribute('foo' => ( + accessor => 'Bar_foo', + default => 'init in BAR' + )); + + # ... later in other code ... + + my $bar = Bar->new(); + prints $bar->Bar_foo(); # init in BAR + prints $bar->Foo_foo(); # init in FOO + + # and ... + + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + + prints $bar->Bar_foo(); # Foo::foo + prints $bar->Foo_foo(); # Bar::foo + +=head1 DESCRIPTION + +This is an example metaclass which encapsulates a class's +attributes on a per-class basis. This means that there is no +possibility of name clashes with inherited attributes. This +is similar to how C++ handles its data members. + +=head1 ACKNOWLEDGEMENTS + +Thanks to Yuval "nothingmuch" Kogman for the idea for this example. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/InsideOutClass.pm b/t/cmop/lib/InsideOutClass.pm new file mode 100644 index 0000000..94ec0c5 --- /dev/null +++ b/t/cmop/lib/InsideOutClass.pm @@ -0,0 +1,194 @@ +package # hide the package from PAUSE + InsideOutClass::Attribute; + +use strict; +use warnings; + +our $VERSION = '0.02'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Attribute'; + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->init_arg; + # try to fetch the init arg from the %params ... + my $val; + $val = $params->{$init_arg} if exists $params->{$init_arg}; + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if (!defined $val && defined $self->default) { + $val = $self->default($instance); + } + my $_meta_instance = $self->associated_class->get_meta_instance; + $_meta_instance->initialize_slot($instance, $self->name); + $_meta_instance->set_slot_value($instance, $self->name, $val); +} + +sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } + +package # hide the package from PAUSE + InsideOutClass::Method::Accessor; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Method::Accessor'; + +## Method generation helpers + +sub _generate_accessor_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + my $meta_instance = $meta_class->get_meta_instance; + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; + $meta_instance->get_slot_value($_[0], $attr_name); + }; +} + +sub _generate_reader_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name); + }; +} + +sub _generate_writer_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + $meta_class->get_meta_instance + ->set_slot_value($_[0], $attr_name, $_[1]); + }; +} + +sub _generate_predicate_method { + my $attr = (shift)->associated_attribute; + my $meta_class = $attr->associated_class; + my $attr_name = $attr->name; + return sub { + defined $meta_class->get_meta_instance + ->get_slot_value($_[0], $attr_name) ? 1 : 0; + }; +} + +package # hide the package from PAUSE + InsideOutClass::Instance; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Carp 'confess'; +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Instance'; + +sub create_instance { + my ($self, $class) = @_; + bless \(my $instance), $self->_class_name; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance}; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; +} + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) + unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; +} + +1; + +__END__ + +=pod + +=head1 NAME + +InsideOutClass - A set of example metaclasses which implement the Inside-Out technique + +=head1 SYNOPSIS + + package Foo; + + use metaclass ( + ':attribute_metaclass' => 'InsideOutClass::Attribute', + ':instance_metaclass' => 'InsideOutClass::Instance' + ); + + __PACKAGE__->meta->add_attribute('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # now you can just use the class as normal + +=head1 DESCRIPTION + +This is a set of example metaclasses which implement the Inside-Out +class technique. What follows is a brief explaination of the code +found in this module. + +We must create a subclass of B<Class::MOP::Instance> and override +the slot operations. This requires +overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and +C<initialize_slot>, as well as their inline counterparts. Additionally we +overload C<add_slot> in order to initialize the global hash containing the +actual slot values. + +And that is pretty much all. Of course I am ignoring need for +inside-out objects to be C<DESTROY>-ed, and some other details as +well (threading, etc), but this is an example. A real implementation is left as +an exercise to the reader. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/InstanceCountingClass.pm b/t/cmop/lib/InstanceCountingClass.pm new file mode 100644 index 0000000..35053fe --- /dev/null +++ b/t/cmop/lib/InstanceCountingClass.pm @@ -0,0 +1,72 @@ +package # hide the package from PAUSE + InstanceCountingClass; + +use strict; +use warnings; + +our $VERSION = '0.03'; + +use parent 'Class::MOP::Class'; + +InstanceCountingClass->meta->add_attribute('count' => ( + reader => 'get_count', + default => 0 +)); + +InstanceCountingClass->meta->add_before_method_modifier('_construct_instance' => sub { + my ($class) = @_; + $class->{'count'}++; +}); + +1; + +__END__ + +=pod + +=head1 NAME + +InstanceCountingClass - An example metaclass which counts instances + +=head1 SYNOPSIS + + package Foo; + + use metaclass 'InstanceCountingClass'; + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # ... meanwhile, somewhere in the code + + my $foo = Foo->new(); + print Foo->meta->get_count(); # prints 1 + + my $foo2 = Foo->new(); + print Foo->meta->get_count(); # prints 2 + + # ... etc etc etc + +=head1 DESCRIPTION + +This is a classic example of a metaclass which keeps a count of each +instance which is created. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/LazyClass.pm b/t/cmop/lib/LazyClass.pm new file mode 100644 index 0000000..1a2dc13 --- /dev/null +++ b/t/cmop/lib/LazyClass.pm @@ -0,0 +1,162 @@ +package # hide the package from PAUSE + LazyClass::Attribute; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.05'; + +use parent 'Class::MOP::Attribute'; + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + + # if the attr has an init_arg, use that, otherwise, + # use the attributes name itself as the init_arg + my $init_arg = $self->init_arg(); + + if ( exists $params->{$init_arg} ) { + my $val = $params->{$init_arg}; + $meta_instance->set_slot_value($instance, $self->name, $val); + } +} + +sub accessor_metaclass { 'LazyClass::Method::Accessor' } + +package # hide the package from PAUSE + LazyClass::Method::Accessor; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Method::Accessor'; + +sub _generate_accessor_method { + my $attr = (shift)->associated_attribute; + + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->get_meta_instance; + + sub { + if (scalar(@_) == 2) { + $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); + } + else { + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value($_[0], $attr_name, $value); + } + + $meta_instance->get_slot_value($_[0], $attr_name); + } + }; +} + +sub _generate_reader_method { + my $attr = (shift)->associated_attribute; + + my $attr_name = $attr->name; + my $meta_instance = $attr->associated_class->get_meta_instance; + + sub { + confess "Cannot assign a value to a read-only accessor" if @_ > 1; + + unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { + my $value = $attr->has_default ? $attr->default($_[0]) : undef; + $meta_instance->set_slot_value($_[0], $attr_name, $value); + } + + $meta_instance->get_slot_value($_[0], $attr_name); + }; +} + +package # hide the package from PAUSE + LazyClass::Instance; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use parent 'Class::MOP::Instance'; + +sub initialize_all_slots {} + +1; + +__END__ + +=pod + +=head1 NAME + +LazyClass - An example metaclass with lazy initialization + +=head1 SYNOPSIS + + package BinaryTree; + + use metaclass ( + ':attribute_metaclass' => 'LazyClass::Attribute', + ':instance_metaclass' => 'LazyClass::Instance', + ); + + BinaryTree->meta->add_attribute('node' => ( + accessor => 'node', + init_arg => ':node' + )); + + BinaryTree->meta->add_attribute('left' => ( + reader => 'left', + default => sub { BinaryTree->new() } + )); + + BinaryTree->meta->add_attribute('right' => ( + reader => 'right', + default => sub { BinaryTree->new() } + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + # ... later in code + + my $btree = BinaryTree->new(); + # ... $btree is an empty hash, no keys are initialized yet + +=head1 DESCRIPTION + +This is an example metclass in which all attributes are created +lazily. This means that no entries are made in the instance HASH +until the last possible moment. + +The example above of a binary tree is a good use for such a +metaclass because it allows the class to be space efficient +without complicating the programing of it. This would also be +ideal for a class which has a large amount of attributes, +several of which are optional. + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/MyMetaClass.pm b/t/cmop/lib/MyMetaClass.pm new file mode 100644 index 0000000..ade02e5 --- /dev/null +++ b/t/cmop/lib/MyMetaClass.pm @@ -0,0 +1,14 @@ +package MyMetaClass; + +use strict; +use warnings; + +use parent 'Class::MOP::Class'; + +sub mymetaclass_attributes{ + my $self = shift; + return grep { $_->isa("MyMetaClass::Attribute") } + $self->get_all_attributes; +} + +1; diff --git a/t/cmop/lib/MyMetaClass/Attribute.pm b/t/cmop/lib/MyMetaClass/Attribute.pm new file mode 100644 index 0000000..c187e9a --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Attribute.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Attribute; + +use strict; +use warnings; + +use parent 'Class::MOP::Attribute'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Instance.pm b/t/cmop/lib/MyMetaClass/Instance.pm new file mode 100644 index 0000000..5383c4a --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Instance.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Instance; + +use strict; +use warnings; + +use parent 'Class::MOP::Instance'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Method.pm b/t/cmop/lib/MyMetaClass/Method.pm new file mode 100644 index 0000000..072d49d --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Method.pm @@ -0,0 +1,8 @@ +package MyMetaClass::Method; + +use strict; +use warnings; + +use parent 'Class::MOP::Method'; + +1; diff --git a/t/cmop/lib/MyMetaClass/Random.pm b/t/cmop/lib/MyMetaClass/Random.pm new file mode 100644 index 0000000..1c79b7b --- /dev/null +++ b/t/cmop/lib/MyMetaClass/Random.pm @@ -0,0 +1,6 @@ +package MyMetaClass::Random; + +use strict; +use warnings; + +1; diff --git a/t/cmop/lib/Perl6Attribute.pm b/t/cmop/lib/Perl6Attribute.pm new file mode 100644 index 0000000..420ef30 --- /dev/null +++ b/t/cmop/lib/Perl6Attribute.pm @@ -0,0 +1,82 @@ +package # hide the package from PAUSE + Perl6Attribute; + +use strict; +use warnings; + +our $VERSION = '0.02'; + +use parent 'Class::MOP::Attribute'; + +Perl6Attribute->meta->add_around_method_modifier('new' => sub { + my $cont = shift; + my ($class, $attribute_name, %options) = @_; + + # extract the sigil and accessor name + my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/); + + # pass the accessor name + $options{accessor} = $accessor_name; + + # create a default value based on the sigil + $options{default} = sub { [] } if ($sigil eq '@'); + $options{default} = sub { {} } if ($sigil eq '%'); + + $cont->($class, $attribute_name, %options); +}); + +1; + +__END__ + +=pod + +=head1 NAME + +Perl6Attribute - An example attribute metaclass for Perl 6 style attributes + +=head1 SYNOPSIS + + package Foo; + + Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); + Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); + Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + +=head1 DESCRIPTION + +This is an attribute metaclass which implements Perl 6 style +attributes, including the auto-generating accessors. + +This code is very simple, we only need to subclass +C<Class::MOP::Attribute> and override C<&new>. Then we just +pre-process the attribute name, and create the accessor name +and default value based on it. + +More advanced features like the C<handles> trait (see +L<Perl6::Bible/A12>) can be accomplished as well doing the +same pre-processing approach. This is left as an exercise to +the reader though (if you do it, please send me a patch +though, and will update this). + +=head1 AUTHORS + +Stevan Little E<lt>stevan@iinteractive.comE<gt> + +Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L<http://www.iinteractive.com> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/cmop/lib/SyntaxError.pm b/t/cmop/lib/SyntaxError.pm new file mode 100644 index 0000000..ab41f14 --- /dev/null +++ b/t/cmop/lib/SyntaxError.pm @@ -0,0 +1,9 @@ +package SyntaxError; +use strict; +use warnings; + +# this syntax error is intentional! + + { + +1; diff --git a/t/cmop/load.t b/t/cmop/load.t new file mode 100644 index 0000000..72f9bb7 --- /dev/null +++ b/t/cmop/load.t @@ -0,0 +1,176 @@ +use strict; +use warnings; + +# for instance, App::ForkProve +my $preloaded; +BEGIN { $preloaded = exists $INC{'Class/MOP.pm'} } + +use Test::More; + +use Class::Load qw(is_class_loaded); + +BEGIN { + use_ok('Class::MOP'); + use_ok('Class::MOP::Mixin'); + use_ok('Class::MOP::Mixin::AttributeCore'); + use_ok('Class::MOP::Mixin::HasAttributes'); + use_ok('Class::MOP::Mixin::HasMethods'); + use_ok('Class::MOP::Mixin::HasOverloads'); + use_ok('Class::MOP::Package'); + use_ok('Class::MOP::Module'); + use_ok('Class::MOP::Class'); + use_ok('Class::MOP::Class::Immutable::Trait'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method::Wrapped'); + use_ok('Class::MOP::Method::Inlined'); + use_ok('Class::MOP::Method::Generated'); + use_ok('Class::MOP::Method::Accessor'); + use_ok('Class::MOP::Method::Constructor'); + use_ok('Class::MOP::Method::Meta'); + use_ok('Class::MOP::Instance'); + use_ok('Class::MOP::Object'); + use_ok('Class::MOP::Overload'); +} + +# make sure we are tracking metaclasses correctly + +my %METAS = ( + 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, + 'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta, + 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta, + 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, + 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, + 'Class::MOP::Method::Meta' => Class::MOP::Method::Meta->meta, + 'Class::MOP::Mixin' => Class::MOP::Mixin->meta, + 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta, + 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta, + 'Class::MOP::Mixin::HasMethods' => Class::MOP::Mixin::HasMethods->meta, + 'Class::MOP::Mixin::HasOverloads' => Class::MOP::Mixin::HasOverloads->meta, + 'Class::MOP::Package' => Class::MOP::Package->meta, + 'Class::MOP::Module' => Class::MOP::Module->meta, + 'Class::MOP::Class' => Class::MOP::Class->meta, + 'Class::MOP::Method' => Class::MOP::Method->meta, + 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta, + 'Class::MOP::Instance' => Class::MOP::Instance->meta, + 'Class::MOP::Object' => Class::MOP::Object->meta, + 'Class::MOP::Overload' => Class::MOP::Overload->meta, + 'Class::MOP::Class::Immutable::Trait' => Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), + 'Class::MOP::Class::Immutable::Class::MOP::Class' => Class::MOP::Class::Immutable::Class::MOP::Class->meta, + 'UNIVERSAL' => Class::MOP::class_of('UNIVERSAL'), +); + +ok( is_class_loaded($_), '... ' . $_ . ' is loaded' ) + for sort keys %METAS; + +# The trait shouldn't be made immutable, it doesn't actually do anything, and +# it doesn't even matter because it's not a class that will be +# instantiated. Making UNIVERSAL immutable just seems like a bad idea. +my %expect_mutable = map { $_ => 1 } qw( Class::MOP::Class::Immutable::Trait UNIVERSAL ); + +for my $meta (values %METAS) { + if ( $expect_mutable{$meta->name} ) { + ok( $meta->is_mutable(), '... ' . $meta->name . ' is mutable' ); + } + else { + ok( $meta->is_immutable(), '... ' . $meta->name . ' is immutable' ); + } +} + +SKIP: { + skip "this list may be incorrect if we preloaded things", 3 if $preloaded; + is_deeply( + {Class::MOP::get_all_metaclasses}, + \%METAS, + '... got all the metaclasses' + ); + + is_deeply( + [ + sort { $a->name cmp $b->name } + Class::MOP::get_all_metaclass_instances + ], + [ + Class::MOP::Attribute->meta, + Class::MOP::Class->meta, + Class::MOP::Class::Immutable::Class::MOP::Class->meta, + Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), + Class::MOP::Instance->meta, + Class::MOP::Method->meta, + Class::MOP::Method::Accessor->meta, + Class::MOP::Method::Constructor->meta, + Class::MOP::Method::Generated->meta, + Class::MOP::Method::Inlined->meta, + Class::MOP::Method::Meta->meta, + Class::MOP::Method::Wrapped->meta, + Class::MOP::Mixin->meta, + Class::MOP::Mixin::AttributeCore->meta, + Class::MOP::Mixin::HasAttributes->meta, + Class::MOP::Mixin::HasMethods->meta, + Class::MOP::Mixin::HasOverloads->meta, + Class::MOP::Module->meta, + Class::MOP::Object->meta, + Class::MOP::Overload->meta, + Class::MOP::Package->meta, + Class::MOP::class_of('UNIVERSAL'), + ], + '... got all the metaclass instances' + ); + + is_deeply( + [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], + [ + sort qw/ + Class::MOP::Attribute + Class::MOP::Class + Class::MOP::Class::Immutable::Class::MOP::Class + Class::MOP::Class::Immutable::Trait + Class::MOP::Mixin + Class::MOP::Mixin::AttributeCore + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin::HasOverloads + Class::MOP::Instance + Class::MOP::Method + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor + Class::MOP::Method::Generated + Class::MOP::Method::Inlined + Class::MOP::Method::Wrapped + Class::MOP::Method::Meta + Class::MOP::Module + Class::MOP::Object + Class::MOP::Overload + Class::MOP::Package + UNIVERSAL + /, + ], + '... got all the metaclass names' + ); +} + +# testing the meta-circularity of the system + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta->meta, Class::MOP::Class->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta->meta == Class::MOP::Class->meta->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta' +); + +is( + Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta->meta, + '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta->meta' +); + +isa_ok(Class::MOP::Class->meta, 'Class::MOP::Class'); + +done_testing; diff --git a/t/cmop/magic.t b/t/cmop/magic.t new file mode 100644 index 0000000..bfb9dba --- /dev/null +++ b/t/cmop/magic.t @@ -0,0 +1,76 @@ +use strict; +use warnings; + +# Testing magical scalars (using tied scalar) +# Note that XSUBs do not handle magical scalars automatically. + +use Test::More; +use Test::Fatal; + +use Class::Load qw( is_class_loaded load_class ); +use Class::MOP; + +use Tie::Scalar; + +{ + package Foo; + use metaclass; + + Foo->meta->add_attribute('bar' => + reader => 'get_bar', + writer => 'set_bar', + ); + + Foo->meta->add_attribute('baz' => + accessor => 'baz', + ); + + Foo->meta->make_immutable(); +} + +{ + tie my $foo, 'Tie::StdScalar', Foo->new(bar => 100, baz => 200); + + is $foo->get_bar, 100, 'reader with tied self'; + is $foo->baz, 200, 'accessor/r with tied self'; + + $foo->set_bar(300); + $foo->baz(400); + + is $foo->get_bar, 300, 'writer with tied self'; + is $foo->baz, 400, 'accessor/w with tied self'; +} + +{ + my $foo = Foo->new(); + + tie my $value, 'Tie::StdScalar', 42; + + $foo->set_bar($value); + $foo->baz($value); + + is $foo->get_bar, 42, 'reader/writer with tied value'; + is $foo->baz, 42, 'accessor with tied value'; +} + +{ + my $x = tie my $value, 'Tie::StdScalar', 'Class::MOP'; + + is( exception { load_class($value) }, undef, 'load_class(tied scalar)' ); + + $value = undef; + $x->STORE('Class::MOP'); # reset + + is( exception { + ok is_class_loaded($value); + }, undef, 'is_class_loaded(tied scalar)' ); + + $value = undef; + $x->STORE(\&Class::MOP::get_code_info); # reset + + is( exception { + is_deeply [Class::MOP::get_code_info($value)], [qw(Class::MOP get_code_info)], 'get_code_info(tied scalar)'; + }, undef ); +} + +done_testing; diff --git a/t/cmop/make_mutable.t b/t/cmop/make_mutable.t new file mode 100644 index 0000000..cf30738 --- /dev/null +++ b/t/cmop/make_mutable.t @@ -0,0 +1,220 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util; + +use Class::MOP; + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Baz metaclass'); + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + # Since this has no default it won't be present yet, but it will + # be after the class is made immutable. + + is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable' ); + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->make_immutable, '... make immutable returns true'); + ok($meta->get_method('new'), '... inlined constructor created'); + ok($meta->has_method('new'), '... inlined constructor created for sure'); + is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it'); + + is( exception { $meta->make_mutable; }, undef, '... changed Baz to be mutable' ); + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + ok(!$meta->get_method('new'), '... inlined constructor created'); + ok(!$meta->has_method('new'), '... inlined constructor removed for sure'); + + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); + + isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class'); + + $meta->add_method('xyz', sub{'xxx'}); + is( Baz->xyz, 'xxx', '... method xyz works'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok(Baz->can('fickle'), '... Baz can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + $meta->add_package_symbol('$ref', $reef); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); + + is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable again' ); + ok($meta->get_method('new'), '... inlined constructor recreated'); +} + +{ + my $meta = Baz->meta; + + is( exception { $meta->make_immutable() }, undef, 'Changed Baz to be immutable' ); + is( exception { $meta->make_mutable() }, undef, '... changed Baz to be mutable' ); + is( exception { $meta->make_immutable() }, undef, '... changed Baz to be immutable' ); + + isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); + + isnt( exception { + $meta->add_attribute('fickle', accessor => 'fickle') + }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); + + my $reef = \ 'reef'; + isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +} + +{ + + ok(Baz->meta->is_immutable, 'Superclass is immutable'); + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + my @orig_meths = sort { $a->name cmp $b->name } $meta->get_all_methods; + ok($meta->is_anon_class, 'We have an anon metaclass'); + ok($meta->is_mutable, '... our anon class is mutable'); + ok(!$meta->is_immutable, '... our anon class is not immutable'); + + is( exception {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + }, undef, '... changed class to be immutable' ); + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->make_immutable, '... make immutable returns true'); + + is( exception { $meta->make_mutable }, undef, '... changed Baz to be mutable' ); + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + ok($meta->is_anon_class, '... still marked as an anon class'); + my $instance = $meta->new_object; + + my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; + my @new_meths = sort { $a->name cmp $b->name } + $meta->get_all_methods; + is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); + is_deeply(\@orig_meths, \@new_meths, '... no straneous methods'); + + isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class'); + + $meta->add_method('xyz', sub{'xxx'}); + is( $instance->xyz , 'xxx', '... method xyz works'); + ok( $meta->remove_method('xyz'), '... removed method'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok($instance->can('fickle'), '... instance can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + $meta->add_package_symbol('$ref', $reef); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +}; + + +#rerun the same tests on an anon class.. just cause we can. +{ + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + + is( exception {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + }, undef, '... changed class to be immutable' ); + is( exception { $meta->make_mutable() }, undef, '... changed class to be mutable' ); + is( exception {$meta->make_immutable }, undef, '... changed class to be immutable' ); + + isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); + + isnt( exception { + $meta->add_attribute('fickle', accessor => 'fickle') + }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); + + my $reef = \ 'reef'; + isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); + isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance get_all_attributes + class_precedence_list ); +} + +{ + Foo->meta->make_immutable; + Bar->meta->make_immutable; + Bar->meta->make_mutable; +} + +done_testing; diff --git a/t/cmop/meta_method.t b/t/cmop/meta_method.t new file mode 100644 index 0000000..de65543 --- /dev/null +++ b/t/cmop/meta_method.t @@ -0,0 +1,66 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Class::MOP; + +{ + can_ok('Class::MOP::Class', 'meta'); + isa_ok(Class::MOP::Class->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); + + { + package Baz; + use metaclass; + } + can_ok('Baz', 'meta'); + isa_ok(Baz->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); + + my $meta = Class::MOP::Class->create('Quux'); + can_ok('Quux', 'meta'); + isa_ok(Quux->meta->find_method_by_name('meta'), + 'Class::MOP::Method::Meta'); +} + +{ + { + package Blarg; + use metaclass meta_name => 'blarg'; + } + ok(!Blarg->can('meta')); + can_ok('Blarg', 'blarg'); + isa_ok(Blarg->blarg->find_method_by_name('blarg'), + 'Class::MOP::Method::Meta'); + + my $meta = Class::MOP::Class->create('Blorg', meta_name => 'blorg'); + ok(!Blorg->can('meta')); + can_ok('Blorg', 'blorg'); + isa_ok(Blorg->blorg->find_method_by_name('blorg'), + 'Class::MOP::Method::Meta'); +} + +{ + { + package Foo; + use metaclass meta_name => undef; + } + + my $meta = Class::MOP::class_of('Foo'); + ok(!$meta->has_method('meta'), "no meta method was installed"); + $meta->add_method(meta => sub { die 'META' }); + is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); + is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); + is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); +} + +{ + my $meta = Class::MOP::Class->create('Bar', meta_name => undef); + ok(!$meta->has_method('meta'), "no meta method was installed"); + $meta->add_method(meta => sub { die 'META' }); + is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); + is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); + is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); +} + +done_testing; diff --git a/t/cmop/meta_package.t b/t/cmop/meta_package.t new file mode 100644 index 0000000..8e7f76e --- /dev/null +++ b/t/cmop/meta_package.t @@ -0,0 +1,280 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Package; + + +isnt( exception { Class::MOP::Package->get_all_package_symbols }, undef, q{... can't call get_all_package_symbols() as a class method} ); +isnt( exception { Class::MOP::Package->name }, undef, q{... can't call name() as a class method} ); + +{ + package Foo; + + use constant SOME_CONSTANT => 1; + + sub meta { Class::MOP::Package->initialize('Foo') } +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +is( exception { + Foo->meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully' ); + +# ... scalar should NOT be created here + +ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = Foo->meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('$baz' => 10); +}, undef, '... created $Foo::baz successfully' ); + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); +}, undef, '... created &Foo::funk successfully' ); + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is( exception { + Foo->meta->add_package_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = Foo->meta->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is( exception { + Foo->meta->remove_package_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +# get_all_package_symbols + +{ + my $syms = Foo->meta->get_all_package_symbols; + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols ], + '... the fetched symbols are the same as the listed ones' + ); +} + +{ + my $syms = Foo->meta->get_all_package_symbols('CODE'); + + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols('CODE') ], + '... the fetched symbols are the same as the listed ones' + ); + + foreach my $symbol (keys %{ $syms }) { + is($syms->{$symbol}, Foo->meta->get_package_symbol('&' . $symbol), '... got the right symbol'); + } +} + +{ + Foo->meta->add_package_symbol('%zork'); + + my $syms = Foo->meta->get_all_package_symbols('HASH'); + + is_deeply( + [ sort keys %{ $syms } ], + [ sort Foo->meta->list_all_package_symbols('HASH') ], + '... the fetched symbols are the same as the listed ones' + ); + + foreach my $symbol (keys %{ $syms }) { + is($syms->{$symbol}, Foo->meta->get_package_symbol('%' . $symbol), '... got the right symbol'); + } + + no warnings 'once'; + is_deeply( + $syms, + { zork => \%Foo::zork }, + "got the right ones", + ); +} + +done_testing; diff --git a/t/cmop/meta_package_extension.t b/t/cmop/meta_package_extension.t new file mode 100644 index 0000000..4754275 --- /dev/null +++ b/t/cmop/meta_package_extension.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package My::Package::Stash; + use strict; + use warnings; + + use parent 'Package::Stash'; + + use metaclass; + + use Symbol 'gensym'; + + __PACKAGE__->meta->add_attribute( + 'namespace' => ( + reader => 'namespace', + default => sub { {} } + ) + ); + + sub new { + my $class = shift; + $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_)); + } + + sub add_symbol { + my ($self, $variable, $initial_value) = @_; + + (my $name = $variable) =~ s/^[\$\@\%\&]//; + + my $glob = gensym(); + *{$glob} = $initial_value if defined $initial_value; + $self->namespace->{$name} = *{$glob}; + } +} + +{ + package My::Meta::Package; + + use strict; + use warnings; + + use parent 'Class::MOP::Package'; + + sub _package_stash { + $_[0]->{_package_stash} ||= My::Package::Stash->new($_[0]->name); + } +} + +# No actually package Foo exists :) +my $meta = My::Meta::Package->initialize('Foo'); + +isa_ok($meta, 'My::Meta::Package'); +isa_ok($meta, 'Class::MOP::Package'); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$meta->has_package_symbol('%foo'), '... the meta agrees'); + +is( exception { + $meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... the %foo symbol is created succcessfully' ); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); +ok($meta->has_package_symbol('%foo'), '... the meta agrees'); + +my $foo = $meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +$foo->{two} = 2; + +is($foo, $meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + $meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); + +ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); + +is( exception { + $meta->add_package_symbol('%baz'); +}, undef, '... created %Foo::baz successfully' ); + +ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); + +done_testing; diff --git a/t/cmop/metaclass.t b/t/cmop/metaclass.t new file mode 100644 index 0000000..6bc5b64 --- /dev/null +++ b/t/cmop/metaclass.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +{ + package FooMeta; + use parent 'Class::MOP::Class'; + + package Foo; + use metaclass 'FooMeta'; +} + +can_ok('Foo', 'meta'); +isa_ok(Foo->meta, 'FooMeta'); +isa_ok(Foo->meta, 'Class::MOP::Class'); + +{ + package BarMeta; + use parent 'Class::MOP::Class'; + + package BarMeta::Attribute; + use parent 'Class::MOP::Attribute'; + + package BarMeta::Method; + use parent 'Class::MOP::Method'; + + package Bar; + use metaclass 'BarMeta' => ( + 'attribute_metaclass' => 'BarMeta::Attribute', + 'method_metaclass' => 'BarMeta::Method', + ); +} + +can_ok('Bar', 'meta'); +isa_ok(Bar->meta, 'BarMeta'); +isa_ok(Bar->meta, 'Class::MOP::Class'); + +is(Bar->meta->attribute_metaclass, 'BarMeta::Attribute', '... got the right attribute metaobject'); +is(Bar->meta->method_metaclass, 'BarMeta::Method', '... got the right method metaobject'); + +{ + package Baz; + use metaclass; +} + +can_ok('Baz', 'meta'); +isa_ok(Baz->meta, 'Class::MOP::Class'); + +eval { + package Boom; + metaclass->import('Foo'); +}; +ok($@, '... metaclasses must be subclass of Class::MOP::Class'); + +done_testing; diff --git a/t/cmop/metaclass_incompatibility.t b/t/cmop/metaclass_incompatibility.t new file mode 100644 index 0000000..9991a18 --- /dev/null +++ b/t/cmop/metaclass_incompatibility.t @@ -0,0 +1,264 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use metaclass; + +my %metaclass_attrs; +BEGIN { + %metaclass_attrs = ( + 'Instance' => 'instance_metaclass', + 'Attribute' => 'attribute_metaclass', + 'Method' => 'method_metaclass', + 'Method::Wrapped' => 'wrapped_method_metaclass', + 'Method::Constructor' => 'constructor_class', + ); + + # meta classes + for my $suffix ('Class', keys %metaclass_attrs) { + Class::MOP::Class->create( + "Foo::Meta::$suffix", + superclasses => ["Class::MOP::$suffix"] + ); + Class::MOP::Class->create( + "Bar::Meta::$suffix", + superclasses => ["Class::MOP::$suffix"] + ); + Class::MOP::Class->create( + "FooBar::Meta::$suffix", + superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"] + ); + } +} + +# checking... + +is( exception { + Foo::Meta::Class->create('Foo') +}, undef, '... Foo.meta => Foo::Meta::Class is compatible' ); +is( exception { + Bar::Meta::Class->create('Bar') +}, undef, '... Bar.meta => Bar::Meta::Class is compatible' ); + +like( exception { + Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo']) +}, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' ); +like( exception { + Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar']) +}, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' ); + +is( exception { + FooBar::Meta::Class->create('FooBar', superclasses => ['Foo']) +}, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' ); +is( exception { + FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar']) +}, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' ); + +Foo::Meta::Class->create( + 'Foo::All', + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, +); + +like( exception { + Bar::Meta::Class->create( + 'Foo::All::Sub::Class', + superclasses => ['Foo::All'], + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, + ) +}, qr/compatible/, 'incompatible Class metaclass' ); +for my $suffix (keys %metaclass_attrs) { + like( exception { + Foo::Meta::Class->create( + "Foo::All::Sub::$suffix", + superclasses => ['Foo::All'], + (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), + $metaclass_attrs{$suffix} => "Bar::Meta::$suffix", + ) + }, qr/compatible/, "incompatible $suffix metaclass" ); +} + +# fixing... + +is( exception { + Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo']) +}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); +isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class'); +is( exception { + Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar']) +}, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); +isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class'); + +is( exception { + Class::MOP::Class->create( + 'Foo::All::Sub::CMOP::Class', + superclasses => ['Foo::All'], + map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, + ) +}, undef, 'metaclass fixing works with other non-default metaclasses' ); +isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class'); + +for my $suffix (keys %metaclass_attrs) { + is( exception { + Foo::Meta::Class->create( + "Foo::All::Sub::CMOP::$suffix", + superclasses => ['Foo::All'], + (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), + $metaclass_attrs{$suffix} => "Class::MOP::$suffix", + ) + }, undef, "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses" ); + for my $suffix2 (keys %metaclass_attrs) { + my $method = $metaclass_attrs{$suffix2}; + isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2"); + } +} + +# initializing... + +{ + package Foo::NoMeta; +} + +Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']); +ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); +isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class'); +isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class'); + +{ + package Foo::NoMeta2; +} +Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']); +ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); +isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class'); +isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class'); + + +BEGIN { + Foo::Meta::Class->create('Foo::WithMeta'); +} +{ + package Foo::WithMeta::Sub; + use parent -norequire => 'Foo::WithMeta'; +} +Class::MOP::Class->create( + 'Foo::WithMeta::Sub::Sub', + superclasses => ['Foo::WithMeta::Sub'] +); + +isa_ok(Class::MOP::class_of('Foo::WithMeta'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub::Sub'), 'Foo::Meta::Class'); + +BEGIN { + Foo::Meta::Class->create('Foo::WithMeta2'); +} +{ + package Foo::WithMeta2::Sub; + use parent -norequire => 'Foo::WithMeta2'; +} +{ + package Foo::WithMeta2::Sub::Sub; + use parent -norequire => 'Foo::WithMeta2::Sub'; +} +Class::MOP::Class->create( + 'Foo::WithMeta2::Sub::Sub::Sub', + superclasses => ['Foo::WithMeta2::Sub::Sub'] +); + +isa_ok(Class::MOP::class_of('Foo::WithMeta2'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub::Sub'), 'Foo::Meta::Class'); + +Class::MOP::Class->create( + 'Foo::Reverse::Sub::Sub', + superclasses => ['Foo::Reverse::Sub'], +); +eval "package Foo::Reverse::Sub; use parent -norequire => 'Foo::Reverse';"; +Foo::Meta::Class->create( + 'Foo::Reverse', +); +isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class'); +{ local $TODO = 'No idea how to handle case where child class is created before parent'; +isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class'); +isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class'); +} + +# unsafe fixing... + +{ + Class::MOP::Class->create( + 'Foo::Unsafe', + attribute_metaclass => 'Foo::Meta::Attribute', + ); + my $meta = Class::MOP::Class->create( + 'Foo::Unsafe::Sub', + ); + $meta->add_attribute(foo => reader => 'foo'); + like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" ); +} + +# immutability... + +{ + my $foometa = Foo::Meta::Class->create( + 'Foo::Immutable', + ); + $foometa->make_immutable; + my $barmeta = Class::MOP::Class->create( + 'Bar::Mutable', + ); + my $bazmeta = Class::MOP::Class->create( + 'Baz::Mutable', + ); + $bazmeta->superclasses($foometa->name); + is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" ); + ok(!$bazmeta->is_immutable, + "immutable superclass doesn't make this class immutable"); + is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" ); +} + +# nonexistent metaclasses + +Class::MOP::Class->create( + 'Weird::Meta::Method::Destructor', + superclasses => ['Class::MOP::Method'], +); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class', + destructor_class => 'Weird::Meta::Method::Destructor', + ); +}, undef, "defined metaclass in child with defined metaclass in parent is fine" ); + +is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class::Sub', + superclasses => ['Weird::Class'], + destructor_class => undef, + ); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +is( exception { + Class::MOP::Class->create( + 'Weird::Class::Sub2', + destructor_class => undef, + ); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is( exception { + Weird::Class::Sub2->meta->superclasses('Weird::Class'); +}, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); + +is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', + "got the right destructor class"); + +done_testing; diff --git a/t/cmop/metaclass_incompatibility_dyn.t b/t/cmop/metaclass_incompatibility_dyn.t new file mode 100644 index 0000000..dccec28 --- /dev/null +++ b/t/cmop/metaclass_incompatibility_dyn.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; + +use metaclass; + +# meta classes +{ + package Foo::Meta; + use parent 'Class::MOP::Class'; + + package Bar::Meta; + use parent 'Class::MOP::Class'; + + package FooBar::Meta; + use parent -norequire => 'Foo::Meta', 'Bar::Meta'; +} + +$@ = undef; +eval { + package Foo; + metaclass->import('Foo::Meta'); +}; +ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Bar; + metaclass->import('Bar::Meta'); +}; +ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package Foo::Foo; + metaclass->import('Bar::Meta'); + Foo::Foo->meta->superclasses('Foo'); +}; +ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package Bar::Bar; + metaclass->import('Foo::Meta'); + Bar::Bar->meta->superclasses('Bar'); +}; +ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; + +$@ = undef; +eval { + package FooBar; + metaclass->import('FooBar::Meta'); + FooBar->meta->superclasses('Foo'); +}; +ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; + +$@ = undef; +eval { + package FooBar2; + metaclass->import('FooBar::Meta'); + FooBar2->meta->superclasses('Bar'); +}; +ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; + +done_testing; diff --git a/t/cmop/metaclass_inheritance.t b/t/cmop/metaclass_inheritance.t new file mode 100644 index 0000000..0cc2a5c --- /dev/null +++ b/t/cmop/metaclass_inheritance.t @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +=pod + +Test that a default set up will cause metaclasses to inherit +the same metaclass type, but produce different metaclasses. + +=cut + +{ + package Foo; + use metaclass; + + package Bar; + use parent -norequire => 'Foo'; + + package Baz; + use parent -norequire => 'Bar'; +} + +my $foo_meta = Foo->meta; +isa_ok($foo_meta, 'Class::MOP::Class'); + +is($foo_meta->name, 'Foo', '... foo_meta->name == Foo'); + +my $bar_meta = Bar->meta; +isa_ok($bar_meta, 'Class::MOP::Class'); + +is($bar_meta->name, 'Bar', '... bar_meta->name == Bar'); +isnt($bar_meta, $foo_meta, '... Bar->meta != Foo->meta'); + +my $baz_meta = Baz->meta; +isa_ok($baz_meta, 'Class::MOP::Class'); + +is($baz_meta->name, 'Baz', '... baz_meta->name == Baz'); +isnt($baz_meta, $bar_meta, '... Baz->meta != Bar->meta'); +isnt($baz_meta, $foo_meta, '... Baz->meta != Foo->meta'); + +done_testing; diff --git a/t/cmop/metaclass_loads_classes.t b/t/cmop/metaclass_loads_classes.t new file mode 100644 index 0000000..9c0fa01 --- /dev/null +++ b/t/cmop/metaclass_loads_classes.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; + +use Class::Load qw(is_class_loaded); + +use lib 't/cmop/lib'; + +{ + package Foo; + + use strict; + use warnings; + + use metaclass 'MyMetaClass' => ( + 'attribute_metaclass' => 'MyMetaClass::Attribute', + 'instance_metaclass' => 'MyMetaClass::Instance', + 'method_metaclass' => 'MyMetaClass::Method', + 'random_metaclass' => 'MyMetaClass::Random', + ); +} + +my $meta = Foo->meta; + +isa_ok($meta, 'MyMetaClass', '... Correct metaclass'); +ok(is_class_loaded('MyMetaClass'), '... metaclass loaded'); + +is($meta->attribute_metaclass, 'MyMetaClass::Attribute', '... Correct attribute metaclass'); +ok(is_class_loaded('MyMetaClass::Attribute'), '... attribute metaclass loaded'); + +is($meta->instance_metaclass, 'MyMetaClass::Instance', '... Correct instance metaclass'); +ok(is_class_loaded('MyMetaClass::Instance'), '... instance metaclass loaded'); + +is($meta->method_metaclass, 'MyMetaClass::Method', '... Correct method metaclass'); +ok(is_class_loaded('MyMetaClass::Method'), '... method metaclass loaded'); + +done_testing; diff --git a/t/cmop/metaclass_reinitialize.t b/t/cmop/metaclass_reinitialize.t new file mode 100644 index 0000000..e4a98f3 --- /dev/null +++ b/t/cmop/metaclass_reinitialize.t @@ -0,0 +1,205 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use metaclass; + sub foo {} + Foo->meta->add_attribute('bar'); +} + +sub check_meta_sanity { + my ($meta, $class) = @_; + isa_ok($meta, 'Class::MOP::Class'); + is($meta->name, $class); + ok($meta->has_method('foo')); + isa_ok($meta->get_method('foo'), 'Class::MOP::Method'); + ok($meta->has_attribute('bar')); + isa_ok($meta->get_attribute('bar'), 'Class::MOP::Attribute'); +} + +can_ok('Foo', 'meta'); + +my $meta = Foo->meta; +check_meta_sanity($meta, 'Foo'); + +is( exception { + $meta = $meta->reinitialize($meta->name); +}, undef ); +check_meta_sanity($meta, 'Foo'); + +is( exception { + $meta = $meta->reinitialize($meta); +}, undef ); +check_meta_sanity($meta, 'Foo'); + +like( exception { + $meta->reinitialize(''); +}, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); + +like( exception { + $meta->reinitialize($meta->new_object); +}, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); + +{ + package Bar::Meta::Method; + use parent 'Class::MOP::Method'; + __PACKAGE__->meta->add_attribute('test', accessor => 'test'); +} + +{ + package Bar::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + __PACKAGE__->meta->add_attribute('tset', accessor => 'tset'); +} + +{ + package Bar; + use metaclass; + Bar->meta->add_method('foo' => Bar::Meta::Method->wrap(sub {}, name => 'foo', package_name => 'Bar')); + Bar->meta->add_attribute(Bar::Meta::Attribute->new('bar')); +} + +$meta = Bar->meta; +check_meta_sanity($meta, 'Bar'); +isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +is( exception { + $meta = $meta->reinitialize('Bar'); +}, undef ); +check_meta_sanity($meta, 'Bar'); +isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); + +Bar->meta->get_method('foo')->test('FOO'); +Bar->meta->get_attribute('bar')->tset('OOF'); + +is(Bar->meta->get_method('foo')->test, 'FOO'); +is(Bar->meta->get_attribute('bar')->tset, 'OOF'); +is( exception { + $meta = $meta->reinitialize('Bar'); +}, undef ); +is(Bar->meta->get_method('foo')->test, 'FOO'); +is(Bar->meta->get_attribute('bar')->tset, 'OOF'); + +{ + package Baz::Meta::Attribute; + use parent 'Class::MOP::Attribute'; +} + +{ + package Baz::Meta::Method; + use parent 'Class::MOP::Method'; +} + +{ + package Baz; + use metaclass meta_name => undef; + + sub foo {} + Class::MOP::class_of('Baz')->add_attribute('bar'); +} + +$meta = Class::MOP::class_of('Baz'); +check_meta_sanity($meta, 'Baz'); +ok(!$meta->get_method('foo')->isa('Baz::Meta::Method')); +ok(!$meta->get_attribute('bar')->isa('Baz::Meta::Attribute')); +is( exception { + $meta = $meta->reinitialize( + 'Baz', + attribute_metaclass => 'Baz::Meta::Attribute', + method_metaclass => 'Baz::Meta::Method' + ); +}, undef ); +check_meta_sanity($meta, 'Baz'); +isa_ok($meta->get_method('foo'), 'Baz::Meta::Method'); +isa_ok($meta->get_attribute('bar'), 'Baz::Meta::Attribute'); + +{ + package Quux; + use metaclass + attribute_metaclass => 'Bar::Meta::Attribute', + method_metaclass => 'Bar::Meta::Method'; + + sub foo {} + Quux->meta->add_attribute('bar'); +} + +$meta = Quux->meta; +check_meta_sanity($meta, 'Quux'); +isa_ok(Quux->meta->get_method('foo'), 'Bar::Meta::Method'); +isa_ok(Quux->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); +like( exception { + $meta = $meta->reinitialize( + 'Quux', + attribute_metaclass => 'Baz::Meta::Attribute', + method_metaclass => 'Baz::Meta::Method', + ); +}, qr/\QAttribute (class_name) is required/ ); + +{ + package Quuux::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + + sub install_accessors {} +} + +{ + package Quuux; + use metaclass; + sub foo {} + Quuux->meta->add_attribute('bar', reader => 'bar'); +} + +$meta = Quuux->meta; +check_meta_sanity($meta, 'Quuux'); +ok($meta->has_method('bar')); +is( exception { + $meta = $meta->reinitialize( + 'Quuux', + attribute_metaclass => 'Quuux::Meta::Attribute', + ); +}, undef ); +check_meta_sanity($meta, 'Quuux'); +ok(!$meta->has_method('bar')); + +{ + package Blah::Meta::Method; + use parent 'Class::MOP::Method'; + + __PACKAGE__->meta->add_attribute('foo', reader => 'foo', default => 'TEST'); +} + +{ + package Blah::Meta::Attribute; + use parent 'Class::MOP::Attribute'; + + __PACKAGE__->meta->add_attribute('oof', reader => 'oof', default => 'TSET'); +} + +{ + package Blah; + use metaclass no_meta => 1; + sub foo {} + Class::MOP::class_of('Blah')->add_attribute('bar'); +} + +$meta = Class::MOP::class_of('Blah'); +check_meta_sanity($meta, 'Blah'); +is( exception { + $meta = Class::MOP::Class->reinitialize( + 'Blah', + attribute_metaclass => 'Blah::Meta::Attribute', + method_metaclass => 'Blah::Meta::Method', + ); +}, undef ); +check_meta_sanity($meta, 'Blah'); +can_ok($meta->get_method('foo'), 'foo'); +is($meta->get_method('foo')->foo, 'TEST'); +can_ok($meta->get_attribute('bar'), 'oof'); +is($meta->get_attribute('bar')->oof, 'TSET'); + +done_testing; diff --git a/t/cmop/method.t b/t/cmop/method.t new file mode 100644 index 0000000..dd15b8a --- /dev/null +++ b/t/cmop/method.t @@ -0,0 +1,172 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Method; + +my $method = Class::MOP::Method->wrap( + sub {1}, + package_name => 'main', + name => '__ANON__', +); +is( $method->meta, Class::MOP::Method->meta, + '... instance and class both lead to the same meta' ); + +is( $method->package_name, 'main', '... our package is main::' ); +is( $method->name, '__ANON__', '... our sub name is __ANON__' ); +is( $method->fully_qualified_name, 'main::__ANON__', + '... our subs full name is main::__ANON__' ); +is( $method->original_method, undef, '... no original_method ' ); +is( $method->original_package_name, 'main', + '... the original_package_name is the same as package_name' ); +is( $method->original_name, '__ANON__', + '... the original_name is the same as name' ); +is( $method->original_fully_qualified_name, 'main::__ANON__', + '... the original_fully_qualified_name is the same as fully_qualified_name' +); +ok( !$method->is_stub, + '... the method is not a stub' ); + +isnt( exception { Class::MOP::Method->wrap }, undef, q{... can't call wrap() without some code} ); +isnt( exception { Class::MOP::Method->wrap( [] ) }, undef, q{... can't call wrap() without some code} ); +isnt( exception { Class::MOP::Method->wrap( bless {} => 'Fail' ) }, undef, q{... can't call wrap() without some code} ); + +isnt( exception { Class::MOP::Method->name }, undef, q{... can't call name() as a class method} ); +isnt( exception { Class::MOP::Method->body }, undef, q{... can't call body() as a class method} ); +isnt( exception { Class::MOP::Method->package_name }, undef, q{... can't call package_name() as a class method} ); +isnt( exception { Class::MOP::Method->fully_qualified_name }, undef, q{... can't call fully_qualified_name() as a class method} ); + +my $meta = Class::MOP::Method->meta; +isa_ok( $meta, 'Class::MOP::Class' ); + +foreach my $method_name ( + qw( + wrap + package_name + name + ) + ) { + ok( $meta->has_method($method_name), + '... Class::MOP::Method->has_method(' . $method_name . ')' ); + my $method = $meta->get_method($method_name); + is( $method->package_name, 'Class::MOP::Method', + '... our package is Class::MOP::Method' ); + is( $method->name, $method_name, + '... our sub name is "' . $method_name . '"' ); +} + +isnt( exception { + Class::MOP::Method->wrap(); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap('Fail'); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( [] ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'} ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'}, package_name => 'main' ); +}, undef, '... bad args for &wrap' ); + +isnt( exception { + Class::MOP::Method->wrap( sub {'FAIL'}, name => '__ANON__' ); +}, undef, '... bad args for &wrap' ); + +is( exception { + Class::MOP::Method->wrap( bless( sub {'FAIL'}, "Foo" ), + name => '__ANON__', package_name => 'Foo::Bar' ); +}, undef, '... blessed coderef to &wrap' ); + +my $clone = $method->clone( + package_name => 'NewPackage', + name => 'new_name', +); + +isa_ok( $clone, 'Class::MOP::Method' ); +is( $clone->package_name, 'NewPackage', + '... cloned method has new package name' ); +is( $clone->name, 'new_name', '... cloned method has new sub name' ); +is( $clone->fully_qualified_name, 'NewPackage::new_name', + '... cloned method has new fq name' ); +is( $clone->original_method, $method, + '... cloned method has correct original_method' ); +is( $clone->original_package_name, 'main', + '... cloned method has correct original_package_name' ); +is( $clone->original_name, '__ANON__', + '... cloned method has correct original_name' ); +is( $clone->original_fully_qualified_name, 'main::__ANON__', + '... cloned method has correct original_fully_qualified_name' ); + +my $clone2 = $clone->clone( + package_name => 'NewerPackage', + name => 'newer_name', +); + +is( $clone2->package_name, 'NewerPackage', + '... clone of clone has new package name' ); +is( $clone2->name, 'newer_name', '... clone of clone has new sub name' ); +is( $clone2->fully_qualified_name, 'NewerPackage::newer_name', + '... clone of clone new fq name' ); +is( $clone2->original_method, $clone, + '... cloned method has correct original_method' ); +is( $clone2->original_package_name, 'main', + '... original_package_name follows clone chain' ); +is( $clone2->original_name, '__ANON__', + '... original_name follows clone chain' ); +is( $clone2->original_fully_qualified_name, 'main::__ANON__', + '... original_fully_qualified_name follows clone chain' ); + +Class::MOP::Class->create( + 'Method::Subclass', + superclasses => ['Class::MOP::Method'], + attributes => [ + Class::MOP::Attribute->new( + foo => ( + accessor => 'foo', + ) + ), + ], +); + +my $wrapped = Method::Subclass->wrap($method, foo => 'bar'); +isa_ok($wrapped, 'Method::Subclass'); +isa_ok($wrapped, 'Class::MOP::Method'); +is($wrapped->foo, 'bar', 'attribute set properly'); +is($wrapped->package_name, 'main', 'package_name copied properly'); +is($wrapped->name, '__ANON__', 'method name copied properly'); + +my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO'); +is($wrapped2->name, 'FOO', 'got a new method name'); + +{ + package Foo; + + sub full {1} + sub stub; +} + +{ + my $meta = Class::MOP::Class->initialize('Foo'); + + ok( $meta->has_method($_), "Foo class has $_ method" ) + for qw( full stub ); + + my $full = $meta->get_method('full'); + ok( !$full->is_stub, 'full is not a stub' ); + + my $stub = $meta->get_method('stub'); + + ok( $stub->is_stub, 'stub is a stub' ); +} + +done_testing; diff --git a/t/cmop/method_modifiers.t b/t/cmop/method_modifiers.t new file mode 100644 index 0000000..cb7078d --- /dev/null +++ b/t/cmop/method_modifiers.t @@ -0,0 +1,203 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; +use Class::MOP::Method; + +# test before and afters +{ + my $trace = ''; + + my $method = Class::MOP::Method->wrap( + body => sub { $trace .= 'primary' }, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + $method->(); + is( $trace, 'primary', '... got the right return value from method' ); + $trace = ''; + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + $wrapped->(); + is( $trace, 'primary', + '... got the right return value from the wrapped method' ); + $trace = ''; + + is( exception { + $wrapped->add_before_modifier( sub { $trace .= 'before -> ' } ); + }, undef, '... added the before modifier okay' ); + + $wrapped->(); + is( $trace, 'before -> primary', + '... got the right return value from the wrapped method (w/ before)' + ); + $trace = ''; + + is( exception { + $wrapped->add_after_modifier( sub { $trace .= ' -> after' } ); + }, undef, '... added the after modifier okay' ); + + $wrapped->(); + is( $trace, 'before -> primary -> after', + '... got the right return value from the wrapped method (w/ before)' + ); + $trace = ''; +} + +# test around method +{ + my $method = Class::MOP::Method->wrap( + sub {4}, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + is( $method->(), 4, '... got the right value from the wrapped method' ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + is( $wrapped->(), 4, '... got the right value from the wrapped method' ); + + is( exception { + $wrapped->add_around_modifier( sub { ( 3, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 2, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 1, $_[0]->() ) } ); + $wrapped->add_around_modifier( sub { ( 0, $_[0]->() ) } ); + }, undef, '... added the around modifier okay' ); + + is_deeply( + [ $wrapped->() ], + [ 0, 1, 2, 3, 4 ], + '... got the right results back from the around methods (in list context)' + ); + + is( scalar $wrapped->(), 4, + '... got the right results back from the around methods (in scalar context)' + ); +} + +{ + my @tracelog; + + my $method = Class::MOP::Method->wrap( + sub { push @tracelog => 'primary' }, + package_name => 'main', + name => '__ANON__', + ); + isa_ok( $method, 'Class::MOP::Method' ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); + isa_ok( $wrapped, 'Class::MOP::Method' ); + + is( exception { + $wrapped->add_before_modifier( sub { push @tracelog => 'before 1' } ); + $wrapped->add_before_modifier( sub { push @tracelog => 'before 2' } ); + $wrapped->add_before_modifier( sub { push @tracelog => 'before 3' } ); + }, undef, '... added the before modifier okay' ); + + is( exception { + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 1'; $_[0]->(); } ); + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 2'; $_[0]->(); } ); + $wrapped->add_around_modifier( + sub { push @tracelog => 'around 3'; $_[0]->(); } ); + }, undef, '... added the around modifier okay' ); + + is( exception { + $wrapped->add_after_modifier( sub { push @tracelog => 'after 1' } ); + $wrapped->add_after_modifier( sub { push @tracelog => 'after 2' } ); + $wrapped->add_after_modifier( sub { push @tracelog => 'after 3' } ); + }, undef, '... added the after modifier okay' ); + + $wrapped->(); + is_deeply( + \@tracelog, + [ + 'before 3', 'before 2', 'before 1', # last-in-first-out order + 'around 3', 'around 2', 'around 1', # last-in-first-out order + 'primary', + 'after 1', 'after 2', 'after 3', # first-in-first-out order + ], + '... got the right tracelog from all our before/around/after methods' + ); +} + +# test introspection +{ + sub before1 { + } + + sub before2 { + } + + sub before3 { + } + + sub after1 { + } + + sub after2 { + } + + sub after3 { + } + + sub around1 { + } + + sub around2 { + } + + sub around3 { + } + + sub orig { + } + + my $method = Class::MOP::Method->wrap( + body => \&orig, + package_name => 'main', + name => '__ANON__', + ); + + my $wrapped = Class::MOP::Method::Wrapped->wrap($method); + + $wrapped->add_before_modifier($_) + for \&before1, \&before2, \&before3; + + $wrapped->add_after_modifier($_) + for \&after1, \&after2, \&after3; + + $wrapped->add_around_modifier($_) + for \&around1, \&around2, \&around3; + + is( $wrapped->get_original_method, $method, + 'check get_original_method' ); + + is_deeply( [ $wrapped->before_modifiers ], + [ \&before3, \&before2, \&before1 ], + 'check before_modifiers' ); + + is_deeply( [ $wrapped->after_modifiers ], + [ \&after1, \&after2, \&after3 ], + 'check after_modifiers' ); + + is_deeply( [ $wrapped->around_modifiers ], + [ \&around3, \&around2, \&around1 ], + 'check around_modifiers' ); +} + +done_testing; diff --git a/t/cmop/methods.t b/t/cmop/methods.t new file mode 100644 index 0000000..a7a5d46 --- /dev/null +++ b/t/cmop/methods.t @@ -0,0 +1,431 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util qw/reftype/; +use Sub::Name; + +use Class::MOP; +use Class::MOP::Class; +use Class::MOP::Method; + +{ + # This package tries to test &has_method as exhaustively as + # possible. More corner cases are welcome :) + package Foo; + + # import a sub + use Scalar::Util 'blessed'; + + sub pie; + sub cake (); + + use constant FOO_CONSTANT => 'Foo-CONSTANT'; + + # define a sub in package + sub bar {'Foo::bar'} + *baz = \&bar; + + # create something with the typeglob inside the package + *baaz = sub {'Foo::baaz'}; + + { # method named with Sub::Name inside the package scope + no strict 'refs'; + *{'Foo::floob'} = Sub::Name::subname 'floob' => sub {'!floob!'}; + } + + # We hateses the "used only once" warnings + { + my $temp1 = \&Foo::baz; + my $temp2 = \&Foo::baaz; + } + + package OinkyBoinky; + our @ISA = "Foo"; + + sub elk {'OinkyBoinky::elk'} + + package main; + + sub Foo::blah { $_[0]->Foo::baz() } + + { + no strict 'refs'; + *{'Foo::bling'} = sub {'$$Bling$$'}; + *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub {'!BANG!'}; + *{'Foo::boom'} = Sub::Name::subname 'boom' => sub {'!BOOM!'}; + + eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }"; + } +} + +my $Foo = Class::MOP::Class->initialize('Foo'); + +is join(' ', sort $Foo->get_method_list), + 'FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie'; + +ok( $Foo->has_method('pie'), '... got the method stub pie' ); +ok( $Foo->has_method('cake'), '... got the constant method stub cake' ); + +my $foo = sub {'Foo::foo'}; + +ok( !Scalar::Util::blessed($foo), + '... our method is not yet blessed' ); + +is( exception { + $Foo->add_method( 'foo' => $foo ); +}, undef, '... we added the method successfully' ); + +my $foo_method = $Foo->get_method('foo'); + +isa_ok( $foo_method, 'Class::MOP::Method' ); + +is( $foo_method->name, 'foo', '... got the right name for the method' ); +is( $foo_method->package_name, 'Foo', + '... got the right package name for the method' ); + +ok( $Foo->has_method('foo'), + '... Foo->has_method(foo) (defined with Sub::Name)' ); + +is( $Foo->get_method('foo')->body, $foo, + '... Foo->get_method(foo) == \&foo' ); +is( $Foo->get_method('foo')->execute, 'Foo::foo', + '... _method_foo->execute returns "Foo::foo"' ); +is( Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"' ); + +my $bork_blessed = bless sub { }, 'Non::Meta::Class'; + +is( exception { + $Foo->add_method('bork', $bork_blessed); +}, undef, 'can add blessed sub as method'); + +# now check all our other items ... + +ok( $Foo->has_method('FOO_CONSTANT'), + '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)' ); +ok( !$Foo->has_method('bling'), + '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))' +); + +ok( $Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)' ); +ok( $Foo->has_method('baz'), + '... Foo->has_method(baz) (typeglob aliased within Foo)' ); +ok( $Foo->has_method('baaz'), + '... Foo->has_method(baaz) (typeglob aliased within Foo)' ); +ok( $Foo->has_method('floob'), + '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)' +); +ok( $Foo->has_method('blah'), + '... Foo->has_method(blah) (defined in main:: using fully qualified package name)' +); +ok( $Foo->has_method('bang'), + '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)' +); +ok( $Foo->has_method('evaled_foo'), + '... Foo->has_method(evaled_foo) (evaled in main::)' ); + +my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky'); + +ok( $OinkyBoinky->has_method('elk'), + "the method 'elk' is defined in OinkyBoinky" ); + +ok( !$OinkyBoinky->has_method('bar'), + "the method 'bar' is not defined in OinkyBoinky" ); + +ok( my $bar = $OinkyBoinky->find_method_by_name('bar'), + "but if you look in the inheritence chain then 'bar' does exist" ); + +is( reftype( $bar->body ), "CODE", "the returned value is a code ref" ); + +# calling get_method blessed them all +for my $method_name ( + qw/baaz + bar + baz + floob + blah + bang + bork + evaled_foo + FOO_CONSTANT/ + ) { + isa_ok( $Foo->get_method($method_name), 'Class::MOP::Method' ); + { + no strict 'refs'; + is( $Foo->get_method($method_name)->body, + \&{ 'Foo::' . $method_name }, + '... body matches CODE ref in package for ' . $method_name ); + } +} + +for my $method_name ( + qw/ + bling + / + ) { + is( ref( $Foo->get_package_symbol( '&' . $method_name ) ), 'CODE', + '... got the __ANON__ methods' ); + { + no strict 'refs'; + is( $Foo->get_package_symbol( '&' . $method_name ), + \&{ 'Foo::' . $method_name }, + '... symbol matches CODE ref in package for ' . $method_name ); + } +} + +ok( !$Foo->has_method('blessed'), + '... !Foo->has_method(blessed) (imported into Foo)' ); +ok( !$Foo->has_method('boom'), + '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)' +); + +ok( !$Foo->has_method('not_a_real_method'), + '... !Foo->has_method(not_a_real_method) (does not exist)' ); +is( $Foo->get_method('not_a_real_method'), undef, + '... Foo->get_method(not_a_real_method) == undef' ); + +is_deeply( + [ sort $Foo->get_method_list ], + [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob foo pie)], + '... got the right method list for Foo' +); + +my @universal_methods = qw/isa can VERSION/; +push @universal_methods, 'DOES' if $] >= 5.010; + +is_deeply( + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } $Foo->get_all_methods() + ], + [ + map { $_->name => $_ } + map { $Foo->find_method_by_name($_) } + sort qw( + FOO_CONSTANT + baaz + bang + bar + baz + blah + bork + cake + evaled_foo + floob + foo + pie + ), + @universal_methods, + ], + '... got the right list of applicable methods for Foo' +); + +is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' ); +ok( !$Foo->has_method('foo'), + '... !Foo->has_method(foo) we just removed it' ); +isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' ); + +is_deeply( + [ sort $Foo->get_method_list ], + [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob pie)], + '... got the right method list for Foo' +); + +# ... test our class creator + +my $Bar = Class::MOP::Class->create( + package => 'Bar', + superclasses => ['Foo'], + methods => { + foo => sub {'Bar::foo'}, + bar => sub {'Bar::bar'}, + } +); +isa_ok( $Bar, 'Class::MOP::Class' ); + +ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' ); +ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' ); + +is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' ); +is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' ); + +is( exception { + $Bar->add_method( 'foo' => sub {'Bar::foo v2'} ); +}, undef, '... overwriting a method is fine' ); + +is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ], + [ "Bar", "foo" ], "subname applied to anonymous method" ); + +ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' ); +is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' ); + +is_deeply( + [ sort $Bar->get_method_list ], + [qw(bar foo meta)], + '... got the right method list for Bar' +); + +is_deeply( + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } $Bar->get_all_methods() + ], + [ + map { $_->name => $_ } + sort { $a->name cmp $b->name } ( + $Foo->get_method('FOO_CONSTANT'), + $Foo->get_method('baaz'), + $Foo->get_method('bang'), + $Bar->get_method('bar'), + ( + map { $Foo->get_method($_) } + qw( + baz + blah + bork + cake + evaled_foo + floob + ) + ), + $Bar->get_method('foo'), + $Bar->get_method('meta'), + $Foo->get_method('pie'), + ( map { $Bar->find_next_method_by_name($_) } @universal_methods ) + ) + ], + '... got the right list of applicable methods for Bar' +); + +my $method = Class::MOP::Method->wrap( + name => 'objecty', + package_name => 'Whatever', + body => sub {q{I am an object, and I feel an object's pain}}, +); + +Bar->meta->add_method( $method->name, $method ); + +my $new_method = Bar->meta->get_method('objecty'); + +isnt( $method, $new_method, + 'add_method clones method objects as they are added' ); +is( $new_method->original_method, $method, + '... the cloned method has the correct original method' ) + or diag $new_method->dump; + +{ + package CustomAccessor; + + use Class::MOP; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->add_attribute( + foo => ( + accessor => 'foo', + ) + ); + + { + no warnings 'redefine', 'once'; + *foo = sub { + my $self = shift; + $self->{custom_store} = $_[0]; + }; + } + + $meta->add_around_method_modifier( + 'foo', + sub { + my $orig = shift; + $orig->(@_); + } + ); + + sub new { + return bless {}, shift; + } +} + +{ + my $o = CustomAccessor->new; + my $str = 'string'; + + $o->foo($str); + + is( + $o->{custom_store}, $str, + 'Custom glob-assignment-created accessor still has method modifier' + ); +} + +{ + # Since the sub reference below is not a closure, Perl caches it and uses + # the same reference each time through the loop. See RT #48985 for the + # bug. + foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) { + my $meta = Class::MOP::Class->create($ns); + + my $sub = sub { }; + + $meta->add_method( 'foo', $sub ); + + my $method = $meta->get_method('foo'); + ok( $method, 'Got the foo method back' ); + } +} + +{ + package HasConstants; + + use constant FOO => 1; + use constant BAR => []; + use constant BAZ => {}; + use constant UNDEF => undef; + + sub quux {1} + sub thing {1} +} + +my $HC = Class::MOP::Class->initialize('HasConstants'); + +is_deeply( + [ sort $HC->get_method_list ], + [qw( BAR BAZ FOO UNDEF quux thing )], + 'get_method_list handles constants properly' +); + +is_deeply( + [ sort map { $_->name } $HC->_get_local_methods ], + [qw( BAR BAZ FOO UNDEF quux thing )], + '_get_local_methods handles constants properly' +); + +{ + package DeleteFromMe; + sub foo { 1 } +} + +{ + my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe'); + ok($DFMmeta->get_method('foo')); + + delete $DeleteFromMe::{foo}; + + ok(!$DFMmeta->get_method('foo')); + ok(!DeleteFromMe->can('foo')); +} + +{ + my $baz_meta = Class::MOP::Class->initialize('Baz'); + $baz_meta->add_method(foo => sub { }); + my $stash = Package::Stash->new('Baz'); + $stash->remove_symbol('&foo'); + is_deeply([$baz_meta->get_method_list], [], "method is deleted"); + ok(!Baz->can('foo'), "Baz can't foo"); +} + + +done_testing; diff --git a/t/cmop/modify_parent_method.t b/t/cmop/modify_parent_method.t new file mode 100644 index 0000000..8ba6c43 --- /dev/null +++ b/t/cmop/modify_parent_method.t @@ -0,0 +1,99 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my @calls; + +{ + package Parent; + + use strict; + use warnings; + use metaclass; + + use Carp 'confess'; + + sub method { push @calls, 'Parent::method' } + + package Child; + + use strict; + use warnings; + use metaclass; + + use parent -norequire => 'Parent'; + + Child->meta->add_around_method_modifier( + 'method' => sub { + my $orig = shift; + push @calls, 'before Child::method'; + $orig->(@_); + push @calls, 'after Child::method'; + } + ); +} + +Parent->method; + +is_deeply( + [ splice @calls ], + [ + 'Parent::method', + ] +); + +Child->method; + +is_deeply( + [ splice @calls ], + [ + 'before Child::method', + 'Parent::method', + 'after Child::method', + ] +); + +{ + package Parent; + + Parent->meta->add_around_method_modifier( + 'method' => sub { + my $orig = shift; + push @calls, 'before Parent::method'; + $orig->(@_); + push @calls, 'after Parent::method'; + } + ); +} + +Parent->method; + +is_deeply( + [ splice @calls ], + [ + 'before Parent::method', + 'Parent::method', + 'after Parent::method', + ] +); + +Child->method; + +TODO: { + local $TODO = "pending fix"; + is_deeply( + [ splice @calls ], + [ + 'before Child::method', + 'before Parent::method', + 'Parent::method', + 'after Parent::method', + 'after Child::method', + ], + "cache is correctly invalidated when the parent method is wrapped" + ); +} + +done_testing; diff --git a/t/cmop/new_and_clone_metaclasses.t b/t/cmop/new_and_clone_metaclasses.t new file mode 100644 index 0000000..1212c97 --- /dev/null +++ b/t/cmop/new_and_clone_metaclasses.t @@ -0,0 +1,124 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +use lib 't/cmop/lib'; + +# make sure the Class::MOP::Class->meta does the right thing + +my $meta = Class::MOP::Class->meta(); +isa_ok($meta, 'Class::MOP::Class'); + +my $new_meta = $meta->new_object('package' => 'Class::MOP::Class'); +isa_ok($new_meta, 'Class::MOP::Class'); +is($new_meta, $meta, '... it still creates the singleton'); + +my $cloned_meta = $meta->clone_object($meta); +isa_ok($cloned_meta, 'Class::MOP::Class'); +is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it'); + +# make sure other metaclasses do the right thing + +{ + package Foo; + use metaclass; +} + +my $foo_meta = Foo->meta; +isa_ok($foo_meta, 'Class::MOP::Class'); + +is($meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton'); +is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton'); + +# make sure subclassed of Class::MOP::Class do the right thing + +my $my_meta = MyMetaClass->meta; +isa_ok($my_meta, 'Class::MOP::Class'); + +my $new_my_meta = $my_meta->new_object('package' => 'MyMetaClass'); +isa_ok($new_my_meta, 'Class::MOP::Class'); +is($new_my_meta, $my_meta, '... even subclasses still create the singleton'); + +my $cloned_my_meta = $meta->clone_object($my_meta); +isa_ok($cloned_my_meta, 'Class::MOP::Class'); +is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it'); + +is($my_meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)'); +is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)'); + +# now create a metaclass for real + +my $bar_meta = $my_meta->new_object('package' => 'Bar'); +isa_ok($bar_meta, 'Class::MOP::Class'); + +is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass'); +is($bar_meta->version, undef, '... Bar does not exists, so it has no version'); + +$bar_meta->superclasses('Foo'); + +# check with MyMetaClass + +{ + package Baz; + use metaclass 'MyMetaClass'; +} + +my $baz_meta = Baz->meta; +isa_ok($baz_meta, 'Class::MOP::Class'); +isa_ok($baz_meta, 'MyMetaClass'); + +is($my_meta->new_object('package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton'); +is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton'); + +$baz_meta->superclasses('Bar'); + +# now create a regular objects for real + +my $foo = $foo_meta->new_object(); +isa_ok($foo, 'Foo'); + +my $bar = $bar_meta->new_object(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +my $baz = $baz_meta->new_object(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +my $cloned_foo = $foo_meta->clone_object($foo); +isa_ok($cloned_foo, 'Foo'); + +isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo'); + +# check some errors + +isnt( exception { + $foo_meta->clone_object($meta); +}, undef, '... this dies as expected' ); + +# test stuff + +{ + package FooBar; + use metaclass; + + FooBar->meta->add_attribute('test'); +} + +my $attr = FooBar->meta->get_attribute('test'); +isa_ok($attr, 'Class::MOP::Attribute'); + +my $attr_clone = $attr->clone(); +isa_ok($attr_clone, 'Class::MOP::Attribute'); + +isnt($attr, $attr_clone, '... we successfully cloned our attributes'); +is($attr->associated_class, + $attr_clone->associated_class, + '... we successfully did not clone our associated metaclass'); + +done_testing; diff --git a/t/cmop/null_stash.t b/t/cmop/null_stash.t new file mode 100644 index 0000000..ee5d363 --- /dev/null +++ b/t/cmop/null_stash.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +use Class::MOP; +my $non = Class::MOP::Class->initialize('Non::Existent::Package'); +$non->get_method('foo'); + +pass("empty stashes don't segfault"); + +done_testing; diff --git a/t/cmop/numeric_defaults.t b/t/cmop/numeric_defaults.t new file mode 100644 index 0000000..4c3102a --- /dev/null +++ b/t/cmop/numeric_defaults.t @@ -0,0 +1,124 @@ +use strict; +use warnings; +use Test::More; +use B; +use Class::MOP; + +my @int_defaults = ( + 100, + -2, + 01234, + 0xFF, +); + +my @num_defaults = ( + 10.5, + -20.0, + 1e3, + 1.3e-10, +); + +my @string_defaults = ( + 'foo', + '', + '100', + '10.5', + '1e3', + '0 but true', + '01234', + '09876', + '0xFF', +); + +for my $default (@int_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy)"); + ok(!($flags & B::SVf_POK), "not a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy) (immutable)"); + ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); + } +} + +for my $default (@num_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy)"); + ok(!($flags & B::SVf_POK), "not a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy) (immutable)"); + ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); + } +} + +for my $default (@string_defaults) { + my $copy = $default; # so we can print it out without modifying flags + my $attr = Class::MOP::Attribute->new( + foo => (default => $default, reader => 'foo'), + ); + my $meta = Class::MOP::Class->create_anon_class( + attributes => [$attr], + methods => {bar => sub { $default }}, + ); + + my $obj = $meta->new_object; + for my $meth (qw(foo bar)) { + my $val = $obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_POK, "it's a string ($copy)"); + } + + $meta->make_immutable; + + my $immutable_obj = $meta->name->new; + for my $meth (qw(foo bar)) { + my $val = $immutable_obj->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_POK, "it's a string ($copy) (immutable)"); + } +} + +done_testing; diff --git a/t/cmop/package_variables.t b/t/cmop/package_variables.t new file mode 100644 index 0000000..bcf960a --- /dev/null +++ b/t/cmop/package_variables.t @@ -0,0 +1,230 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use metaclass; +} + +=pod + +This is the same test as 080_meta_package.t just here +we call all the methods through Class::MOP::Class. + +=cut + +# ---------------------------------------------------------------------- +## tests adding a HASH + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +is( exception { + Foo->meta->add_package_symbol('%foo' => { one => 1 }); +}, undef, '... created %Foo::foo successfully' ); + +# ... scalar should NOT be created here + +ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = Foo->meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +}, undef, '... created @Foo::bar successfully' ); + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('$baz' => 10); +}, undef, '... created $Foo::baz successfully' ); + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +is( exception { + Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); +}, undef, '... created &Foo::funk successfully' ); + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +is( exception { + Foo->meta->add_package_symbol('@foo' => $ARRAY); +}, undef, '... created @Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('&foo' => $CODE); +}, undef, '... created &Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +is( exception { + Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); +}, undef, '... created $Foo::foo successfully' ); + +ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = Foo->meta->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +is( exception { + Foo->meta->remove_package_symbol('%foo'); +}, undef, '... removed %Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('&foo'); +}, undef, '... removed &Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +is( exception { + Foo->meta->remove_package_symbol('$foo'); +}, undef, '... removed $Foo::foo successfully' ); + +ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +done_testing; diff --git a/t/cmop/random_eval_bug.t b/t/cmop/random_eval_bug.t new file mode 100644 index 0000000..285edb0 --- /dev/null +++ b/t/cmop/random_eval_bug.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +=pod + +This tests a bug which is fixed in 0.22 by localizing all the $@'s around any +evals. + +This a real pain to track down. + +Moral of the story: + + ALWAYS localize your globals :) + +=cut + +{ + package Company; + use strict; + use warnings; + use metaclass; + + sub new { + my ($class) = @_; + return bless {} => $class; + } + + sub employees { + die "This didnt work"; + } + + sub DESTROY { + my $self = shift; + foreach + my $method ( $self->meta->find_all_methods_by_name('DEMOLISH') ) { + $method->{code}->($self); + } + } +} + +eval { + my $c = Company->new(); + $c->employees(); +}; +ok( $@, '... we die correctly with bad args' ); + +done_testing; diff --git a/t/cmop/rebless_instance.t b/t/cmop/rebless_instance.t new file mode 100644 index 0000000..4cbefd6 --- /dev/null +++ b/t/cmop/rebless_instance.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Scalar::Util 'blessed'; + +{ + package Parent; + use metaclass; + + sub new { bless {} => shift } + sub whoami { "parent" } + sub parent { "parent" } + + package Child; + use metaclass; + use parent -norequire => 'Parent'; + + sub whoami { "child" } + sub child { "child" } + + package LeftField; + use metaclass; + + sub new { bless {} => shift } + sub whoami { "leftfield" } + sub myhax { "areleet" } +} + +# basic tests +my $foo = Parent->new; +is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); +is($foo->whoami, "parent", 'Parent->whoami gives parent'); +is($foo->parent, "parent", 'Parent->parent gives parent'); +isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); + +Child->meta->rebless_instance($foo); +is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance'); +is($foo->whoami, "child", 'reblessed->whoami gives child'); +is($foo->parent, "parent", 'reblessed->parent gives parent'); +is($foo->child, "child", 'reblessed->child gives child'); + +like( exception { LeftField->meta->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./ ); + +like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./ ); + +Parent->meta->rebless_instance_back($foo); +is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); +is($foo->whoami, "parent", 'Parent->whoami gives parent'); +is($foo->parent, "parent", 'Parent->parent gives parent'); +isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); + +like( exception { LeftField->meta->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./ ); + +like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./ ); + +# make sure our ->meta is still sane +my $bar = Parent->new; +is(blessed($bar), 'Parent', "sanity check"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); + +ok($bar->meta->has_method('new'), 'metaclass has "new" method'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); + +is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); + +Child->meta->rebless_instance($bar); +is(blessed($bar), 'Child', "rebless really reblessed"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child"); + +ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method'); +ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method'); +ok(!$bar->meta->has_method('new'), 'no "new" method in this class'); +ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('child'), 'metaclass has "child" method'); + +is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child'); + +Parent->meta->rebless_instance_back($bar); +is(blessed($bar), 'Parent', "sanity check"); +is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); +is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); + +ok($bar->meta->has_method('new'), 'metaclass has "new" method'); +ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); +ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); + +is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); + +done_testing; diff --git a/t/cmop/rebless_instance_away.t b/t/cmop/rebless_instance_away.t new file mode 100644 index 0000000..ad411ec --- /dev/null +++ b/t/cmop/rebless_instance_away.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +my @calls; + +do { + package My::Meta::Class; + use parent 'Class::MOP::Class'; + + sub rebless_instance_away { + push @calls, [@_]; + shift->SUPER::rebless_instance_away(@_); + } +}; + +do { + package Parent; + use metaclass 'My::Meta::Class'; + + package Child; + use metaclass 'My::Meta::Class'; + use parent -norequire => 'Parent'; +}; + +my $person = Parent->meta->new_object; +Child->meta->rebless_instance($person); + +is(@calls, 1, "one call to rebless_instance_away"); +is($calls[0][0]->name, 'Parent', 'rebless_instance_away is called on the old metaclass'); +is($calls[0][1], $person, 'with the instance'); +is($calls[0][2]->name, 'Child', 'and the new metaclass'); +splice @calls; + +Child->meta->rebless_instance($person, foo => 1); +is($calls[0][0]->name, 'Child'); +is($calls[0][1], $person); +is($calls[0][2]->name, 'Child'); +is($calls[0][3], 'foo'); +is($calls[0][4], 1); +splice @calls; + +done_testing; diff --git a/t/cmop/rebless_overload.t b/t/cmop/rebless_overload.t new file mode 100644 index 0000000..c3a7a68 --- /dev/null +++ b/t/cmop/rebless_overload.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +do { + package Without::Overloading; + sub new { bless {}, shift } + + package With::Overloading; + use parent -norequire => 'Without::Overloading'; + use overload q{""} => sub { "overloaded" }; +}; + +my $without = bless {}, "Without::Overloading"; +like("$without", qr/^Without::Overloading/, "no overloading"); + +my $with = With::Overloading->new; +is("$with", "overloaded", "initial overloading works"); + + +my $meta = Class::MOP::Class->initialize('With::Overloading'); + +$meta->rebless_instance($without); +is("$without", "overloaded", "overloading after reblessing works"); + +done_testing; diff --git a/t/cmop/rebless_with_extra_params.t b/t/cmop/rebless_with_extra_params.t new file mode 100644 index 0000000..2493ec4 --- /dev/null +++ b/t/cmop/rebless_with_extra_params.t @@ -0,0 +1,95 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::MOP; + +{ + package Foo; + use metaclass; + Foo->meta->add_attribute('bar' => (reader => 'bar')); + + sub new { (shift)->meta->new_object(@_) } + + package Bar; + use metaclass; + use parent -norequire => 'Foo'; + Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ')); +} + +# normal ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo, (baz => 'FOO-BAZ')) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); +} + +# with extra params ... +{ + my $foo = Foo->new(bar => 'BAR'); + isa_ok($foo, 'Foo'); + + is($foo->bar, 'BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + + is( exception { + Bar->meta->rebless_instance($foo, (bar => 'FOO-BAR', baz => 'FOO-BAZ')) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok($foo->can('baz'), '... we have baz method now'); + is($foo->baz, 'FOO-BAZ', '... got the expect value'); + + is( exception { + Foo->meta->rebless_instance_back($foo) + }, undef, '... this works' ); + + is($foo->bar, 'FOO-BAR', '... got the expect value'); + ok(!$foo->can('baz'), '... no baz method though'); + ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); +} + +done_testing; diff --git a/t/cmop/scala_style_mixin_composition.t b/t/cmop/scala_style_mixin_composition.t new file mode 100644 index 0000000..428b77d --- /dev/null +++ b/t/cmop/scala_style_mixin_composition.t @@ -0,0 +1,172 @@ +use strict; +use warnings; + +use Test::More; +use Test::Requires { + 'SUPER' => 1.10, # skip all if not installed +}; + +=pod + +This test demonstrates how simple it is to create Scala Style +Class Mixin Composition. Below is an example taken from the +Scala web site's example section, and trancoded to Class::MOP. + +NOTE: +We require SUPER for this test to handle the issue with SUPER:: +being determined at compile time. + +L<http://scala.epfl.ch/intro/mixin.html> + +A class can only be used as a mixin in the definition of another +class, if this other class extends a subclass of the superclass +of the mixin. Since ColoredPoint3D extends Point3D and Point3D +extends Point2D which is the superclass of ColoredPoint2D, the +code above is well-formed. + + class Point2D(xc: Int, yc: Int) { + val x = xc; + val y = yc; + override def toString() = "x = " + x + ", y = " + y; + } + + class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) { + val color = c; + def setColor(newCol: String): Unit = color = newCol; + override def toString() = super.toString() + ", col = " + color; + } + + class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) { + val z = zc; + override def toString() = super.toString() + ", z = " + z; + } + + class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String) + extends Point3D(xc, yc, zc) + with ColoredPoint2D(xc, yc, col); + + + Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString()) + + "x = 1, y = 2, z = 3, col = blue" + +=cut + +use Scalar::Util 'blessed'; +use Carp 'confess'; + +sub ::with ($) { + # fetch the metaclass for the + # caller and the mixin arg + my $metaclass = (caller)->meta; + my $mixin = (shift)->meta; + + # according to Scala, the + # the superclass of our class + # must be a subclass of the + # superclass of the mixin (see above) + my ($super_meta) = $metaclass->superclasses(); + my ($super_mixin) = $mixin->superclasses(); + ($super_meta->isa($super_mixin)) + || confess "The superclass must extend a subclass of the superclass of the mixin"; + + # collect all the attributes + # and clone them so they can + # associate with the new class + my @attributes = map { + $mixin->get_attribute($_)->clone() + } $mixin->get_attribute_list; + + my %methods = map { + my $method = $mixin->get_method($_); + # we want to ignore accessors since + # they will be created with the attrs + (blessed($method) && $method->isa('Class::MOP::Method::Accessor')) + ? () : ($_ => $method) + } $mixin->get_method_list; + + # NOTE: + # I assume that locally defined methods + # and attributes get precedence over those + # from the mixin. + + # add all the attributes in .... + foreach my $attr (@attributes) { + $metaclass->add_attribute($attr) + unless $metaclass->has_attribute($attr->name); + } + + # add all the methods in .... + foreach my $method_name (keys %methods) { + $metaclass->add_method($method_name => $methods{$method_name}) + unless $metaclass->has_method($method_name); + } +} + +{ + package Point2D; + use metaclass; + + Point2D->meta->add_attribute('$x' => ( + accessor => 'x', + init_arg => 'x', + )); + + Point2D->meta->add_attribute('$y' => ( + accessor => 'y', + init_arg => 'y', + )); + + sub new { + my $class = shift; + $class->meta->new_object(@_); + } + + sub toString { + my $self = shift; + "x = " . $self->x . ", y = " . $self->y; + } + + package ColoredPoint2D; + our @ISA = ('Point2D'); + + ColoredPoint2D->meta->add_attribute('$color' => ( + accessor => 'color', + init_arg => 'color', + )); + + sub toString { + my $self = shift; + $self->SUPER() . ', col = ' . $self->color; + } + + package Point3D; + our @ISA = ('Point2D'); + + Point3D->meta->add_attribute('$z' => ( + accessor => 'z', + init_arg => 'z', + )); + + sub toString { + my $self = shift; + $self->SUPER() . ', z = ' . $self->z; + } + + package ColoredPoint3D; + our @ISA = ('Point3D'); + + ::with('ColoredPoint2D'); + +} + +my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue'); +isa_ok($colored_point_3d, 'ColoredPoint3D'); +isa_ok($colored_point_3d, 'Point3D'); +isa_ok($colored_point_3d, 'Point2D'); + +is($colored_point_3d->toString(), + 'x = 1, y = 2, z = 3, col = blue', + '... got the right toString method'); + +done_testing; diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t new file mode 100644 index 0000000..69128f2 --- /dev/null +++ b/t/cmop/self_introspection.t @@ -0,0 +1,359 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; +use Class::MOP::Class; +use Class::MOP::Package; +use Class::MOP::Module; + +{ + my $class = Class::MOP::Class->initialize('Foo'); + is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta'); +} + +my $class_mop_class_meta = Class::MOP::Class->meta(); +isa_ok($class_mop_class_meta, 'Class::MOP::Class'); + +my $class_mop_package_meta = Class::MOP::Package->meta(); +isa_ok($class_mop_package_meta, 'Class::MOP::Package'); + +my $class_mop_module_meta = Class::MOP::Module->meta(); +isa_ok($class_mop_module_meta, 'Class::MOP::Module'); + +my @class_mop_package_methods = qw( + _new + + initialize reinitialize create create_anon is_anon + _free_anon _anon_cache_key _anon_package_prefix + + name + namespace + + add_package_symbol get_package_symbol has_package_symbol + remove_package_symbol get_or_add_package_symbol + list_all_package_symbols get_all_package_symbols remove_package_glob + + _package_stash + + DESTROY +); + +my @class_mop_module_methods = qw( + _new + + _instantiate_module + + version authority identifier create + + _anon_cache_key _anon_package_prefix +); + +my @class_mop_class_methods = qw( + _new + + is_pristine + + initialize reinitialize create + + create_anon_class is_anon_class + _anon_cache_key _anon_package_prefix + + instance_metaclass get_meta_instance + _inline_create_instance + _inline_rebless_instance + _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot + _create_meta_instance + new_object clone_object + _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses + _inline_slot_initializer _inline_extra_init _inline_fallback_constructor + _inline_generate_instance _inline_params _inline_slot_initializers + _inline_init_attr_from_constructor _inline_init_attr_from_default + _generate_fallback_constructor + _eval_environment + _construct_instance + _construct_class_instance + _clone_instance + rebless_instance rebless_instance_back rebless_instance_away + _force_rebless_instance _fixup_attributes_after_rebless + _check_metaclass_compatibility + _check_class_metaclass_compatibility _check_single_metaclass_compatibility + _class_metaclass_is_compatible _single_metaclass_is_compatible + _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility + _fix_single_metaclass_incompatibility _base_metaclasses + _can_fix_metaclass_incompatibility + _class_metaclass_can_be_made_compatible + _single_metaclass_can_be_made_compatible + + _remove_generated_metaobjects + _restore_metaobjects_from + + add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies + add_dependent_meta_instance remove_dependent_meta_instance + invalidate_meta_instances invalidate_meta_instance + + superclasses subclasses direct_subclasses class_precedence_list + linearized_isa _method_lookup_order _superclasses_updated _superclass_metas + + get_all_method_names get_all_methods + find_method_by_name find_all_methods_by_name find_next_method_by_name + + add_before_method_modifier add_after_method_modifier add_around_method_modifier + + _attach_attribute + _post_add_attribute + remove_attribute + find_attribute_by_name + get_all_attributes + + is_mutable is_immutable make_mutable make_immutable + _initialize_immutable _install_inlined_code _inlined_methods + _add_inlined_method _inline_accessors _inline_constructor + _inline_destructor _immutable_options _real_ref_name + _rebless_as_immutable _rebless_as_mutable _remove_inlined_code + + _immutable_metaclass + immutable_trait immutable_options + constructor_name constructor_class destructor_class +); + +# check the class ... + +is_deeply([ sort $class_mop_class_meta->get_method_list ], [ sort @class_mop_class_methods ], '... got the correct method list for class'); + +foreach my $method_name (sort @class_mop_class_methods) { + ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_class_meta->get_method($method_name)->body, + \&{'Class::MOP::Class::' . $method_name}, + '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name); + } +} + +## check the package .... + +is_deeply([ sort $class_mop_package_meta->get_method_list ], [ sort @class_mop_package_methods ], '... got the correct method list for package'); + +foreach my $method_name (sort @class_mop_package_methods) { + ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_package_meta->get_method($method_name)->body, + \&{'Class::MOP::Package::' . $method_name}, + '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name); + } +} + +## check the module .... + +is_deeply([ sort $class_mop_module_meta->get_method_list ], [ sort @class_mop_module_methods ], '... got the correct method list for module'); + +foreach my $method_name (sort @class_mop_module_methods) { + ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')'); + { + no strict 'refs'; + is($class_mop_module_meta->get_method($method_name)->body, + \&{'Class::MOP::Module::' . $method_name}, + '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name); + } +} + + +# check for imported functions which are not methods + +foreach my $non_method_name (qw( + confess + blessed + subname + svref_2object + )) { + ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); +} + +# check for the right attributes + +my @class_mop_package_attributes = ( + 'package', + 'namespace', +); + +my @class_mop_module_attributes = ( + 'version', + 'authority' +); + +my @class_mop_class_attributes = ( + 'superclasses', + 'instance_metaclass', + 'immutable_trait', + 'constructor_name', + 'constructor_class', + 'destructor_class', +); + +# check class + +is_deeply( + [ sort $class_mop_class_meta->get_attribute_list ], + [ sort @class_mop_class_attributes ], + '... got the right list of attributes' +); + +is_deeply( + [ sort keys %{$class_mop_class_meta->_attribute_map} ], + [ sort @class_mop_class_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_class_attributes) { + ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +# check module + +is_deeply( + [ sort $class_mop_package_meta->get_attribute_list ], + [ sort @class_mop_package_attributes ], + '... got the right list of attributes'); + +is_deeply( + [ sort keys %{$class_mop_package_meta->_attribute_map} ], + [ sort @class_mop_package_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_package_attributes) { + ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +# check package + +is_deeply( + [ sort $class_mop_module_meta->get_attribute_list ], + [ sort @class_mop_module_attributes ], + '... got the right list of attributes'); + +is_deeply( + [ sort keys %{$class_mop_module_meta->_attribute_map} ], + [ sort @class_mop_module_attributes ], + '... got the right list of attributes'); + +foreach my $attribute_name (sort @class_mop_module_attributes) { + ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); +} + +## check the attributes themselves + +# ... package + +ok($class_mop_package_meta->get_attribute('package')->has_reader, '... Class::MOP::Class package has a reader'); +is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... Class::MOP::Class package\'s a reader is { name => sub { ... } }'); + +ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg'); +is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package'); + +# ... class, but inherited from HasMethods +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('method_metaclass')->reader, + { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass }, + '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->init_arg, + 'method_metaclass', + '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); + +ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->reader, + { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass }, + '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg, + 'wrapped_method_metaclass', + '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); + + +# ... class, but inherited from HasAttributes + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader, + { '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map }, + '... Class::MOP::Class attributes\'s a reader is &_attribute_map'); + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg, + 'attributes', + '... Class::MOP::Class attributes\'s a init_arg is attributes'); + +ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'), + {}, + '... Class::MOP::Class attributes\'s a default of {}'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader'); +is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader, + { 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass }, + '... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg'); +is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg, + 'attribute_metaclass', + '... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass'); + +ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default'); +is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default, + 'Class::MOP::Attribute', + '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute'); + +# check the values of some of the methods + +is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name'); +is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version'); + +if ( defined $Class::MOP::Class::VERSION ) { + ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)'); +} +is(${$class_mop_class_meta->get_package_symbol('$VERSION')}, + $Class::MOP::Class::VERSION, + '... Class::MOP::Class->get_package_symbol($VERSION)'); + +is_deeply( + [ $class_mop_class_meta->superclasses ], + [ qw/Class::MOP::Module Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods Class::MOP::Mixin::HasOverloads/ ], + '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]'); + +is_deeply( + [ $class_mop_class_meta->class_precedence_list ], + [ qw/ + Class::MOP::Class + Class::MOP::Module + Class::MOP::Package + Class::MOP::Object + Class::MOP::Mixin + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin + Class::MOP::Mixin::HasOverloads + Class::MOP::Mixin + / ], + '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]'); + +is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass'); +is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass'); +is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass'); + +done_testing; diff --git a/t/cmop/subclasses.t b/t/cmop/subclasses.t new file mode 100644 index 0000000..3104bf4 --- /dev/null +++ b/t/cmop/subclasses.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; +use Class::MOP; + +do { + package Grandparent; + use metaclass; + + package Parent; + use metaclass; + use parent -norequire => 'Grandparent'; + + package Uncle; + use metaclass; + use parent -norequire => 'Grandparent'; + + package Son; + use metaclass; + use parent -norequire => 'Parent'; + + package Daughter; + use metaclass; + use parent -norequire => 'Parent'; + + package Cousin; + use metaclass; + use parent -norequire => 'Uncle'; +}; + +is_deeply([sort Grandparent->meta->subclasses], ['Cousin', 'Daughter', 'Parent', 'Son', 'Uncle']); +is_deeply([sort Parent->meta->subclasses], ['Daughter', 'Son']); +is_deeply([sort Uncle->meta->subclasses], ['Cousin']); +is_deeply([sort Son->meta->subclasses], []); +is_deeply([sort Daughter->meta->subclasses], []); +is_deeply([sort Cousin->meta->subclasses], []); + +is_deeply([sort Grandparent->meta->direct_subclasses], ['Parent', 'Uncle']); +is_deeply([sort Parent->meta->direct_subclasses], ['Daughter', 'Son']); +is_deeply([sort Uncle->meta->direct_subclasses], ['Cousin']); +is_deeply([sort Son->meta->direct_subclasses], []); +is_deeply([sort Daughter->meta->direct_subclasses], []); +is_deeply([sort Cousin->meta->direct_subclasses], []); + +done_testing; diff --git a/t/cmop/subname.t b/t/cmop/subname.t new file mode 100644 index 0000000..6c113cc --- /dev/null +++ b/t/cmop/subname.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More; + +use Class::MOP; + +{ + + package Origin; + sub bar { ( caller(0) )[3] } + + package Foo; +} + +my $Foo = Class::MOP::Class->initialize('Foo'); + +$Foo->add_method( foo => sub { ( caller(0) )[3] } ); + +is_deeply( + [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], + [ "Foo", "foo" ], + "subname applied to anonymous method", +); + +is( Foo->foo, "Foo::foo", "caller() aggrees" ); + +$Foo->add_method( bar => \&Origin::bar ); + +is( Origin->bar, "Origin::bar", "normal caller() operation in unrelated class" ); + +is_deeply( + [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], + [ "Foo", "foo" ], + "subname not applied if a name already exists", +); + +is( Foo->bar, "Origin::bar", "caller aggrees" ); + +is( Origin->bar, "Origin::bar", "unrelated class untouched" ); + +done_testing; diff --git a/t/cmop/universal_methods.t b/t/cmop/universal_methods.t new file mode 100644 index 0000000..0d3d646 --- /dev/null +++ b/t/cmop/universal_methods.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; +use Class::MOP; + +my $meta_class = Class::MOP::Class->create_anon_class; + +my %methods = map { $_->name => 1 } $meta_class->get_all_methods(); +my %method_names = map { $_ => 1 } $meta_class->get_all_method_names(); + +my @universal_methods = qw/isa can VERSION/; +push @universal_methods, 'DOES' if $] >= 5.010; + +for my $method (@universal_methods) { + ok( + $meta_class->find_method_by_name($method), + "find_method_by_name finds UNIVERSAL method $method" + ); + ok( + $meta_class->find_next_method_by_name($method), + "find_next_method_by_name finds UNIVERSAL method $method" + ); + ok( + scalar $meta_class->find_all_methods_by_name($method), + "find_all_methods_by_name finds UNIVERSAL method $method" + ); + ok( + $methods{$method}, + "get_all_methods includes $method from UNIVERSAL" + ); + ok( + $method_names{$method}, + "get_all_method_names includes $method from UNIVERSAL" + ); +} + +done_testing; |