From: Matt S Trout Date: Thu, 20 Jan 2011 12:10:10 +0000 (+0000) Subject: initial import of ToXS X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FData-Dumper-ToXS.git;a=commitdiff_plain;h=a231da50692cfbaa840edb5c85ea037212997b46 initial import of ToXS --- a231da50692cfbaa840edb5c85ea037212997b46 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 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 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 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 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 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 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, + ] + }; + } +]