File Coverage

blib/lib/xsub.pm

Criterion	Covered	Total	%
statement	72	93	77.4
branch	17	48	35.4
condition	6	18	33.3
subroutine	5	5	100.0
pod			n/a
total	100	164	60.9

package xsub;
$VERSION = 1.0;

my %XSUB;

sub import {
  my $p = shift;

  my ($package, $file, $line) = caller;

  my $source = pop;
  my $name = shift;
  my $prototype = @_ && $_[0] !~ /^:/ ? shift : undef;
  my $attributes = [@_];
  s/^:// for @$attributes;

  my $xs = bless {
    name       => $name,
    source     => $source,
    package    => $package,
    file       => $file,
    line       => $line,
    prototype  => $prototype,
    attributes => $attributes,
  }, $p;

  if ($name) {
    my $pr = defined($prototype) ? "($prototype)" : "";
    eval "package $package; sub $name $pr";
    $@ and die $@;
  }

  local *XSUB  = \@{$XSUB{$file}};
  push @XSUB, $xs;
}

sub _reindent($$) {
  my $v = ' ' x shift;
  my @l = split /\n/, $_[0];

  my $i = 0;
  $i++ while $i < @l && $l[$i] eq '';
  $i < @l && $l[$i] =~ m/^(\s+)/ or return $_[0];
  my $k = $1;

  s/^$k/$v/ for @l;
  join "\n", @l, '';
}

sub _unindent($) {
  _reindent(0, $_[0])
}

sub _compile {
  my ($c, $so) = @_;
  my $cmd =
    "$C{cc} $C{ccflags} -O3 $C{cccdlflags} " .
    "-I$C{archlib}/CORE $C{lddlflags} -o $so $c";
  my $x = system $cmd;
  $x and die;
  -e $so or die;
}

sub bootstrap {
  my $p = shift;
  my ($q, $qpm) = (caller)[0, 1];
  my ($qc, $qso);

  local *XSUB  = \@{$XSUB{$qpm}};
  defined @XSUB or return;

  -e $qpm or die;
  $qpm =~ m/\.pm$/ or die;
  ($qc =  $qpm) =~ s/\.pm$/\.c/ or die;
  ($qso = $qpm) =~ s/\.pm$/\.so/ or die;

  if (!-e $qso || (-M $qpm < -M $qso) || (-M __FILE__ < -M $qso)) {
    local *XS;
    open XS, '>', $qc or die;
    my $pre = select(XS);

    print _unindent qq{
      #include "EXTERN.h"
      #include "perl.h"
      #include "XSUB.h"

      #define __PACKAGE__	"$q"
      #define undef		(&PL_sv_undef)
      #define true		(&PL_sv_yes)
      #define yes		true
      #define false		(&PL_sv_no)
      #define no		false
      #define unless(x)		if (!(x))
      #define wantarray		(GIMME == G_ARRAY)
      #define wantvoid		(GIMME == G_VOID)
      #define wantscalar	(GIMME == G_SCALAR)
    };

    print _unindent q{
      #define _C_RETURN_AV(sv) { \
        AV *av = (AV *)(sv); I32 n = 1 + AvFILL(av); \
        EXTEND(SP, n); Copy(AvARRAY(av), SP + 1, n, SV *); SP += n; \
        av_undef(av); \
        PUTBACK; return; \
      }

      #define _C_RETURN_SV(sv) { \
        PUSHs(sv_2mortal(sv)); \
        PUTBACK; return; \
      }

      #define _C_DECLARE(name) XS(name) { \
        dXSARGS; SP -= items; { \
          SV *(_C_ ## name)(U32, SV **); \
          SV *sv = (_C_ ## name)(items, &ST(0)); \
          if (!sv) { PUTBACK; return; } \
          if (SvTYPE(sv) == SVt_PVAV) \
            _C_RETURN_AV(sv) \
          else \
            _C_RETURN_SV(sv) \
        } \
      } SV *_C_ ## name (UV argc, SV **argv)
    };

    for (@XSUB) {
      unless ($$_{name}) {
        print "#line $$_{line} \"$$_{file}\"\n";
        print _unindent($$_{source}), "\n";
        next;
      }

      (my $name = "XS_$$_{package}_$$_{name}") =~ s/::/__/g;

      print "\n";
      print "_C_DECLARE($name) {\n";
      print "#line $$_{line} \"$$_{file}\"\n";
      print _reindent(2, $$_{source});
      print "}\n";
      # print "#define $$_{name} _C_$name\n";
    }

    (my $boot_q = "boot_$q") =~ s/::/__/g;
    print "\nXS($boot_q) {\n";
    for (@XSUB) {
      $$_{name} or next;
      my $realname = "$$_{package}::$$_{name}";
      (my $name = "XS_$$_{package}_$$_{name}") =~ s/::/__/g;

      my $pr = $$_{prototype};
      defined $pr and $pr =~ s/\\/\\\\/g;

      print "  newXS";
      print "proto" if defined $pr;
      print "(\"$realname\", $name, __FILE__";
      print ", \"$pr\"" if defined $pr;
      print ");\n";
    }
    print "}\n";

    select($pre);
    close XS;

    require Config;
    local *C = \%Config::Config;

    unlink($qso);
    _compile($qc, $qso);
    unlink($qc);
  }

  require DynaLoader;
  $qso =~ m<^/> or $qso = "./$qso";
  my $libref = DynaLoader::dl_load_file($qso, 0) or die;
  (my $boot_q = "boot_$q") =~ s/::/__/g;
  my $symref = DynaLoader::dl_find_symbol($libref, $boot_q) or die;
  DynaLoader::dl_install_xsub($boot_q, $symref, $qso) or die;

  &{$boot_q};

  require attributes;
  for (@XSUB) {
    $$_{name} && @{$$_{attributes}} or next;
    for my $a (@{$$_{attributes}}) {
      import attributes $$_{package}, \&{"$$_{package}::$$_{name}"}, $a;
    }
  }
}

1