lib/Imager/Probe.pm

   1 package Imager::Probe;
   2 use 5.006;
   3 use strict;
   4 use File::Spec;
   5 use Config;
   6 use Cwd ();
   7
   8 our $VERSION = "1.007";
   9
  10 my @alt_transfer = qw/altname incsuffix libbase/;
  11
  12 sub probe {
  13   my ($class, $req) = @_;
  14
  15   $req->{verbose} ||= $ENV{IM_VERBOSE};
  16
  17   my $name = $req->{name};
  18   my $result;
  19   if ($req->{code}) {
  20     $result = _probe_code($req);
  21   }
  22   if (!$result && $req->{pkg}) {
  23     $result = _probe_pkg($req);
  24   }
  25   if (!$result && $req->{inccheck} && ($req->{libcheck} || $req->{libbase})) {
  26     $req->{altname} ||= "main";
  27     $result = _probe_check($req);
  28   }
  29
  30   if ($result && $req->{testcode}) {
  31     $result = _probe_test($req, $result);
  32   }
  33
  34   if (!$result && $req->{alternatives}) {
  35   ALTCHECK:
  36     my $index = 1;
  37     for my $alt (@{$req->{alternatives}}) {
  38       $req->{altname} = $alt->{altname} || "alt $index";
  39       $req->{verbose}
  40         and print "$req->{name}: Trying alternative $index\n";
  41       my %work = %$req;
  42       for my $key (@alt_transfer) {
  43         exists $alt->{$key} and $work{$key} = $alt->{$key};
  44       }
  45       $result = _probe_check(\%work);
  46
  47       if ($result && $req->{testcode}) {
  48         $result = _probe_test(\%work, $result);
  49       }
  50
  51       $result
  52         and last;
  53
  54       ++$index;
  55     }
  56   }
  57
  58   if (!$result && $req->{testcode}) {
  59     $result = _probe_fake($req);
  60
  61     $result or return;
  62
  63     $result = _probe_test($req, $result);
  64   }
  65
  66   $result or return;
  67
  68   return $result;
  69 }
  70
  71 sub _probe_code {
  72   my ($req) = @_;
  73
  74   my $code = $req->{code};
  75   my @probes = ref $code eq "ARRAY" ? @$code : $code;
  76
  77   my $result;
  78   for my $probe (@probes) {
  79     $result = $probe->($req)
  80       and return $result;
  81   }
  82
  83   return;
  84 }
  85
  86 sub is_exe {
  87   my ($name) = @_;
  88
  89   my @exe_suffix = $Config{_exe};
  90   if ($^O eq 'MSWin32') {
  91     push @exe_suffix, qw/.bat .cmd/;
  92   }
  93   elsif ($^O eq 'cygwin') {
  94     push @exe_suffix, "";
  95   }
  96
  97   for my $dir (File::Spec->path) {
  98     for my $suffix (@exe_suffix) {
  99       -x File::Spec->catfile($dir, "$name$suffix")
 100         and return 1;
 101     }
 102   }
 103
 104   return;
 105 }
 106
 107 sub _probe_pkg {
 108   my ($req) = @_;
 109
 110   # Setup pkg-config's environment variable to search non-standard paths
 111   # which may be provided by --libdirs.
 112   my @pkgcfg_paths = map { "$_/pkgconfig" } _lib_paths( $req );
 113   push @pkgcfg_paths, $ENV{ 'PKG_CONFIG_PATH' } if $ENV{ 'PKG_CONFIG_PATH' };
 114
 115   local $ENV{ 'PKG_CONFIG_PATH' } = join $Config{path_sep}, @pkgcfg_paths;
 116
 117   is_exe('pkg-config') or return;
 118   my $redir = $^O eq 'MSWin32' ? '' : '2>/dev/null';
 119
 120   my @pkgs = @{$req->{pkg}};
 121   for my $pkg (@pkgs) {
 122     if (!system("pkg-config $pkg --exists $redir")) {
 123       # if we find it, but the following fail, then pkg-config is too
 124       # broken to be useful
 125       my $cflags = `pkg-config $pkg --cflags`
 126         and !$? or return;
 127
 128       my $lflags = `pkg-config $pkg --libs`
 129         and !$? or return;
 130
 131       my $defines = '';
 132       $cflags =~ s/(-D\S+)/$defines .= " $1"; ''/ge;
 133
 134       chomp $cflags;
 135       chomp $lflags;
 136       print "$req->{name}: Found via pkg-config $pkg\n";
 137       print <<EOS if $req->{verbose};
 138   cflags: $cflags
 139   defines: $defines
 140   lflags: $lflags
 141 EOS
 142       # rt 75869
 143       # if Win32 doesn't provide this information, too bad
 144       if (!grep(/^-L/, split " ", $lflags)
 145           && $^O ne 'MSWin32') {
 146         # pkg-config told us about the library, make sure it's
 147         # somewhere EU::MM can find it
 148         print "Checking if EU::MM can find $lflags\n" if $req->{verbose};
 149         my ($extra, $bs_load, $ld_load, $ld_run_path) =
 150           ExtUtils::Liblist->ext($lflags, $req->{verbose});
 151         unless ($ld_run_path) {
 152           # search our standard places
 153           $lflags = _resolve_libs($req, $lflags);
 154         }
 155       }
 156
 157       return
 158         {
 159          INC => $cflags,
 160          LIBS => $lflags,
 161          DEFINE => $defines,
 162         };
 163     }
 164   }
 165
 166   print "$req->{name}: Not found via pkg-config\n";
 167
 168   return;
 169 }
 170
 171 sub _is_msvc {
 172   return $Config{cc} eq "cl";
 173 }
 174
 175 sub _lib_basename {
 176   my ($base) = @_;
 177
 178   if (_is_msvc()) {
 179     return $base;
 180   }
 181   else {
 182     return "lib$base";
 183   }
 184 }
 185
 186 sub _lib_option {
 187   my ($base) = @_;
 188
 189   if (_is_msvc()) {
 190     return $base . $Config{_a};
 191   }
 192   else {
 193     return "-l$base";
 194   }
 195 }
 196
 197 sub _quotearg {
 198   my ($opt) = @_;
 199
 200   return $opt =~ /\s/ ? qq("$opt") : $opt;
 201 }
 202
 203 sub _probe_check {
 204   my ($req) = @_;
 205
 206   my @libcheck;
 207   my @libbase;
 208   if ($req->{libcheck}) {
 209     if (ref $req->{libcheck} eq "ARRAY") {
 210       push @libcheck, @{$req->{libcheck}};
 211     }
 212     else {
 213       push @libcheck, $req->{libcheck};
 214     }
 215   }
 216   elsif ($req->{libbase}) {
 217     @libbase = ref $req->{libbase} ? @{$req->{libbase}} : $req->{libbase};
 218
 219     my $lext=$Config{'so'};   # Get extensions of libraries
 220     my $aext=$Config{'_a'};
 221
 222     for my $libbase (@libbase) {
 223       my $basename = _lib_basename($libbase);
 224       push @libcheck, sub {
 225         -e File::Spec->catfile($_[0], "$basename$aext")
 226           || -e File::Spec->catfile($_[0], "$basename.$lext")
 227         };
 228     }
 229   }
 230   else {
 231     print "$req->{name}: No libcheck or libbase, nothing to search for\n"
 232       if $req->{verbose};
 233     return;
 234   }
 235
 236   my @found_libpath;
 237   my @lib_search = _lib_paths($req);
 238   print "$req->{name}: Searching directories for libraries:\n"
 239     if $req->{verbose};
 240   for my $libcheck (@libcheck) {
 241     for my $path (@lib_search) {
 242       print "$req->{name}:   $path\n" if $req->{verbose};
 243       if ($libcheck->($path)) {
 244         print "$req->{name}: Found!\n" if $req->{verbose};
 245         push @found_libpath, $path;
 246         last;
 247       }
 248     }
 249   }
 250
 251   my $found_incpath;
 252   my $inccheck = $req->{inccheck};
 253   my @inc_search = _inc_paths($req);
 254   print "$req->{name}: Searching directories for headers:\n"
 255     if $req->{verbose};
 256   for my $path (@inc_search) {
 257     print "$req->{name}:   $path\n" if $req->{verbose};
 258     if ($inccheck->($path)) {
 259       print "$req->{name}: Found!\n" if $req->{verbose};
 260       $found_incpath = $path;
 261       last;
 262     }
 263   }
 264
 265   my $alt = "";
 266   if ($req->{altname}) {
 267     $alt = " $req->{altname}:";
 268   }
 269   print "$req->{name}:$alt includes ", $found_incpath ? "" : "not ",
 270     "found - libraries ", @found_libpath == @libcheck ? "" : "not ", "found\n";
 271
 272   @found_libpath == @libcheck && $found_incpath
 273     or return;
 274
 275   my @libs = map "-L$_", @found_libpath;
 276   if ($req->{libopts}) {
 277     push @libs, $req->{libopts};
 278   }
 279   elsif (@libbase) {
 280     push @libs, map _lib_option($_), @libbase;
 281   }
 282   else {
 283     die "$req->{altname}: inccheck but no libbase or libopts";
 284   }
 285
 286   return
 287     {
 288      INC => _quotearg("-I$found_incpath"),
 289      LIBS => join(" ", map _quotearg($_), @libs),
 290      DEFINE => "",
 291     };
 292 }
 293
 294 sub _probe_fake {
 295   my ($req) = @_;
 296
 297   # the caller provided test code, and the compiler may look in
 298   # places we don't, see Imager-Screenshot ticket 56793,
 299   # so fake up a result so the test code can
 300   my $lopts;
 301   if ($req->{libopts}) {
 302     $lopts = $req->{libopts};
 303   }
 304   elsif (defined $req->{libbase}) {
 305     # might not need extra libraries, eg. Win32 perl already links
 306     # everything
 307     my @libs = $req->{libbase}
 308       ? ( ref $req->{libbase} ? @{$req->{libbase}} : $req->{libbase} )
 309       : ();
 310     $lopts = join " ", map _lib_option($_), @libs;
 311   }
 312   if (defined $lopts) {
 313     print "$req->{name}: Checking if the compiler can find them on its own\n";
 314     return
 315       {
 316        INC => "",
 317        LIBS => $lopts,
 318        DEFINE => "",
 319       };
 320   }
 321   else {
 322     print "$req->{name}: Can't fake it - no libbase or libopts\n"
 323       if $req->{verbose};
 324     return;
 325   }
 326 }
 327
 328 sub _probe_test {
 329   my ($req, $result) = @_;
 330
 331   require Devel::CheckLib;
 332   # setup LD_RUN_PATH to match link time
 333   print "Asking liblist for LD_RUN_PATH:\n" if $req->{verbose};
 334   my ($extra, $bs_load, $ld_load, $ld_run_path) =
 335     ExtUtils::Liblist->ext($result->{LIBS}, $req->{verbose});
 336   local $ENV{LD_RUN_PATH};
 337
 338   if ($ld_run_path) {
 339     print "Setting LD_RUN_PATH=$ld_run_path for $req->{name} probe\n"
 340       if $req->{verbose};
 341     $ENV{LD_RUN_PATH} = $ld_run_path;
 342     if ($Config{lddlflags} =~ /([^ ]*-(?:rpath|R)[,=]?)([^ ]+)/
 343         && -d $2) {
 344       # hackety, hackety
 345       # LD_RUN_PATH is ignored when there's already an -rpath option
 346       # so provide one
 347       my $prefix = $1;
 348       $result->{LDDLFLAGS} = $Config{lddlflags} . " " .
 349         join " ", map "$prefix$_", split $Config{path_sep}, $ld_run_path;
 350     }
 351   }
 352   my $good =
 353     Devel::CheckLib::check_lib
 354         (
 355          debug => $req->{verbose},
 356          LIBS => [ $result->{LIBS} ],
 357          INC => $result->{INC},
 358          header => $req->{testcodeheaders},
 359          function => $req->{testcode},
 360          prologue => $req->{testcodeprologue},
 361         );
 362   unless ($good) {
 363     print "$req->{name}: Test code failed: $@";
 364     return;
 365   }
 366
 367   print "$req->{name}: Passed code check\n";
 368   return $result;
 369 }
 370
 371 sub _resolve_libs {
 372   my ($req, $lflags) = @_;
 373
 374   my @libs = grep /^-l/, split ' ', $lflags;
 375   my %paths;
 376   my @paths = _lib_paths($req);
 377   my $so = $Config{so};
 378   my $libext = $Config{_a};
 379   for my $lib (@libs) {
 380     $lib =~ s/^-l/lib/;
 381
 382     for my $path (@paths) {
 383       if (-e "$path/$lib.$so" || -e "$path/$lib$libext") {
 384         $paths{$path} = 1;
 385       }
 386     }
 387   }
 388
 389   return join(" ", ( map "-L$_", keys %paths ), $lflags );
 390 }
 391
 392 sub _lib_paths {
 393   my ($req) = @_;
 394
 395   print "$req->{name} IM_LIBPATH: $ENV{IM_LIBPATH}\n"
 396     if $req->{verbose} && defined $ENV{IM_LIBPATH};
 397   print "$req->{name} LIB: $ENV{IM_LIBPATH}\n"
 398     if $req->{verbose} && defined $ENV{LIB} && $^O eq "MSWin32";
 399   my $lp = $req->{libpath};
 400   print "$req->{name} libpath: ", ref $lp ? join($Config{path_sep}, @$lp) : $lp, "\n"
 401     if $req->{verbose} && defined $lp;
 402
 403   return _paths
 404     (
 405      $ENV{IM_LIBPATH},
 406      $req->{libpath},
 407      (
 408       map { split ' ' }
 409       grep $_,
 410       @Config{qw/loclibpth libpth libspath/}
 411      ),
 412      $^O eq "MSWin32" ? $ENV{LIB} : "",
 413      $^O eq "cygwin" ? "/usr/lib/w32api" : "",
 414      "/usr/lib",
 415      "/usr/local/lib",
 416      _gcc_lib_paths(),
 417      _dyn_lib_paths(),
 418     );
 419 }
 420
 421 sub _gcc_lib_paths {
 422   $Config{gccversion}
 423     or return;
 424
 425   my ($base_version) = $Config{gccversion} =~ /^([0-9]+)/
 426     or return;
 427
 428   $base_version >= 4
 429     or return;
 430
 431   local $ENV{LANG} = "C";
 432   local $ENV{LC_ALL} = "C";
 433   my ($lib_line) = grep /^libraries:/, `$Config{cc} -print-search-dirs`
 434     or return;
 435   $lib_line =~ s/^libraries: =//;
 436   chomp $lib_line;
 437
 438   return grep !/gcc/ && -d, split /:/, $lib_line;
 439 }
 440
 441 sub _dyn_lib_paths {
 442   return map { defined() ? split /\Q$Config{path_sep}/ : () }
 443     map $ENV{$_},
 444       qw(LD_RUN_PATH LD_LIBRARY_PATH DYLD_LIBRARY_PATH LIBRARY_PATH);
 445 }
 446
 447 sub _inc_paths {
 448   my ($req) = @_;
 449
 450   print "$req->{name} IM_INCPATH: $ENV{IM_INCPATH}\n"
 451     if $req->{verbose} && defined $ENV{IM_INCPATH};
 452   print "$req->{name} INCLUDE: $ENV{INCLUDE}\n"
 453     if $req->{verbose} && defined $ENV{INCLUDE} && $^O eq "MSWin32";
 454   my $ip = $req->{incpath};
 455   print "$req->{name} incpath: ", ref $ip ? join($Config{path_sep}, @$ip) : $ip, "\n"
 456     if $req->{verbose} && defined $req->{incpath};
 457
 458   my @paths = _paths
 459     (
 460      $ENV{IM_INCPATH},
 461      $req->{incpath},
 462      $^O eq "MSWin32" ? $ENV{INCLUDE} : "",
 463      $^O eq "cygwin" ? "/usr/include/w32api" : "",
 464      (
 465       map { split ' ' }
 466       grep $_,
 467       @Config{qw/locincpth incpath/}
 468      ),
 469      "/usr/include",
 470      "/usr/local/include",
 471      _gcc_inc_paths(),
 472      _dyn_inc_paths(),
 473     );
 474
 475   if ($req->{incsuffix}) {
 476     @paths = map File::Spec->catdir($_, $req->{incsuffix}), @paths;
 477   }
 478
 479   return @paths;
 480 }
 481
 482 sub _gcc_inc_paths {
 483   $Config{gccversion}
 484     or return;
 485
 486   my ($base_version) = $Config{gccversion} =~ /^([0-9]+)/
 487     or return;
 488
 489   $base_version >= 4
 490     or return;
 491
 492   local $ENV{LANG} = "C";
 493   local $ENV{LC_ALL} = "C";
 494   my $devnull = File::Spec->devnull;
 495   my @spam = `$Config{cc} -E -v - <$devnull 2>&1`;
 496   # output includes lines like:
 497   # ...
 498   # ignoring nonexistent directory "/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/include"
 499   # #include "..." search starts here:
 500   # #include <...> search starts here:
 501   #  /usr/lib/gcc/x86_64-linux-gnu/4.9/include
 502   #  /usr/local/include
 503   #  /usr/lib/gcc/x86_64-linux-gnu/4.9/include-fixed
 504   #  /usr/include/x86_64-linux-gnu
 505   #  /usr/include
 506   # End of search list.
 507   # # 1 "<stdin>"
 508   # # 1 "<built-in>"
 509   # ...
 510
 511   while (@spam && $spam[0] !~ /^#include /) {
 512     shift @spam;
 513   }
 514   my @inc;
 515   while (@spam && $spam[0] !~ /^End of search/) {
 516     my $line = shift @spam;
 517     chomp $line;
 518     next if $line =~ /^#include /;
 519     next unless $line =~ s/^\s+//;
 520     push @inc, $line;
 521   }
 522   return @inc;
 523 }
 524
 525 sub _dyn_inc_paths {
 526   return map {
 527     my $tmp = $_;
 528     $tmp =~ s/\blib$/include/ ? $tmp : ()
 529   } _dyn_lib_paths();
 530 }
 531
 532 sub _paths {
 533   my (@in) = @_;
 534
 535   my @out;
 536
 537   # expand any array refs
 538   @in = map { ref() ? @$_ : $_ } @in;
 539
 540   for my $path (@in) {
 541     $path or next;
 542     $path = _tilde_expand($path);
 543
 544     push @out, grep -d $_, split /\Q$Config{path_sep}/, $path;
 545   }
 546
 547   @out = map Cwd::realpath($_), @out;
 548
 549   my %seen;
 550   @out = grep !$seen{$_}++, @out;
 551
 552   return @out;
 553 }
 554
 555 my $home;
 556 sub _tilde_expand {
 557   my ($path) = @_;
 558
 559   if ($path =~ m!^~[/\\]!) {
 560     defined $home or $home = $ENV{HOME};
 561     if (!defined $home && $^O eq 'MSWin32'
 562        && defined $ENV{HOMEDRIVE} && defined $ENV{HOMEPATH}) {
 563       $home = $ENV{HOMEDRIVE} . $ENV{HOMEPATH};
 564     }
 565     unless (defined $home) {
 566       $home = eval { (getpwuid($<))[7] };
 567     }
 568     defined $home or die "You supplied $path, but I can't find your home directory\n";
 569     $path =~ s/^~//;
 570     $path = File::Spec->catdir($home, $path);
 571   }
 572
 573   return $path;
 574 }
 575
 576 1;
 577
 578 __END__
 579
 580 =head1 NAME
 581
 582 Imager::Probe - hot needle of inquiry for libraries
 583
 584 =head1 SYNOPSIS
 585
 586   require Imager::Probe;
 587
 588   my %probe =
 589     (
 590      # short name of what we're looking for (displayed to user)
 591      name => "FOO",
 592      # pkg-config lookup
 593      pkg => [ qw/name1 name2 name3/ ],
 594      # perl subs that probe for the library
 595      code => [ \&foo_probe1, \&foo_probe2 ],
 596      # or just: code => \&foo_probe,
 597      inccheck => sub { ... },
 598      libcheck => sub { ... },
 599      # search for this library if libcheck not supplied
 600      libbase => "foo",
 601      # library link time options, uses libbase to build options otherwise
 602      libopts => "-lfoo",
 603      # C code to check the library is sane
 604      testcode => "...",
 605      # header files needed
 606      testcodeheaders => [ "stdio.h", "foo.h" ],
 607     );
 608   my $result = Imager::Probe->probe(\%probe)
 609     or print "Foo library not found: ",Imager::Probe->error;
 610
 611 =head1 DESCRIPTION
 612
 613 Does the probes that were hidden in Imager's F<Makefile.PL>, pulled
 614 out so the file format libraries can be externalized.
 615
 616 The return value is either nothing if the probe fails, or a hash
 617 containing:
 618
 619 =over
 620
 621 =item *
 622
 623 C<INC> - C<-I> and other C options
 624
 625 =item *
 626
 627 C<LIBS> - C<-L>, C<-l> and other link-time options
 628
 629 =item *
 630
 631 C<DEFINE> - C<-D> options, if any.
 632
 633 =back
 634
 635 The possible values for the hash supplied to the probe() method are:
 636
 637 =over
 638
 639 =item *
 640
 641 C<pkg> - an array of F<pkg-config> names to probe for.  If the
 642 F<pkg-config> checks pass, C<inccheck> and C<libcheck> aren't used.
 643
 644 =item *
 645
 646 C<inccheck> - a code reference that checks if the supplied include
 647 directory contains the required header files.
 648
 649 =item *
 650
 651 C<libcheck> - a code reference that checks if the supplied library
 652 directory contains the required library files.  Note: the
 653 F<Makefile.PL> version of this was supplied all of the library file
 654 names instead.  C<libcheck> can also be an arrayref of library check
 655 code references, all of which must find a match for the library to be
 656 considered "found".
 657
 658 =item *
 659
 660 C<libbase> - if C<inccheck> is supplied, but C<libcheck> isn't, then a
 661 C<libcheck> that checks for C<lib>I<libbase>I<$Config{_a}> and
 662 C<lib>I<libbase>.I<$Config{so}> is created.  If C<libopts> isn't
 663 supplied then that can be synthesized as C<< -lI<libbase>
 664 >>. C<libbase> can also be an arrayref of library base names to search
 665 for, in which case all of the libraries mentioned must be found for
 666 the probe to succeed.
 667
 668 =item *
 669
 670 C<libopts> - if the libraries are found via C<inccheck>/C<libcheck>,
 671 these are the C<-l> options to supply during the link phase.
 672
 673 =item *
 674
 675 C<code> - a code reference to perform custom checks.  Returns the
 676 probe result directly.  Can also be an array ref of functions to call.
 677
 678 =item *
 679
 680 C<testcode> - test C code that is run with Devel::CheckLib.  You also
 681 need to set C<testcodeheaders>.
 682
 683 =item *
 684
 685 C<testcodeprologue> - C code to insert between the headers and the
 686 main function.
 687
 688 =item *
 689
 690 C<incpath> - C<$Config{path_sep}> separated list of header file
 691 directories to check, or a reference to an array of such.
 692
 693 =item *
 694
 695 C<libpath> - C<$Config{path_sep}> separated list of library file
 696 directories to check, or a reference to an array of such.
 697
 698 =item *
 699
 700 C<alternatives> - an optional array reference of alternate
 701 configurations (as hash references) to test if the primary
 702 configuration isn't successful.  Each alternative should include an
 703 C<altname> key describing the alternative.  Any key not mentioned in
 704 an alternative defaults to the value from the main configuration.
 705
 706 =back
 707
 708 =head1 AUTHOR
 709
 710 Tony Cook <tonyc@cpan.org>, Arnar M. Hrafnkelsson
 711
 712 =cut