diff options
Diffstat (limited to 't/metaclasses/overloading.t')
| -rw-r--r-- | t/metaclasses/overloading.t | 480 |
1 files changed, 480 insertions, 0 deletions
diff --git a/t/metaclasses/overloading.t b/t/metaclasses/overloading.t new file mode 100644 index 0000000..31cd907 --- /dev/null +++ b/t/metaclasses/overloading.t @@ -0,0 +1,480 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Sub::Name qw( subname ); + +my $quote = qr/['`"]/; + +{ + package Foo; + use Moose; +} + +{ + my $meta = Foo->meta; + + subtest( + 'Foo class (not overloaded)', + sub { + ok( !$meta->is_overloaded, 'is not overloaded' ); + + ok( + !$meta->has_overloaded_operator('+'), + 'has no + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], [], + '->get_overload_list returns an empty list' + ); + + is_deeply( + [ $meta->get_all_overloaded_operators ], [], + '->get_all_overloaded_operators return an empty list' + ); + + is( + $meta->get_overloaded_operator('+'), undef, + 'get_overloaded_operator(+) returns undef' + ); + is( + $meta->get_overloaded_operator('-'), undef, + 'get_overloaded_operator(-) returns undef' + ); + } + ); +} + +my $plus = 0; +my $plus_impl; + +BEGIN { + $plus_impl = sub { $plus = 1; 42 } +} +{ + package Foo::Overloaded; + use Moose; + use overload '+' => $plus_impl; +} + +{ + my $meta = Foo::Overloaded->meta; + + subtest( + 'Foo::Overload class (overloaded with coderef)', + sub { + ok( $meta->is_overloaded, 'is overloaded' ); + + ok( + $meta->has_overloaded_operator('+'), + 'has + overloading' + ); + ok( + !$meta->has_overloaded_operator('-'), + 'has no - overloading' + ); + + is_deeply( + [ $meta->get_overload_list ], ['+'], + '->get_overload_list returns (+) ' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 operator' + ); + my $plus_overload = $overloads[0]; + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( $plus_overload->operator, '+', 'operator for overload is +' ); + is( + $plus_overload->coderef, $plus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $plus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $plus_overload->coderef_name, '__ANON__', + 'coderef name for overload is __ANON__' + ); + ok( + $plus_overload->is_anonymous, + 'overload is anonymous' + ); + ok( + !$plus_overload->has_method_name, + 'overload has no method name' + ); + ok( + !$plus_overload->has_method, + 'overload has no method' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + my $plus_overload2 = $meta->get_overloaded_operator('+'); + is( + $plus_overload2, $plus_overload, + '->get_overloaded_operator(+) returns the same operator on each call' + ); + + is( $plus, 0, '+ overloading has not been called' ); + is( + Foo::Overloaded->new + Foo::Overloaded->new, 42, + '+ overloading returns 42' + ); + is( $plus, 1, '+ overloading was called once' ); + + ok( + $plus_overload->_is_equal_to($plus_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $plus_overload3 = Class::MOP::Overload->new( + operator => '+', + coderef => $plus_impl, + coderef_package => 'main', + coderef_name => '__ANON__', + ); + + ok( + $plus_overload->_is_equal_to($plus_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + my $minus = 0; + my $minus_impl + = subname( 'overload_minus', sub { $minus = 1; -42 } ); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails' + ); + + $meta->add_overloaded_operator( '-' => $minus_impl ); + + ok( + $meta->has_overloaded_operator('-'), + 'has - operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '+', '-' ], + '->get_overload_list returns (+, -)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $minus_overload = $meta->get_overloaded_operator('-'); + isa_ok( + $minus_overload, 'Class::MOP::Overload', + 'object for - overloading' + ); + is( + $minus_overload->operator, '-', + 'operator for overload is -' + ); + is( + $minus_overload->coderef, $minus_impl, + 'coderef for overload matches sub we passed' + ); + is( + $minus_overload->coderef_package, 'main', + 'coderef package for overload is main' + ); + is( + $minus_overload->coderef_name, 'overload_minus', + 'coderef name for overload is overload_minus' + ); + ok( + !$minus_overload->is_anonymous, + 'overload is not anonymous' + ); + is( + $minus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $minus, 0, '- overloading has not been called' ); + is( + Foo::Overloaded->new - Foo::Overloaded->new, -42, + '- overloading returns -42' + ); + is( $minus, 1, '+- overloading was called once' ); + + ok( + !$plus_overload->_is_equal_to($minus_overload), + '_is_equal_to returns false for objects with different properties' + ); + + $meta->remove_overloaded_operator('-'); + + like( + exception { Foo::Overloaded->new - Foo::Overloaded->new }, + qr/Operation $quote-$quote: no .+ found/, + 'trying to call - on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +my $times = 0; +my $divided = 0; +{ + package Foo::OverloadWithMethod; + use Moose; + use overload '*' => 'times'; + + sub times { $times = 1; 'times' } + sub divided { $divided = 1; 'divided' } +} + +{ + my $meta = Foo::OverloadWithMethod->meta; + + subtest( + 'Foo::OverloadWithMethod (overloaded via method)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('*'), + 'overloads *' + ); + ok( + !$meta->has_overloaded_operator('/'), + 'does not overload /' + ); + + is_deeply( + [ $meta->get_overload_list ], ['*'], + '->get_overload_list returns (*)' + ); + + my @overloads = $meta->get_all_overloaded_operators; + is( + scalar(@overloads), 1, + '->get_all_overloaded_operators returns 1 item' + ); + my $times_overload = $overloads[0]; + isa_ok( + $times_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $times_overload->operator, '*', + 'operator for overload is +' + ); + ok( + $times_overload->has_method_name, + 'overload has a method name' + ); + is( + $times_overload->method_name, 'times', + q{method name is 'times'} + ); + ok( + !$times_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$times_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$times_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$times_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + $times_overload->has_method, + 'overload has a method' + ); + is( + $times_overload->method, $meta->get_method('times'), + '->method returns method object for times method' + ); + is( + $times_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + is( $times, 0, '* overloading has not been called' ); + is( + Foo::OverloadWithMethod->new * Foo::OverloadWithMethod->new, + 'times', + q{* overloading returns 'times'} + ); + is( $times, 1, '* overloading was called once' ); + + my $times_overload2 = $meta->get_overloaded_operator('*'); + + ok( + $times_overload->_is_equal_to($times_overload2), + '_is_equal_to returns true for the exact same object' + ); + + my $times_overload3 = Class::MOP::Overload->new( + operator => '*', + method_name => 'times', + ); + + ok( + $times_overload->_is_equal_to($times_overload3), + '_is_equal_to returns true for object with the same properties' + ); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails' + ); + + $meta->add_overloaded_operator( '/' => 'divided' ); + + ok( + $meta->has_overloaded_operator('/'), + 'has / operator after call to ->add_overloaded_operator' + ); + + is_deeply( + [ sort $meta->get_overload_list ], [ '*', '/' ], + '->get_overload_list returns (*, /)' + ); + + is( + scalar( $meta->get_all_overloaded_operators ), 2, + '->get_all_overloaded_operators returns 2 operators' + ); + + my $divided_overload = $meta->get_overloaded_operator('/'); + isa_ok( + $divided_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $divided_overload->operator, '/', + 'operator for overload is /' + ); + is( + $divided_overload->method_name, 'divided', + q{method name is 'divided'} + ); + is( + $divided_overload->method, $meta->get_method('divided'), + '->method returns method object for divided method' + ); + is( + $divided_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + + $meta->remove_overloaded_operator('/'); + + like( + exception { + Foo::OverloadWithMethod->new + / Foo::OverloadWithMethod->new + }, + qr{Operation $quote/$quote: no .+ found}, + 'trying to call / on objects fails after call to ->remove_overloaded_operator' + ); + } + ); +} + +{ + package Foo::UnimplementedOverload; + use Moose; + use overload '+' => 'plus'; +} + +{ + my $meta = Foo::UnimplementedOverload->meta; + + subtest( + 'Foo::UnimplementedOverload (overloaded via method that does not exist)', + sub { + ok( + $meta->is_overloaded, + 'is overloaded' + ); + + ok( + $meta->has_overloaded_operator('+'), + 'overloads +' + ); + + my $plus_overload = $meta->get_overloaded_operator('+'); + isa_ok( + $plus_overload, 'Class::MOP::Overload', + 'overload object' + ); + is( + $plus_overload->operator, '+', + 'operator for overload is +' + ); + ok( + $plus_overload->has_method_name, + 'overload has a method name' + ); + is( + $plus_overload->method_name, 'plus', + q{method name is 'plus'} + ); + ok( + !$plus_overload->has_coderef, + 'overload does not have a coderef' + ); + ok( + !$plus_overload->has_coderef_package, + 'overload does not have a coderef package' + ); + ok( + !$plus_overload->has_coderef_name, + 'overload does not have a coderef name' + ); + ok( + !$plus_overload->is_anonymous, + 'overload is not anonymous' + ); + ok( + !$plus_overload->has_method, + 'overload has no method object' + ); + is( + $plus_overload->associated_metaclass, $meta, + 'overload is associated with expected metaclass' + ); + } + ); +} + +done_testing; |