File Coverage

blib/lib/Test/Alien.pm

Criterion	Covered	Total	%
statement	235	300	78.3
branch	66	112	58.9
condition	16	35	45.7
subroutine	34	37	91.8
pod	5	6	83.3
total	356	490	72.6

package Test::Alien;

use strict;
use warnings;
use 5.008001;
use Env qw( @PATH );
use File::Which 1.10 qw( which );
use if $^O ne 'MSWin32', 'Capture::Tiny' => 'capture_merged';
use Capture::Tiny qw( capture );
use File::Temp ();
use Carp qw( croak );
use File::Spec;
use File::Basename qw( dirname );
use File::Path qw( mkpath );
use File::Copy qw( move );
use Text::ParseWords qw( shellwords );
use Test2::API qw( context run_subtest );
use base qw( Exporter );

BEGIN {
  *capture_merged = sub (&;@)
  {
    # TODO: fix this error properly:
    #Error in tempfile() using template C:\Users\ollisg\AppData\Local\Temp\XXXXXXXXXX: Could not create temp file C:\Users\ollisg\AppData\Local\Temp\eysiq7e9w5: Permission denied at N:/home/ollisg/perl5/straw
    # rry/x86/5.22.1/lib/perl5/Capture/Tiny.pm line 360.

    # this seems to work more reliably on windows, at the cost of being much noisier.
    my $code = shift;
    wantarray ? ('', $code->(@_)) : '';
  } if $^O eq 'MSWin32';
}

our @EXPORT = qw( alien_ok run_ok xs_ok ffi_ok with_subtest synthetic );

# ABSTRACT: Testing tools for Alien modules
our $VERSION = '0.15'; # VERSION


our @aliens;

sub alien_ok ($;$)
{
  my($alien, $message) = @_;

  my $name = ref $alien ? ref($alien) . '[instance]' : $alien;

  my @methods = qw( cflags libs dynamic_libs bin_dir );
  $message ||= "$name responds to: @methods";
  my @missing = grep { ! $alien->can($_) } @methods;

  my $ok = !@missing;
  my $ctx = context();
  $ctx->ok($ok, $message);
  $ctx->diag("  missing method $_") for @missing;
  $ctx->release;

  if($ok)
  {
    push @aliens, $alien;
    unshift @PATH, $alien->bin_dir;
  }

  $ok;
}


sub synthetic
{
  my($opt) = @_;
  $opt ||= {};
  my %alien = %$opt;
  require Test::Alien::Synthetic;
  bless \%alien, 'Test::Alien::Synthetic',
}


sub run_ok
{
  my($command, $message) = @_;

  my(@command) = ref $command ? @$command : ($command);
  $message ||= "run @command";

  require Test::Alien::Run;
  my $run = bless {
    out    => '',
    err    => '',
    exit   => 0,
    sig    => 0,
    cmd    => [@command],
  }, 'Test::Alien::Run';

  my $ctx = context();
  my $exe = which $command[0];
  if(defined $exe)
  {
    shift @command;
    $run->{cmd} = [$exe, @command];
    my @diag;
    my $ok = 1;
    my($exit, $errno);
    ($run->{out}, $run->{err}, $exit, $errno) = capture { system $exe, @command; ($?,$!); };

    if($exit == -1)
    {
      $ok = 0;
      $run->{fail} = "failed to execute: $errno";
      push @diag, "  failed to execute: $errno";
    }
    elsif($exit & 127)
    {
      $ok = 0;
      push @diag, "  killed with signal: @{[ $exit & 127 ]}";
      $run->{sig} = $exit & 127;
    }
    else
    {
      $run->{exit} = $exit >> 8;
    }

    $ctx->ok($ok, $message);
    $ok
      ? $ctx->note("  using $exe")
      : $ctx->diag("  using $exe");
    $ctx->diag(@diag) for @diag;

  }
  else
  {
    $ctx->ok(0, $message);
    $ctx->diag("  command not found");
    $run->{fail} = 'command not found';
  }

  $ctx->release;

  $run;
}


sub _flags
{
  my($class, $method) = @_;
  my $static = "${method}_static";
  $class->can($static) && $class->can('install_type') && $class->install_type eq 'share'
    ? $class->$static
    : $class->$method;
}

