Skip to content

Commit

Permalink
Support calling Perl 5 methods in scalar context
Browse files Browse the repository at this point in the history 
It's now possible to call a method on a Perl 5 object in scalar context by
passing Scalar as the first argument: $p5obj.foo(Scalar, 1, 2)
  • Loading branch information
@niner
niner committed Feb 24, 2019
1 parent fcb27f5 commit d89367c
Show file tree
Hide file tree
Showing 9 changed files with 294 additions and 16 deletions.
21 changes: 18 additions & 3 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,6 @@ Inline::Perl5
# SYNOPSIS

```
use Inline::Perl5;
use DBI:from<Perl5>;
my $dbh = DBI.connect('dbi:Pg:database=test');
Expand Down Expand Up @@ -83,6 +82,8 @@ They can be used as if they were Perl 6 modules:
ok 'yes', 'looks like a Perl 6 function';
```

In this example, the `plan` function exported by `Test::More` is called.

Inline::Perl5's call($name, \*@args) method allows calling arbitrary Perl 5
functions. Use a fully qualified name (like "Test::More::ok") if the function
is not in the "main" namespace.
Expand Down Expand Up @@ -127,15 +128,29 @@ Once you have a Perl 5 object in a variable it will behave just like a Perl 6
object. You can call methods on it like on any other object.

```
use Inline::Perl5;
use IO::Compress::Bzip2:from<Perl5>;
my $bzip2 = IO::Compress::Bzip2.new('/tmp/foo.bz2');
$bzip2.print($data);
$bzip2.close;
```

### Invoking a method in scalar context

Please note that since Perl 6 does not have the same concept of "context",
Perl 5 methods are always called in list context.
Perl 5 methods are by default called in list context. If you need to call the
method in scalar context, you can tell it so explicitly, by passing the
`Scalar` type object as first argument:

```
use IO::Compress::Bzip2:from<Perl5>;
my $bzip2 = IO::Compress::Bzip2.new(Scalar, '/tmp/foo.bz2');
$bzip2.print(Scalar, $data);
$bzip2.close(Scalar);
```

This may be neccessary if the Perl 5 method exposes different behavior when
called in list and scalar context. Calling in scalar context may also improve
performance in some cases.

## Access a Perl 5 object's data directly

Expand Down
73 changes: 73 additions & 0 deletions lib/Inline/Perl5.pm6
View file
Original file line number Diff line number Diff line change
Expand Up @@ -503,6 +503,22 @@ method invoke-gv(Pointer $obj, Pointer $function) {
self.unpack_return_values($av, $retvals, $type);
}

method scalar-invoke-gv(Pointer $obj, Pointer $function) {
my int32 $retvals;
my int32 $err;
my int32 $type;
my $av = $!p5.p5_scalar_call_gv(
$function,
1,
$obj,
$retvals,
$err,
$type,
);
self.handle_p5_exception() if $err;
self.unpack_return_values($av, $retvals, $type);
}

