Full support for 'can' on P6 subclasses of P5 classes

We now support $object->can('bar') and $class->can('bar') and return
methods found in the Perl 6 subclass or the Perl 5 parent as code
reference.

lib/Inline/Perl5.pm6

@@ -545,6 +545,9 @@ class Perl6Callbacks {
 
 method init_callbacks {
     self.run(q:to/PERL5/);
+        use strict;
+        use warnings;
+
         package Perl6::Object;
 
         use overload '""' => sub {
@@ -563,7 +566,9 @@ method init_callbacks {
         sub can {
             my ($self) = shift;
 
-            return ref $self ? Perl6::Object::call_method('can', $self, @_) : v6::invoke($self, 'can', @_);
+            return ref $self
+                ? Perl6::Object::call_method('can', $self, @_)
+                : v6::invoke($self =~ s/\APerl6::Object:://r, 'can', @_);
         }
 
         package Perl6::Callable;
@@ -909,17 +914,19 @@ role Perl5Parent[Str:D $package, Inline::Perl5:D $perl5] {
     method can($name) {
         my @candidates = self.^can($name);
         return @candidates[0] if @candidates;
-        return $.parent.perl5.invoke-parent($package, $.parent.ptr, True, 'can', $.parent, $name);
+        return defined(self)
+            ?? $perl5.invoke-parent($package, $.parent.ptr, True, 'can', $.parent, $name)
+            !! $perl5.invoke($package, 'can', $name);
     }
 
     ::?CLASS.HOW.add_fallback(::?CLASS, -> $, $ { True },
         method ($name) {
             -> \self, |args {
                 my $scalar = (
                     callframe(1).code ~~ Perl5Caller
-                    and $.parent.perl5.retrieve_scalar_context
+                    and $perl5.retrieve_scalar_context
                 );
-                $.parent.perl5.invoke-parent($package, $.parent.ptr, $scalar, $name, $.parent, args.list, args.hash);
+                $perl5.invoke-parent($package, $.parent.ptr, $scalar, $name, $.parent, args.list, args.hash);
             }
         }
     );

t/lib/TestV6.pm

@@ -56,16 +56,36 @@ sub test_isa {
     return $self->isa(__PACKAGE__);
 }
 
+sub return_1 {
+    return 1;
+}
+
 sub test_can {
     my ($self) = @_;
 
-    return defined $self->can('test_can');
+    die 'can returns positive result for non-existing method' if $self->can('non-existing');
+    return $self->can('return_1')->($self);
 }
 
 sub test_can_subclass {
     my ($self) = @_;
 
-    return defined $self->can('hello');
+    return $self->can('return_2')->($self);
+}
+
+sub test_package_can {
+    my ($self) = @_;
+
+    my $class = ref $self;
+    die 'can returns positive result for non-existing method' if $class->can('non-existing');
+    return $class->can('return_1')->($self);
+}
+
+sub test_package_can_subclass {
+    my ($self) = @_;
+
+    my $class = ref $self;
+    return $class->can('return_2')->($self);
 }
 
 # yes, this happens in real code :/
@@ -94,3 +114,7 @@ method call_context {
 method fetch_foo() {
     return self.foo;
 }
+
+method return_2() {
+    return 2;
+}

t/v6.t

@@ -17,8 +17,10 @@ is(Foo::Bar::TestV6.new.test_scalar_context, 'scalar');
 is(Foo::Bar::TestV6.new.test_array_context, 'array');
 is(Foo::Bar::TestV6.new.test_call_context, 'array');
 is(Foo::Bar::TestV6.new.test_isa, 1);
-is(Foo::Bar::TestV6.new.test_can, 1, "can finds the base class' methods");
-is(Foo::Bar::TestV6.new.test_can_subclass, 1, "can finds the subclass' methods");
+is(Foo::Bar::TestV6.new('bar').test_can, 1, "can finds the base class' methods");
+is(Foo::Bar::TestV6.new('bar').test_can_subclass, 2, "can finds the subclass' methods");
+is(Foo::Bar::TestV6.new('bar').test_package_can, 1, "can finds the base class' methods via package");
+is(Foo::Bar::TestV6.new('bar').test_package_can_subclass, 2, "can finds the subclass' methods via package");
 is(Foo::Bar::TestV6.new('bar').foo, 'bar');
 is(Foo::Bar::TestV6.new('bar').get_foo, 'bar');
 is(Foo::Bar::TestV6.new('bar').get_foo_indirect, 'bar');