From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 20 Jan 2011 17:11:53 +0000 (+0000)
Subject: blessed reference support
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4a4c86ce592ccdf074c45875e35c090b1e911e3d;p=p5sagit%2FData-Dumper-ToXS.git

blessed reference support
---

diff --git a/lib/Data/Dumper/ToXS.pm b/lib/Data/Dumper/ToXS.pm
index 2f2a88d..2026ee1 100644
--- a/lib/Data/Dumper/ToXS.pm
+++ b/lib/Data/Dumper/ToXS.pm
@@ -1,12 +1,12 @@
 package Data::Dumper::ToXS;
 
-our (%ix, %seen, $weaken);
+our (%ix, %seen, $postamble, %stash);
 
 sub _newix { $_[0].'['.($ix{$_[0]}++).']' }
 sub _getglob { \*{$_[0]} }
 
 use B qw(svref_2object cstring);
-use Scalar::Util qw(refaddr isweak);
+use Scalar::Util qw(refaddr isweak blessed reftype);
 use Moo;
 
 has target_package => (is => 'ro', required => 1);
@@ -15,7 +15,7 @@ has _to_generate => (is => 'ro', default => sub { [] });
 
 sub add_generator {
   my ($self, $name, $ref) = @_;
-  die "Generation target must be a reference" unless ref($ref);
+  die "Generation target ${\($ref||'undef')} for ${\($name||'undef')} must be a reference" unless ref($ref);
   push(@{$self->_to_generate}, [ $name => $ref ]);
 }
 
@@ -64,7 +64,8 @@ sub _generate_target {
   my ($self, $name, $ref) = @_;
   local %ix = map +($_ => 0), qw(av hv sv);
   local %seen;
-  local $weaken = '';
+  local $postamble = '';
+  local %stash;
   my $first = _newix('sv');
   my $body = $self->_dump_svrv($first, $ref);
   my $vars = join '', map +(
@@ -73,20 +74,29 @@ sub _generate_target {
   <<"END";
 SV * ${name} (pTHX)
 {
-${vars}${body}${weaken}  return ${first};
+${vars}${body}${postamble}  return ${first};
 }
 END
 }
 
 sub _dump_svrv {
   my ($self, $ix, $ref) = @_;
-  my $r = ref($ref);
-  $weaken .= "  sv_rvweaken(${ix});\n" if isweak($_[2]);
+  my $r = reftype($ref);
+  $postamble .= "  sv_rvweaken(${ix});\n" if isweak($_[2]);
   if ($seen{$ref}) {
     # already seen this reference so make a copy
     "  ${ix} = newSVsv($seen{$ref});\n";
   } else {
     $seen{$ref} = $ix;
+    if (my $class = blessed($ref)) {
+      my $s_ix = $stash{$class} ||= do {
+        my $s_ix = _newix('hv');
+        $postamble .= "  ${s_ix} = gv_stashpvs(${\cstring $class}, GV_ADD);\n";
+        $s_ix;
+      };
+      $postamble .=
+        "  sv_bless(${ix}, ${s_ix});\n";
+    }  
     if ($r eq 'SCALAR') {
       my $t_ix = _newix('sv');
       join '',
diff --git a/t/fixtures.pl b/t/fixtures.pl
index cb6e5aa..2ed6e75 100644
--- a/t/fixtures.pl
+++ b/t/fixtures.pl
@@ -50,4 +50,6 @@ do { sub DDXSTest::foo { 'DDXSTest::foo' } () },
     weaken($y->[0]);
     $y;
   }
-]
+],
+[ simple_object => { object => bless({}, 'Class') } ],
+[ double_object => { o1 => bless({}, 'Class'), o2 => bless({}, 'Class') } ],