sub xs_ok
{
  my $cb;
  $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
  my($xs, $message) = @_;
  $message ||= 'xs';

  require ExtUtils::CBuilder;
  my $skip = !ExtUtils::CBuilder->new->have_compiler;

  if($skip)
  {
    my $ctx = context();
    $ctx->skip($message, 'test requires a compiler');
    $ctx->skip("$message subtest", 'test requires a compiler') if $cb;
    $ctx->release;
    return;
  }

  $xs = { xs => $xs } unless ref $xs;
  # make sure this is a copy because we may
  # modify it.
  $xs->{xs} = "@{[ $xs->{xs} ]}";
  $xs->{pxs} ||= {};
  my $verbose = $xs->{verbose};
  my $ok = 1;
  my @diag;
  my $dir = _tempdir( CLEANUP => 1, TEMPLATE => 'testalienXXXXX' );
  my $xs_filename = File::Spec->catfile($dir, 'test.xs');
  my $c_filename  = File::Spec->catfile($dir, 'test.c');

  my $ctx = context();
  my $module;

  if($xs->{xs} =~ /\bTA_MODULE\b/)
  {
    our $count;
    $count = 0 unless defined $count;
    my $name = sprintf "Test::Alien::XS::Mod%s", $count++;
    my $code = $xs->{xs};
    $code =~ s{\bTA_MODULE\b}{$name}g;
    $xs->{xs} = $code;
  }

  # this regex copied shamefully from ExtUtils::ParseXS
  # in part because we need the module name to do the bootstrap
  # and also because if this regex doesn't match then ParseXS
  # does an exit() which we don't want.
  if($xs->{xs} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/m)
  {
    $module = $1;
    $ctx->note("detect module name $module") if $verbose;
  }
  else
  {
    $ok = 0;
    push @diag, '  XS does not have a module decleration that we could find';
  }

  if($ok)
  {
    open my $fh, '>', $xs_filename;
    print $fh $xs->{xs};
    close $fh;

    require ExtUtils::ParseXS;
    my $pxs = ExtUtils::ParseXS->new;

    my($out, $err) = capture_merged {
      eval {
        $pxs->process_file(
          filename     => $xs_filename,
          output       => $c_filename,
          versioncheck => 0,
          prototypes   => 0,
          %{ $xs->{pxs} },
        );
      };
      $@;
    };

    $ctx->note("parse xs $xs_filename => $c_filename") if $verbose;
    $ctx->note($out) if $verbose;
    $ctx->note("error: $err") if $verbose && $err;

    unless($pxs->report_error_count == 0)
    {
      $ok = 0;
      push @diag, '  ExtUtils::ParseXS failed:';
      push @diag, "    $err" if $err;
      push @diag, "    $_" for split /\r?\n/, $out;
    }
  }

  if($ok)
  {
    my $cb = ExtUtils::CBuilder->new;

    my($out, $obj, $err) = capture_merged {
      my $obj = eval {
        $cb->compile(
          source               => $c_filename,
          extra_compiler_flags => [shellwords map { _flags $_, 'cflags' } @aliens],
        );
      };
      ($obj, $@);
    };

    $ctx->note("compile $c_filename") if $verbose;
    $ctx->note($out) if $verbose;
    $ctx->note($err) if $verbose && $err;

    unless($obj)
    {
      $ok = 0;
      push @diag, '  ExtUtils::CBuilder->compile failed';
      push @diag, "    $err" if $err;
      push @diag, "    $_" for split /\r?\n/, $out;
    }

    if($ok)
    {

      my($out, $lib, $err) = capture_merged {
        my $lib = eval {
          $cb->link(
            objects            => [$obj],
            module_name        => $module,
            extra_linker_flags => [shellwords map { _flags $_, 'libs' } @aliens],
          );
        };
        ($lib, $@);
      };

      $ctx->note("link $obj") if $verbose;
      $ctx->note($out) if $verbose;
      $ctx->note($err) if $verbose && $err;

      if($lib)
      {
        $ctx->note("created lib $lib") if $xs->{verbose};
      }
      else
      {
        $ok = 0;
        push @diag, '  ExtUtils::CBuilder->link failed';
        push @diag, "    $err" if $err;
        push @diag, "    $_" for split /\r?\n/, $out;
      }

      if($ok)
      {
        require Config;
        my @modparts = split(/::/,$module);
        my $dl_dlext = $Config::Config{dlext};
        my $modfname = $modparts[-1];

        my $libpath = File::Spec->catfile($dir, 'auto', @modparts, "$modfname.$dl_dlext");
        mkpath(dirname($libpath), 0, 0700);
        move($lib, $libpath) || die "unable to copy $lib => $libpath $!";

        pop @modparts;
        my $pmpath = File::Spec->catfile($dir, @modparts, "$modfname.pm");
        mkpath(dirname($pmpath), 0, 0700);
        open my $fh, '>', $pmpath;
        print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
          package $module;

          use strict;
          use warnings;
          require XSLoader;
          our \$VERSION = '0.01';
          XSLoader::load('$module','\$VERSION');

          1;
        };
        close $fh;

        {
          local @INC = @INC;
          unshift @INC, $dir;
          eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
            use $module;
          };
        }

        if(my $error = $@)
        {
          $ok = 0;
          push @diag, '  DynaLoader failed';
          push @diag, "    $error";
        }
      }
    }
  }

  $ctx->ok($ok, $message);
  $ctx->diag($_) for @diag;
  $ctx->release;

  if($cb)
  {
    $cb = sub {
      my $ctx = context();
      $ctx->plan(0, 'SKIP', "subtest requires xs success");
      $ctx->release;
    } unless $ok;

    @_ = ("$message subtest", $cb, 1, $module);

    goto \&Test2::API::run_subtest;
  }

  $ok;
}

