File Coverage

blib/lib/Imager/Probe.pm

Criterion	Covered	Total	%
statement	14	265	5.2
branch	0	188	0.0
condition	0	92	0.0
subroutine	5	26	19.2
pod	0	2	0.0
total	19	573	3.3

package Imager::Probe;
use 5.006;
use strict;
use File::Spec;
use Config;
use Cwd ();

our $VERSION = "1.008";

my @alt_transfer = qw/altname incsuffix libbase/;

sub probe {
  my ($class, $req) = @_;

  $req->{verbose} ||= $ENV{IM_VERBOSE};

  my $name = $req->{name};
  my $result;
  if ($req->{code}) {
    $result = _probe_code($req);
  }
  if (!$result && $req->{pkg}) {
    $result = _probe_pkg($req);
  }
  if (!$result && $req->{inccheck} && ($req->{libcheck} || $req->{libbase})) {
    $req->{altname} ||= "main";
    $result = _probe_check($req);
  }

  if ($result && $req->{testcode}) {
    $result = _probe_test($req, $result);
  }

  if (!$result && $req->{alternatives}) {
  ALTCHECK:
    my $index = 1;
    for my $alt (@{$req->{alternatives}}) {
      $req->{altname} = $alt->{altname} || "alt $index";
      $req->{verbose}
	and print "$req->{name}: Trying alternative $index\n";
      my %work = %$req;
      for my $key (@alt_transfer) {
	exists $alt->{$key} and $work{$key} = $alt->{$key};
      }
      $result = _probe_check(\%work);

      if ($result && $req->{testcode}) {
	$result = _probe_test(\%work, $result);
      }

      $result
	and last;

      ++$index;
    }
  }

  if (!$result && $req->{testcode}) {
    $result = _probe_fake($req);

    $result or return;

    $result = _probe_test($req, $result);
  }

  $result or return;

  return $result;
}

sub _probe_code {
  my ($req) = @_;

  my $code = $req->{code};
  my @probes = ref $code eq "ARRAY" ? @$code : $code;

  my $result;
  for my $probe (@probes) {
    $result = $probe->($req)
      and return $result;
  }

  return;
}

sub is_exe {
  my ($name) = @_;

  my @exe_suffix = $Config{_exe};
  if ($^O eq 'MSWin32') {
    push @exe_suffix, qw/.bat .cmd/;
  }
  elsif ($^O eq 'cygwin') {
    push @exe_suffix, "";
  }

  for my $dir (File::Spec->path) {
    for my $suffix (@exe_suffix) {
      -x File::Spec->catfile($dir, "$name$suffix")
	and return 1;
    }
  }

  return;
}

sub _probe_pkg {
  my ($req) = @_;

  # Setup pkg-config's environment variable to search non-standard paths
  # which may be provided by --libdirs.
  my @pkgcfg_paths = map { "$_/pkgconfig" } _lib_paths( $req );
  unshift @pkgcfg_paths, $ENV{ 'PKG_CONFIG_PATH' } if $ENV{ 'PKG_CONFIG_PATH' };

  local $ENV{ 'PKG_CONFIG_PATH' } = join $Config{path_sep}, @pkgcfg_paths;
  print "PKG_CONFIG_PATH=$ENV{PKG_CONFIG_PATH}\n" if $req->{verbose};

  is_exe('pkg-config') or return;
  my $redir = $^O eq 'MSWin32' ? '' : '2>/dev/null';

  my @pkgs = @{$req->{pkg}};
  for my $pkg (@pkgs) {
    if (!system("pkg-config $pkg --exists $redir")) {
      # if we find it, but the following fail, then pkg-config is too
      # broken to be useful
      my $cflags = `pkg-config $pkg --cflags`
	and !$? or return;

      my $lflags = `pkg-config $pkg --libs`
	and !$? or return;

      my $defines = '';
      $cflags =~ s/(-D\S+)/$defines .= " $1"; ''/ge;

      chomp $cflags;
      chomp $lflags;
      print "$req->{name}: Found via pkg-config $pkg\n";
      print <{verbose};
  cflags: $cflags
  defines: $defines
  lflags: $lflags
EOS
      # rt 75869
      # if Win32 doesn't provide this information, too bad
      if (!grep(/^-L/, split " ", $lflags)
	  && $^O ne 'MSWin32') {
	# pkg-config told us about the library, make sure it's
	# somewhere EU::MM can find it
	print "Checking if EU::MM can find $lflags\n" if $req->{verbose};
	my ($extra, $bs_load, $ld_load, $ld_run_path) =
	  ExtUtils::Liblist->ext($lflags, $req->{verbose});
	unless ($ld_run_path) {
	  # search our standard places
	  $lflags = _resolve_libs($req, $lflags);
	}
      }

      return
	{
	 INC => $cflags,
	 LIBS => $lflags,
	 DEFINE => $defines,
	};
    }
  }

  print "$req->{name}: Not found via pkg-config\n";

  return;
}

