File Coverage

blib/lib/InlineX/C2XS.pm

Criterion	Covered	Total	%
statement	305	334	91.3
branch	144	186	77.4
condition	16	18	88.8
subroutine	12	12	100.0
pod	0	1	0.0
total	477	551	86.5

package InlineX::C2XS;
use warnings;
use strict;
use Carp;
use Config;

require Exporter;
our @ISA = qw(Exporter);

our @EXPORT_OK = qw(c2xs context);

our $VERSION = '0.27';
#$VERSION = eval $VERSION;

use InlineX::C2XS::Context;

my $config_options;

our @allowable_config_keys = ('AUTOWRAP', 'AUTO_INCLUDE', 'CODE', 'DIST', 'TYPEMAPS', 'LIBS', 'INC',
        'WRITE_MAKEFILE_PL', 'BUILD_NOISY', 'BOOT', 'BOOT_F', 'EXPORT_ALL', 'EXPORT_OK_ALL', 'MANIF',
        'EXPORT_TAGS_ALL', 'MAKE', 'PREFIX', 'PREREQ_PM', 'CCFLAGS', 'CCFLAGSEX', 'LD', 'LDDLFLAGS',
        'MYEXTLIB', 'OBJECT', 'OPTIMIZE', 'PRE_HEAD', 'PROTOTYPE', 'PROTOTYPES', 'CC', 'SRC_LOCATION', 'T',
        '_TESTING', 'USE', 'USING', 'WRITE_PM', 'VERSION');

##=========================##

