weak ref support

diff --git a/Makefile.PL b/Makefile.PL
index ab37b57..aefe6ec 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -4,3 +4,7 @@ WriteMakefile(
   NAME => 'Data::Dumper::ToXS::Test',
   VERSION => 1,
 );
+
+sub MY::postamble {
+  'Test.xs :: t/fixtures.pl'
+}

diff --git a/lib/Data/Dumper/ToXS.pm b/lib/Data/Dumper/ToXS.pm
index 0383d92..2f2a88d 100644 (file)
--- a/lib/Data/Dumper/ToXS.pm
+++ b/lib/Data/Dumper/ToXS.pm
@@ -1,12 +1,12 @@
 package Data::Dumper::ToXS;
 
-our (%ix, %seen);
+our (%ix, %seen, $weaken);
 
 sub _newix { $_[0].'['.($ix{$_[0]}++).']' }
 sub _getglob { \*{$_[0]} }
 
 use B qw(svref_2object cstring);
-use Scalar::Util qw(refaddr);
+use Scalar::Util qw(refaddr isweak);
 use Moo;
 
 has target_package => (is => 'ro', required => 1);
@@ -64,6 +64,7 @@ sub _generate_target {
   my ($self, $name, $ref) = @_;
   local %ix = map +($_ => 0), qw(av hv sv);
   local %seen;
+  local $weaken = '';
   my $first = _newix('sv');
   my $body = $self->_dump_svrv($first, $ref);
   my $vars = join '', map +(
@@ -72,7 +73,7 @@ sub _generate_target {
   <<"END";
 SV * ${name} (pTHX)
 {
-${vars}${body}  return ${first};
+${vars}${body}${weaken}  return ${first};
 }
 END
 }
@@ -80,6 +81,7 @@ END
 sub _dump_svrv {
   my ($self, $ix, $ref) = @_;
   my $r = ref($ref);
+  $weaken .= "  sv_rvweaken(${ix});\n" if isweak($_[2]);
   if ($seen{$ref}) {
     # already seen this reference so make a copy
     "  ${ix} = newSVsv($seen{$ref});\n";

diff --git a/t/basic.t b/t/basic.t
index 0e46ba9..9c6fe07 100644 (file)
--- a/t/basic.t
+++ b/t/basic.t
@@ -2,6 +2,8 @@ use strictures 1;
 use Test::More;
 use Data::Dumper::ToXS::Test;
 use Data::Dumper;
+use Devel::Peek qw(SvREFCNT);
+use Scalar::Util qw(isweak);
 
 my @fix = do 't/fixtures.pl' or die "t/fixtures.pl: $@";
 
@@ -16,4 +18,10 @@ foreach my $f (@fix) {
   is($l, $d, "Round tripped ${\$f->[0]} ok");
 }
 
+{
+  my $r = $result{weaken_1};
+  ok(isweak($r->[1]), 'Weak element is weak');
+  is(SvREFCNT(${$r->[1]}), 2, 'Refcount of target correct');
+}
+
 done_testing;

diff --git a/t/fixtures.pl b/t/fixtures.pl
index fbb6755..cb6e5aa 100644 (file)
--- a/t/fixtures.pl
+++ b/t/fixtures.pl
@@ -2,6 +2,7 @@ use strictures 1;
 # disable the "Useless use of anonymous list ([]) in void context"
 # warning so we can perl -c this file during development
 no warnings 'void';
+use Scalar::Util qw(weaken);
 [
   data_structure =>
   {
@@ -33,4 +34,20 @@ no warnings 'void';
 do { sub DDXSTest::foo { 'DDXSTest::foo' } () },
 [
   global_sub => { foo => \&DDXSTest::foo }
-];
+],
+[
+  weaken_1 => do {
+    my $x = 1;
+    my $y = [ \$x, \$x, \$x ];
+    weaken($y->[1]);
+    $y;
+  }
+],
+[
+  weaken_0 => do {
+    my $x = 1;
+    my $y = [ \$x, \$x, \$x ];
+    weaken($y->[0]);
+    $y;
+  }
+]