sub _is_msvc {
  return $Config{cc} eq "cl";
}

sub _lib_basename {
  my ($base) = @_;

  if (_is_msvc()) {
    return $base;
  }
  else {
    return "lib$base";
  }
}

sub _lib_option {
  my ($base) = @_;

  if (_is_msvc()) {
    return $base . $Config{_a};
  }
  else {
    return "-l$base";
  }
}

sub _quotearg {
  my ($opt) = @_;

  return $opt =~ /\s/ ? qq("$opt") : $opt;
}

sub _probe_check {
  my ($req) = @_;

  my @libcheck;
  my @libbase;
  if ($req->{libcheck}) {
    if (ref $req->{libcheck} eq "ARRAY") {
      push @libcheck, @{$req->{libcheck}};
    }
    else {
      push @libcheck, $req->{libcheck};
    }
  }
  elsif ($req->{libbase}) {
    @libbase = ref $req->{libbase} ? @{$req->{libbase}} : $req->{libbase};

    my $lext=$Config{'so'};   # Get extensions of libraries
    my $aext=$Config{'_a'};

    for my $libbase (@libbase) {
      my $basename = _lib_basename($libbase);
      push @libcheck, sub {
	-e File::Spec->catfile($_[0], "$basename$aext")
	  || -e File::Spec->catfile($_[0], "$basename.$lext")
	};
    }
  }
  else {
    print "$req->{name}: No libcheck or libbase, nothing to search for\n"
      if $req->{verbose};
    return;
  }

  my @found_libpath;
  my @lib_search = _lib_paths($req);
  print "$req->{name}: Searching directories for libraries:\n"
    if $req->{verbose};
  for my $libcheck (@libcheck) {
    for my $path (@lib_search) {
      print "$req->{name}:   $path\n" if $req->{verbose};
      if ($libcheck->($path)) {
	print "$req->{name}: Found!\n" if $req->{verbose};
        push @found_libpath, $path;
	last;
      }
    }
  }

  my $found_incpath;
  my $inccheck = $req->{inccheck};
  my @inc_search = _inc_paths($req);
  print "$req->{name}: Searching directories for headers:\n"
    if $req->{verbose};
  for my $path (@inc_search) {
    print "$req->{name}:   $path\n" if $req->{verbose};
    if ($inccheck->($path)) {
      print "$req->{name}: Found!\n" if $req->{verbose};
      $found_incpath = $path;
      last;
    }
  }

  my $alt = "";
  if ($req->{altname}) {
    $alt = " $req->{altname}:";
  }
  print "$req->{name}:$alt includes ", $found_incpath ? "" : "not ",
    "found - libraries ", @found_libpath == @libcheck ? "" : "not ", "found\n";

  @found_libpath == @libcheck && $found_incpath
    or return;

  my @libs = map "-L$_", @found_libpath;
  if ($req->{libopts}) {
    push @libs, $req->{libopts};
  }
  elsif (@libbase) {
    push @libs, map _lib_option($_), @libbase;
  }
  else {
    die "$req->{altname}: inccheck but no libbase or libopts";
  }

  return
    {
     INC => _quotearg("-I$found_incpath"),
     LIBS => join(" ", map _quotearg($_), @libs),
     DEFINE => "",
    };
}