sub c2xs {
    eval {require "Inline/C.pm"};
    if($@) {die "Need a functioning Inline::C (version 0.46_01 or later). $@"}
    my $module = shift;
    my $pkg = shift;

    # Set the default for $build_dir.
    # (This will be overwritten by a supplied build_dir argument.)
    my $build_dir = '.';

    if(@_) {
      if(ref($_[0]) eq "HASH") {
        $config_options = shift;
        # Check for invalid config options - and die if one is found
        for(keys(%$config_options)) { die "$_ is an invalid config option" if !_check_config_keys($_)}
        if(@_) {die "Incorrect usage - there should be no arguments to c2xs() after the hash reference"}
      }
      else {$build_dir = shift}
    }

    if(@_) {
      if(ref($_[0]) ne "HASH") {die "Fourth arg to c2xs() needs to be a hash containing config options ... but it's not !!\n"}
      $config_options = shift;
      # Check for invalid config options - and die if one is found
      for(keys(%$config_options)) { die "$_ is an invalid config option" if !_check_config_keys($_)}
    }

    unless(-d $build_dir) {
       die "$build_dir is not a valid directory";
    }
    my $modfname = (split /::/, $module)[-1];
    my $need_inline_h = $config_options->{AUTOWRAP} ? 1 : 0;
    my $code = '';
    my $o;

    if(exists($config_options->{CODE}) && exists($config_options->{SRC_LOCATION})) {
      die "You can provide either CODE *or* SRC_LOCATION arguments ... but not *both*";
    }

    if(exists($config_options->{BOOT}) && exists($config_options->{BOOT_F})) {
      die "You can provide either BOOT *or* BOOT_F arguments ... but not *both*";
    }

    if(exists($config_options->{CODE})) {
      $code = $config_options->{CODE};
      if($code =~ /inline_stack_vars/i) {$need_inline_h = 1 }
    }
    elsif(exists($config_options->{SRC_LOCATION})) {
      open(RD, "<", $config_options->{SRC_LOCATION}) or die "Can't open ", $config_options->{SRC_LOCATION}, " for reading: $!";
      while() {
           $code .= $_;
           if($_ =~ /inline_stack_vars/i) {$need_inline_h = 1}
      }
      close(RD) or die "Can't close ", $config_options->{SRC_LOCATION}, " after reading: $!";
    }
    else {
      open(RD, "<", "src/$modfname.c") or die "Can't open src/${modfname}.c for reading: $!";
      while() {
           $code .= $_;
           if($_ =~ /inline_stack_vars/i) {$need_inline_h = 1}
      }
      close(RD) or die "Can't close src/$modfname.c after reading: $!";
    }

    ## Initialise $o.
    ## Many of these keys may not be needed for the purpose of this
    ## specific exercise - but they shouldn't do any harm, so I'll
    ## leave them in, just in case they're ever needed.
    $o->{CONFIG}{BUILD_TIMERS} = 0;
    $o->{CONFIG}{PRINT_INFO} = 0;
    $o->{CONFIG}{USING} = [];
    $o->{CONFIG}{WARNINGS} = 1;
    $o->{CONFIG}{PRINT_VERSION} = 0;
    $o->{CONFIG}{CLEAN_BUILD_AREA} = 0;
    $o->{CONFIG}{GLOBAL_LOAD} = 0;
    $o->{CONFIG}{DIRECTORY} = '';
    $o->{CONFIG}{SAFEMODE} = -1;
    $o->{CONFIG}{CLEAN_AFTER_BUILD} = 1;
    $o->{CONFIG}{FORCE_BUILD} = 0;
    $o->{CONFIG}{NAME} = '';
    $o->{CONFIG}{_INSTALL_} = 0;
    $o->{CONFIG}{WITH} = [];
    $o->{CONFIG}{AUTONAME} = 1;
    $o->{CONFIG}{REPORTBUG} = 0;
    $o->{CONFIG}{UNTAINT} = 0;
    $o->{CONFIG}{VERSION} = '';
    $o->{CONFIG}{BUILD_NOISY} = 1;
    $o->{INLINE}{ILSM_suffix} = $Config::Config{dlext};
    $o->{INLINE}{ILSM_module} = 'Inline::C';
    $o->{INLINE}{version} = $Inline::VERSION;
    $o->{INLINE}{ILSM_type} = 'compiled';
    $o->{INLINE}{DIRECTORY} = 'irrelevant_0';
    $o->{INLINE}{object_ready} = 0;
    $o->{INLINE}{md5} = 'irrelevant_1';
    $o->{API}{modfname} = $modfname;
    $o->{API}{script} = 'irrelevant_2';
    $o->{API}{location} = 'irrelevant_3';
    $o->{API}{language} = 'C';
    $o->{API}{modpname} = 'irrelevant_4';
    $o->{API}{directory} = 'irrelevant_5';
    $o->{API}{install_lib} = 'irrelevant_6';
    $o->{API}{build_dir} = $build_dir;
    $o->{API}{language_id} = 'C';
    $o->{API}{pkg} = $pkg;
    $o->{API}{suffix} = $Config::Config{dlext};
    $o->{API}{cleanup} = 1;
    $o->{API}{module} = $module;
    $o->{API}{code} = $code;

    if(exists($config_options->{PROTOTYPE})) {$o->{CONFIG}{PROTOTYPE} = $config_options->{PROTOTYPE}}

    if(exists($config_options->{PROTOTYPES})) {$o->{CONFIG}{PROTOTYPES} = $config_options->{PROTOTYPES}}

    if(exists($config_options->{BUILD_NOISY})) {$o->{CONFIG}{BUILD_NOISY} = $config_options->{BUILD_NOISY}}

    if(exists($config_options->{_TESTING})) {$o->{CONFIG}{_TESTING} = $config_options->{_TESTING}} # Internal testing flag

    if($config_options->{AUTOWRAP}) {$o->{ILSM}{AUTOWRAP} = 1}

    if($config_options->{BOOT}) {$o->{ILSM}{XS}{BOOT} = $config_options->{BOOT}}

    if($config_options->{DIST}) {
      $config_options->{WRITE_MAKEFILE_PL} = 1;
      $config_options->{WRITE_PM} = 1;
      $config_options->{MANIF} = 1;
      $config_options->{T} = 1;
    }

    if($config_options->{BOOT_F}) {
      my $code;
      open(RD, "<", $config_options->{BOOT_F}) or die "Can't open ", $config_options->{BOOT_F}, " for reading: $!";
      while() {
           $code .= $_;
           if($_ =~ /inline_stack_vars/i) {$need_inline_h = 1}
      }
      close(RD) or die "Can't close ", $config_options->{BOOT_F}, " after reading: $!";
      $o->{ILSM}{XS}{BOOT} = $code;
    }

    # This is what Inline::C does with the MAKE parameter ... so we'll do the same.
    # Not sure that this achieves anything in the context of InlineX::C2XS.
    if($config_options->{MAKE}) {$o->{ILSM}{MAKE} = $config_options->{MAKE}}

    if(exists($config_options->{TYPEMAPS})) {
      my $val =$config_options->{TYPEMAPS};
      if(ref($val) eq 'ARRAY') {
        for(@{$val}) {
           die "Couldn't locate the typemap $_" unless -f $_;
        }
        $o->{ILSM}{MAKEFILE}{TYPEMAPS} = $val;
      }
      else {
        my @vals = split /\s+/, $val;
        for(@vals) {
           die "Couldn't locate the typemap $_" unless -f $_;
        }
        $o->{ILSM}{MAKEFILE}{TYPEMAPS} = \@vals;
      }
    }
    else {
      $o->{ILSM}{MAKEFILE}{TYPEMAPS} = [];
    }

    my @uncorrupted_typemaps = @{$o->{ILSM}{MAKEFILE}{TYPEMAPS}};

    if($config_options->{LIBS}) {
        $o->{ILSM}{MAKEFILE}{LIBS} = $config_options->{LIBS};
    }

    if($config_options->{PREFIX}) {$o->{ILSM}{XS}{PREFIX} = $config_options->{PREFIX}}

    bless($o, 'Inline::C');

    Inline::C::validate($o);

    if($config_options->{PRE_HEAD}) {
      my $v = $config_options->{PRE_HEAD};
      #{ # open scope
      #  no warnings 'newline';
        unless( -f $v) {
          $o->{ILSM}{AUTO_INCLUDE} = $v . "\n" . $o->{ILSM}{AUTO_INCLUDE};
        }
        else {
          my $insert;
          open RD, '<', $v or die "Couldn't open $v for reading: $!";
          while() {$insert .= $_}
          close RD or die "Couldn't close $v after reading: $!";
          $o->{ILSM}{AUTO_INCLUDE} = $insert . "\n" . $o->{ILSM}{AUTO_INCLUDE};
        }
      #} # close scope
    }

    if($config_options->{AUTO_INCLUDE}) {$o->{ILSM}{AUTO_INCLUDE} .= $config_options->{AUTO_INCLUDE} . "\n"}

    if($config_options->{CC}) {$o->{ILSM}{MAKEFILE}{CC} = $config_options->{CC}}

    if($config_options->{OBJECT}) {$o->{ILSM}{MAKEFILE}{OBJECT} = $config_options->{OBJECT}}

    if($config_options->{CCFLAGS}) {$o->{ILSM}{MAKEFILE}{CCFLAGS} = " " . $config_options->{CCFLAGS}}

    if($config_options->{CCFLAGSEX}) {$o->{ILSM}{MAKEFILE}{CCFLAGS} = $Config{ccflags} . " "
                                                                      . $config_options->{CCFLAGSEX}}

    if(exists($config_options->{INC})) {
      if(ref($config_options->{INC}) eq 'ARRAY') {$o->{ILSM}{MAKEFILE}{INC} = join ' ', @{$config_options->{INC}};}
      else {$o->{ILSM}{MAKEFILE}{INC} = $config_options->{INC};}
    }
    else {$o->{ILSM}{MAKEFILE}{INC} = ''}

    my $uncorrupted_inc = $o->{ILSM}{MAKEFILE}{INC};

    if($config_options->{LD}) {$o->{ILSM}{MAKEFILE}{LD} = " " . $config_options->{LD}}

    if($config_options->{PREREQ_PM}) {$o->{ILSM}{MAKEFILE}{PREREQ_PM} = $config_options->{PREREQ_PM}}

    if($config_options->{LDDLFLAGS}) {$o->{ILSM}{MAKEFILE}{LDDLFLAGS} = " " . $config_options->{LDDLFLAGS}}

    # Here, we'll add the MAKE parameter to $o->{ILSM}{MAKEFILE}{MAKE} ... which
    # could be useful (given that recent versions of Extutils::MakeMaker now recognise it):
    if($config_options->{MAKE}) {$o->{ILSM}{MAKEFILE}{MAKE} = $config_options->{MAKE}}

    if($config_options->{MYEXTLIB}) {$o->{ILSM}{MAKEFILE}{MYEXTLIB} = " " . $config_options->{MYEXTLIB}}

    if($config_options->{OPTIMIZE}) {$o->{ILSM}{MAKEFILE}{OPTIMIZE} = " " . $config_options->{OPTIMIZE}}

    if($config_options->{USING}) {
      my $val = $config_options->{USING};
      if(ref($val) eq 'ARRAY') {
        $o->{CONFIG}{USING} = $val;
      }
      else {
        $o->{CONFIG}{USING} = [$val];
      }
      Inline::push_overrides($o);
    }

    if(!$need_inline_h) {$o->{ILSM}{AUTO_INCLUDE} =~ s/#include "INLINE\.h"//i}

    _build($o, $need_inline_h);

    if($config_options->{WRITE_MAKEFILE_PL}) {
      $o->{ILSM}{MAKEFILE}{INC} = $uncorrupted_inc; # Make sure cwd is included only if it was specified.
      $o->{ILSM}{MAKEFILE}{TYPEMAPS} = \@uncorrupted_typemaps; # Otherwise the standard perl typemap gets included ... annoying.
      if($config_options->{VERSION}) {$o->{API}{version} = $config_options->{VERSION}}
      else {warn "'VERSION' being set to '0.00' in the Makefile.PL. Did you supply a correct version number to c2xs() ?"}
      print "Writing Makefile.PL in the ", $o->{API}{build_dir}, " directory\n";
      $o->call('write_Makefile_PL', 'Build Glue 3');
    }

    if($config_options->{WRITE_PM}) {
      if($config_options->{VERSION}) {$o->{API}{version} = $config_options->{VERSION}}
      else {
        warn "'\$VERSION' being set to '0.00' in ", $o->{API}{modfname}, ".pm. Did you supply a correct version number to c2xs() ?";
        $o->{API}{version} = '0.00';
      }
    _write_pm($o);
    }

    if($config_options->{MANIF}) {
      _write_manifest($modfname, $build_dir, $config_options, $need_inline_h);
    }

    if($config_options->{T}) {
      _write_test_script($module, $build_dir);
    }
}

##=========================##

sub _build {
    my $o = shift;
    my $need_inline_headers = shift;

    $o->call('preprocess', 'Build Preprocess');
    $o->call('parse', 'Build Parse');

    print "Writing ", $o->{API}{modfname}, ".xs in the ", $o->{API}{build_dir}, " directory\n";
    $o->call('write_XS', 'Build Glue 1');

    if($need_inline_headers) {
      print "Writing INLINE.h in the ", $o->{API}{build_dir}, " directory\n";
      $o->call('write_Inline_headers', 'Build Glue 2');
    }
}

##=========================##

sub _check_config_keys {
    for(@allowable_config_keys) {
        return 1 if $_ eq $_[0]; # it's a valid config option
    }
    return 0;                    # it's an invalid config option
}

##=========================##

sub _write_pm {
    my $o = shift;
    my $offset = 4;
    my $max = 100;
    my $length = $offset;
    my @use;

    if($config_options->{USE}) {
      die "Value supplied to config option USE must be an array reference"
        if ref($config_options->{USE}) ne 'ARRAY';
      @use = @{$config_options->{USE}};
    }

    open(WR, '>', $o->{API}{build_dir} . '/' . $o->{API}{modfname} . ".pm")
        or die "Couldn't create the .pm file: $!";
    print "Writing ", $o->{API}{modfname}, ".pm in the ", $o->{API}{build_dir}, " directory\n";
    print WR "## This file generated by InlineX::C2XS (version ",
             $InlineX::C2XS::VERSION, ") using Inline::C (version ", $Inline::C::VERSION, ")\n";
    print WR "package ", $o->{API}{module}, ";\n";
    for(@use) {
      print WR "use ${_};\n";
    }
    print WR "\n";
    print WR "require Exporter;\n*import = \\&Exporter::import;\nrequire DynaLoader;\n\n";
    # Switch to xdg's recommendation for assigning version number
    #print WR "\$", $o->{API}{module}, "::VERSION = '", $o->{API}{version}, "';\n\n";
    print WR "our \$VERSION = '", $o->{API}{version}, "';\n\$VERSION = eval \$VERSION;\n";
    print WR "DynaLoader::bootstrap ", $o->{API}{module}, " \$VERSION;\n\n";

    unless($config_options->{EXPORT_ALL}) {
      print WR "\@", $o->{API}{module}, "::EXPORT = ();\n";
    }
    else {
      print WR "\@", $o->{API}{module}, "::EXPORT = qw(\n";
      for(@{$o->{ILSM}{parser}{data}{functions}}) {
        if ($_ =~ /^_/ && $_ !~ /^__/) {next}
        my $l = length($_);
        if($length + $l > $max) {
          print WR "\n", " " x $offset, "$_ ";
          $length = $offset + $l + 1;
        }
        if($length == $offset) {print WR " " x $offset, "$_ "}
        else {print WR "$_ " }
        $length += $l + 1;
      }
      print WR "\n", " " x $offset, ");\n\n";
      $length = $offset;
    }

    unless($config_options->{EXPORT_OK_ALL} || $config_options->{EXPORT_TAGS_ALL}) {
      print WR "\@", $o->{API}{module}, "::EXPORT_OK = ();\n\n";
    }
    else {
      print WR "\@", $o->{API}{module}, "::EXPORT_OK = qw(\n";
      for(@{$o->{ILSM}{parser}{data}{functions}}) {
        if ($_ =~ /^_/ && $_ !~ /^__/) {next}
        my $l = length($_);
        if($length + $l > $max) {
          print WR "\n", " " x $offset, "$_ ";
          $length = $offset + $l + 1;
        }
        if($length == $offset) {print WR " " x $offset, "$_ "}
        else {print WR "$_ " }
        $length += $l + 1;
      }
      print WR "\n", " " x $offset, ");\n\n";
      $length = $offset;
    }

    if($config_options->{EXPORT_TAGS_ALL}){
      print WR "\%", $o->{API}{module}, "::EXPORT_TAGS = (", $config_options->{EXPORT_TAGS_ALL}, " => [qw(\n";
      for(@{$o->{ILSM}{parser}{data}{functions}}) {
        if ($_ =~ /^_/ && $_ !~ /^__/) {next}
        my $l = length($_);
        if($length + $l > $max) {
          print WR "\n", " " x $offset, "$_ ";
          $length = $offset + $l + 1;
        }
        if($length == $offset) {print WR " " x $offset, "$_ "}
        else {print WR "$_ " }
        $length += $l + 1;
      }
      print WR "\n", " " x $offset, ")]);\n\n";
      $length = $offset;
    }

    print WR "sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking\n\n";
    print WR "1;\n";
    close(WR) or die "Couldn't close the .pm file after writing to it: $!";
}

##=========================##

sub _write_manifest {
    my $m = shift;  # name of pm and xs files
    my $bd = shift; # build directory
    my $c = shift;  # config options
    my $ih = shift; # INLINE.h is present ?

    print "Writing the MANIFEST file in the $bd directory\n";

    open WRM, '>', "$bd/MANIFEST" or die "Can't open MANIFEST for writing: $!";
    print WRM "MANIFEST\n";
    if($c->{WRITE_PM}) {print WRM "$m.pm\n"}
    if($ih) {print WRM "INLINE.h\n"}
    print WRM "$m.xs\n";
    if($c->{WRITE_MAKEFILE_PL}) {
      print WRM "Makefile.PL\n";
    }
    if($c->{T}){
      print WRM "t/00load.t\n";
    }
    close WRM or die "Can't close $bd/MANIFEST after writing: $!";
}

##=========================##

sub _write_test_script {
  use File::Path;
  my $mod = $_[0];
  my $path = "$_[1]/t";
  unless(-d $path) {
    if(!File::Path::make_path($path, {verbose => 1})) {die "Failed to create $path directory"};
  }

  print "Writing 00load.t in the $path directory\n";
  open WRT, '>', "$path/00load.t" or die "Couldn't open $path/00load.t for writing: $!";
  print WRT "## This file auto-generated by InlineX-C2XS-" . $InlineX::C2XS::VERSION . "\n\n";
  print WRT "use strict;\nuse warnings;\n\n";
  print WRT "print \"1..1\\n\";\n\n";
  print WRT "eval{require $mod;};\n";
  print WRT "if(\$\@) {\n  warn \"\\\$\\\@: \$\@\";\n  print \"not ok 1\\n\";\n}\n";
  print WRT "else {print \"ok 1\\n\"}\n";
  close WRT or die "Couldn't close $path/00load.t after writing: $!";
}

##=========================##

*context         = \&InlineX::C2XS::Context::apply_context_args;

##=========================##

##=========================##

1;

__END__