File Coverage

blib/lib/FFI/CheckLib.pm

Criterion	Covered	Total	%
statement	146	174	83.9
branch	67	96	69.7
condition	15	28	53.5
subroutine	18	23	78.2
pod	9	9	100.0
total	255	330	77.2

package FFI::CheckLib;

use strict;
use warnings;
use File::Spec;
use List::Util 1.33 qw( any );
use Carp qw( croak carp );
use base qw( Exporter );

our @EXPORT = qw(
  find_lib
  assert_lib
  check_lib
  check_lib_or_exit
  find_lib_or_exit
  find_lib_or_die
);

our @EXPORT_OK = qw(
  which
  where
  has_symbols
);

# ABSTRACT: Check that a library is available for FFI
our $VERSION = '0.30'; # VERSION


our $system_path = [];
our $os ||= $^O;
my $try_ld_on_text = 0;

if($os eq 'MSWin32' || $os eq 'msys')
{
  $system_path = eval {
    require Env;
    Env->import('@PATH');
    \our @PATH;
  };
  die $@ if $@;
}
else
{
  $system_path = eval {
    require DynaLoader;
    no warnings 'once';
    \@DynaLoader::dl_library_path;
  };
  die $@ if $@;
}

our $pattern = [ qr{^lib(.*?)\.so(?:\.([0-9]+(?:\.[0-9]+)*))?$} ];
our $version_split = qr/\./;

if($os eq 'cygwin')
{
  push @$pattern, qr{^cyg(.*?)(?:-([0-9])+)?\.dll$};
}
elsif($os eq 'msys')
{
  # doesn't seem as though msys uses psudo libfoo.so files
  # in the way that cygwin sometimes does.  we can revisit
  # this if we find otherwise.
  $pattern = [ qr{^msys-(.*?)(?:-([0-9])+)?\.dll$} ];
}
elsif($os eq 'MSWin32')
{
  #  handle cases like libgeos-3-7-0___.dll, libproj_9_1.dll and libgtk-2.0-0.dll
  $pattern = [ qr{^(?:lib)?(\w+?)(?:[_-]([0-9\-\._]+))?_*\.dll$}i ];
  $version_split = qr/[_\-]/;
}
elsif($os eq 'darwin')
{
  push @$pattern, qr{^lib(.*?)(?:\.([0-9]+(?:\.[0-9]+)*))?\.(?:dylib|bundle)$};
}
elsif($os eq 'linux')
{
  if(-e '/etc/redhat-release' && -x '/usr/bin/ld')
  {
    $try_ld_on_text = 1;
  }
}

sub _matches
{
  my($filename, $path) = @_;

  foreach my $regex (@$pattern)
  {
    return [
      $1,                                            # 0    capture group 1 library name
      File::Spec->catfile($path, $filename),         # 1    full path to library
      defined $2 ? (split $version_split, $2) : (),  # 2... capture group 2 library version
    ] if $filename =~ $regex;
  }
  return ();
}

sub _cmp
{
  my($A,$B) = @_;

  return $A->[0] cmp $B->[0] if $A->[0] ne $B->[0];

  my $i=2;
  while(1)
  {
    return 0  if !defined($A->[$i]) && !defined($B->[$i]);
    return -1 if !defined $A->[$i];
    return 1  if !defined $B->[$i];
    return $B->[$i] <=> $A->[$i] if $A->[$i] != $B->[$i];
    $i++;
  }
}


my $diagnostic;

sub _is_binary
{
  -B $_[0]
}

