Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

merge PNG branch and some clean-up

  • Loading branch information...
commit 1d7e31241ca511af650a51cb7f3bb39104857d58 1 parent eecabc0
Tony Cook authored
View
6 Changes
@@ -8,6 +8,12 @@ Imager 0.76
format files and allows white space padding between files.
Thanks to Philip Gwyn (Leolo) for this patch.
+ - moved the PNG file handling code into a sub-module in preparation
+ for separate distribution.
+ https://rt.cpan.org/Ticket/Display.html?id=49616 (partial)
+ Also helps avoid complications from -I/-L compile/link options from
+ other libraries.
+
Bugs:
- Imager->new(data => $data) didn't try to process image file data in
View
138 Imager.pm
@@ -81,9 +81,6 @@ use Imager::Font;
i_writetiff_wiol
i_writetiff_wiol_faxable
- i_readpng_wiol
- i_writepng_wiol
-
i_readgif
i_readgif_wiol
i_readgif_callback
@@ -185,15 +182,25 @@ BEGIN {
}
}
+my %formats_low;
+my %format_classes =
+ (
+ png => "Imager::File::PNG",
+ gif => "Imager::File::GIF",
+ tiff => "Imager::File::TIFF",
+ jpeg => "Imager::File::JPEG",
+ );
+
+tie %formats, "Imager::FORMATS", \%formats_low, \%format_classes;
+
BEGIN {
Imager::Font::__init();
- for(i_list_formats()) { $formats{$_}++; }
+ for(i_list_formats()) { $formats_low{$_}++; }
- if (!$formats{'t1'} and !$formats{'tt'}
- && !$formats{'ft2'} && !$formats{'w32'}) {
+ if (!$formats_low{'t1'} and !$formats_low{'tt'}
+ && !$formats_low{'ft2'} && !$formats_low{'w32'}) {
$fontstate='no font support';
}
-
%OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
$DEBUG=0;
@@ -1367,7 +1374,7 @@ sub read {
return $readers{$input{type}}{single}->($self, $IO, %input);
}
- unless ($formats{$input{'type'}}) {
+ unless ($formats_low{$input{'type'}}) {
my $read_types = join ', ', sort Imager->read_types();
$self->_set_error("format '$input{'type'}' not supported - formats $read_types available for reading");
return;
@@ -1407,15 +1414,6 @@ sub read {
return $self;
}
- if ( $input{'type'} eq 'png' ) {
- $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
- if ( !defined($self->{IMG}) ) {
- $self->{ERRSTR} = $self->_error_as_msg();
- return undef;
- }
- $self->{DEBUG} && print "loading a png file\n";
- }
-
if ( $input{'type'} eq 'bmp' ) {
$self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
if ( !defined($self->{IMG}) ) {
@@ -1572,7 +1570,7 @@ sub write_types {
sub _reader_autoload {
my $type = shift;
- return if $formats{$type} || $readers{$type};
+ return if $formats_low{$type} || $readers{$type};
return unless $type =~ /^\w+$/;
@@ -1600,7 +1598,7 @@ sub _reader_autoload {
sub _writer_autoload {
my $type = shift;
- return if $formats{$type} || $readers{$type};
+ return if $formats_low{$type} || $readers{$type};
return unless $type =~ /^\w+$/;
@@ -1759,7 +1757,7 @@ sub write {
or return undef;
}
else {
- if (!$formats{$input{'type'}}) {
+ if (!$formats_low{$input{'type'}}) {
my $write_types = join ', ', sort Imager->write_types();
$self->_set_error("format '$input{'type'}' not supported - formats $write_types available for writing");
return undef;
@@ -3929,6 +3927,106 @@ sub Inline {
# threads shouldn't try to close raw Imager objects
sub Imager::ImgRaw::CLONE_SKIP { 1 }
+# backward compatibility for %formats
+package Imager::FORMATS;
+use strict;
+use constant IX_FORMATS => 0;
+use constant IX_LIST => 1;
+use constant IX_INDEX => 2;
+use constant IX_CLASSES => 3;
+
+sub TIEHASH {
+ my ($class, $formats, $classes) = @_;
+
+ return bless [ $formats, [ ], 0, $classes ], $class;
+}
+
+sub _check {
+ my ($self, $key) = @_;
+
+ (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
+ my $value;
+ if (eval { require $file; 1 }) {
+ $value = 1;
+ }
+ else {
+ $value = undef;
+ }
+ $self->[IX_FORMATS]{$key} = $value;
+
+ return $value;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+
+ exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
+
+ $self->[IX_CLASSES]{$key} or return undef;
+
+ return $self->_check($key);
+}
+
+sub STORE {
+ die "%Imager::formats is not user monifiable";
+}
+
+sub DELETE {
+ die "%Imager::formats is not user monifiable";
+}
+
+sub CLEAR {
+ die "%Imager::formats is not user monifiable";
+}
+
+sub EXISTS {
+ my ($self, $key) = @_;
+
+ if (exists $self->[IX_FORMATS]{$key}) {
+ my $value = $self->[IX_FORMATS]{$key}
+ or return;
+ return 1;
+ }
+
+ $self->_check($key) or return 1==0;
+
+ return 1==1;
+}
+
+sub FIRSTKEY {
+ my ($self) = @_;
+
+ unless (@{$self->[IX_LIST]}) {
+ # full populate it
+ @{$self->[IX_LIST]} = keys %{$self->[IX_FORMATS]};
+
+ for my $key (keys %{$self->[IX_CLASSES]}) {
+ $self->[IX_FORMATS]{$key} and next;
+ $self->_check($key)
+ and push @{$self->[IX_LIST]}, $key;
+ }
+ }
+
+ @{$self->[IX_LIST]} or return;
+ $self->[IX_INDEX] = 1;
+ return $self->[IX_LIST][0];
+}
+
+sub NEXTKEY {
+ my ($self) = @_;
+
+ $self->[IX_INDEX] < @{$self->[IX_LIST]}
+ or return;
+
+ return $self->[IX_LIST][$self->[IX_INDEX]++];
+}
+
+sub SCALAR {
+ my ($self) = @_;
+
+ return scalar @{$self->[IX_LIST]};
+}
+
1;
__END__
# Below is the stub of documentation for your module. You better edit it!
View
12 Imager.xs
@@ -2502,18 +2502,6 @@ i_tiff_has_compression(name)
#ifdef HAVE_LIBPNG
-Imager::ImgRaw
-i_readpng_wiol(ig, length)
- Imager::IO ig
- int length
-
-
-undef_int
-i_writepng_wiol(im, ig)
- Imager::ImgRaw im
- Imager::IO ig
-
-
#endif
View
14 MANIFEST
@@ -55,6 +55,15 @@ Mandelbrot/mandel.c
Mandelbrot/t/t00mandel.t
Makefile.PL
README
+PNG/Makefile.PL
+PNG/PNG.pm
+PNG/PNG.xs
+PNG/impng.c
+PNG/impng.h
+PNG/t/00load.t
+PNG/t/10png.t Test png support
+PNG/testimg/palette.png
+PNG/testimg/palette_out.png
SGI/Makefile.PL
SGI/SGI.pm
SGI/SGI.xs
@@ -175,6 +184,7 @@ lib/Imager/IO.pod Document Imager::IO objects
lib/Imager/LargeSamples.pod Track large sample support
lib/Imager/Matrix2d.pm
lib/Imager/Preprocess.pm
+lib/Imager/Probe.pm Library probes
lib/Imager/Regops.pm
lib/Imager/Test.pm
lib/Imager/Transform.pm
@@ -190,7 +200,6 @@ maskimg.c
palimg.c
paste.im
plug.h
-png.c
pnm.c
polygon.c
ppport.h
@@ -239,7 +248,6 @@ t/t1000files.t Format independent file tests
t/t101jpeg.t Test jpeg support
t/t101nojpeg.t Test handling when jpeg not available
t/t102nopng.t Test handling when png not available
-t/t102png.t Test png support
t/t103raw.t
t/t104ppm.t
t/t105gif.t Test gif support
@@ -340,8 +348,6 @@ testimg/maxval_asc.ppm
testimg/multiple.ppm Test multiple PPM reading
testimg/newgimpgrad.ggr Test GIMP Gradient file (newer type)
testimg/nocmap.gif
-testimg/palette.png
-testimg/palette_out.png
testimg/penguin-base.ppm
testimg/pengtile.tif Tiled tiff image, same as penguin-base.ppm
testimg/pgm.pgm Simple pgm for testing the right sample is in the right place
View
39 Makefile.PL
@@ -11,6 +11,10 @@ use vars qw(%formats $VERBOSE $INCPATH $LIBPATH $NOLOG $DEBUG_MALLOC $MANUAL $CF
use lib 'inc';
use Devel::CheckLib;
+# EU::MM runs Makefile.PL all in the same process, so sub-modules will
+# see this
+our $BUILDING_IMAGER = 1;
+
#
# IM_INCPATH colon seperated list of paths to extra include paths
# IM_LIBPATH colon seperated list of paths to extra library paths
@@ -55,6 +59,8 @@ GetOptions("help" => \$help,
'coverage' => \$coverage,
"assert|a" => \$assert);
+setenv();
+
if ($ENV{AUTOMATED_TESTING}) {
$assert = 1;
}
@@ -534,19 +540,19 @@ sub init {
postcheck => \&postcheck_tiff,
};
- $formats{'png'}={
- order=>'22',
- def=>'HAVE_LIBPNG',
- inccheck=>sub { -e catfile($_[0], 'png.h') },
- libcheck=>sub { $_[0] eq "libpng$aext" or $_[0] eq "libpng.$lext" },
- libfiles=>$^O eq 'MSWin32' ? '-lpng -lzlib' : '-lpng -lz',
- objfiles=>'png.o',
- docs=>q{
- Png stands for Portable Network Graphics and is intended as
- a replacement for gif on the web. It is patent free and
- is recommended by the w3c, you need libpng to use these formats},
- code => \&png_probe,
- };
+# $formats{'png'}={
+# order=>'22',
+# def=>'HAVE_LIBPNG',
+# inccheck=>sub { -e catfile($_[0], 'png.h') },
+# libcheck=>sub { $_[0] eq "libpng$aext" or $_[0] eq "libpng.$lext" },
+# libfiles=>$^O eq 'MSWin32' ? '-lpng -lzlib' : '-lpng -lz',
+# objfiles=>'png.o',
+# docs=>q{
+# Png stands for Portable Network Graphics and is intended as
+# a replacement for gif on the web. It is patent free and
+# is recommended by the w3c, you need libpng to use these formats},
+# code => \&png_probe,
+# };
$formats{'gif'}={
order=>'20',
@@ -678,6 +684,13 @@ sub getenv {
}
+# populate the environment so that sub-modules get the same info
+sub setenv {
+ $ENV{IM_VERBOSE} = 1 if $VERBOSE;
+ $ENV{IM_INCPATH} = join $Config{path_sep}, @incpaths if @incpaths;
+ $ENV{IM_LIBPATH} = join $Config{path_sep}, @libpaths if @libpaths;
+}
+
sub make_imconfig {
my ($defines) = @_;
View
100 PNG/Makefile.PL
@@ -0,0 +1,100 @@
+#!perl -w
+use strict;
+use ExtUtils::MakeMaker qw(WriteMakefile WriteEmptyMakefile);
+use Getopt::Long;
+
+my $verbose = $ENV{IM_VERBOSE};
+my @libpaths;
+my @incpaths;
+
+GetOptions("incpath=s", \@incpaths,
+ "libpath=s" => \@libpaths,
+ "verbose|v" => \$verbose);
+
+our $BUILDING_IMAGER;
+
+my $MM_ver = eval $ExtUtils::MakeMaker::VERSION;
+
+my %opts =
+ (
+ NAME => 'Imager::File::PNG',
+ VERSION_FROM => 'PNG.pm',
+ OBJECT => 'PNG.o impng.o',
+ );
+
+my @inc;
+if ($BUILDING_IMAGER) {
+ push @inc, "-I..";
+ push @INC, "../lib";
+}
+else {
+ print "PNG: building independently\n";
+ require Imager::ExtUtils;
+ push @inc, Imager::ExtUtils->includes;
+ $opts{TYPEMAPS} = [ Imager::ExtUtils->typemap ];
+
+ # Imager required configure through use
+ my @Imager_req = ( Imager => "0.76" );
+ if ($MM_ver >= 6.46) {
+ $opts{META_MERGE} =
+ {
+ configure_requires =>
+ {
+ @Imager_req,
+ },
+ build_requires =>
+ {
+ @Imager_req,
+ "Test::More" => "0.47",
+ }
+ };
+ $opts{PREREQ_PM} =
+ {
+ @Imager_req,
+ };
+ }
+}
+
+require Imager::Probe;
+
+my %probe =
+ (
+ name => "PNG",
+ pkg => [ qw/libpng14 libpng12 libpng10 libpng/ ],
+ inccheck => sub { -e File::Spec->catfile($_[0], "png.h") },
+ libbase => "png",
+ testcode => _png_test_code(),
+ testcodeheaders => [ "png.h", "stdio.h" ],
+ );
+
+my $probe_res = Imager::Probe->probe(\%probe);
+if ($probe_res) {
+ push @inc, $probe_res->{INC};
+ $opts{LIBS} = $probe_res->{LIBS};
+
+ $opts{INC} = "@inc";
+
+ if ($MM_ver > 6.06) {
+ $opts{AUTHOR} = 'Tony Cook <tony@imager.perl.org>';
+ $opts{ABSTRACT} = 'PNG Image file support';
+ }
+
+ WriteMakefile(%opts);
+}
+else {
+ if ($BUILDING_IMAGER) {
+ WriteEmptyMakefile(%opts);
+ }
+ else {
+ # fail in good way
+ die "OS unsupported: PNG libraries or headers not found\n";
+ }
+}
+
+sub _png_test_code {
+ return <<'CODE';
+
+fprintf(stderr, "PNG: library version %ld, header version %ld\n", (long)png_access_version_number(), (long)PNG_LIBPNG_VER);
+return 0;
+CODE
+}
View
83 PNG/PNG.pm
@@ -0,0 +1,83 @@
+package Imager::File::PNG;
+use strict;
+use Imager;
+use vars qw($VERSION @ISA);
+
+BEGIN {
+ $VERSION = "0.76";
+
+ eval {
+ require XSLoader;
+ XSLoader::load('Imager::File::PNG', $VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ bootstrap Imager::File::PNG $VERSION;
+ };
+}
+
+Imager->register_reader
+ (
+ type=>'png',
+ single =>
+ sub {
+ my ($im, $io, %hsh) = @_;
+ $im->{IMG} = i_readpng_wiol($io);
+
+ unless ($im->{IMG}) {
+ $im->_set_error(Imager->_error_as_msg);
+ return;
+ }
+ return $im;
+ },
+ );
+
+Imager->register_writer
+ (
+ type=>'png',
+ single =>
+ sub {
+ my ($im, $io, %hsh) = @_;
+
+ $im->_set_opts(\%hsh, "i_", $im);
+ $im->_set_opts(\%hsh, "png_", $im);
+
+ unless (i_writepng_wiol($im->{IMG}, $io)) {
+ $im->_set_error(Imager->_error_as_msg);
+ return;
+ }
+ return $im;
+ },
+ );
+
+__END__
+
+=head1 NAME
+
+Imager::File::PNG - read and write PNG files
+
+=head1 SYNOPSIS
+
+ use Imager;
+
+ my $img = Imager->new;
+ $img->read(file=>"foo.png")
+ or die $img->errstr;
+
+ $img->write(file => "foo.png")
+ or die $img->errstr;
+
+=head1 DESCRIPTION
+
+Imager's PNG support is documented in L<Imager::Files>.
+
+=head1 AUTHOR
+
+Tony Cook <tony@imager.perl.org>
+
+=head1 SEE ALSO
+
+Imager, Imager::Files.
+
+=cut
View
26 PNG/PNG.xs
@@ -0,0 +1,26 @@
+#define PERL_NO_GET_CONTEXT
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "imext.h"
+#include "imperl.h"
+#include "impng.h"
+
+DEFINE_IMAGER_CALLBACKS;
+
+MODULE = Imager::File::PNG PACKAGE = Imager::File::PNG
+
+Imager::ImgRaw
+i_readpng_wiol(ig)
+ Imager::IO ig
+
+undef_int
+i_writepng_wiol(im, ig)
+ Imager::ImgRaw im
+ Imager::IO ig
+
+BOOT:
+ PERL_INITIALIZE_IMAGER_CALLBACKS;
View
19 png.c → PNG/impng.c
@@ -1,5 +1,4 @@
-#include "iolayer.h"
-#include "imageri.h"
+#include "impng.h"
#include "png.h"
/* Check to see if a file is a PNG file using png_sig_cmp(). png_sig_cmp()
@@ -73,7 +72,6 @@ i_writepng_wiol(i_img *im, io_glue *ig) {
double xres, yres;
int aspect_only, have_res;
- io_glue_commit_types(ig);
mm_log((1,"i_writepng(im %p ,ig %p)\n", im, ig));
height = im->ysize;
@@ -183,7 +181,7 @@ i_writepng_wiol(i_img *im, io_glue *ig) {
static void get_png_tags(i_img *im, png_structp png_ptr, png_infop info_ptr);
i_img*
-i_readpng_wiol(io_glue *ig, int length) {
+i_readpng_wiol(io_glue *ig) {
i_img *im = NULL;
png_structp png_ptr;
png_infop info_ptr;
@@ -195,8 +193,7 @@ i_readpng_wiol(io_glue *ig, int length) {
sig_read = 0;
- io_glue_commit_types(ig);
- mm_log((1,"i_readpng_wiol(ig %p, length %d)\n", ig, length));
+ mm_log((1,"i_readpng_wiol(ig %p)\n", ig));
png_ptr = png_create_read_struct(PNG_LIBPNG_VER_STRING,NULL,NULL,NULL);
png_set_read_fn(png_ptr, (png_voidp) (ig), wiol_read_data);
@@ -253,7 +250,7 @@ i_readpng_wiol(io_glue *ig, int length) {
mm_log((1,"number of passes=%d\n",number_passes));
png_read_update_info(png_ptr, info_ptr);
- im = i_img_empty_ch(NULL,width,height,channels);
+ im = i_img_8_new(width,height,channels);
if (!im) {
png_destroy_read_struct(&png_ptr, &info_ptr, (png_infopp)NULL);
return NULL;
@@ -277,7 +274,7 @@ static void get_png_tags(i_img *im, png_structp png_ptr, png_infop info_ptr) {
png_uint_32 xres, yres;
int unit_type;
- i_tags_add(&im->tags, "i_format", 0, "png", -1, 0);
+ i_tags_set(&im->tags, "i_format", "png", -1);
if (png_get_pHYs(png_ptr, info_ptr, &xres, &yres, &unit_type)) {
mm_log((1,"pHYs (%d, %d) %d\n", xres, yres, unit_type));
if (unit_type == PNG_RESOLUTION_METER) {
@@ -285,9 +282,9 @@ static void get_png_tags(i_img *im, png_structp png_ptr, png_infop info_ptr) {
i_tags_set_float2(&im->tags, "i_yres", 0, yres * 0.0254, 5);
}
else {
- i_tags_addn(&im->tags, "i_xres", 0, xres);
- i_tags_addn(&im->tags, "i_yres", 0, yres);
- i_tags_addn(&im->tags, "i_aspect_only", 0, 1);
+ i_tags_setn(&im->tags, "i_xres", xres);
+ i_tags_setn(&im->tags, "i_yres", yres);
+ i_tags_setn(&im->tags, "i_aspect_only", 1);
}
}
}
View
9 PNG/impng.h
@@ -0,0 +1,9 @@
+#ifndef IMAGER_IMPNG_H
+#define IMAGER_IMPNG_H
+
+#include "imext.h"
+
+i_img *i_readpng_wiol(io_glue *ig);
+undef_int i_writepng_wiol(i_img *im, io_glue *ig);
+
+#endif
View
5 PNG/t/00load.t
@@ -0,0 +1,5 @@
+#!perl -w
+use strict;
+use Test::More tests => 1;
+
+use_ok("Imager::File::PNG");
View
16 t/t102png.t → PNG/t/10png.t
@@ -4,9 +4,11 @@ use Imager qw(:all);
use Test::More;
use Imager::Test qw(test_image_raw);
+-d "testout" or mkdir "testout";
+
init_log("testout/t102png.log",1);
-i_has_format("png")
+$Imager::formats{"png"}
or plan skip_all => "No png support";
plan tests => 33;
@@ -29,13 +31,13 @@ Imager::i_tags_add($img, "i_yres", 0, undef, 200);
open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
binmode(FH);
my $IO = Imager::io_new_fd(fileno(FH));
-ok(i_writepng_wiol($img, $IO), "write");
+ok(Imager::File::PNG::i_writepng_wiol($img, $IO), "write");
close(FH);
open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
-my $cmpimg = i_readpng_wiol($IO, -1);
+my $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
close(FH);
ok($cmpimg, "read png");
@@ -52,14 +54,14 @@ open FH, "> testout/t102_trans.png"
or die "Cannot open testout/t102_trans.png: $!";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
-ok(i_writepng_wiol($timg, $IO), "write tranparent");
+ok(Imager::File::PNG::i_writepng_wiol($timg, $IO), "write tranparent");
close FH;
open FH,"testout/t102_trans.png"
or die "cannot open testout/t102_trans.png\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
-$cmpimg = i_readpng_wiol($IO, -1);
+$cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
ok($cmpimg, "read transparent");
close(FH);
@@ -74,7 +76,7 @@ open FH, "< testimg/palette.png"
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
# 1.1 may segfault here (it does with libefence)
-my $pimg = i_readpng_wiol($IO,-1);
+my $pimg = Imager::File::PNG::i_readpng_wiol($IO);
ok($pimg, "read transparent paletted image");
close FH;
@@ -82,7 +84,7 @@ open FH, "< testimg/palette_out.png"
or die "cannot open testimg/palette_out.png: $!\n";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
-my $poimg = i_readpng_wiol($IO, -1);
+my $poimg = Imager::File::PNG::i_readpng_wiol($IO);
ok($poimg, "read palette_out image");
close FH;
if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
View
0  testimg/palette.png → PNG/testimg/palette.png
File renamed without changes
View
0  testimg/palette_out.png → PNG/testimg/palette_out.png
File renamed without changes
View
5 imager.h
@@ -399,11 +399,6 @@ int i_tiff_has_compression(char const *name);
#endif /* HAVE_LIBTIFF */
-#ifdef HAVE_LIBPNG
-i_img *i_readpng_wiol(io_glue *ig, int length);
-undef_int i_writepng_wiol(i_img *im, io_glue *ig);
-#endif /* HAVE_LIBPNG */
-
#ifdef HAVE_LIBGIF
i_img *i_readgif(int fd, int **colour_table, int *colours);
i_img *i_readgif_wiol(io_glue *ig, int **colour_table, int *colours);
View
414 lib/Imager/Probe.pm
@@ -0,0 +1,414 @@
+package Imager::Probe;
+use strict;
+use File::Spec;
+use Config;
+
+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})) {
+ $result = _probe_check($req);
+ }
+
+ if (!$result && $req->{testcode}) {
+ $result = _probe_fake($req);
+ }
+ $result or return;
+
+ if ($req->{testcode}) {
+ $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/;
+ }
+
+ 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) = @_;
+
+ 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;
+
+ chomp $cflags;
+ chomp $lflags;
+ print "$req->{name}: Found via pkg-config $pkg\n";
+ return
+ {
+ INC => $cflags,
+ LIBS => $lflags,
+ };
+ }
+ }
+
+ print "$req->{name}: Not found via pkg-config\n";
+
+ return;
+}
+
+sub _probe_check {
+ my ($req) = @_;
+
+ my $libcheck = $req->{libcheck};
+ my $libbase = $req->{libbase};
+ if (!$libcheck && $req->{libbase}) {
+ # synthesize a libcheck
+ my $lext=$Config{'so'}; # Get extensions of libraries
+ my $aext=$Config{'_a'};
+ $libcheck = sub {
+ -e File::Spec->catfile($_[0], "lib$libbase$aext")
+ || -e File::Spec->catfile($_[0], "lib$libbase.$lext")
+ };
+ }
+
+ my $found_libpath;
+ my @lib_search = _lib_paths($req);
+ print "$req->{name}: Searching directories for libraries:\n"
+ if $req->{verbose};
+ for my $path (@lib_search) {
+ print "$req->{name}: $path\n" if $req->{verbose};
+ if ($libcheck->($path)) {
+ print "$req->{name}: Found!\n" if $req->{verbose};
+ $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;
+ }
+ }
+
+ print "$req->{name}: includes ", $found_incpath ? "" : "not ",
+ "found - libraries ", $found_libpath ? "" : "not ", "found\n";
+
+ $found_libpath && $found_incpath
+ or return;
+
+ my @libs = "-L$found_libpath";
+ if ($req->{libopts}) {
+ push @libs, $req->{libopts};
+ }
+ elsif ($libbase) {
+ push @libs, "-l$libbase";
+ }
+ else {
+ die "$req->{name}: inccheck but no libbase or libopts";
+ }
+
+ return
+ {
+ INC => "-I$found_incpath",
+ LIBS => "@libs",
+ };
+}
+
+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
+ $lopts = $req->{libbase} ? "-l$req->{libbase}" : "";
+ }
+ if (defined $lopts) {
+ print "$req->{name}: Checking if the compiler can find them on it's own\n";
+ return
+ {
+ INC => "",
+ LIBS => $lopts,
+ };
+ }
+ 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
+ my ($extra, $bs_load, $ld_load, $ld_run_path) =
+ ExtUtils::Liblist->ext($req->{LIBS}, $req->{verbose});
+ local $ENV{LD_RUN_PATH};
+
+ if ($ld_run_path) {
+ print "Setting LD_RUN_PATH=$ld_run_path for TIFF probe\n"
+ if $req->{verbose};
+ $ENV{LD_RUN_PATH} = $ld_run_path;
+ }
+ my $good =
+ Devel::CheckLib::check_lib
+ (
+ debug => $req->{verbose},
+ LIBS => $result->{LIBS},
+ INC => $result->{INC},
+ header => $req->{testcodeheaders},
+ function => $req->{testcode},
+ );
+ unless ($good) {
+ print "$req->{name}: Test code failed checklib probe: $@\n"
+ if $req->{verbose};
+ return;
+ }
+
+ print "$req->{name}: Passed code check\n";
+ return $result;
+}
+
+sub _lib_paths {
+ my ($req) = @_;
+
+ return _paths
+ (
+ $ENV{IM_LIBPATH},
+ $req->{libpath},
+ (
+ map { split ' ' }
+ grep $_,
+ @Config{qw/loclibpath libpth libspath/}
+ ),
+ $^O eq "MSWin32" ? $ENV{LIB} : "",
+ $^O eq "cygwin" ? "/usr/lib/w32api" : "",
+ );
+}
+
+sub _inc_paths {
+ my ($req) = @_;
+
+ return _paths
+ (
+ $ENV{IM_INCPATH},
+ $req->{incpath},
+ $^O eq "MSWin32" ? $ENV{INCLUDE} : "",
+ $^O eq "cygwin" ? "/usr/include/w32api" : "",
+ (
+ map { split ' ' }
+ grep $_,
+ @Config{qw/locincpath incpath/}
+ ),
+ "/usr/include",
+ "/usr/local/include",
+ );
+}
+
+sub _paths {
+ my (@in) = @_;
+
+ my @out;
+
+ for my $path (@in) {
+ $path or next;
+ $path = _tilde_expand($path);
+
+ push @out, grep -d $_, split /\Q$Config{path_sep}/, $path;
+ }
+
+ 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__
+
+=head1 NAME
+
+Imager::Probe - hot needle of inquiry for libraries
+
+=head1 SYNOPSIS
+
+ require Imager::Probe;
+
+ my %probe =
+ (
+ # short name of what we're looking for (displayed to user)
+ name => "FOO",
+ # pkg-config lookup
+ pkg => [ qw/name1 name2 name3/ ],
+ # perl subs that probe for the library
+ code => [ \&foo_probe1, \&foo_probe2 ],
+ # or just: code => \&foo_probe,
+ inccheck => sub { ... },
+ libcheck => sub { ... },
+ # search for this library if libcheck not supplied
+ libbase => "foo",
+ # library link time options, uses libbase to build options otherwise
+ libopts => "-lfoo",
+ # C code to check the library is sane
+ testcode => "...",
+ # header files needed
+ testcodeheaders => [ "stdio.h", "foo.h" ],
+ );
+ my $result = Imager::Probe->probe(\%probe)
+ or print "Foo library not found: ",Imager::Probe->error;
+
+=head1 DESCRIPTION
+
+Does the probes that were hidden in Imager's F<Makefile.PL>, pulled
+out so the file format libraries can be externalized.
+
+The return value is either nothing if the probe fails, or a hash
+containing:
+
+=over
+
+=item *
+
+C<INC> - C<-I> and other C options
+
+=item *
+
+C<LIBS> - C<-L>, C<-l> and other link-time options
+
+=back
+
+The possible values for the hash supplied to the probe() method are:
+
+=over
+
+=item *
+
+C<pkg> - an array of F<pkg-config> names to probe for. If the
+F<pkg-config> checks pass, C<inccheck> and C<libcheck> aren't used.
+
+=item *
+
+C<inccheck> - a code reference that checks if the supplied include
+directory contains the required header files.
+
+=item *
+
+C<libcheck> - a code reference that checks if the supplied library
+directory contains the required library files. Note: the
+F<Makefile.PL> version of this was supplied all of the library file
+names instead.
+
+=item *
+
+C<libbase> - if C<inccheck> is supplied, but C<libcheck> isn't, then a
+C<libcheck> that checks for C<lib>I<libbase>I<$Config{_a}> and
+C<lib>I<libbase>.I<$Config{so}> is created. If C<libopts> isn't
+supplied then that can be synthesized as C<-l>C<<I<libbase>>>.
+
+=item *
+
+C<libopts> - if the libraries are found via C<inccheck>/C<libcheck>,
+these are the C<-l> options to supply during the link phase.
+
+=item *
+
+C<code> - a code reference to perform custom checks. Returns the
+probe result directly. Can also be an array ref of functions to call.
+
+=item *
+
+C<testcode> - test C code that is run with Devel::CheckLib. You also
+need to set C<testcodeheaders>.
+
+=item *
+
+C<incpath> - C<$Config{path_sep}> separated list of header file
+directories to check.
+
+=item *
+
+C<libpath> - C<$Config{path_sep}> separated list of library file
+directories to check.
+
+=back
+
+=cut
View
2  t/t102nopng.t
@@ -3,7 +3,7 @@ use strict;
use Imager qw(:all);
use Test::More;
-i_has_format("png")
+$Imager::formats{"png"}
and plan skip_all => "png available, and this tests the lack of it";
plan tests => 6;
View
1  t/t104ppm.t
@@ -572,6 +572,7 @@ print "# check error handling\n";
{
ok(open(FH, "< testimg/penguin-base.ppm"), "open test file")
or skip("couldn't open data source", 4);
+ binmode FH;
my $imdata = do { local $/; <FH> };
close FH;
ok(length $imdata, "we got the data");
Please sign in to comment.
Something went wrong with that request. Please try again.