Moose-2.1405HEADMoose-2.1405master

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;