Skip to content

Commit

Permalink
Properly represent P6 subclasses of P5 packages in P5
Browse files Browse the repository at this point in the history
  • Loading branch information
@niner
niner committed Apr 26, 2019
1 parent 21ad533 commit ca4df01
Show file tree
Hide file tree
Showing 6 changed files with 140 additions and 37 deletions.
65 changes: 58 additions & 7 deletions lib/Inline/Perl5.pm6
View file
Expand Up @@ -17,9 +17,9 @@ use Inline::Perl5::TypeGlob;
has Inline::Perl5::Interpreter $!p5;
has Bool $!external_p5 = False;
has Bool $!scalar_context = False;
has %!loaded_modules;

my $default_perl5;
my %loaded_modules;

# I'd like to call this from Inline::Perl5::Interpreter
# But it raises an error in the END { ... } call
Expand Down Expand Up @@ -310,10 +310,19 @@ multi method p5_to_p6_type(Pointer:D \value, Blessed) {
}
else {
$!p5.p5_sv_refcnt_inc(value);
if %loaded_modules{self.stash-name(value)}:exists {
my $class := %loaded_modules{self.stash-name(value)};
my $stash-name = self.stash-name(value);
if %!loaded_modules{$stash-name}:exists {
my $class := %!loaded_modules{$stash-name};
use nqp;
nqp::p6bindattrinvres($class.CREATE, $class, '$!wrapped-perl5-object', value)
my $p5class := $class.^mro.list.first({nqp::istype($_.HOW, Inline::Perl5::ClassHOW)});
if $p5class !=:= Nil {
my $obj = nqp::p6bindattrinvres($class.CREATE, $p5class, '$!wrapped-perl5-object', value);
$!p5.p5_add_magic(value, $objects.keep($obj));
$obj
}
else {
Inline::Perl5::Object.new(perl5 => self, ptr => value)
}
}
else {
Inline::Perl5::Object.new(perl5 => self, ptr => value)
Expand Down Expand Up @@ -457,6 +466,48 @@ multi method invoke(Str $package, Str $function, *@args, *%args) {
self.unpack_return_values($av, $retvals, $type);
}

multi method invoke(Any:U $package, Str $base_package, Str $function, *@args, *%args) {
my int32 $retvals;
my int32 $err;
my int32 $type;
my $av = $!p5.p5_call_inherited_package_method(
$package.^name,
$base_package,
$function,
|self.setup_arguments(@args, %args),
$retvals,
$err,
$type,
);
if $type == -1 {
# need to create the P5 wrapper package
self.run: "
package {$package.^name} \{
our @ISA = qw(Perl6::Object $base_package);
{
join "\n", $package.^methods.map(*.name).grep(/^\w+$/).grep({$_ ne 'DESTROY' and $_ ne 'isa' and $_ ne 'can'}).unique.map: -> $name {
qq[sub $name \{
Perl6::Object::call_method('$name', \@_);
\}]
}
}
\}
";
$av = $!p5.p5_call_inherited_package_method(
$package.^name,
$base_package,
$function,
|self.setup_arguments(@args, %args),
$retvals,
$err,
$type,
);
%!loaded_modules{$package.^name} := $package;
}
self.handle_p5_exception() if $err;
self.unpack_return_values($av, $retvals, $type);
}

multi method invoke(Pointer $obj, Str $function) {
my int32 $retvals;
my int32 $err;
Expand Down Expand Up @@ -915,14 +966,14 @@ method !create_wrapper_class(Str $module, Stash $stash) {
my $first-time = True;
my $symbols = self.subs_in_module($module);
my $variables = self.variables_in_module($module);
if %loaded_modules{$module}:exists {
$class := %loaded_modules{$module};
if %!loaded_modules{$module}:exists {
$class := %!loaded_modules{$module};
$first-time = False;
}
else {
my $p5 := self;

%loaded_modules{$module} := $class :=
%!loaded_modules{$module} := $class :=
Inline::Perl5::ClassHOW.new_type(name => $module, :p5(self), :ip5($!p5));

# install methods
Expand Down
31 changes: 10 additions & 21 deletions lib/Inline/Perl5/ClassHOW.pm6
View file
Expand Up @@ -37,25 +37,14 @@ class Inline::Perl5::ClassHOW
[Any, Mu],
:authoritative, :call_accepts);

my $p5 = $!p5;
my $module = $!name;

# Steal methods of Any/Mu for our method cache.
for flat Any.^method_table.pairs, Mu.^method_table.pairs {
%!cache{.key} //= .value;
}
my $p5 = $!p5;
my $module = $!name;
%!cache<new> := my method new(\SELF: *@args, *%args) {
if (SELF.^name ne $module) { # subclass
my $self = Metamodel::Primitives.rebless(
$p5.invoke($module, 'new', |@args, |%args.kv),
SELF.WHAT,
);
$p5.rebless($self.wrapped-perl5-object, 'Perl6::Object', $self);
$self.BUILDALL(@args, %args);
return $self;
}
else {
return $p5.invoke($module, 'new', |@args.list, |%args.hash);
}
%!cache<DESTROY> := my method DESTROY (\SELF:) {
};
%!cache<AT-KEY> := my method AT-KEY(\SELF: Str() \key) {
$p5.at-key(SELF.wrapped-perl5-object, key)
Expand Down Expand Up @@ -85,6 +74,7 @@ class Inline::Perl5::ClassHOW
}
);
nqp::bindattr(self, $?CLASS, '$!composed_repr', nqp::unbox_i(1));
self.add_wrapper_method(type, 'new');
$*W.add_object(type) if $*W;

type
Expand Down Expand Up @@ -138,8 +128,7 @@ class Inline::Perl5::ClassHOW
my $ip5 = $!ip5;
my $module = $!name;

my $gv := $!p5.look-up-method(self.name($type), $name)
or die qq/Could not find method "$name" of "{self.name($type)}" object/;
my $gv := $!p5.look-up-method(self.name($type), $name);

my $generic-proto := my proto method AUTOGEN(::T $: |) { * }
my $proto := $generic-proto.instantiate_generic(%('T' => $type));
Expand Down Expand Up @@ -212,13 +201,13 @@ class Inline::Perl5::ClassHOW
my $many-args := my sub many-args(Any $self, *@args, *%kwargs) {
$self.defined
?? $p5.invoke-parent($module, $self.wrapped-perl5-object, False, $name, [flat $self, |@args], %kwargs)
!! $p5.invoke($module, $name, |@args.list, |%kwargs)
!! $p5.invoke($self, $module, $name, |@args.list, |%kwargs)
};
$proto.add_dispatchee($many-args);
my $scalar-many-args := my sub scalar-many-args(Any $self, Scalar:U, *@args, *%kwargs) {
$self.defined
?? $p5.invoke-parent($module, $self.wrapped-perl5-object, True, $name, [flat $self, |@args], %kwargs)
!! $p5.invoke($module, $name, |@args.list, |%kwargs)
!! $p5.invoke($self, $module, $name, |@args.list, |%kwargs)
};
$proto.add_dispatchee($many-args);

Expand All @@ -230,7 +219,7 @@ class Inline::Perl5::ClassHOW
my $av = $ip5.p5_call_gv(
$gv,
1,
SELF.wrapped-perl5-object,
$p5.p6_to_p5(SELF),
$retvals,
$err,
$type,
Expand Down Expand Up @@ -301,7 +290,7 @@ class Inline::Perl5::ClassHOW
}

method BUILDALLPLAN($type) {
[].FLATTENABLE_LIST
[]
}

method compose_attributes(\obj, :$compiler_services) {
Expand Down
6 changes: 6 additions & 0 deletions lib/Inline/Perl5/Interpreter.pm6
View file
Expand Up @@ -205,12 +205,18 @@ class Inline::Perl5::Interpreter is repr('CPointer') {
method p5_call_package_method(Str, Str, int32, CArray[Pointer], int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

method p5_call_inherited_package_method(Str, Str, Str, int32, CArray[Pointer], int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

method p5_call_code_ref(Pointer, int32, CArray[Pointer], int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

method p5_rebless_object(Pointer, Str, IV) is native($p5helper)
{ ... }

method p5_add_magic(Pointer, IV) is native($p5helper)
{ ... }

method p5_destruct_perl() is native($p5helper)
{ ... }

Expand Down
59 changes: 58 additions & 1 deletion p5helper.c
View file
Expand Up @@ -600,13 +600,53 @@ GV *p5_look_up_package_method(PerlInterpreter *my_perl, char *module, char *name
PERL_SET_CONTEXT(my_perl);
{
HV * const pkg = gv_stashpvn(module, strlen(module), 0);
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
GV * const gv = gv_fetchmeth_pvn(pkg, name, strlen(name), -1, SVf_UTF8);
if (gv && isGV(gv))
return gv;
return NULL;
}
}

SV *p5_call_inherited_package_method(PerlInterpreter *my_perl, char *package, char *base_package, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;
HV * stash = gv_stashpvn(package, strlen(package), SVf_UTF8);
int flags = G_ARRAY | G_EVAL;

if (stash == NULL) {
*type = -1; /* signal that a wrapper package needs to be created */
return NULL;
}

ENTER;
SAVETMPS;

PUSHMARK(SP);

XPUSHs(newSVpv(package, 0));
push_arguments(sp, len, args);

{
GV * const gv = p5_look_up_package_method(my_perl, base_package, name);
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, flags);
}

SPAGAIN;

handle_p5_error(err);

retval = pop_return_values(my_perl, sp, *count, type);

FREETMPS;
LEAVE;

return retval;
}
}

GV *p5_look_up_method(PerlInterpreter *my_perl, SV *obj, char *name) {
PERL_SET_CONTEXT(my_perl);
{
Expand Down Expand Up @@ -1001,6 +1041,19 @@ void p5_rebless_object(PerlInterpreter *my_perl, SV *obj, char *package, IV i) {
}
}

void p5_add_magic(PerlInterpreter *my_perl, SV *obj, IV i) {
PERL_SET_CONTEXT(my_perl);
{
SV * const inst = SvRV(obj);
_perl6_magic priv;

/* set up magic */
priv.key = PERL6_MAGIC_KEY;
priv.index = i;
sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));
}
}

SV *p5_wrap_p6_object(PerlInterpreter *my_perl, IV i, SV *p5obj) {
PERL_SET_CONTEXT(my_perl);
{
Expand Down Expand Up @@ -1223,6 +1276,10 @@ XS(p5_call_p6_method) {
}
SV * const obj_deref = SvRV(obj);
MAGIC * const mg = mg_find(obj_deref, '~');
if (!mg) {
XSRETURN_EMPTY;
return;
}
_perl6_magic* const p6mg = (_perl6_magic*)(mg->mg_ptr);
SV *err = NULL;
SV * const args_rv = newRV_noinc((SV *) args);
Expand Down
10 changes: 5 additions & 5 deletions t/p6_to_p5.t
View file
Expand Up @@ -92,7 +92,7 @@ $p5.run(q/
my (%params) = @_;
return $params{a} + $params{b};
}
package Foo;
package P5Foo;
sub new {
return bless {};
}
Expand All @@ -103,11 +103,11 @@ $p5.run(q/
/);

is($p5.call('test_named', a => 1, b => 2), 3);
is($p5.invoke('Foo', 'test_named', a => 1, b => 2), 3);
is($p5.invoke('Foo', 'new').test_named('a', 1, 'b', 2), 3, 'positional args on object method');
is($p5.invoke('Foo', 'new').test_named(a => 1, b => 2), 3, 'named args on object method');
is($p5.invoke('P5Foo', 'test_named', a => 1, b => 2), 3);
is($p5.invoke('P5Foo', 'new').test_named('a', 1, 'b', 2), 3, 'positional args on object method');
is($p5.invoke('P5Foo', 'new').test_named(a => 1, b => 2), 3, 'named args on object method');

class Bar does Inline::Perl5::Perl5Parent['Foo', $p5] {
class Bar does Inline::Perl5::Perl5Parent['P5Foo', $p5] {
}

is(Bar.new.test_named(a => 1, b => 2), 3, 'named args on parent object method');
Expand Down
6 changes: 3 additions & 3 deletions t/perl5parent.t
View file
Expand Up @@ -47,9 +47,9 @@ sub baz {
}
@Perl6::Object::Foo::ISA = ("Perl6::Object");
@Perl6::Object::Bar::ISA = ("Perl6::Object");
@Perl6::Object::P5Bar::ISA = ("Perl6::Object");
package Bar;
package P5Bar;
use Moose;
Expand Down Expand Up @@ -81,7 +81,7 @@ class Baz does Inline::Perl5::Perl5Parent['Foo', $p5] {

is(Baz.new.test, 'Perl6!');

class Qux does Inline::Perl5::Perl5Parent['Bar', $p5] {
class Qux does Inline::Perl5::Perl5Parent['P5Bar', $p5] {
method qux {
return "Perl6!!";
}
Expand Down

0 comments on commit ca4df01

Please sign in to comment.