method invoke-gv-simple-arg(Pointer $obj, Pointer $function, $arg) {
my @svs := CArray[Pointer].new();
@svs.ASSIGN-POS(0, $obj);
Expand Down Expand Up @@ -547,6 +563,31 @@ method invoke-gv-arg(Pointer $obj, Pointer $function, $arg) {
self.unpack_return_values($av, $retvals, $type);
}

method scalar-invoke-gv-arg(Pointer $obj, Pointer $function, $arg) {
my @svs := CArray[Pointer].new();
@svs[0] = $obj;
if $arg.WHAT =:= Pair {
@svs[1] = self.p6_to_p5($arg.key);
@svs[2] = self.p6_to_p5($arg.value);
}
else {
@svs[1] = self.p6_to_p5($arg);
}
my int32 $retvals;
my int32 $err;
my int32 $type;
my $av = $!p5.p5_scalar_call_gv(
$function,
2,
nativecast(Pointer, @svs),
$retvals,
$err,
$type,
);
self.handle_p5_exception() if $err;
self.unpack_return_values($av, $retvals, $type);
}

method invoke-args(Pointer $obj, Str $function, Capture $args) {
my @svs := CArray[Pointer].new();
my Int $j = 0;
Expand Down Expand Up @@ -613,6 +654,38 @@ method invoke-gv-args(Pointer $obj, Pointer $function, Capture $args) {
self.unpack_return_values($av, $retvals, $type);
}

method scalar-invoke-gv-args(Pointer $obj, Pointer $function, Capture $args) {
my @svs := CArray[Pointer].new();
my Int $j = 0;
@svs[$j++] = $obj;
for $args.list {
if $_.WHAT =:= Pair {
@svs[$j++] = self.p6_to_p5($_.key);
@svs[$j++] = self.p6_to_p5($_.value);
}
else {
@svs[$j++] = self.p6_to_p5($_);
}
}
for $args.hash {
@svs[$j++] = self.p6_to_p5($_.key);
@svs[$j++] = self.p6_to_p5($_.value);
}
my int32 $retvals;
my int32 $err;
my int32 $type;
my $av = $!p5.p5_scalar_call_gv(
$function,
$j,
nativecast(Pointer, @svs),
$retvals,
$err,
$type,
);
self.handle_p5_exception() if $err;
self.unpack_return_values($av, $retvals, $type);
}

multi method invoke(Pointer $obj, Str $function, *@args, *%args) {
my @svs := CArray[Pointer].new();
my Int $j = 0;
Expand Down
77 changes: 65 additions & 12 deletions lib/Inline/Perl5/ClassHOW.pm6
View file
Original file line number Diff line number Diff line change
Expand Up @@ -156,14 +156,23 @@ class Inline::Perl5::ClassHOW
nqp::scwbenable();
entry
}
my $arity = nqp::captureposelems(capture);
add_to_cache(SELF,
nqp::capturenamedshash(capture) || !nqp::captureposarg(capture, 0).defined
?? nqp::getattr(SELF, SELF.WHAT, '&!many-args')
!! nqp::captureposelems(capture) == 1
?? $arity < 2 || nqp::captureposarg(capture, 1) !=== Scalar
?? nqp::getattr(SELF, SELF.WHAT, '&!many-args')
!! nqp::getattr(SELF, SELF.WHAT, '&!scalar-many-args')
!! $arity == 1
?? nqp::getattr(SELF, SELF.WHAT, '&!no-args')
!! nqp::captureposelems(capture) == 2 && !(nqp::captureposarg(capture, 1) ~~ Pair)
?? nqp::getattr(SELF, SELF.WHAT, '&!one-arg')
!! nqp::getattr(SELF, SELF.WHAT, '&!many-args')
!! $arity == 2 && !(nqp::captureposarg(capture, 1) ~~ Pair)
?? nqp::captureposarg(capture, 1) === Scalar
?? nqp::getattr(SELF, SELF.WHAT, '&!scalar-no-args')
!! nqp::getattr(SELF, SELF.WHAT, '&!one-arg')
!! $arity == 3 && nqp::captureposarg(capture, 1) === Scalar
?? nqp::getattr(SELF, SELF.WHAT, '&!scalar-one-arg')
!! nqp::captureposarg(capture, 1) === Scalar
?? nqp::getattr(SELF, SELF.WHAT, '&!scalar-many-args')
!! nqp::getattr(SELF, SELF.WHAT, '&!many-args')
)
}
ROLE
Expand All @@ -182,24 +191,36 @@ class Inline::Perl5::ClassHOW
&find_best_dispatchee //= -> \SELF, Mu \capture { use nqp; nqp::getattr(SELF, SELF.WHAT, '&!many-args') };
$proto does role :: {
has &!many-args;
has &!scalar-many-args;
has &!one-arg;
has &!scalar-one-arg;
has &!no-args;
has &!scalar-no-args;
method find_best_dispatchee(Mu \capture) {
find_best_dispatchee(self, capture);
}
method add_methods(&many-args, &one-arg, &no-args) {
&!many-args := &many-args;
&!one-arg := &one-arg;
&!no-args := &no-args;
method add_methods(&many-args, &scalar-many-args, &one-arg, &scalar-one-arg, &no-args, &scalar-no-args) {
&!many-args := &many-args;
&!scalar-many-args := &scalar-many-args;
&!one-arg := &one-arg;
&!scalar-one-arg := &scalar-one-arg;
&!no-args := &no-args;
&!scalar-no-args := &scalar-no-args;
}
}

my $method := my sub many-args(Any $self, *@args, *%kwargs) {
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)
};
$proto.add_dispatchee($method);
$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)
};
$proto.add_dispatchee($many-args);

my $defined_type := Metamodel::DefiniteHOW.new_type(:base_type($type), :definite(1));
my $no-args := my sub no-args(Any:D \SELF) {
Expand All @@ -218,6 +239,22 @@ class Inline::Perl5::ClassHOW
$p5.unpack_return_values($av, $retvals, $type);
};
$proto.add_dispatchee($no-args);
my $scalar-no-args := my sub scalar-no-args(Any:D \SELF, Scalar:U) {
my int32 $retvals;
my int32 $err;
my int32 $type;
my $av = $ip5.p5_scalar_call_gv(
$gv,
1,
SELF.wrapped-perl5-object,
$retvals,
$err,
$type,
);
$p5.handle_p5_exception() if $err;
$p5.unpack_return_values($av, $retvals, $type);
};
$proto.add_dispatchee($scalar-no-args);
my $one-pair-arg := my sub one-pair-arg(Any:D $self, Pair \arg) {
$p5.invoke-gv-arg($self.wrapped-perl5-object, $gv, arg)
};
Expand All @@ -238,7 +275,23 @@ class Inline::Perl5::ClassHOW
$p5.unpack_return_values($av, $retvals, $type);
};
$proto.add_dispatchee($one-arg);
$proto.add_methods($method, $one-arg, $no-args);
my $scalar-one-arg := my sub scalar-one-arg(Any:D \SELF, Scalar:U, \arg) {
my int32 $retvals = 0;
my int32 $err = 0;
my int32 $type = 0;
my $av = $ip5.p5_scalar_call_gv_two_args(
$gv,
SELF.wrapped-perl5-object,
$p5.p6_to_p5(arg),
$retvals,
$type,
$err,
);
$p5.handle_p5_exception if $err;
$p5.unpack_return_values($av, $retvals, $type);
};
$proto.add_dispatchee($scalar-one-arg);
$proto.add_methods($many-args, $scalar-many-args, $one-arg, $scalar-one-arg, $no-args, $scalar-no-args);

