From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 20 Jan 2011 13:08:36 +0000 (+0000)
Subject: global CV support
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c77361b0997c806cfe75c9cb0ebee0ff61376706;p=p5sagit%2FData-Dumper-ToXS.git

global CV support
---

diff --git a/lib/Data/Dumper/ToXS.pm b/lib/Data/Dumper/ToXS.pm
index aec48cd..0383d92 100644
--- a/lib/Data/Dumper/ToXS.pm
+++ b/lib/Data/Dumper/ToXS.pm
@@ -2,7 +2,8 @@ package Data::Dumper::ToXS;
 
 our (%ix, %seen);
 
-sub newix { $_[0].'['.($ix{$_[0]}++).']' }
+sub _newix { $_[0].'['.($ix{$_[0]}++).']' }
+sub _getglob { \*{$_[0]} }
 
 use B qw(svref_2object cstring);
 use Scalar::Util qw(refaddr);
@@ -63,7 +64,7 @@ sub _generate_target {
   my ($self, $name, $ref) = @_;
   local %ix = map +($_ => 0), qw(av hv sv);
   local %seen;
-  my $first = newix('sv');
+  my $first = _newix('sv');
   my $body = $self->_dump_svrv($first, $ref);
   my $vars = join '', map +(
     $ix{$_} ? "  ${\uc}* ${_}[$ix{$_}];\n" : ""
@@ -85,25 +86,35 @@ sub _dump_svrv {
   } else {
     $seen{$ref} = $ix;
     if ($r eq 'SCALAR') {
-      my $t_ix = newix('sv');
+      my $t_ix = _newix('sv');
       join '',
         $self->_dump_sv($t_ix, $ref),
         "  ${ix} = newRV_noinc(${t_ix});\n";
     } elsif ($r eq 'HASH') {
-      my $t_ix = newix('hv');
+      my $t_ix = _newix('hv');
       join '',
         $self->_dump_hv($t_ix, $ref),
         "  ${ix} = newRV_noinc((SV *)${t_ix});\n";
     } elsif ($r eq 'ARRAY') {
-      my $t_ix = newix('av');
+      my $t_ix = _newix('av');
       join '',
         $self->_dump_av($t_ix, $ref),
         "  ${ix} = newRV_noinc((SV *)${t_ix});\n";
     } elsif ($r eq 'REF') {
-      my $t_ix = newix('sv');
+      my $t_ix = _newix('sv');
       join '',
         $self->_dump_svrv($t_ix, $$ref),
         "  ${ix} = newRV_noinc(${t_ix});\n";
+    } elsif ($r eq 'CODE') {
+      my $full_name = join '::',
+        map $_->NAME, map +($_->GV->STASH, $_->GV), svref_2object($ref);
+      if (*{_getglob($full_name)}{CODE}||'' eq $ref) {
+        # GV_ADD strikes me as more likely to DWIM than to simply blow up
+        # if the generated routine gets called before the method is declared.
+        "  ${ix} = newRV_inc((SV *) get_cv(${\cstring $full_name}, GV_ADD));\n";
+      } else {
+        die "Can't find ${ref} at ${full_name}";
+      }
     } else {
       die "Can't handle reftype ${r}";
     }
@@ -136,7 +147,7 @@ sub _dump_hv {
   join '',
     "  ${ix} = newHV();\n",
     map {
-      my $t_ix = newix('sv');
+      my $t_ix = _newix('sv');
       ($self->_dump_sv($t_ix, \($ref->{$_})),
       "  hv_stores(${ix}, ${\cstring $_}, ${t_ix});\n")
     } sort keys %$ref;
@@ -147,7 +158,7 @@ sub _dump_av {
   join '',
     "  ${ix} = newAV();\n",
     map {
-      my $t_ix = newix('sv');
+      my $t_ix = _newix('sv');
       $self->_dump_sv($t_ix, \($ref->[$_])),
       "  av_push(${ix}, ${t_ix});\n"
     } 0 .. $#$ref;
diff --git a/t/basic.t b/t/basic.t
index 0512d62..0e46ba9 100644
--- a/t/basic.t
+++ b/t/basic.t
@@ -6,10 +6,13 @@ use Data::Dumper;
 my @fix = do 't/fixtures.pl' or die "t/fixtures.pl: $@";
 
 $Data::Dumper::Sortkeys = 1;
+$Data::Dumper::Deparse = 1;
+
+my (%source, %result);
 
 foreach my $f (@fix) {
-  my $d = Dumper($f->[1]);
-  my $l = Dumper(Data::Dumper::ToXS::Test->can($f->[0])->());
+  my $d = Dumper($source{$f->[0]} = $f->[1]);
+  my $l = Dumper($result{$f->[0]} = Data::Dumper::ToXS::Test->can($f->[0])->());
   is($l, $d, "Round tripped ${\$f->[0]} ok");
 }
 
diff --git a/t/fixtures.pl b/t/fixtures.pl
index 3884f4d..fbb6755 100644
--- a/t/fixtures.pl
+++ b/t/fixtures.pl
@@ -1,3 +1,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';
 [
   data_structure =>
   {
@@ -25,4 +29,8 @@
         ]
       };
     }
-]
+],
+do { sub DDXSTest::foo { 'DDXSTest::foo' } () },
+[
+  global_sub => { foo => \&DDXSTest::foo }
+];