sub _probe_fake {
  my ($req) = @_;

  # the caller provided test code, and the compiler may look in
  # places we don't, see Imager-Screenshot ticket 56793,
  # so fake up a result so the test code can
  my $lopts;
  if ($req->{libopts}) {
    $lopts = $req->{libopts};
  }
  elsif (defined $req->{libbase}) {
    # might not need extra libraries, eg. Win32 perl already links
    # everything
    my @libs = $req->{libbase}
      ? ( ref $req->{libbase} ? @{$req->{libbase}} : $req->{libbase} )
      : ();
    $lopts = join " ", map _lib_option($_), @libs;
  }
  if (defined $lopts) {
    print "$req->{name}: Checking if the compiler can find them on its own\n";
    return
      {
       INC => "",
       LIBS => $lopts,
       DEFINE => "",
      };
  }
  else {
    print "$req->{name}: Can't fake it - no libbase or libopts\n"
      if $req->{verbose};
    return;
  }
}

sub _probe_test {
  my ($req, $result) = @_;

  require Devel::CheckLib;
  # setup LD_RUN_PATH to match link time
  print "Asking liblist for LD_RUN_PATH:\n" if $req->{verbose};
  my ($extra, $bs_load, $ld_load, $ld_run_path) =
    ExtUtils::Liblist->ext($result->{LIBS}, $req->{verbose});
  local $ENV{LD_RUN_PATH};

  if ($ld_run_path) {
    print "Setting LD_RUN_PATH=$ld_run_path for $req->{name} probe\n"
      if $req->{verbose};
    $ENV{LD_RUN_PATH} = $ld_run_path;
    if ($Config{lddlflags} =~ /([^ ]*-(?:rpath|R)[,=]?)([^ ]+)/
	&& -d $2) {
      # hackety, hackety
      # LD_RUN_PATH is ignored when there's already an -rpath option
      # so provide one
      my $prefix = $1;
      $result->{LDDLFLAGS} = $Config{lddlflags} . " " .
	join " ", map "$prefix$_", split $Config{path_sep}, $ld_run_path;
    }
  }
  my $good =
    Devel::CheckLib::check_lib
	(
	 debug => $req->{verbose},
	 LIBS => [ $result->{LIBS} ],
	 INC => $result->{INC},
	 header => $req->{testcodeheaders},
	 function => $req->{testcode},
	 prologue => $req->{testcodeprologue},
	);
  unless ($good) {
    print "$req->{name}: Test code failed: $@";
    return;
  }

  print "$req->{name}: Passed code check\n";
  return $result;
}

sub _resolve_libs {
  my ($req, $lflags) = @_;

  my @libs = grep /^-l/, split ' ', $lflags;
  my %paths;
  my @paths = _lib_paths($req);
  my $so = $Config{so};
  my $libext = $Config{_a};
  for my $lib (@libs) {
    $lib =~ s/^-l/lib/;

    for my $path (@paths) {
      if (-e "$path/$lib.$so" || -e "$path/$lib$libext") {
	$paths{$path} = 1;
      }
    }
  }

  return join(" ", ( map "-L$_", keys %paths ), $lflags );
}

sub _lib_paths {
  my ($req) = @_;

  print "$req->{name} IM_LIBPATH: $ENV{IM_LIBPATH}\n"
    if $req->{verbose} && defined $ENV{IM_LIBPATH};
  print "$req->{name} LIB: $ENV{IM_LIBPATH}\n"
    if $req->{verbose} && defined $ENV{LIB} && $^O eq "MSWin32";
  my $lp = $req->{libpath};
  print "$req->{name} libpath: ", ref $lp ? join($Config{path_sep}, @$lp) : $lp, "\n"
    if $req->{verbose} && defined $lp;

  return _paths
    (
     $ENV{IM_LIBPATH},
     $req->{libpath},
     (
      map { split ' ' }
      grep $_,
      @Config{qw/loclibpth libpth libspath/}
     ),
     $^O eq "MSWin32" ? $ENV{LIB} : "",
     $^O eq "cygwin" ? "/usr/lib/w32api" : "",
     "/usr/lib",
     "/usr/local/lib",
     _gcc_lib_paths(),
     _dyn_lib_paths(),
    );
}

sub _gcc_lib_paths {
  $Config{gccversion}
    or return;

  my ($base_version) = $Config{gccversion} =~ /^([0-9]+)/
    or return;

  $base_version >= 4
    or return;

  local $ENV{LANG} = "C";
  local $ENV{LC_ALL} = "C";
  my ($lib_line) = grep /^libraries:/, `$Config{cc} -print-search-dirs`
    or return;
  $lib_line =~ s/^libraries: =//;
  chomp $lib_line;

  return grep !/gcc/ && -d, split /:/, $lib_line;
}

