#!perl -w
use Imager ':all';
-use Test::More tests => 143;
+use Test::More tests => 205;
use strict;
-use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image);
+use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image test_image_named);
-init_log("testout/t104ppm.log",1);
+$| = 1;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t104ppm.log");
my $green = i_color_new(0,255,0,255);
my $blue = i_color_new(0,0,255,255);
my $red = i_color_new(255,0,0,255);
+my @files;
+
my $img = test_image_raw();
my $fh = openimage(">testout/t104.ppm");
+push @files, "t104.ppm";
my $IO = Imager::io_new_fd(fileno($fh));
ok(i_writeppm_wiol($img, $IO), "write pnm low")
or die "Cannot write testout/t104.ppm\n";
i_box_filled($gimg, 40, 40, 110, 110, $dgray);
i_arc($gimg, 75, 75, 30, 0, 361, $white);
+push @files, "t104_gray.pgm";
open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
"compare written and read greyscale images");
my $ooim = Imager->new;
-ok($ooim->read(file=>"testimg/simple.pbm"), "read simple pbm, via OO");
+ok($ooim->read(file=>"testimg/simple.pbm"), "read simple pbm, via OO")
+ or print "# ", $ooim->errstr, "\n";
check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 0), 0);
check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 1), 255);
# check we correctly sync with the data stream
my $im = Imager->new;
ok($im->read(file => 'testimg/pgm.pgm', type => 'pnm'),
- "read pgm.pgm");
+ "read pgm.pgm")
+ or print "# cannot read pgm.pgm: ", $im->errstr, "\n";
print "# ", $im->getsamples('y' => 0), "\n";
is_color1($im->getpixel(x=>0, 'y' => 0), 254, "check top left");
}
{ # check error messages set correctly
- my $im = Imager->new(xsize=>100, ysize=>100, channels=>4);
- ok(!$im->write(file=>"testout/t104_fail.ppm", type=>'pnm'),
- "should fail to write 4 channel image");
- is($im->errstr, 'can only save 1 or 3 channel images to pnm',
- "check error message");
+ my $im = Imager->new;
ok(!$im->read(file=>'t/t104ppm.t', type=>'pnm'),
'should fail to read script as an image file');
is($im->errstr, 'unable to read pnm image: bad header magic, not a PNM file',
"check error message");
}
+{
+ # RT #30074
+ # give 4/2 channel images a background color when saving to pnm
+ my $im = Imager->new(xsize=>16, ysize=>16, channels=>4);
+ $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
+ $im->box(filled => 1, color => NC(0, 192, 192, 128),
+ ymin => 8, xmax => 7);
+ push @files, "t104_alpha.ppm";
+ ok($im->write(file=>"testout/t104_alpha.ppm", type=>'pnm'),
+ "should succeed writing 4 channel image");
+ my $imread = Imager->new;
+ ok($imread->read(file => 'testout/t104_alpha.ppm'), "read it back")
+ or print "# ", $imread->errstr, "\n";
+ is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0,
+ "check transparent became black");
+ is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+ "check color came through");
+ is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
+ "check translucent came through");
+ my $data;
+ ok($im->write(data => \$data, type => 'pnm', i_background => '#FF0000'),
+ "write with red background");
+ ok($imread->read(data => $data, type => 'pnm'),
+ "read it back");
+ is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0,
+ "check transparent became red");
+ is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+ "check color came through");
+ is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
+ "check translucent came through");
+}
+
+{
+ # more RT #30074 - 16 bit images
+ my $im = Imager->new(xsize=>16, ysize=>16, channels=>4, bits => 16);
+ $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
+ $im->box(filled => 1, color => NC(0, 192, 192, 128),
+ ymin => 8, xmax => 7);
+ push @files, "t104_alp16.ppm";
+ ok($im->write(file=>"testout/t104_alp16.ppm", type=>'pnm',
+ pnm_write_wide_data => 1),
+ "should succeed writing 4 channel image");
+ my $imread = Imager->new;
+ ok($imread->read(file => 'testout/t104_alp16.ppm'), "read it back");
+ is($imread->bits, 16, "check we did produce a 16 bit image");
+ is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0,
+ "check transparent became black");
+ is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+ "check color came through");
+ is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
+ "check translucent came through");
+ my $data;
+ ok($im->write(data => \$data, type => 'pnm', i_background => '#FF0000',
+ pnm_write_wide_data => 1),
+ "write with red background");
+ ok($imread->read(data => $data, type => 'pnm'),
+ "read it back");
+ is($imread->bits, 16, "check it's 16-bit");
+ is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0,
+ "check transparent became red");
+ is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+ "check color came through");
+ is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
+ "check translucent came through");
+}
+
# various bad input files
print "# check error handling\n";
{
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_bin.ppm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bin ppm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_bin16.ppm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bin16 ppm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_bin.pgm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bin pgm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_bin16.pgm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bin16 pgm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_bin.pbm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bin pbm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_asc.ppm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read asc ppm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_asc.pgm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read asc pgm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/short_asc.pbm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read asc pbm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
}
+{
+ my @imgs = Imager->read_multi(file => 'testimg/multiple.ppm');
+ is( 0+@imgs, 3, "Read 3 images");
+ is( $imgs[0]->tags( name => 'pnm_type' ), 1, "Image 1 is type 1" );
+ is( $imgs[0]->getwidth, 2, " ... width=2" );
+ is( $imgs[0]->getheight, 2, " ... width=2" );
+ is( $imgs[1]->tags( name => 'pnm_type' ), 6, "Image 2 is type 6" );
+ is( $imgs[1]->getwidth, 164, " ... width=164" );
+ is( $imgs[1]->getheight, 180, " ... width=180" );
+ is( $imgs[2]->tags( name => 'pnm_type' ), 5, "Image 3 is type 5" );
+ is( $imgs[2]->getwidth, 2, " ... width=2" );
+ is( $imgs[2]->getheight, 2, " ... width=2" );
+}
+
{
my $im = Imager->new;
ok($im->read(file => 'testimg/bad_asc.ppm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bad asc ppm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/bad_asc.pgm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bad asc pgm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
my $im = Imager->new;
ok($im->read(file => 'testimg/bad_asc.pbm', type => 'pnm',
- allow_partial => 1),
+ allow_incomplete => 1),
"partial read bad asc pbm");
is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
{
print "# monochrome output\n";
- my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+ my $im = Imager->new(xsize => 10, ysize => 10, channels => 1, type => 'paletted');
ok($im->addcolors(colors => [ '#000000', '#FFFFFF' ]),
"add black and white");
$im->box(filled => 1, xmax => 4, color => '#000000');
$im->box(filled => 1, xmin => 5, color => '#FFFFFF');
is($im->type, 'paletted', 'mono still paletted');
+ push @files, "t104_mono.pbm";
ok($im->write(file => 'testout/t104_mono.pbm', type => 'pnm'),
"save as pbm");
or print "# ", $imread->errstr, "\n";
is($imread->type, 'paletted', "check result is paletted");
is($imread->tags(name => 'pnm_type'), 4, "check type");
+ is_image($im, $imread, "check image matches");
+}
+
+{
+ print "# monochrome output - reversed palette\n";
+ my $im = Imager->new(xsize => 10, ysize => 10, channels => 1, type => 'paletted');
+ ok($im->addcolors(colors => [ '#FFFFFF', '#000000' ]),
+ "add white and black");
+ $im->box(filled => 1, xmax => 4, color => '#000000');
+ $im->box(filled => 1, xmin => 5, color => '#FFFFFF');
+ is($im->type, 'paletted', 'mono still paletted');
+ push @files, "t104_mono2.pbm";
+ ok($im->write(file => 'testout/t104_mono2.pbm', type => 'pnm'),
+ "save as pbm");
+
+ # check it
+ my $imread = Imager->new;
+ ok($imread->read(file => 'testout/t104_mono2.pbm', type=>'pnm'),
+ "read it back in")
+ or print "# ", $imread->errstr, "\n";
+ is($imread->type, 'paletted', "check result is paletted");
+ is($imread->tags(name => 'pnm_type'), 4, "check type");
+ is_image($im, $imread, "check image matches");
}
{
$data = '';
ok($im->write(data => \$data, type => 'pnm'),
"write 16-bit image as 16-bit/sample ppm");
+ push @files, "t104_16.ppm";
$im->write(file=>'testout/t104_16.ppm');
my $im16 = Imager->new;
ok($im16->read(data => $data), "read it back");
is($im16->tags(name => 'pnm_maxval'), 65535, "check maxval");
+ push @files, "t104_16b.ppm";
$im16->write(file=>'testout/t104_16b.ppm');
is_image($im, $im16, "check image matches");
}
+{
+ ok(grep($_ eq 'pnm', Imager->read_types), "check pnm in read types");
+ ok(grep($_ eq 'pnm', Imager->write_types), "check pnm in write types");
+}
+
+{ # test new() loading an image
+ my $im = Imager->new(file => "testimg/penguin-base.ppm");
+ ok($im, "received an image");
+ is($im->getwidth, 164, "check width matches image");
+
+ # fail to load an image
+ my $im2 = Imager->new(file => "Imager.pm", filetype => "pnm");
+ ok(!$im2, "no image when file failed to load");
+ cmp_ok(Imager->errstr, '=~', "bad header magic, not a PNM file",
+ "check error message transferred");
+
+ # load from data
+ SKIP:
+ {
+ 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");
+ my $im3 = Imager->new(data => $imdata);
+ ok($im3, "read the file data");
+ is($im3->getwidth, 164, "check width matches image");
+ }
+}
+
+{ # image too large handling
+ {
+ ok(!Imager->new(file => "testimg/toowide.ppm", filetype => "pnm"),
+ "fail to read a too wide image");
+ is(Imager->errstr, "unable to read pnm image: could not read image width: integer overflow",
+ "check error message");
+ }
+ {
+ ok(!Imager->new(file => "testimg/tootall.ppm", filetype => "pnm"),
+ "fail to read a too wide image");
+ is(Imager->errstr, "unable to read pnm image: could not read image height: integer overflow",
+ "check error message");
+ }
+}
+
+{ # make sure close is checked for each image type
+ my $fail_close = sub {
+ Imager::i_push_error(0, "synthetic close failure");
+ return 0;
+ };
+
+ for my $type (qw(basic basic16 gray gray16 mono)) {
+ my $im = test_image_named($type);
+ my $io = Imager::io_new_cb(sub { 1 }, undef, undef, $fail_close);
+ ok(!$im->write(io => $io, type => "pnm"),
+ "write $type image with a failing close handler");
+ like($im->errstr, qr/synthetic close failure/,
+ "check error message");
+ }
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t104ppm.log";
+ unlink map "testout/$_", @files;
+}
+
sub openimage {
my $fname = shift;
local(*FH);
projects / imager.git / blobdiff