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