File Coverage

blib/lib/Test/Alien.pm

Criterion	Covered	Total	%
statement	362	435	83.2
branch	97	150	64.6
condition	36	67	53.7
subroutine	51	53	96.2
pod	7	8	87.5
total	553	713	77.5

package Test::Alien;

use strict;
use warnings;
use 5.008004;
use Env qw( @PATH );
use File::Which 1.10 qw( which );
use Capture::Tiny qw( capture capture_merged );
use Alien::Build::Temp;
use File::Copy qw( move );
use Text::ParseWords qw( shellwords );
use Test2::API qw( context run_subtest );
use Exporter qw( import );
use Path::Tiny qw( path );
use Alien::Build::Util qw( _dump );
use Config;

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

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


our @aliens;

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

  my $name = ref $alien ? ref($alien) . '[instance]' : $alien;
  $name = 'undef' unless defined $name;
  my @methods = qw( cflags libs dynamic_libs bin_dir );
  $message ||= "$name responds to: @methods";

  my $ok;
  my @diag;

  if(defined $alien)
  {
    my @missing = grep { ! $alien->can($_) } @methods;

    $ok = !@missing;
    push @diag, map { "  missing method $_" } @missing;

    if($ok)
    {
      push @aliens, $alien;
      unshift @PATH, $alien->bin_dir;
    }
  }
  else
  {
    $ok = 0;
    push @diag, "  undefined alien";
  }

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

  $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';
  }

  unless(@aliens)
  {
    $ctx->diag("run_ok called without any aliens, you may want to call alien_ok");
  }

  $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->can('xs_load'))
    ? $class->$static
    : $class->$method;
}

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

  $xs = { xs => $xs } unless ref $xs;
  # make sure this is a copy because we may
  # modify it.
  $xs->{xs} = "@{[ $xs->{xs} ]}";
  $xs->{pxs}              ||= {};
  $xs->{cbuilder_check}   ||= 'have_compiler';
  $xs->{cbuilder_config}  ||= {};
  $xs->{cbuilder_compile} ||= {};
  $xs->{cbuilder_link}    ||= {};

  require ExtUtils::CBuilder;
  my $skip = do {
    my $have_compiler = $xs->{cbuilder_check};
    !ExtUtils::CBuilder->new( config => $xs->{cbuilder_config} )->$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;
  }

  if($xs->{cpp} || $xs->{'C++'})
  {
    my $ctx = context();
    $ctx->bail("The cpp and C++ options have been removed from xs_ok");
  }
  else
  {
    $xs->{c_ext} ||= 'c';
  }

  my $verbose = $xs->{verbose} || 0;
  my $ok = 1;
  my @diag;
  my $dir = Alien::Build::Temp->newdir(
    TEMPLATE => 'test-alien-XXXXXX',
    CLEANUP  => $^O =~ /^(MSWin32|cygwin|msys)$/ ? 0 : 1,
  );
  my $xs_filename = path($dir)->child('test.xs')->stringify;
  my $c_filename  = path($dir)->child("test.@{[ $xs->{c_ext} ]}")->stringify;

  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%s", $count, chr(65 + $count % 26 ) x 4;
    $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;
    }
  }

  push @diag, "xs_ok called without any aliens, you may want to call alien_ok" unless @aliens;

  if($ok)
  {
    my $cb = ExtUtils::CBuilder->new(
      config => do {
        my %config = %{ $xs->{cbuilder_config} };
        my $lddlflags = join(' ', grep !/^-l/, shellwords map { _flags $_, 'libs' } @aliens) . " $Config{lddlflags}";
        $config{lddlflags} = defined $config{lddlflags} ? "$lddlflags $config{lddlflags}" : $lddlflags;
        \%config;
      },
    );

    my %compile_options = (
      source               => $c_filename,
      %{ $xs->{cbuilder_compile} },
    );

    if(defined $compile_options{extra_compiler_flags} && ref($compile_options{extra_compiler_flags}) eq '')
    {
      $compile_options{extra_compiler_flags} = [ shellwords $compile_options{extra_compiler_flags} ];
    }

    push @{ $compile_options{extra_compiler_flags} }, shellwords map { _flags $_, 'cflags' } @aliens;

    my($out, $obj, $err) = capture_merged {
      my $obj = eval {
        $cb->compile(%compile_options);
      };
      ($obj, $@);
    };

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

    if($verbose > 1)
    {
      $ctx->note(_dump({ compile_options => \%compile_options }));
    }

    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 %link_options = (
        objects            => [$obj],
        module_name        => $module,
        %{ $xs->{cbuilder_link} },
      );

      if(defined $link_options{extra_linker_flags} && ref($link_options{extra_linker_flags}) eq '')
      {
        $link_options{extra_linker_flags} = [ shellwords $link_options{extra_linker_flags} ];
      }

      unshift @{ $link_options{extra_linker_flags} }, grep /^-l/, shellwords map { _flags $_, 'libs' } @aliens;

      my($out, $lib, $err) = capture_merged {
        my $lib = eval {
          $cb->link(%link_options);
        };
        ($lib, $@);
      };

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

      if($verbose > 1)
      {
        $ctx->note(_dump({ link_options => \%link_options }));
      }

      if($lib && -f $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)
      {
        my @modparts = split(/::/,$module);
        my $dl_dlext = $Config{dlext};
        my $modfname = $modparts[-1];

        my $libpath = path($dir)->child('auto', @modparts, "$modfname.$dl_dlext");
        $libpath->parent->mkpath;
        move($lib, "$libpath") || die "unable to copy $lib => $libpath $!";

        pop @modparts;
        my $pmpath = path($dir)->child(@modparts, "$modfname.pm");
        $pmpath->parent->mkpath;
        open my $fh, '>', "$pmpath";

        my($alien_with_xs_load, @rest) = grep { $_->can('xs_load') } @aliens;

        if($alien_with_xs_load)
        {
          {
            no strict 'refs';
            @{join '::', $module, 'rest'} = @rest;
            ${join '::', $module, 'alien_with_xs_load'} = $alien_with_xs_load;
          }
          print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
            package $module;

            use strict;
            use warnings;
            our \$VERSION = '0.01';
            our \@rest;
            our \$alien_with_xs_load;

            \$alien_with_xs_load->xs_load('$module', \$VERSION, \@rest);

            1;
          };
        }
        else
        {
          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";
          ## no critic
          eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
            use $module;
          };
          ## use critic
        }

        if(my $error = $@)
        {
          $ok = 0;
          push @diag, '  XSLoader 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 (&)
{
  my($code) = @_;

  # it may be possible to catch a segmentation fault,
  # but not with signal handlers apparently.  See:
  # https://feepingcreature.github.io/handling.html
  return $code if $^O eq 'MSWin32';

  # try to catch a segmentation fault and bail out
  # with a useful diagnostic.  prove test to swallow
  # the diagnostic on such failures.
  sub {
    local $SIG{SEGV} = sub {
      my $ctx = context();
      $ctx->bail("Segmentation fault");
    };
    $code->(@_);
  }
}


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};
    $min = '0.99' if defined $opt->{api} && $opt->{api} > 0;
    unless(eval { require FFI::Platypus; FFI::Platypus->VERSION($min) })
    {
      $ok = 0;
      $skip = "Test requires FFI::Platypus $min";
    }
  }

  if($ok && $opt->{lang})
  {
    my $class = "FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
    {
      my $pm = "$class.pm";
      $pm =~ s/::/\//g;
      eval { require $pm };
    }
    if($@)
    {
      $ok = 0;
      $skip = "Test requires FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
    }
  }

  unless(@aliens)
  {
    push @diag, 'ffi_ok called without any aliens, you may want to call alien_ok';
  }

  if($ok)
  {
    $ffi = FFI::Platypus->new(
      do {
        my @args = (
          lib              => [map { $_->dynamic_libs } @aliens],
          ignore_not_found => $opt->{ignore_not_found},
          lang             => $opt->{lang},
        );
        push @args, api => $opt->{api} if defined $opt->{api};
        @args;
      }
    );
    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 _interpolator
{
  require Alien::Build::Interpolate::Default;
  my $intr = Alien::Build::Interpolate::Default->new;

  foreach my $alien (@aliens)
  {
    if($alien->can('alien_helper'))
    {
      my $help = $alien->alien_helper;
      foreach my $name (keys %$help)
      {
        my $code = $help->{$name};
        $intr->replace_helper($name, $code);
      }
    }
  }

  $intr;
}

sub helper_ok
{
  my($name, $message) = @_;

  $message ||= "helper $name exists";

  my $intr = _interpolator;

  my $code = $intr->has_helper($name);

  my $ok = defined $code;

  my $ctx = context();
  $ctx->ok($ok, $message);
  $ctx->diag("helper_ok called without any aliens, you may want to call alien_ok") unless @aliens;
  $ctx->release;

  $ok;
}


sub interpolate_template_is
{
  my($template, $pattern, $message) = @_;

  $message ||= "template matches";

  my $intr = _interpolator;

  my $value = eval { $intr->interpolate($template) };
  my $error = $@;
  my @diag;
  my $ok;

  if($error)
  {
    $ok = 0;
    push @diag, "error in evaluation:";
    push @diag, "  $error";
  }
  elsif(ref($pattern) eq 'Regexp')
  {
    $ok = $value =~ $pattern;
    push @diag, "value '$value' does not match $pattern'" unless $ok;
  }
  else
  {
    $ok = $value eq "$pattern";
    push @diag, "value '$value' does not equal '$pattern'" unless $ok;
  }

  my $ctx = context();
  $ctx->ok($ok, $message, [@diag]);
  $ctx->diag('interpolate_template_is called without any aliens, you may want to call alien_ok') unless @aliens;
  $ctx->release;

  $ok;
}

1;

__END__