Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Failed attempt to use Mu as base for Perl5Object 
Using Mu instead of Any as base class for Perl5Object and Perl5Package
classes might have helped cases where Any's methods shadow the Perl 5
object's methods.

But as timotimo++ pointed out, the big majority of parameters is restricted
to Any (so Perl5Objects would not be accepted). So this would probably cause
more harm than good.

Push it into a branch to document this fact and what changes would have
been necessary.
  • Loading branch information
@niner
niner committed Jul 27, 2015
1 parent b41e80a commit f1d4668
Show file tree
Hide file tree
Showing 2 changed files with 104 additions and 102 deletions.
56 changes: 29 additions & 27 deletions lib/Inline/Perl5.pm6
View file
Expand Up @@ -48,7 +48,7 @@ class ObjectKeeper {
has @!objects;
has $!last_free = -1;

method keep(Any:D $value) returns Int {
method keep(Mu:D $value) returns Int {
if $!last_free != -1 {
my $index = $!last_free;
$!last_free = @!objects[$!last_free];
Expand All @@ -61,7 +61,7 @@ class ObjectKeeper {
}
}

method get(Int $index) returns Any:D {
method get(Int $index) returns Mu:D {
@!objects[$index];
}

Expand Down Expand Up @@ -260,7 +260,7 @@ multi method p6_to_p5(Perl5Object $value) returns OpaquePointer {
multi method p6_to_p5(OpaquePointer $value) returns OpaquePointer {
$value;
}
multi method p6_to_p5(Any:U $value) returns OpaquePointer {
multi method p6_to_p5(Mu:U $value) returns OpaquePointer {
p5_undef($!p5);
}

Expand All @@ -274,7 +274,7 @@ multi method p6_to_p5(Perl5Object:D $value, OpaquePointer $inst) {
p5_sv_refcnt_inc($!p5, $inst);
$inst;
}
multi method p6_to_p5(Any:D $value, OpaquePointer $inst = OpaquePointer) {
multi method p6_to_p5(Mu:D $value, OpaquePointer $inst = OpaquePointer) {
my $index = $objects.keep($value);

p5_wrap_p6_object(
Expand Down Expand Up @@ -432,7 +432,7 @@ method !setup_arguments(@args) {
my @svs := CArray[OpaquePointer].new();
my Int $j = 0;
loop (my Int $i = 0; $i < $len; $i = $i + 1) {
if @args[$i] ~~ Pair {
if @args[$i].WHAT ~~ Pair {
@svs[$j++] = self.p6_to_p5(@args[$i].key);
@svs[$j++] = self.p6_to_p5(@args[$i].value);
}
Expand Down Expand Up @@ -487,7 +487,7 @@ multi method invoke(Str $package, OpaquePointer $obj, Str $function, *@args) {
my Int $j = 0;
@svs[$j++] = self.p6_to_p5(@args[0], $obj);
loop (my Int $i = 1; $i < $len; $i++) {
if @args[$i] ~~ Pair {
if @args[$i].WHAT ~~ Pair {
@svs[$j++] = self.p6_to_p5(@args[$i].key);
@svs[$j++] = self.p6_to_p5(@args[$i].value);
}
Expand Down Expand Up @@ -657,7 +657,7 @@ role Perl5Package[Inline::Perl5 $p5, Str $module] {
}
}

submethod BUILD(:$parent) {
submethod BUILD(Mu :$parent) {
$!parent = $parent;
$p5.rebless($parent) if $parent;
}
Expand All @@ -668,16 +668,16 @@ role Perl5Package[Inline::Perl5 $p5, Str $module] {
!! $p5.invoke($module, $name, |@args);
}

for Any.^methods>>.name.list, <say> -> $name {
$?CLASS.^add_method(
$name,
method (|args) {
return self.defined
?? $p5.invoke($module, $!parent.ptr, $name, self, args.list, args.hash)
!! $p5.invoke($module, $name, args.list, args.hash);
}
);
}
# for Any.^methods>>.name.list, <say> -> $name {
# $?CLASS.^add_method(
# $name,
# method (|args) {
# return self.defined
# ?? $p5.invoke($module, $!parent.ptr, $name, self, args.list, args.hash)
# !! $p5.invoke($module, $name, args.list, args.hash);
# }
# );
# }
}

my $loaded_modules = SetHash.new;
Expand All @@ -695,7 +695,7 @@ method require(Str $module, Num $version?) {
$loaded_modules{$module} = True;

my $p5 = self;
EVAL "class GLOBAL::$module does Perl5Package[\$p5, \$module] \{ \}";
EVAL "class GLOBAL::$module is Mu does Perl5Package[\$p5, \$module] \{ \}";

::($module).WHO<EXPORT> := Metamodel::PackageHOW.new();
::($module).WHO<&EXPORT> := sub EXPORT(*@args) {
Expand All @@ -720,7 +720,7 @@ submethod DESTROY {
$!p5 = Perl5Interpreter;
}

class Perl5Object {
class Perl5Object is Mu {
has OpaquePointer $.ptr;
has Inline::Perl5 $.perl5;

Expand Down Expand Up @@ -813,14 +813,16 @@ BEGIN {
}
}
);
for Any.^methods>>.name -> $name {
Perl5Object.^add_method(
$name,
method (|args) {
$.perl5.invoke($.ptr, $name, self, args.list, args.hash);
}
);
}
# for Any.^methods>>.name -> $name {
# my $method = my method (|args) {
# $.perl5.invoke($.ptr, $name, self, args.list, args.hash);
# };
# $method.set_name($name);
# Perl5Object.^add_method(
# $name,
# $method,
# );
# }
Perl5Object.^compose;
}

Expand Down
150 changes: 75 additions & 75 deletions t/call.t
View file
Expand Up @@ -6,98 +6,98 @@ use Inline::Perl5;
say "1..12";

my $p5 = Inline::Perl5.new();
say $p5.run('
use 5.10.0;
$| = 1;
say $p5.run(q:heredoc/PERL5/);
use 5.10.0;
$| = 1;
sub test {
say "ok 1 - executing a parameterless function without return value";
return;
}
sub test_int_params {
if ($_[0] == 2 and $_[1] == 1) {
say "ok 2 - int params";
sub test {
say "ok 1 - executing a parameterless function without return value";
return;
}
else {
say "not ok 2 - int params";
}
return;
}
sub test_str_params {
if (@_ == 2 and $_[0] eq "Hello" and $_[1] eq "Perl 5") {
say "ok 3 - str params";
sub test_int_params {
if ($_[0] == 2 and $_[1] == 1) {
say "ok 2 - int params";
}
else {
say "not ok 2 - int params";
}
return;
}
else {
say "not ok 3 - str params";
}
return;
}
sub test_int_retval {
return 1;
}
sub test_str_params {
if (@_ == 2 and $_[0] eq "Hello" and $_[1] eq "Perl 5") {
say "ok 3 - str params";
}
else {
say "not ok 3 - str params";
}
return;
}
sub test_int_retvals {
return 3, 1, 2;
}
sub test_int_retval {
return 1;
}
sub test_str_retval {
return "Hello Perl 6!";
}
sub test_int_retvals {
return 3, 1, 2;
}
sub test_mixed_retvals {
return ("Hello", "Perl", 6);
}
sub test_str_retval {
return "Hello Perl 6!";
}
sub test_undef {
my ($self, $undef) = @_;
sub test_mixed_retvals {
return ("Hello", "Perl", 6);
}
return (@_ == 2 and $self eq "main" and not defined $undef);
}
sub test_undef {
my ($self, $undef) = @_;
sub test_hash {
my ($self, $h) = @_;
return (@_ == 2 and $self eq "main" and not defined $undef);
}
return (
ref $h eq "HASH"
and keys %$h == 2
and exists $h->{a}
and exists $h->{b}
and $h->{a} == 2
and ref $h->{b}
and ref $h->{b} eq "HASH"
and ref $h->{b}{c}
and ref $h->{b}{c} eq "ARRAY"
and @{ $h->{b}{c} } == 2
and $h->{b}{c}[0] == 4
and $h->{b}{c}[1] == 3
);
}
sub test_hash {
my ($self, $h) = @_;
return (
ref $h eq "HASH"
and keys %$h == 2
and exists $h->{a}
and exists $h->{b}
and $h->{a} == 2
and ref $h->{b}
and ref $h->{b} eq "HASH"
and ref $h->{b}{c}
and ref $h->{b}{c} eq "ARRAY"
and @{ $h->{b}{c} } == 2
and $h->{b}{c}[0] == 4
and $h->{b}{c}[1] == 3
);
}
sub test_foo {
my ($self, $foo) = @_;
return $foo->test;
}
sub test_foo {
my ($self, $foo) = @_;
return $foo->test;
}
package Foo;
package Foo;
sub new {
my ($class, $val) = @_;
return bless \$val, $class;
}
sub new {
my ($class, $val) = @_;
return bless \$val, $class;
}
sub test {
my ($self) = @_;
return $$self;
}
sub test {
my ($self) = @_;
return $$self;
}
sub sum {
my ($self, $a, $b) = @_;
return $a + $b;
}
');
sub sum {
my ($self, $a, $b) = @_;
return $a + $b;
}
PERL5

$p5.call('test');
$p5.call('test_int_params', 2, 1);
Expand Down

0 comments on commit f1d4668

Please sign in to comment.