Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

377 lines (307 sloc) 9.793 kB
use v6;
use Test;
use soft;
# L<S06/Wrapping>
# TODO
# nextsame, nextwith, callsame
# unwrap with no args pops the top most (is this spec?)
#
# mutating wraps -- those should be "deep", as in not touching coderefs
# but actually mutating how the coderef works.
plan 85;
my @log;
sub foo {
push @log, "foo";
}
sub wrapper {
push @log, "wrapper before";
try { callwith() };
push @log, "wrapper after";
}
sub other_wrapper () {
push @log, "wrapper2";
try { callwith() };
}
foo();
is(+@log, 1, "one event logged");
is(@log[0], "foo", "it's foo");
dies-ok { &foo.unwrap() }, 'cannot upwrap a never-wrapped sub.';
@log = ();
wrapper();
is(+@log, 2, "two events logged");
is(@log[0], "wrapper before", "wrapper before");
is(@log[1], "wrapper after", "wrapper after");
@log = ();
my $wrapped = &foo.wrap(&wrapper);
foo();
is @log.join('|'), 'wrapper before|foo|wrapper after', 'logged the correct events';
@log = ();
my $doublywrapped = &foo.wrap(&other_wrapper);
foo();
is(+@log, 4, "four events");
is(@log[0], "wrapper2", "additional wrapping takes effect");
is(@log[1], "wrapper before", "... on top of initial wrapping");
@log = ();
&foo.unwrap($doublywrapped);
foo();
is(+@log, 3, "old wrapped sub was not destroyed");
is(@log[0], "wrapper before", "the original wrapper is still in effect");
@log = ();
&foo.unwrap($wrapped);
foo();
is(+@log, 1, "one events for unwrapped (should be back to original now)");
is(@log[0], "foo", "got execpted value");
@log = ();
$wrapped = &foo.wrap(&wrapper);
$doublywrapped = &foo.wrap(&other_wrapper);
&foo.unwrap($wrapped);
foo();
is(+@log, 2, "out of order unwrapping gave right number of results");
is(@log[0], "wrapper2", "got execpted value from remaining wrapper");
is(@log[1], "foo", "got execpted value from original sub");
dies-ok { &foo.unwrap($wrapped) }, "can't re-unwrap an already unwrapped sub";
#First level wrapping
sub hi { "Hi" };
is( hi, "Hi", "Basic sub." );
my $handle;
lives-ok( { $handle = &hi.wrap({ callsame() ~ " there" }) },
"Basic wrapping works ");
ok( $handle, "Recieved handle for unwrapping." );
is( hi, "Hi there", "Function produces expected output after wrapping" );
#unwrap the handle
lives-ok { $handle = &hi.unwrap( $handle )}, "unwrap the function";
is( hi, "Hi", "Function is no longer wrapped." );
#Check 10 levels of wrapping
#useless function.
sub levelwrap($n) {
return $n;
}
# Make sure useless function does it's job.
is( levelwrap( 1 ), 1, "Sanity test." );
is( levelwrap( 2 ), 2, "Sanity test." );
#?rakudo todo 'callwith RT #124653'
lives-ok { &levelwrap.callwith( 1 )},
"Check that functions have a 'callwith' that works. ";
#?DOES 20
{
for (1..10) -> $num {
lives-ok {
&levelwrap.wrap({
callwith( $^t + 1 );
}),
" Wrapping #$num"
}, "wrapping $num";
is( levelwrap( 1 ), 1 + $num, "Checking $num level wrapping" );
}
}
#Check removal of wrap in the middle by handle.
sub functionA {
return 'z';
}
is( functionA(), 'z', "Sanity." );
my $middle;
lives-ok { $middle = &functionA.wrap(sub { return 'y' ~ callsame })},
"First wrapping lived";
is( functionA(), "yz", "Middle wrapper sanity." );
lives-ok { &functionA.wrap(sub { return 'x' ~ callsame })},
'Second wraping lived';
is( functionA(), "xyz", "three wrappers sanity." );
lives-ok { &functionA.unwrap( $middle )}, 'unwrap the middle wrapper.';
is( functionA(), "xz", "First wrapper and final function only, middle removed." );
#temporization (end scope removal of wrapping)
sub functionB {
return 'xxx';
}
{
is( functionB, "xxx", "Sanity" );
{
try {
temp &functionB.wrap({ return 'yyy' });
};
is( functionB, 'yyy', 'Check that function is wrapped.' );
}
#?rakudo todo 'temp and wrap'
is( functionB, 'xxx', "Wrap is now out of scope, should be back to normal." );
}
#?rakudo todo 'temp and wrap RT #124654'
is( functionB, 'xxx', "Wrap is now out of scope, should be back to normal." );
#?rakudo todo 'RT #70267: call to nextsame with nowhere to go'
dies-ok { {nextsame}() }, '{nextsame}() dies properly';
# RT #66658
#?niecza skip "undefined undefined"
{
sub meet( $person ) { return "meet $person" }
sub greet( $person ) { return "greet $person" }
my $wrapped;
for &greet, &meet -> $wrap {
my $name = $wrap.name;
$wrap.wrap({ $wrapped = $name; callsame; });
}
ok ! $wrapped.defined, 'wrapper test variable is undefined';
is greet('japhb'), 'greet japhb', 'wrapped greet() works';
is $wrapped, 'greet', 'wrapper sees lexical from time of wrap (greet)';
undefine $wrapped;
ok ! $wrapped.defined, 'wrapper test variable is undefined';
is meet('masak'), 'meet masak', 'wrapped meet() works';
is $wrapped, 'meet', 'wrapper sees lexical from time of wrap (meet)';
}
{
sub foo() { 1 }
my $h = &foo.wrap(-> { 1 + callsame });
is foo(), 2, 'wrap worked (sanity)';
$h.restore();
is foo(), 1, 'could unwrap by calling .restore on the handle';
}
# RT #69312
#?rakudo.jvm skip "control operator crossed continuation barrier RT #124655"
{
my @t = gather {
sub triangle { take '=' x 3; }
for reverse ^3 -> $n {
&triangle.wrap({
take '=' x $n;
callsame;
take '=' x $n;
});
}
triangle();
}
is @t.join("\n"), "\n=\n==\n===\n==\n=\n", 'multiple wrappings in a loop';
}
# RT #77472
{
multi multi-to-wrap($x) {
$x * 2;
};
&multi-to-wrap.wrap({
2 * callsame;
});
#?rakudo.jvm todo "?"
is multi-to-wrap(5), 20, 'can wrap a multi';
}
{
my $didfoo;
my role SomeTrait {
method apply_handles($attr: Mu $pkg) {
my $name = $attr.name;
my $accessor = $name.subst(/^../, '');
my $r = sub ($obj, |args) is rw {
my (|c) ::= callsame;
c;
}
$pkg.^find_method($accessor).wrap($r);
}
method foo { $didfoo++ }
}
multi trait_mod:<is>(Attribute $var, :$wtf!) {
die "Must have accessor" unless $var.has-accessor;
$var.set_rw;
$var does SomeTrait;
$var.foo;
}
my class foo {
has $.x is rw is wtf = 16;
}
ok $didfoo, "Did foo, capture return";
my $foo = foo.new; # x = 16;
my $bar = foo.new(x => 32);
#?rakudo.moar 2 todo 'RT #122259'
#?rakudo.jvm 3 skip 'RT #122259'
is $foo.x, 16, "default works with wrapped accessor, capture return";
is $bar.x, 32, "BUILD binding works with wrapped accessor, capture return";
try $bar.x = 64;
is $bar.x, 64, "assignment works with wrapped accessor, capture return";
}
{
my $didfoo;
my role SomeTrait {
method apply_handles($attr: Mu $pkg) {
my $name = $attr.name;
my $accessor = $name.subst(/^../, '');
my $r = sub ($obj, |args) is rw {
return callsame;
}
$pkg.^find_method($accessor).wrap($r);
}
method foo { $didfoo++ }
}
multi trait_mod:<is>(Attribute $var, :$wtf!) {
die "Must have accessor" unless $var.has-accessor;
$var.set_rw;
$var does SomeTrait;
$var.foo;
}
my class foo {
has $.x is rw is wtf = 16;
}
ok $didfoo, "Did foo, return callsame";
my $foo = foo.new; # x = 16;
my $bar = foo.new(x => 32);
is $foo.x, 16, "default works with wrapped accessor, return callsame";
is $bar.x, 32, "BUILD binding works with wrapped accessor, return callsame";
try $bar.x = 64;
#?rakudo todo 'RT #122259'
is $bar.x, 64, "assignment works with wrapped accessor, return callsame";
}
{
my $didfoo;
my role SomeTrait {
method apply_handles($attr: Mu $pkg) {
my $name = $attr.name;
my $accessor = $name.subst(/^../, '');
my $r = sub ($obj, |args) is rw {
callsame;
}
$pkg.^find_method($accessor).wrap($r);
}
method foo { $didfoo++ }
}
multi trait_mod:<is>(Attribute $var, :$wtf!) {
die "Must have accessor" unless $var.has-accessor;
$var.set_rw;
$var does SomeTrait;
$var.foo;
}
my class foo {
has $.x is rw is wtf = 16;
}
ok $didfoo, "Did foo, callsame";
my $foo = foo.new; # x = 16;
my $bar = foo.new(x => 32);
is $foo.x, 16, "default works with wrapped accessor, callsame";
is $bar.x, 32, "BUILD binding works with wrapped accessor, callsame";
try $bar.x = 64;
is $bar.x, 64, "assignment works with wrapped accessor, callsame";
}
{
my $didfoo;
my role SomeTrait {
method apply_handles($attr: Mu $pkg) {
my $name = $attr.name;
my $accessor = $name.subst(/^../, '');
my $r = sub ($obj, |args) is rw {
nextsame;
}
$pkg.^find_method($accessor).wrap($r);
}
method foo { $didfoo++ }
}
multi trait_mod:<is>(Attribute $var, :$wtf!) {
die "Must have accessor" unless $var.has-accessor;
$var.set_rw;
$var does SomeTrait;
$var.foo;
}
my class foo {
has $.x is rw is wtf = 16;
}
ok $didfoo, "Did foo, nextsame";
my $foo = foo.new; # x = 16;
my $bar = foo.new(x => 32);
is $foo.x, 16, "default works with wrapped accessor, nextsame";
is $bar.x, 32, "BUILD binding works with wrapped accessor, nextsame";
try $bar.x = 64;
#?rakudo todo 'RT #122259'
is $bar.x, 64, "assignment works with wrapped accessor, nextsame";
}
# vim: ft=perl6
Jump to Line
Something went wrong with that request. Please try again.