sub find_lib
{
  my(%args) = @_;

  undef $diagnostic;
  croak "find_lib requires lib argument" unless defined $args{lib};

  my $recursive = $args{_r} || $args{recursive} || 0;

  # make arguments be lists.
  foreach my $arg (qw( lib libpath symbol verify alien ))
  {
    next if ref $args{$arg} eq 'ARRAY';
    if(defined $args{$arg})
    {
      $args{$arg} = [ $args{$arg} ];
    }
    else
    {
      $args{$arg} = [];
    }
  }

  if(defined $args{systempath} && !ref($args{systempath}))
  {
    $args{systempath} = [ $args{systempath} ];
  }

  my @path = @{ $args{libpath} };
  @path = map { _recurse($_) } @path if $recursive;
  push @path, grep { defined } defined $args{systempath}
    ? @{ $args{systempath} }
    : @$system_path;

  my $any = any { $_ eq '*' } @{ $args{lib} };
  my %missing = map { $_ => 1 } @{ $args{lib} };
  my %symbols = map { $_ => 1 } @{ $args{symbol} };
  my @found;

  delete $missing{'*'};

  alien: foreach my $alien (reverse @{ $args{alien} })
  {
    unless($alien =~ /^([A-Za-z_][A-Za-z_0-9]*)(::[A-Za-z_][A-Za-z_0-9]*)*$/)
    {
      croak "Doesn't appear to be a valid Alien name $alien";
    }
    unless(eval { $alien->can('dynamic_libs') })
    {
      {
        my $pm = "$alien.pm";
        $pm =~ s/::/\//g;
        local $@ = '';
        eval { require $pm };
        next alien if $@;
      }
      unless(eval { $alien->can('dynamic_libs') })
      {
        croak "Alien $alien doesn't provide a dynamic_libs method";
      }
    }
    unshift @path, [$alien->dynamic_libs];
  }

  foreach my $path (@path)
  {
    next if ref $path ne 'ARRAY' && ! -d $path;

    my @maybe =
      # make determinist based on names and versions
      sort { _cmp($a,$b) }
      # Filter out the items that do not match the name that we are looking for
      # Filter out any broken symbolic links
      grep { ($any || $missing{$_->[0]} ) && (-e $_->[1]) }
      ref $path eq 'ARRAY'
        ? do {
          map {
            my($v, $d, $f) = File::Spec->splitpath($_);
            _matches($f, File::Spec->catpath($v,$d,''));
          } @$path;
        }
        : do {
          my $dh;
          opendir $dh, $path;
          # get [ name, full_path ] mapping,
          # each entry is a 2 element list ref
          map { _matches($_,$path) } readdir $dh;
        };

    if($try_ld_on_text && $args{try_linker_script})
    {
      # This is tested in t/ci.t only
      @maybe = map {
        -B $_->[1] ? $_ : do {
          my($name, $so) = @$_;
          my $output = `/usr/bin/ld -t $so -o /dev/null -shared`;
          $output =~ /\((.*?lib.*\.so.*?)\)/
            ? [$name, $1]
            : die "unable to parse ld output";
        }
      } @maybe;
    }

    midloop:
    foreach my $lib (@maybe)
    {
      next unless $any || $missing{$lib->[0]};

      foreach my $verify (@{ $args{verify} })
      {
        next midloop unless $verify->(@$lib);
      }

      delete $missing{$lib->[0]};

      if(%symbols)
      {
        require DynaLoader;
        my $dll = DynaLoader::dl_load_file($lib->[1],0);
        foreach my $symbol (keys %symbols)
        {
          if(DynaLoader::dl_find_symbol($dll, $symbol) ? 1 : 0)
          {
            delete $symbols{$symbol}
          }
        }
        DynaLoader::dl_unload_file($dll);
      }

      my $found = $lib->[1];

      unless($any)
      {
        while(-l $found)
        {
          require File::Basename;
          my $dir = File::Basename::dirname($found);
          $found = File::Spec->rel2abs( readlink($found), $dir );
        }
      }

      push @found, $found;
    }
  }

  if(%missing)
  {
    my @missing = sort keys %missing;
    if(@missing > 1)
    { $diagnostic = "libraries not found: @missing" }
    else
    { $diagnostic = "library not found: @missing" }
  }
  elsif(%symbols)
  {
    my @missing = sort keys %symbols;
    if(@missing > 1)
    { $diagnostic = "symbols not found: @missing" }
    else
    { $diagnostic = "symbol not found: @missing" }
  }

  return if %symbols;
  return $found[0] unless wantarray;
  return @found;
}

sub _recurse
{
  my($dir) = @_;
  return unless -d $dir;
  my $dh;
  opendir $dh, $dir;
  my @list = grep { -d $_ } map { File::Spec->catdir($dir, $_) } grep !/^\.\.?$/, readdir $dh;
  closedir $dh;
  ($dir, map { _recurse($_) } @list);
}


sub assert_lib
{
  croak $diagnostic || 'library not found' unless check_lib(@_);
}


sub check_lib_or_exit
{
  unless(check_lib(@_))
  {
    carp $diagnostic || 'library not found';
    exit;
  }
}


sub find_lib_or_exit
{
  my(@libs) = find_lib(@_);
  unless(@libs)
  {
    carp $diagnostic || 'library not found';
    exit;
  }
  return unless @libs;
  wantarray ? @libs : $libs[0];
}


sub find_lib_or_die
{
  my(@libs) = find_lib(@_);
  unless(@libs)
  {
    croak $diagnostic || 'library not found';
  }
  return unless @libs;
  wantarray ? @libs : $libs[0];
}


sub check_lib
{
  find_lib(@_) ? 1 : 0;
}


sub which
{
  my($name) = @_;
  croak("cannot which *") if $name eq '*';
  scalar find_lib( lib => $name );
}


sub where
{
  my($name) = @_;
  $name eq '*'
    ? find_lib(lib => '*')
    : find_lib(lib => '*', verify => sub { $_[0] eq $name });
}


sub has_symbols
{
  my($path, @symbols) = @_;
  require DynaLoader;
  my $dll = DynaLoader::dl_load_file($path, 0);

  my $ok = 1;

  foreach my $symbol (@symbols)
  {
    unless(DynaLoader::dl_find_symbol($dll, $symbol))
    {
      $ok = 0;
      last;
    }
  }

  DynaLoader::dl_unload_file($dll);

  $ok;
}


sub system_path
{
  $system_path;
}

1;

__END__