lib/Data/Dumper/ToXS.pm

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