sub _dyn_lib_paths {
  return map { defined() ? split /\Q$Config{path_sep}/ : () }
    map $ENV{$_},
      qw(LD_RUN_PATH LD_LIBRARY_PATH DYLD_LIBRARY_PATH LIBRARY_PATH);
}

sub _inc_paths {
  my ($req) = @_;

  print "$req->{name} IM_INCPATH: $ENV{IM_INCPATH}\n"
    if $req->{verbose} && defined $ENV{IM_INCPATH};
  print "$req->{name} INCLUDE: $ENV{INCLUDE}\n"
    if $req->{verbose} && defined $ENV{INCLUDE} && $^O eq "MSWin32";
  my $ip = $req->{incpath};
  print "$req->{name} incpath: ", ref $ip ? join($Config{path_sep}, @$ip) : $ip, "\n"
    if $req->{verbose} && defined $req->{incpath};

  my @paths = _paths
    (
     $ENV{IM_INCPATH},
     $req->{incpath},
     $^O eq "MSWin32" ? $ENV{INCLUDE} : "",
     $^O eq "cygwin" ? "/usr/include/w32api" : "",
     (
      map { split ' ' }
      grep $_,
      @Config{qw/locincpth incpath/}
     ),
     "/usr/include",
     "/usr/local/include",
     _gcc_inc_paths(),
     _dyn_inc_paths(),
    );

  if ($req->{incsuffix}) {
    @paths = map File::Spec->catdir($_, $req->{incsuffix}), @paths;
  }

  return @paths;
}

sub _gcc_inc_paths {
  $Config{gccversion}
    or return;

  my ($base_version) = $Config{gccversion} =~ /^([0-9]+)/
    or return;

  $base_version >= 4
    or return;

  local $ENV{LANG} = "C";
  local $ENV{LC_ALL} = "C";
  my $devnull = File::Spec->devnull;
  my @spam = `$Config{cc} -E -v - <$devnull 2>&1`;
  # output includes lines like:
  # ...
  # ignoring nonexistent directory "/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/include"
  # #include "..." search starts here:
  # #include <...> search starts here:
  #  /usr/lib/gcc/x86_64-linux-gnu/4.9/include
  #  /usr/local/include
  #  /usr/lib/gcc/x86_64-linux-gnu/4.9/include-fixed
  #  /usr/include/x86_64-linux-gnu
  #  /usr/include
  # End of search list.
  # # 1 ""
  # # 1 ""
  # ...

  while (@spam && $spam[0] !~ /^#include /) {
    shift @spam;
  }
  my @inc;
  while (@spam && $spam[0] !~ /^End of search/) {
    my $line = shift @spam;
    chomp $line;
    next if $line =~ /^#include /;
    next unless $line =~ s/^\s+//;
    push @inc, $line;
  }
  return @inc;
}

sub _dyn_inc_paths {
  return map {
    my $tmp = $_;
    $tmp =~ s/\blib$/include/ ? $tmp : ()
  } _dyn_lib_paths();
}

sub _paths {
  my (@in) = @_;

  my @out;

  # expand any array refs
  @in = map { ref() ? @$_ : $_ } @in;

  for my $path (@in) {
    $path or next;
    $path = _tilde_expand($path);

    push @out, grep -d $_, split /\Q$Config{path_sep}/, $path;
  }

  @out = map Cwd::realpath($_), @out;

  my %seen;
  @out = grep !$seen{$_}++, @out;

  return @out;
}

my $home;
sub _tilde_expand {
  my ($path) = @_;

  if ($path =~ m!^~[/\\]!) {
    defined $home or $home = $ENV{HOME};
    if (!defined $home && $^O eq 'MSWin32'
       && defined $ENV{HOMEDRIVE} && defined $ENV{HOMEPATH}) {
      $home = $ENV{HOMEDRIVE} . $ENV{HOMEPATH};
    }
    unless (defined $home) {
      $home = eval { (getpwuid($<))[7] };
    }
    defined $home or die "You supplied $path, but I can't find your home directory\n";
    $path =~ s/^~//;
    $path = File::Spec->catdir($home, $path);
  }

  return $path;
}

1;

__END__