#!/usr/bin/perl
use strict;
use warnings;
use Test::More 'no_plan';
use Scalar::Util qw(refaddr);
use ok 'Sub::Clone' => ':all';
sub foo { "foo" }
my $bar = "bar";
{
sub bar { $bar };
}
my $anon = sub { "anon" };
my $blah = "closure";
my $closure = sub { $blah };
ok( !is_cloned(\&foo), "foo is not a cloned sub" );
ok( !is_cloned(\&bar), "bar is a non cloned closure" );
ok( !is_cloned($anon), "non closure anon is not cloned" );
ok( is_cloned($closure), "closure is cloned" );
my $destroyed;
sub Foo::DESTROY { $destroyed++ };
foreach my $sub ( \&foo, \&bar, $anon, $closure ) {
my $foo = {};
my $clone = clone_sub($sub);
ok( is_cloned($clone), "clone is cloned" );
isnt( refaddr($sub), refaddr($clone), "refaddrs differ" );
SKIP: {
skip "no Scalar::Util::weaken" unless defined &Scalar::Util::weaken;
Scalar::Util::weaken($foo);
is( $foo, undef, "didn't randomly capture stuff" );
}
use Devel::Peek;
is( $clone->(), $sub->(), "behaves the same" );# || do { Dump($clone); Dump($sub) };
undef $destroyed;
bless $clone, "Foo";
is( ref($sub), "CODE", "orig sub not blessed" );
my $clone_2 = clone_sub($clone);
is( ref($clone_2), "Foo", "clone is blessed the same way" );
undef $clone_2;
is( $destroyed, 1, "DESTROY called on clone of clone" );
undef $destroyed;
my $clone_3 = clone_sub($clone);
undef $clone;
#ok( $destroyed, "DESTROY called on clone" ); # passes with XS, but not with pure perl
undef $clone_3;
is( $destroyed, 2, "DESTROY called on clone and second clone of clone" );
my $mortal = clone_if_immortal($sub);
ok( is_cloned($mortal), "mortal" );
if ( is_cloned($sub) ) {
is( refaddr($mortal), refaddr($sub), "orig is already mortal, refaddr is the same" );
} else {
isnt( refaddr($mortal), refaddr($sub), "orig is not mortal, refaddrs differ" );
}
}
{
my $weak;
{
my ( $anon, $clone );
{
my $x = "foo";
if ( defined &Scalar::Util::weaken ) {
$weak = \$x;
Scalar::Util::weaken($weak);
}
$anon = sub { $x };
is( $anon->(), "foo", "anon's closed over value" );
$clone = clone_sub($anon);
is( $clone->(), "foo", "clone returns the same" );
$x = "bar";
is( $anon->(), "bar", "var is captured" );
is( $clone->(), "bar", "clone in sync" );
}
undef $anon;
is( $clone->(), "bar", "clone refcounts closed var" );
SKIP: {
skip "no Scalar::Util::weaken" unless defined &Scalar::Util::weaken;
is( $$weak, "bar", "weakref is valid" );
}
}
SKIP: {
skip "no Scalar::Util::weaken" unless defined &Scalar::Util::weaken;
is( $weak, undef, "weakref went away" );
}
}
sub mk {
my $x = shift;
sub { $x };
}
{
my $a = mk(3);
is( $a->(), 3, "closure for left scope" );
my $clone = clone_sub($a);
is( $clone->(), 3, "clone works too" );
}