Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[t] move perl5/* to spec/S01-perl-5-integration/

(Didn't review them all, but the ones I looked at were rather sane)

git-svn-id: http://svn.pugscode.org/pugs@26823 c213334d-75ef-0310-aa23-eaa082d1ae64
  • Loading branch information...
commit 2c8a840393af8c5cd8780d0b0fdbc14184add80e 1 parent c3f1caf
moritz authored
View
1  S01-perl-5-integration/README
@@ -0,0 +1 @@
+This directory features tests for Perl5 embedding.
View
92 S01-perl-5-integration/array.t
@@ -0,0 +1,92 @@
+use v6;
+
+use Test;
+
+plan 18;
+
+unless (try { eval("1", :lang<perl5>) }) {
+ skip_rest;
+ exit;
+}
+
+die unless
+eval(q/
+package My::Array;
+use strict;
+
+sub new {
+ my ($class, $ref) = @_;
+ bless \$ref, $class;
+}
+
+sub array {
+ my $self = shift;
+ return $$self;
+}
+
+sub my_elems {
+ my $self = shift;
+ return scalar(@{$$self});
+}
+
+sub my_exists {
+ my ($self, $idx) = @_;
+ return exists $$self->[$idx];
+}
+
+sub fetch {
+ my ($self, $idx) = @_;
+ return $$self->[$idx];
+}
+
+sub store {
+ my ($self, $idx, $val) = @_;
+ $$self->[$idx] = $val;
+}
+
+sub push {
+ my ($self, $val) = @_;
+ push @{$$self}, $val;
+}
+
+1;
+/, :lang<perl5>);
+
+my $p5ar = eval('sub { My::Array->new($_[0]) }', :lang<perl5>);
+my @array = (5,6,7,8);
+my $p5array = $p5ar(VAR @array);
+
+my $retarray = $p5array.array;
+
+is($p5array.my_elems, @array.elems, 'elems');
+is($p5array.my_exists(1), @array.exists(1), 'exists');
+is($p5array.my_exists(10), @array.exists(10), 'nonexists fail');
+is($p5array.fetch(3)+0, @array[3], 'fetch');
+
+my $match = 0;
+lives_ok {
+ $match = ?($retarray.[3] ~~ @array[3]);
+}, 'can retro fetch';
+ok $match, 'retro fetch';
+
+is(eval(q{$retarray.elems}), @array.elems, 'retro elems');
+is($retarray.exists(1), @array.exists(1), 'retro exists');
+is($retarray.exists(10), @array.exists(10), 'retro nonexists' );
+
+ok(($p5array.push(9)), 'can push');
+
+is(0+$p5array.fetch(4), 9, 'push result via obj', :todo<bug>);
+is(@array[4], 9, 'push result via array', :todo<feature>);
+
+flunk("push(9) non-terminates", :todo<bug>);
+#$retarray.push(9); # this will loop
+
+is(0+$p5array.fetch(5), 9, 'retro push result', :todo<bug>);
+is(@array[5], 9, 'retro push result', :todo<bug>);
+
+ok($p5array.store(0,3), 'can store');
+
+is(@array[0], 3, 'store result');
+is(0+$p5array.fetch(0), 3, 'store result');
+
+# TODO: pop, shift, unshift, splice, delete
View
109 S01-perl-5-integration/basic.t
@@ -0,0 +1,109 @@
+use v6;
+use Test;
+plan 19;
+
+unless (try { eval("1", :lang<perl5>) }) {
+ skip_rest;
+ exit;
+}
+
+{
+ my $r = eval("0", :lang<perl5>);
+ is($r, 0, "number");
+}
+
+{
+ my $r = eval("2", :lang<perl5>);
+ is($r, 2, "number");
+}
+
+{
+ my $r = eval('"perl6 now"', :lang<perl5>);
+ is($r, 'perl6 now', "string");
+}
+
+
+my $p5_dumper = eval('sub {return(wantarray ? @_ : $_[0]); }', :lang<perl5>);
+
+my %h = ( a => 1 );
+
+{
+ my $test = '%h.kv received as hash';
+ my ($k,$v) = $p5_dumper(%h.kv);
+ is($k, 'a', $test~' (key)');
+ is($v, '1', $test~' (value)');
+}
+
+{
+ my $test = '\%h received as hashref';
+ my %o := $p5_dumper(\%h);
+ is(%o<a>, 1, $test);
+
+ my $ref = $p5_dumper(\%h);
+ is($ref<a>, 1, $test);
+}
+
+{
+ my $test = q{ (VAR %h)received as hashref };
+ my %o := $p5_dumper(VAR %h);
+ is(%o<a>, 1, $test);
+}
+
+my @a = <b c d>;
+
+{
+ my $test = q{ (@a) received as array };
+ my @o = $p5_dumper(@a);
+ is(@o[0], "b", $test);
+ is(@o[2], "d", $test);
+}
+
+{
+ my $test = q{ (\@a) received as arrayref };
+ my $o = $p5_dumper(\@a);
+ is($o[0], "b", $test);
+ is($o[2], "d", $test);
+}
+
+{
+ my $test = q{ (VAR @a) received as arrayref };
+ my $o = $p5_dumper(VAR @a);
+ is($o[0], "b", $test);
+ is($o[2], "d", $test);
+}
+
+my $s = 'str';
+
+{
+ my $test = q{ ($s) received as scalar };
+ my $o = $p5_dumper($s);
+ is($o, $s, $test);
+}
+
+{
+ my $test = q{ (\$s) received as scalarref };
+ my $o = $p5_dumper(\$s);
+ is($$o, $s, $test);
+}
+
+{
+ my $test = q{ (VAR $s) received as scalarref };
+ my $o = $p5_dumper(VAR $s);
+ is($$o, $s, $test);
+}
+
+{
+ my $test = q{ (&p6func) Passing a Perl 6 coderef to Perl 5 };
+
+ sub plus_one (Int $int) { $int+1 }
+ my $sub = eval('sub { my $p6_coderef = shift; $p6_coderef->(3) }', :lang<perl5>);
+ my $result = $sub(&plus_one);
+ is($result,4,$test);
+}
+
+sub add_in_perl5 ($x, $y) {
+ use v5;
+ $x + $y;
+}
+
+is(add_in_perl5(42, 42), 84, 'Defining subroutines with "use v5" blocks');
View
21 S01-perl-5-integration/class.t
@@ -0,0 +1,21 @@
+use v6;
+
+use Test;
+
+plan(2);
+
+unless (try { eval("1", :lang<perl5>) }) {
+ skip_rest;
+ exit;
+}
+
+{
+ lives_ok {
+ eval q|
+ use perl5:CGI;
+ my $q = CGI.new;
+ is $q.isa(CGI), 1, "Correct isa";
+ |
+ or die $!;
+ }, "perl5:CLASS.new";
+}
View
7 S01-perl-5-integration/eval_lex.t
@@ -0,0 +1,7 @@
+use v6;
+use Test;
+plan 1;
+
+my $self = "some text";
+
+is ~eval(q/"self is $self"/,:lang<perl5>),"self is some text","lexical inside an eval";
View
39 S01-perl-5-integration/exception_handling.t
@@ -0,0 +1,39 @@
+use v6;
+
+use Test;
+
+
+BEGIN {
+plan 3;
+unless (try { eval("1", :lang<perl5>) }) {
+ skip_rest('no perl 5 support'); exit;
+}
+}
+
+use perl5:Carp;
+
+my $err;
+lives_ok({ try { Carp.croak() }; $err = $! }, "Perl 5 exception (die) caught");
+like($err, rx:P5/Carp/, "Exception is propagated to Perl 6 land");
+
+eval(q[
+package Foo;
+
+sub new {
+ bless {}, __PACKAGE__;
+}
+
+sub error {
+ my $error = Foo->new;
+ die $error;
+}
+
+sub test { "1" }
+], :lang<perl5>);
+
+my $foo = eval("Foo->new",:lang<perl5>);
+try { $foo.error };
+lives_ok( {
+ my $err = $!;
+ $err.test;
+}, "Accessing Perl5 method doesn't die");
View
73 S01-perl-5-integration/hash.t
@@ -0,0 +1,73 @@
+use v6;
+
+use Test;
+
+plan(5);
+
+unless eval 'eval("1", :lang<perl5>)' {
+ skip_rest;
+ exit;
+}
+
+die unless
+eval(q/
+package My::Hash;
+use strict;
+
+sub new {
+ my ($class, $ref) = @_;
+ bless \$ref, $class;
+}
+
+sub hash {
+ my $self = shift;
+ return $$self;
+}
+
+sub my_keys {
+ my $self = shift;
+ return keys %{$$self};
+}
+
+sub my_exists {
+ my ($self, $idx) = @_;
+ return exists $$self->{$idx};
+}
+
+sub fetch {
+ my ($self, $idx) = @_;
+ return $$self->{$idx};
+}
+
+sub store {
+ my ($self, $idx, $val) = @_;
+ $$self->{$idx} = $val;
+}
+
+sub push {
+ my ($self, $val) = @_;
+}
+
+1;
+/, :lang<perl5>);
+
+my $p5ha = eval('sub { My::Hash->new($_[0]) }', :lang<perl5>);
+my %hash = (5 => 'a', 6 => 'b', 7 => 'c', 8 => 'd');
+my $p5hash = $p5ha(\%hash);
+
+my $rethash = $p5hash.hash;
+my @keys = %hash.keys.sort;
+my @p5keys;
+try {
+ @p5keys = $p5hash.my_keys; # this doesn't even pass lives_ok ??
+ @p5keys .= sort;
+};
+
+is("{ @keys }", "{ @p5keys }");
+
+ok($p5hash.store(9, 'e'), 'can store');
+is(%hash{9}, 'e', 'store result');
+
+is($p5hash.fetch(5), 'a', 'fetch result');
+is($p5hash.my_exists(5), %hash.exists(5), 'exists');
+is($p5hash.my_exists(12), %hash.exists(12), 'nonexists fail', :todo<bug>);
View
20 S01-perl-5-integration/import.t
@@ -0,0 +1,20 @@
+use v6;
+
+use Test;
+plan 1;
+
+=begin pod
+
+P5 module import test
+
+=end pod
+
+unless (try { eval("1", :lang<perl5>) }) {
+ skip_rest;
+ exit;
+}
+
+eval q[
+use perl5:Text::Wrap 'wrap';
+is(wrap('foo', 'bar', 'baz'), 'foobaz', "import p5 module");
+] or die $!.perl;
View
126 S01-perl-5-integration/method.t
@@ -0,0 +1,126 @@
+use v6;
+
+use Test;
+
+plan(13);
+
+unless (try { eval("1", :lang<perl5>) }) {
+ skip_rest;
+ exit;
+}
+
+eval(q/
+#line 16 method.t
+package FooBar;
+our $VERSION = '6.0';
+print '';
+
+sub new {
+ bless {}, __PACKAGE__;
+}
+
+sub foo {
+ return 'foo';
+}
+
+sub echo {
+ my ($self, $what) = @_;
+#print "==> echo got $what\n";
+ return $what;
+}
+
+sub callcode {
+ my ($self, $code) = @_;
+#print "==> callcode got $code\n";
+ return eval { $code->($self) };
+}
+
+sub asub {
+ return sub { return "asub" };
+}
+
+sub submany {
+ return sub { ("many", "return") };
+}
+
+sub many {
+ return ("many", "return") ;
+}
+
+sub modify_array {
+ my ($class, $val) = @_;
+ $val->[0] = 99;
+}
+
+# takes an object and invoke me on that
+sub invoke {
+ my ($class, $obj) = @_;
+ $obj->me ('invoking');
+}
+
+/, :lang<perl5>);
+
+{
+ my $r = eval("FooBar->VERSION", :lang<perl5>);
+ is($r, '6.0', "class method");
+}
+
+my $obj;
+
+{
+ $obj = eval("FooBar->new", :lang<perl5>);
+ isa_ok($obj, 'FooBar', "blessed");
+ like($obj, rx:Perl5/FooBar/, "blessed");
+}
+
+{
+ is($obj.foo, 'foo', 'invoke method');
+}
+
+{
+ my $r = $obj.echo("bar");
+ is($r, 'bar', 'invoke method with pugs arg');
+}
+
+{
+ my $r = $obj.asub;
+
+ flunk('isa_ok vs Perl5 not yet defined');
+ # isa_ok($r, 'CODE', "returning a coderef");
+
+ is($r.(), 'asub', 'invoking p5 coderef');
+ my $rr = $obj.callcode($r);
+ is($rr, 'asub', 'invoke with p5 coderef');
+}
+
+{
+ my @r = $obj.many;
+ is(@r.elems, 2);
+}
+
+{
+ my $r = $obj.submany;
+ my @r = $r.();
+ is(@r.elems, 2);
+}
+
+{
+ my $callback = { "baz" };
+ my $r = $obj.callcode($callback);
+ is($r, 'baz', 'invoke method with callback');
+}
+
+{
+ class Foo6 {
+ method me ($class: $arg) { 'Foo6'~$arg };
+ };
+ my $obj6 = Foo6.new;
+ $obj = eval("FooBar->new", :lang<perl5>);
+ is($obj.invoke($obj6), 'Foo6invoking', 'invoke pugs method from p5');
+}
+
+{
+ my @rw = (1, 2, 3);
+ $obj.modify_array(VAR @rw);
+ is(@rw[0], 99, 'modify a scalar ref');
+}
View
12 S01-perl-5-integration/modify_inside_p5.t
@@ -0,0 +1,12 @@
+use v6;
+use Test;
+plan(1);
+
+my $x = 'test';
+my $y = 'case';
+{
+ use v5;
+ $x .= 'ing';
+};
+
+is $x, 'testing', "scalar modified inside perl5 block";
View
25 S01-perl-5-integration/modify_inside_p5_p6.t
@@ -0,0 +1,25 @@
+use v6;
+use Test;
+plan(2);
+
+my $x = 'test';
+my $y = 'case';
+{
+ use v5;
+ $x .= 'ing';
+
+ #the following code hangs pugs.
+ {
+ # Smoke does not complete because of this
+ # Uncomment the following two lines when this is fixed
+ #?pugs emit #
+ use v6;
+ #?pugs emit #
+ $y ~= 'book';
+ };
+};
+
+is $x, 'testing', "scalar modified inside perl5 block";
+
+#?pugs todo 'nested p5/p6 embedding'
+is $y, 'casebook', "scalar modified inside perl6 block inside perl5 block";
View
31 S01-perl-5-integration/return.t
@@ -0,0 +1,31 @@
+use v6;
+
+use Test;
+
+plan(2);
+
+unless (try { eval("1", :lang<perl5>) }) {
+ skip_rest;
+ exit;
+}
+
+eval q<<<
+
+use perl5:Digest::MD5 <md5_hex>;
+
+sub get_dmd5 {
+ my $ctx = Digest::MD5.new;
+ return($ctx);
+}
+
+{
+ is( md5_hex('test'), '098f6bcd4621d373cade4e832627b4f6', 'perl5 function exported' );
+}
+
+{
+ my $ctx = get_dmd5();
+ $ctx.add('test');
+ is( $ctx.hexdigest, '098f6bcd4621d373cade4e832627b4f6', 'XS return' );
+}
+
+>>>;
View
42 S01-perl-5-integration/roundtrip.t
@@ -0,0 +1,42 @@
+use v6;
+
+use Test;
+
+plan(5);
+
+unless eval 'eval("1", :lang<perl5>)' {
+ skip_rest;
+ exit;
+}
+
+eval(q/
+package Id;
+sub new {
+ my ($class, $ref) = @_;
+ bless \$ref, $class;
+}
+sub identity {
+ my $self = shift;
+ return $$self;
+}
+/, :lang<perl5>);
+
+my $japh = { "Just another $_ hacker" };
+my $japh2 = -> $name { "Just another $name hacker" };
+my $id = eval('sub { Id->new($_[0]) }', :lang<perl5>);
+
+is($id($japh).identity('Pugs'), 'Just another Pugs hacker', "Closure roundtrips");
+is($id($japh2).identity('Pugs'), 'Just another Pugs hacker', "Closure roundtrips");
+
+my $keys_p5 = eval('sub {keys %{$_[0]}}', :lang<perl5>);
+my $tohash_p5 = eval('sub { return {map {$_ => 1} @_ } }', :lang<perl5>);
+my %hash = (foo => 'bar', hate => 'software');
+{
+ my $foo = $tohash_p5.(keys %hash);
+ cmp_ok($foo, &infix:<cmp>, %hash);
+ is_deeply([$foo.keys].sort, [%hash.keys].sort);
+}
+
+{
+ is_deeply([%hash.keys].sort, [$keys_p5(VAR %hash)].sort);
+}
Please sign in to comment.
Something went wrong with that request. Please try again.