lib/Data/Dumper/ToXS.pm

   1 package Data::Dumper::ToXS;
   2
   3 our (%ix, %seen);
   4
   5 sub newix { $_[0].'['.($ix{$_[0]}++).']' }
   6
   7 use B qw(svref_2object cstring);
   8 use Scalar::Util qw(refaddr);
   9 use Moo;
  10
  11 has target_package => (is => 'ro', required => 1);
  12
  13 has _to_generate => (is => 'ro', default => sub { [] });
  14
  15 sub add_generator {
  16   my ($self, $name, $ref) = @_;
  17   die "Generation target must be a reference" unless ref($ref);
  18   push(@{$self->_to_generate}, [ $name => $ref ]);
  19 }
  20
  21 sub xs_code {
  22   my ($self) = @_;
  23   my @do = @{$self->_to_generate};
  24   join "\n\n", $self->_preamble,
  25     (map $self->_generate_target(@$_), @do),
  26     $self->_package_start($self->target_package),
  27     (map $self->_generate_xsub($_->[0]), @do);
  28 }
  29
  30 sub _preamble {
  31   <<'END';
  32 #define PERL_NO_GET_CONTEXT
  33 #include "EXTERN.h"
  34 #include "perl.h"
  35 #include "XSUB.h"
  36
  37 END
  38 }
  39
  40 sub _package_start {
  41   my ($self, $package) = @_;
  42   <<"END";
  43 MODULE = ${package} PACKAGE = ${package}
  44
  45 PROTOTYPES: DISABLE
  46
  47 END
  48 }
  49
  50 sub _generate_xsub {
  51   my ($self, $name) = @_;
  52   <<"END";
  53 SV *
  54 ${name}()
  55   CODE:
  56     RETVAL = ${name}(aTHX);
  57   OUTPUT:
  58     RETVAL
  59 END
  60 }
  61
  62 sub _generate_target {
  63   my ($self, $name, $ref) = @_;
  64   local %ix = map +($_ => 0), qw(av hv sv);
  65   local %seen;
  66   my $first = newix('sv');
  67   my $body = $self->_dump_svrv($first, $ref);
  68   my $vars = join '', map +(
  69     $ix{$_} ? "  ${\uc}* ${_}[$ix{$_}];\n" : ""
  70   ), qw(av hv sv);
  71   <<"END";
  72 SV * ${name} (pTHX)
  73 {
  74 ${vars}${body}  return ${first};
  75 }
  76 END
  77 }
  78
  79 sub _dump_svrv {
  80   my ($self, $ix, $ref) = @_;
  81   my $r = ref($ref);
  82   if ($seen{$ref}) {
  83     # already seen this reference so make a copy
  84     "  ${ix} = newSVsv($seen{$ref});\n";
  85   } else {
  86     $seen{$ref} = $ix;
  87     if ($r eq 'SCALAR') {
  88       my $t_ix = newix('sv');
  89       join '',
  90         $self->_dump_sv($t_ix, $ref),
  91         "  ${ix} = newRV_noinc(${t_ix});\n";
  92     } elsif ($r eq 'HASH') {
  93       my $t_ix = newix('hv');
  94       join '',
  95         $self->_dump_hv($t_ix, $ref),
  96         "  ${ix} = newRV_noinc((SV *)${t_ix});\n";
  97     } elsif ($r eq 'ARRAY') {
  98       my $t_ix = newix('av');
  99       join '',
 100         $self->_dump_av($t_ix, $ref),
 101         "  ${ix} = newRV_noinc((SV *)${t_ix});\n";
 102     } elsif ($r eq 'REF') {
 103       my $t_ix = newix('sv');
 104       join '',
 105         $self->_dump_svrv($t_ix, $$ref),
 106         "  ${ix} = newRV_noinc(${t_ix});\n";
 107     } else {
 108       die "Can't handle reftype ${r}";
 109     }
 110   }
 111 }
 112
 113 sub _dump_sv {
 114   my ($self, $ix, $ref) = @_;
 115   if (ref($$ref)) {
 116     $self->_dump_svrv($ix, $$ref);
 117   } else {
 118     # Not a reference. What are we dumping?
 119     my $sv = svref_2object($ref);
 120     if (!defined($$ref)) {
 121       "  ${ix} = newSVsv(&PL_sv_undef);\n";
 122     } elsif ($sv->isa('B::IV')) {
 123       "  ${ix} = newSViv(".$sv->int_value.");\n";
 124     } elsif ($sv->isa('B::NV')) {
 125       "  ${ix} = newSVnv(".$sv->NV.");\n";
 126     } elsif ($sv->isa('B::PV')) {
 127       "  ${ix} = newSVpvs(".cstring($$ref).");\n";
 128     } else {
 129       die "Unsure how to dump ".$$ref;
 130     }
 131   }
 132 }
 133
 134 sub _dump_hv {
 135   my ($self, $ix, $ref) = @_;
 136   join '',
 137     "  ${ix} = newHV();\n",
 138     map {
 139       my $t_ix = newix('sv');
 140       ($self->_dump_sv($t_ix, \($ref->{$_})),
 141       "  hv_stores(${ix}, ${\cstring $_}, ${t_ix});\n")
 142     } sort keys %$ref;
 143 }
 144
 145 sub _dump_av {
 146   my ($self, $ix, $ref) = @_;
 147   join '',
 148     "  ${ix} = newAV();\n",
 149     map {
 150       my $t_ix = newix('sv');
 151       $self->_dump_sv($t_ix, \($ref->[$_])),
 152       "  av_push(${ix}, ${t_ix});\n"
 153     } 0 .. $#$ref;
 154 }
 155
 156 1;