initial import of ToXS

diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
index 0000000..ab37b57
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,6 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+  NAME => 'Data::Dumper::ToXS::Test',
+  VERSION => 1,
+);

diff --git a/Test.xs.PL b/Test.xs.PL
new file mode 100644 (file)
index 0000000..665ce7b
--- /dev/null
+++ b/Test.xs.PL
@@ -0,0 +1,16 @@
+#!/usr/bin/env perl
+
+use lib 'lib';
+use Data::Dumper::ToXS;
+
+open my $out, '>', $ARGV[0] or die "fail: $!";
+
+my $ddxs = Data::Dumper::ToXS->new(
+  target_package => 'Data::Dumper::ToXS::Test'
+);
+
+my @fix = do 't/fixtures.pl' or die "t/fixtures.pl: $@";
+
+$ddxs->add_generator(@$_) for @fix;
+
+print $out $ddxs->xs_code;

diff --git a/lib/Data/Dumper/ToXS.pm b/lib/Data/Dumper/ToXS.pm
new file mode 100644 (file)
index 0000000..aec48cd
--- /dev/null
+++ b/lib/Data/Dumper/ToXS.pm
@@ -0,0 +1,156 @@
+package Data::Dumper::ToXS;
+
+our (%ix, %seen);
+
+sub newix { $_[0].'['.($ix{$_[0]}++).']' }
+
+use B qw(svref_2object cstring);
+use Scalar::Util qw(refaddr);
+use Moo;
+
+has target_package => (is => 'ro', required => 1);
+
+has _to_generate => (is => 'ro', default => sub { [] });
+
+sub add_generator {
+  my ($self, $name, $ref) = @_;
+  die "Generation target must be a reference" unless ref($ref);
+  push(@{$self->_to_generate}, [ $name => $ref ]);
+}
+
+sub xs_code {
+  my ($self) = @_;
+  my @do = @{$self->_to_generate};
+  join "\n\n", $self->_preamble,
+    (map $self->_generate_target(@$_), @do),
+    $self->_package_start($self->target_package),
+    (map $self->_generate_xsub($_->[0]), @do);
+}
+
+sub _preamble {
+  <<'END';
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+END
+}
+
+sub _package_start {
+  my ($self, $package) = @_;
+  <<"END";
+MODULE = ${package} PACKAGE = ${package}
+
+PROTOTYPES: DISABLE
+
+END
+}
+
+sub _generate_xsub {
+  my ($self, $name) = @_;
+  <<"END";
+SV *
+${name}()
+  CODE:
+    RETVAL = ${name}(aTHX);
+  OUTPUT:
+    RETVAL
+END
+}
+
+sub _generate_target {
+  my ($self, $name, $ref) = @_;
+  local %ix = map +($_ => 0), qw(av hv sv);
+  local %seen;
+  my $first = newix('sv');
+  my $body = $self->_dump_svrv($first, $ref);
+  my $vars = join '', map +(
+    $ix{$_} ? "  ${\uc}* ${_}[$ix{$_}];\n" : ""
+  ), qw(av hv sv);
+  <<"END";
+SV * ${name} (pTHX)
+{
+${vars}${body}  return ${first};
+}
+END
+}
+
+sub _dump_svrv {
+  my ($self, $ix, $ref) = @_;
+  my $r = ref($ref);
+  if ($seen{$ref}) {
+    # already seen this reference so make a copy
+    "  ${ix} = newSVsv($seen{$ref});\n";
+  } else {
+    $seen{$ref} = $ix;
+    if ($r eq 'SCALAR') {
+      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');
+      join '',
+        $self->_dump_hv($t_ix, $ref),
+        "  ${ix} = newRV_noinc((SV *)${t_ix});\n";
+    } elsif ($r eq 'ARRAY') {
+      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');
+      join '',
+        $self->_dump_svrv($t_ix, $$ref),
+        "  ${ix} = newRV_noinc(${t_ix});\n";
+    } else {
+      die "Can't handle reftype ${r}";
+    }
+  }
+}
+
+sub _dump_sv {
+  my ($self, $ix, $ref) = @_;
+  if (ref($$ref)) {
+    $self->_dump_svrv($ix, $$ref);
+  } else {
+    # Not a reference. What are we dumping?
+    my $sv = svref_2object($ref);
+    if (!defined($$ref)) {
+      "  ${ix} = newSVsv(&PL_sv_undef);\n";
+    } elsif ($sv->isa('B::IV')) {
+      "  ${ix} = newSViv(".$sv->int_value.");\n";
+    } elsif ($sv->isa('B::NV')) {
+      "  ${ix} = newSVnv(".$sv->NV.");\n";
+    } elsif ($sv->isa('B::PV')) {
+      "  ${ix} = newSVpvs(".cstring($$ref).");\n";
+    } else {
+      die "Unsure how to dump ".$$ref;
+    }
+  }
+}
+
+sub _dump_hv {
+  my ($self, $ix, $ref) = @_;
+  join '',
+    "  ${ix} = newHV();\n",
+    map {
+      my $t_ix = newix('sv');
+      ($self->_dump_sv($t_ix, \($ref->{$_})),
+      "  hv_stores(${ix}, ${\cstring $_}, ${t_ix});\n")
+    } sort keys %$ref;
+}
+
+sub _dump_av {
+  my ($self, $ix, $ref) = @_;
+  join '',
+    "  ${ix} = newAV();\n",
+    map {
+      my $t_ix = newix('sv');
+      $self->_dump_sv($t_ix, \($ref->[$_])),
+      "  av_push(${ix}, ${t_ix});\n"
+    } 0 .. $#$ref;
+}
+
+1;

diff --git a/lib/Data/Dumper/ToXS/Test.pm b/lib/Data/Dumper/ToXS/Test.pm
new file mode 100644 (file)
index 0000000..fbb030f
--- /dev/null
+++ b/lib/Data/Dumper/ToXS/Test.pm
@@ -0,0 +1,9 @@
+package Data::Dumper::ToXS::Test;
+
+use XSLoader;
+
+our $VERSION = 1;
+
+XSLoader::load __PACKAGE__, 1;
+
+1;

diff --git a/t/basic.t b/t/basic.t
new file mode 100644 (file)
index 0000000..0512d62
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,16 @@
+use strictures 1;
+use Test::More;
+use Data::Dumper::ToXS::Test;
+use Data::Dumper;
+
+my @fix = do 't/fixtures.pl' or die "t/fixtures.pl: $@";
+
+$Data::Dumper::Sortkeys = 1;
+
+foreach my $f (@fix) {
+  my $d = Dumper($f->[1]);
+  my $l = Dumper(Data::Dumper::ToXS::Test->can($f->[0])->());
+  is($l, $d, "Round tripped ${\$f->[0]} ok");
+}
+
+done_testing;

diff --git a/t/fixtures.pl b/t/fixtures.pl
new file mode 100644 (file)
index 0000000..3884f4d
--- /dev/null
+++ b/t/fixtures.pl
@@ -0,0 +1,28 @@
+[
+  data_structure =>
+  {
+    sv_undef => undef,
+    sv_iv => 3,
+    sv_nv => 4.2,
+    sv_pv => "spoon",
+    ref_scalar => \"foo\nbar",
+    ref_array => [ 1, \undef, "73" ],
+  }
+],
+[
+  cross_refs =>
+    do {
+      my ($x, $y, $z) = (\1, { two => 2 }, [ three => 3 ]);
+      +{
+        one => $x,
+        two => $y,
+        three => $z,
+        inner => {
+          one => $x,
+        },
+        inner2 => [
+          three => $z,
+        ]
+      };
+    }
+]