sub with_subtest (&) { $_[0]; }


sub ffi_ok
{
  my $cb;
  $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
  my($opt, $message) = @_;

  $message ||= 'ffi';

  my $ok = 1;
  my $skip;
  my $ffi;
  my @diag;

  {
    my $min = '0.12'; # the first CPAN release
    $min = '0.15' if $opt->{ignore_not_found};
    $min = '0.18' if $opt->{lang};
    eval qq{ use FFI::Platypus $min };
    if($@)
    {
      $ok = 0;
      $skip = "Test requires FFI::Platypus $min";
    }
  }

  if($ok && $opt->{lang})
  {
    my $class = "FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
    eval qq{ use $class () };
    if($@)
    {
      $ok = 0;
      $skip = "Test requires FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
    }
  }

  if($ok)
  {
    $ffi = FFI::Platypus->new(
      lib              => [map { $_->dynamic_libs } @aliens],
      ignore_not_found => $opt->{ignore_not_found},
      lang             => $opt->{lang},
    );
    foreach my $symbol (@{ $opt->{symbols} || [] })
    {
      unless($ffi->find_symbol($symbol))
      {
        $ok = 0;
        push @diag, "  $symbol not found"
      }
    }
  }

  my $ctx = context();

  if($skip)
  {
    $ctx->skip($message, $skip);
  }
  else
  {
    $ctx->ok($ok, $message);
  }
  $ctx->diag($_) for @diag;

  $ctx->release;

  if($cb)
  {
    $cb = sub {
      my $ctx = context();
      $ctx->plan(0, 'SKIP', "subtest requires ffi success");
      $ctx->release;
    } unless $ok;

    @_ = ("$message subtest", $cb, 1, $ffi);

    goto \&Test2::API::run_subtest;
  }

  $ok;
}

sub _tempdir
{
  # makes sure /tmp or whatever isn't mounted noexec,
  # which will cause xs_ok tests to fail.

  my $dir = File::Temp::tempdir(@_);

  if($^O ne 'MSWin32')
  {
    my $filename = File::Spec->catfile($dir, 'foo.pl');
    my $fh;
    open $fh, '>', $filename;
    print $fh "#!$^X";
    close $fh;
    chmod 0755, $filename;
    system $filename, 'foo';
    if($?)
    {
      $dir = File::Temp::tempdir( DIR => File::Spec->curdir );
    }
  }

  $dir;
}

1;

__END__