lib/Imager/Probe.pm

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