self.add_method($type, $name, $proto)
}
Expand Down
6 changes: 6 additions & 0 deletions lib/Inline/Perl5/Interpreter.pm6
View file
Original file line number Diff line number Diff line change
Expand Up @@ -187,9 +187,15 @@ class Inline::Perl5::Interpreter is repr('CPointer') {
method p5_call_gv(Pointer, int32, Pointer, int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

method p5_scalar_call_gv(Pointer, int32, Pointer, int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

method p5_call_gv_two_args(Pointer, Pointer, Pointer, int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

method p5_scalar_call_gv_two_args(Pointer, Pointer, Pointer, int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

method p5_call_method(Pointer, int32, Str, int32, Pointer, int32 is rw, int32 is rw, int32 is rw) is native($p5helper)
returns Pointer { ... }

Expand Down
13 changes: 13 additions & 0 deletions lib/Inline/Perl5/Object.pm6
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,14 +38,27 @@ class Inline::Perl5::Object {
?? $!perl5.invoke-gv-args($!ptr, $gv, Capture.new(:hash(%_)))
!! $!perl5.invoke-gv($!ptr, $gv)
});
$role.^add_multi_method($name, method (Scalar:U) {
%_
?? $!perl5.scalar-invoke-gv-args($!ptr, $gv, Capture.new(:hash(%_)))
!! $!perl5.scalar-invoke-gv($!ptr, $gv)
});
$role.^add_multi_method($name, method (\arg) {
%_
?? $!perl5.invoke-gv-args($!ptr, $gv, Capture.new(:list([arg]), :hash(%_)))
!! $!perl5.invoke-gv-arg($!ptr, $gv, arg)
});
$role.^add_multi_method($name, method (Scalar:U, \arg) {
%_
?? $!perl5.scalar-invoke-gv-args($!ptr, $gv, Capture.new(:list([arg]), :hash(%_)))
!! $!perl5.scalar-invoke-gv-arg($!ptr, $gv, arg)
});
$role.^add_multi_method($name, method (|args) {
$!perl5.invoke-gv-args($!ptr, $gv, args)
});
$role.^add_multi_method($name, method (Scalar:U, |args) {
$!perl5.scalar-invoke-gv-args($!ptr, $gv, args)
});
$role.^set_body_block(-> |args {});
$role.^compose;
self does $role;
Expand Down
77 changes: 77 additions & 0 deletions p5helper.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -665,6 +665,48 @@ SV *p5_call_gv(PerlInterpreter *my_perl, GV *gv, int len, SV *args[], I32 *count
}
}

SV *p5_scalar_call_gv(PerlInterpreter *my_perl, GV *gv, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
int i;
SV * retval = NULL;

ENTER;
SAVETMPS;

PUSHMARK(SP);

if (len > 1) {
XPUSHs(args[0]);
for (i = 1; i < len; i++) {
if (args[i] != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(sv_2mortal(args[i]));
}
}
else if (len > 0)
if (args != NULL) /* skip Nil which gets turned into NULL */
XPUSHs((SV*)args);

PUTBACK;

SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv))); /* FIXME: can be done once */

*count = call_sv(rv, G_SCALAR | G_EVAL);
SPAGAIN;

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

PUTBACK;
FREETMPS;
LEAVE;

return retval;
}
}

SV *p5_call_gv_two_args(PerlInterpreter *my_perl, GV *gv, SV *arg, SV *arg2, I32 *count, I32 *type, I32 *err) {
PERL_SET_CONTEXT(my_perl);
{
Expand Down Expand Up @@ -700,6 +742,41 @@ SV *p5_call_gv_two_args(PerlInterpreter *my_perl, GV *gv, SV *arg, SV *arg2, I32
}
}

SV *p5_scalar_call_gv_two_args(PerlInterpreter *my_perl, GV *gv, SV *arg, SV *arg2, I32 *count, I32 *type, I32 *err) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;

ENTER;
SAVETMPS;

PUSHMARK(SP);

XPUSHs((SV*)arg);
XPUSHs((SV*)arg2);

PUTBACK;

SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));

*count = call_sv(rv, G_SCALAR | G_EVAL);
SPAGAIN;

handle_p5_error(err);
if (*err)
fprintf(stderr, "err: %d\n", *err);
retval = pop_return_values(my_perl, sp, *count, type);
SPAGAIN;

PUTBACK;
FREETMPS;
LEAVE;

return retval;
}
}

SV *p5_call_method(PerlInterpreter *my_perl, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
Expand Down
Loading

0 comments on commit d89367c

Please sign in to comment.