spot.perl For making an ordered dither matrix from a spot function
stackmach.c
stackmach.h
+t/000-load.t Test Imager modules can be loaded
+t/100-base/010-introvert.t Test image inspection
+t/100-base/020-color.t Test Imager::Color
+t/100-base/030-countc.t Test getcolorcount() etc
+t/100-base/800-tr18561.t Regression test for RT #18561
+t/100-base/801-tr18561b.t Regression test for RT #18561
+t/150-type/020-sixteen.t Test 16-bit/sample images
+t/150-type/030-double.t Test double/sample images
+t/150-type/040-palette.t Test paletted images
+t/150-type/100-masked.t Test masked images
+t/200-file/010-iolayer.t Test Imager I/O layer objects
+t/200-file/100-files.t Format independent file tests
+t/200-file/200-nojpeg.t Test handling when jpeg not available
+t/200-file/210-nopng.t Test handling when png not available
+t/200-file/220-nogif.t Test handling when gif not available
+t/200-file/230-notiff.t Test handling when tiff not available
+t/200-file/300-raw.t Test raw file handling
+t/200-file/310-pnm.t Test PNM file handling
+t/200-file/320-bmp.t Test BMP file handling
+t/200-file/330-tga.t Test TGA file handling
+t/200-file/400-basic.t Test basic operations across file formats
+t/250-draw/010-draw.t Basic drawing tests
+t/250-draw/020-flood.t Flood fill tests
+t/250-draw/030-paste.t Test the paste() method
+t/250-draw/040-rubthru.t Test the rubthrough() method
+t/250-draw/050-polyaa.t polygon()
+t/250-draw/100-fill.t fills
+t/250-draw/200-compose.t compose()
+t/300-transform/010-scale.t scale(), scaleX() and scaleY()
+t/300-transform/020-combine.t Test combine() method
+t/300-transform/030-copyflip.t Test copy, flip, rotate, matrix_transform
+t/300-transform/040-crop.t
+t/300-transform/050-convert.t
+t/300-transform/060-map.t
+t/300-transform/500-trans.t transform()
+t/300-transform/600-trans2.t transform2() using RPN
+t/300-transform/610-postfix.t more transform2() using RPN
+t/300-transform/620-infix.t transform2() using infix
+t/300-transform/630-assem.t transform2() using assembler
+t/350-font/010-font.t General font interface tests
+t/350-font/020-tt.t low level FT1 tests
+t/350-font/030-ttoo.t OO level FT1 tests
+t/350-font/040-ttstd.t Standard font tests for TT
+t/350-font/100-texttools.t Test text wrapping
+t/400-filter/010-filters.t Consolidated filter tests (needs to split)
+t/450-api/100-inline.t Inline::C integration and API
+t/450-api/110-inlinectx.t context APIs
+t/850-thread/010-base.t Test wrt to perl threads
+t/850-thread/100-error.t error stack handling with threads
+t/850-thread/110-log.t log handling with threads
+t/900-util/010-test.t Test Imager::Test
+t/900-util/020-error.t Error stack
+t/900-util/030-log.t log
+t/900-util/040-limit.t file size limits
+t/900-util/050-matrix.t Imager::Matrix2d
+t/900-util/060-extutil.t Imager::ExtUtils
+t/900-util/060-hlines.t hlines.c internal API
+t/950-kwalitee/010-pod.t Test POD with Test::Pod
+t/950-kwalitee/020-samples.t Check samples are in samples/README
+t/950-kwalitee/030-podcover.t POD Coverage tests
+t/950-kwalitee/040-strict.t Check use strict is usede
+t/950-kwalitee/050-meta.t Check META.yml is valid
t/GoodTestFont.pm A dummy (hardly implemented) font driver.
t/Pod/Coverage/Imager.pm
-t/t00basic.t
-t/t01introvert.t
-t/t020masked.t
-t/t021sixteen.t
-t/t022double.t Test double/sample images
-t/t023palette.t Test paletted images
-t/t03test.t Test Imager::Test
-t/t05error.t
-t/t07iolayer.t
-t/t080log.t
-t/t081error.t
-t/t082limit.t
-t/t1000files.t Format independent file tests
t/t1000lib/Imager/File/BAD.pm Test failing to load a file handler
-t/t101nojpeg.t Test handling when jpeg not available
-t/t102nopng.t Test handling when png not available
-t/t103raw.t
-t/t104ppm.t
-t/t105nogif.t Test handling when gif not available
-t/t106notiff.t Test handling when tiff not available
-t/t107bmp.t
-t/t108tga.t
-t/t15color.t
-t/t16matrix.t Tests Imager::Matrix2d
-t/t20fill.t Tests fills
-t/t21draw.t Basic drawing tests
-t/t22flood.t Flood fill tests
-t/t31font.t General font interface tests
-t/t35ttfont.t
-t/t36oofont.t
-t/t37std.t Standard font tests for TT
-t/t40scale.t
-t/t50basicoo.t
-t/t55trans.t
-t/t56postfix.t
-t/t57infix.t
-t/t58trans2.t
-t/t59assem.t
-t/t61filters.t
-t/t62compose.t
-t/t63combine.t Test combine() method
-t/t64copyflip.t Test copy, flip, rotate, matrix_transform
-t/t65crop.t
-t/t66paste.t
-t/t67convert.t
-t/t68map.t
-t/t69rubthru.t
-t/t75polyaa.t
-t/t80texttools.t Test text wrapping
-t/t81hlines.t Test hlines.c
-t/t82inline.t Test Inline::C integration
-t/t83extutil.t Test Imager::ExtUtils
-t/t84inlinectx.t
-t/t90cc.t
-t/t91pod.t Test POD with Test::Pod
-t/t92samples.t
-t/t93podcover.t POD Coverage tests
-t/t94kwalitee.t Various "kwalitee" tests
-t/t95log.t
-t/t98meta.t
-t/t99thread.t Test wrt to perl threads
-t/tr18561.t Regression tests
-t/tr18561b.t
T1/fontfiles/dcr10.afm
T1/fontfiles/dcr10.pfb
T1/fontfiles/ExistenceTest.afm please edit ExistenceTest.sfd in CVS
W32/Makefile.PL
W32/README
W32/t/t10win32.t Tests Win32 GDI font support
-W32/t/t90std.t Standard font tests for W32
+W32/t/t90std.t Standard font tests for W32
W32/W32.pm
W32/W32.xs
W32/win32.c Implements font support through Win32 GDI
# unshipped test images
^xtestimg/
+# unshipped tests
+^xt/
+
# base for some other images
^testimg/pbm_base\.pgm$
^fileformatdocs/
^extraimages/
^fontfiles/.*\.sfd$
-^t/x.*\.t$
^imcover.perl$
# might distribute one day
# generated if we build them in their own directory
^(PNG|TIFF|FT2|W32|GIF)/blib/
+# not shipped with Imager itself
+^(PNG|TIFF|FT2|W32|GIF)/MANIFEST
+
# generated from .im files
^combine\.c$
^compose\.c$
# sub-module build junk
\.bak$
-MYMETA.json
\ No newline at end of file
+MYMETA.json
+
+# dist dir
+^Imager-[01]\.[0-9]+/
\ No newline at end of file
$CFLAGS .= " -DIMAGER_TRACE_CONTEXT";
}
+my $tests = 't/*.t t/*/*.t';
+if (-d "xt" && scalar(() = glob("xt/*.t"))) {
+ $tests .= " xt/*.t";
+}
+
my %opts=
(
'NAME' => 'Imager',
'XSLoader' => 0,
},
TYPEMAPS => \@typemaps,
+ test => { TESTS => $tests },
);
if ($coverage) {
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 15;
+
+use_ok('Imager');
+use_ok('Imager::Font');
+use_ok('Imager::Color');
+use_ok('Imager::Color::Float');
+use_ok('Imager::Color::Table');
+use_ok('Imager::Matrix2d');
+use_ok('Imager::ExtUtils');
+use_ok('Imager::Expr');
+use_ok('Imager::Expr::Assem');
+use_ok('Imager::Font::BBox');
+use_ok('Imager::Font::Wrap');
+use_ok('Imager::Fountain');
+use_ok('Imager::Regops');
+use_ok('Imager::Test');
+use_ok('Imager::Transform');
--- /dev/null
+#!perl -w
+# t/t01introvert.t - tests internals of image formats
+# to make sure we get expected values
+
+use strict;
+use Test::More tests => 466;
+
+BEGIN { use_ok(Imager => qw(:handy :all)) }
+
+use Imager::Test qw(image_bounds_checks is_color3 is_color4 is_fcolor4 color_cmp mask_tests is_fcolor3);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t01introvert.log");
+
+my $im_g = Imager::ImgRaw::new(100, 101, 1);
+
+my $red = NC(255, 0, 0);
+my $green = NC(0, 255, 0);
+my $blue = NC(0, 0, 255);
+
+use Imager::Color::Float;
+my $f_black = Imager::Color::Float->new(0, 0, 0);
+my $f_red = Imager::Color::Float->new(1.0, 0, 0);
+my $f_green = Imager::Color::Float->new(0, 1.0, 0);
+my $f_blue = Imager::Color::Float->new(0, 0, 1.0);
+
+is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
+ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
+ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
+is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
+is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
+is(Imager::i_img_get_width($im_g), 100, "100 pixels wide");
+is(Imager::i_img_get_height($im_g), 101, "101 pixels high");
+
+my @ginfo = Imager::i_img_info($im_g);
+is($ginfo[0], 100, "1 channel image width");
+is($ginfo[1], 101, "1 channel image height");
+
+undef $im_g; # can we check for release after this somehow?
+
+my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
+
+is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
+is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
+is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
+is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
+
+undef $im_rgb;
+
+my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
+
+ok($im_pal, "make paletted image");
+is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
+is(Imager::i_img_bits($im_pal), 8, "pal img bits");
+is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
+
+my $red_idx = check_add($im_pal, $red, 0);
+my $green_idx = check_add($im_pal, $green, 1);
+my $blue_idx = check_add($im_pal, $blue, 2);
+
+# basic writing of palette indicies
+# fill with red
+is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100,
+ "write red 100 times");
+# and blue
+is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
+ "write blue 50 times");
+
+# make sure we get it back
+my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
+ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
+ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
+is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50,
+ "gpal in scalar context");
+my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
+is(@samp, 300, "gsamp count in list context");
+my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
+is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
+my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
+is(length($samp), 300, "gsamp scalar length");
+is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
+
+# reading indicies as colors
+my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
+ok($c_red, "got the red pixel");
+is_color3($c_red, 255, 0, 0, "and it's red");
+my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
+ok($c_blue, "got the blue pixel");
+is_color3($c_blue, 0, 0, 255, "and it's blue");
+
+# drawing with colors
+ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
+# that was in the palette, should still be paletted
+is(Imager::i_img_type($im_pal), 1, "image still paletted");
+
+my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
+ok($c_green, "got green pixel");
+is_color3($c_green, 0, 255, 0, "and it's green");
+
+is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
+is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
+
+my $black = NC(0, 0, 0);
+# this should convert the image to RGB
+ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
+is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
+
+{
+ my %quant =
+ (
+ colors => [$red, $green, $blue, $black],
+ make_colors => 'none',
+ );
+ my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
+ ok($im_pal2, "got an image from quantizing");
+ is(@{$quant{colors}}, 4, "quant has the right number of colours");
+ is(Imager::i_colorcount($im_pal2), 4, "and so does the image");
+ my @colors = Imager::i_getcolors($im_pal2, 0, 4);
+ my ($first) = Imager::i_getcolors($im_pal2, 0);
+ my @first = $colors[0]->rgba;
+ is_color3($first, $first[0], $first[1], $first[2],
+ "check first color is first for multiple or single fetch");
+ is_color3($colors[0], 255, 0, 0, "still red");
+ is_color3($colors[1], 0, 255, 0, "still green");
+ is_color3($colors[2], 0, 0, 255, "still blue");
+ is_color3($colors[3], 0, 0, 0, "still black");
+ my @samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
+ my @expect = unpack("C*", "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50);
+ my $match_list = is_deeply(\@samples, \@expect, "colors are still correct");
+ my $samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
+ my $match_scalar = is_deeply([ unpack("C*", $samples) ],
+ \@expect, "colors are still correct (scalar)");
+ unless ($match_list && $match_scalar) {
+ # this has been failing on a particular smoker, provide more
+ # diagnostic information
+ print STDERR "Pallete:\n";
+ print STDERR " $_: ", join(",", $colors[$_]->rgba), "\n" for 0..$#colors;
+ print STDERR "Samples (list): ", join(",", @samples), "\n";
+ print STDERR "Samples (scalar): ", join(",", unpack("C*", $samples)), "\n";
+ print STDERR "Indexes: ", join(",", Imager::i_gpal($im_pal2, 0, 100, 0)), "\n";
+ }
+}
+
+# test the OO interfaces
+my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
+ok($impal2, "make paletted via OO")
+ or diag(Imager->errstr);
+is($impal2->getchannels, 3, "check channels");
+is($impal2->bits, 8, "check bits");
+is($impal2->type, 'paletted', "check type");
+is($impal2->getwidth, 200, "check width");
+is($impal2->getheight, 201, "check height");
+
+{
+ my $red_idx = $impal2->addcolors(colors=>[$red]);
+ ok($red_idx, "add red to OO");
+ is(0+$red_idx, 0, "and it's expected index for red");
+ my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
+ ok($blue_idx, "add blue/green via OO");
+ is($blue_idx, 1, "and it's expected index for blue");
+ my $green_idx = $blue_idx + 1;
+ my $c = $impal2->getcolors(start=>$green_idx);
+ is_color3($c, 0, 255, 0, "found green where expected");
+ my @cols = $impal2->getcolors;
+ is(@cols, 3, "got 3 colors");
+ my @exp = ( $red, $blue, $green );
+ my $good = 1;
+ for my $i (0..2) {
+ if (color_cmp($cols[$i], $exp[$i])) {
+ $good = 0;
+ last;
+ }
+ }
+ ok($good, "all colors in palette as expected");
+ is($impal2->colorcount, 3, "and colorcount returns 3");
+ is($impal2->maxcolors, 256, "maxcolors as expected");
+ is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
+ ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
+ "we can setcolors");
+
+ # make an rgb version
+ my $imrgb2 = $impal2->to_rgb8()
+ or diag($impal2->errstr);
+ is($imrgb2->type, 'direct', "converted is direct");
+
+ # and back again, specifying the palette
+ my @colors = ( $red, $blue, $green );
+ my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
+ make_colors=>'none',
+ translate=>'closest');
+ ok($impal3, "got a paletted image from conversion");
+ dump_colors(@colors);
+ print "# in image\n";
+ dump_colors($impal3->getcolors);
+ is($impal3->colorcount, 3, "new image has expected color table size");
+ is($impal3->type, 'paletted', "and is paletted");
+}
+
+{
+ my $im = Imager->new;
+ ok($im, "make empty image");
+ ok(!$im->to_rgb8, "convert to rgb8");
+ is($im->errstr, "to_rgb8: empty input image", "check message");
+ is($im->bits, undef, "can't call bits on an empty image");
+ is($im->errstr, "bits: empty input image", "check message");
+ is($im->type, undef, "can't call type on an empty image");
+ is($im->errstr, "type: empty input image", "check message");
+ is($im->virtual, undef, "can't call virtual on an empty image");
+ is($im->errstr, "virtual: empty input image", "check message");
+ is($im->is_bilevel, undef, "can't call virtual on an empty image");
+ is($im->errstr, "is_bilevel: empty input image", "check message");
+ ok(!$im->getscanline(y => 0), "can't call getscanline on an empty image");
+ is($im->errstr, "getscanline: empty input image", "check message");
+ ok(!$im->setscanline(y => 0, pixels => [ $red, $blue ]),
+ "can't call setscanline on an empty image");
+ is($im->errstr, "setscanline: empty input image", "check message");
+ ok(!$im->getsamples(y => 0), "can't call getsamples on an empty image");
+ is($im->errstr, "getsamples: empty input image", "check message");
+ is($im->getwidth, undef, "can't get width of empty image");
+ is($im->errstr, "getwidth: empty input image", "check message");
+ is($im->getheight, undef, "can't get height of empty image");
+ is($im->errstr, "getheight: empty input image", "check message");
+ is($im->getchannels, undef, "can't get channels of empty image");
+ is($im->errstr, "getchannels: empty input image", "check message");
+ is($im->getmask, undef, "can't get mask of empty image");
+ is($im->errstr, "getmask: empty input image", "check message");
+ is($im->setmask, undef, "can't set mask of empty image");
+ is($im->errstr, "setmask: empty input image", "check message");
+}
+
+{ # basic checks, 8-bit direct images
+ my $im = Imager->new(xsize => 2, ysize => 3);
+ ok($im, 'create 8-bit direct image');
+ is($im->bits, 8, '8 bits');
+ ok(!$im->virtual, 'not virtual');
+ is($im->type, 'direct', 'direct image');
+ ok(!$im->is_bilevel, 'not mono');
+}
+
+ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "0 height error message check");
+ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "0 width error message check");
+ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "-ve width error message check");
+ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "-ve height error message check");
+ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "-ve width/height error message check");
+
+ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
+ "fail to create a zero channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+ "out of range channel message check");
+ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
+ "fail to create a five channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+ "out of range channel message check");
+
+{
+ # https://rt.cpan.org/Ticket/Display.html?id=8213
+ # check for handling of memory allocation of very large images
+ # only test this on 32-bit machines - on a 64-bit machine it may
+ # result in trying to allocate 4Gb of memory, which is unfriendly at
+ # least and may result in running out of memory, causing a different
+ # type of exit
+ SKIP:
+ {
+ use Config;
+ skip("don't want to allocate 4Gb", 8) unless $Config{ptrsize} == 4;
+
+ my $uint_range = 256 ** $Config{intsize};
+ print "# range $uint_range\n";
+ my $dim1 = int(sqrt($uint_range))+1;
+
+ my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
+ is($im_b, undef, "integer overflow check - 1 channel");
+
+ $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
+ ok($im_b, "but same height ok");
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+
+ # do a similar test with a 3 channel image, so we're sure we catch
+ # the same case where the third dimension causes the overflow
+ my $dim3 = int(sqrt($uint_range / 3))+1;
+
+ $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
+ is($im_b, undef, "integer overflow check - 3 channel");
+
+ $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
+ ok($im_b, "but same height ok");
+
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+ }
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ my $img = Imager->new(xsize=>10, ysize=>10);
+ $img->to_rgb8(); # doesn't really matter what the source is
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 'introvert\\.t', "correct file");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=11860
+ my $im = Imager->new(xsize=>2, ysize=>2);
+ $im->setpixel(x=>0, 'y'=>0, color=>$red);
+ $im->setpixel(x=>1, 'y'=>0, color=>$blue);
+
+ my @row = Imager::i_glin($im->{IMG}, 0, 2, 0);
+ is(@row, 2, "got 2 pixels from i_glin");
+ is_color3($row[0], 255, 0, 0, "red first");
+ is_color3($row[1], 0, 0, 255, "then blue");
+}
+
+{ # general tag tests
+
+ # we don't care much about the image itself
+ my $im = Imager::ImgRaw::new(10, 10, 1);
+
+ ok(Imager::i_tags_addn($im, 'alpha', 0, 101), "i_tags_addn(...alpha, 0, 101)");
+ ok(Imager::i_tags_addn($im, undef, 99, 102), "i_tags_addn(...undef, 99, 102)");
+ is(Imager::i_tags_count($im), 2, "should have 2 tags");
+ ok(Imager::i_tags_addn($im, undef, 99, 103), "i_tags_addn(...undef, 99, 103)");
+ is(Imager::i_tags_count($im), 3, "should have 3 tags, despite the dupe");
+ is(Imager::i_tags_find($im, 'alpha', 0), '0 but true', "find alpha");
+ is(Imager::i_tags_findn($im, 99, 0), 1, "find 99");
+ is(Imager::i_tags_findn($im, 99, 2), 2, "find 99 again");
+ is(Imager::i_tags_get($im, 0), 101, "check first");
+ is(Imager::i_tags_get($im, 1), 102, "check second");
+ is(Imager::i_tags_get($im, 2), 103, "check third");
+
+ ok(Imager::i_tags_add($im, 'beta', 0, "hello", 0),
+ "add string with string key");
+ ok(Imager::i_tags_add($im, 'gamma', 0, "goodbye", 0),
+ "add another one");
+ ok(Imager::i_tags_add($im, undef, 199, "aloha", 0),
+ "add one keyed by number");
+ is(Imager::i_tags_find($im, 'beta', 0), 3, "find beta");
+ is(Imager::i_tags_find($im, 'gamma', 0), 4, "find gamma");
+ is(Imager::i_tags_findn($im, 199, 0), 5, "find 199");
+ ok(Imager::i_tags_delete($im, 2), "delete");
+ is(Imager::i_tags_find($im, 'beta', 0), 2, 'find beta after deletion');
+ ok(Imager::i_tags_delbyname($im, 'beta'), 'delete beta by name');
+ is(Imager::i_tags_find($im, 'beta', 0), undef, 'beta not there now');
+ is(Imager::i_tags_get_string($im, "gamma"), "goodbye",
+ 'i_tags_get_string() on a string');
+ is(Imager::i_tags_get_string($im, 99), 102,
+ 'i_tags_get_string() on a number entry');
+ ok(Imager::i_tags_delbycode($im, 99), 'delete by code');
+ is(Imager::i_tags_findn($im, 99, 0), undef, '99 not there now');
+ is(Imager::i_tags_count($im), 3, 'final count of 3');
+}
+
+{
+ print "# low-level scan line function tests\n";
+ my $im = Imager::ImgRaw::new(10, 10, 4);
+ Imager::i_ppix($im, 5, 0, $red);
+
+ # i_glin/i_glinf
+ my @colors = Imager::i_glin($im, 0, 10, 0);
+ is_deeply([ (0) x 20, (255, 0, 0, 255), (0) x 16 ],
+ [ map $_->rgba, @colors ],
+ "i_glin - list context");
+ my $colors = Imager::i_glin($im, 0, 10, 0);
+ is("00" x 20 . "FF0000FF" . "00" x 16,
+ uc unpack("H*", $colors), "i_glin - scalar context");
+ my @fcolors = Imager::i_glinf($im, 0, 10, 0);
+ is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
+ [ map $_->rgba, @fcolors ],
+ "i_glinf - list context");
+ my $fcolors = Imager::i_glinf($im, 0, 10, 0);
+ is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
+ [ unpack "d*", $fcolors ],
+ "i_glinf - scalar context");
+
+ # i_plin/i_plinf
+ my @plin_colors = (($black) x 4, $red, $blue, ($black) x 4);
+ is(Imager::i_plin($im, 0, 1, @plin_colors),
+ 10, "i_plin - pass in a list");
+ # make sure we get it back
+ is_deeply([ map [ $_->rgba ], @plin_colors ],
+ [ map [ $_->rgba ], Imager::i_glin($im, 0, 10, 1) ],
+ "check i_plin wrote to the image");
+ my @scalar_plin =
+ (
+ (0,0,0,0) x 4,
+ (0, 255, 0, 255),
+ (0, 0, 255, 255),
+ (0, 0, 0, 0) x 4,
+ );
+ is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)),
+ 10, "i_plin - pass in a scalar");
+ is_deeply(\@scalar_plin,
+ [ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ],
+ "check i_plin scalar wrote to the image");
+
+ my @plinf_colors = # Note: only 9 pixels
+ (
+ ($f_blue) x 4,
+ $f_red,
+ ($f_black) x 3,
+ $f_black
+ );
+ is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9,
+ "i_plinf - list");
+ is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ],
+ [ map $_->rgba, @plinf_colors ],
+ "check colors were written");
+ my @scalar_plinf =
+ (
+ ( 1.0, 1.0, 0, 1.0 ) x 3,
+ ( 0, 1.0, 1.0, 1.0 ) x 2,
+ ( 0, 0, 0, 0 ),
+ ( 1.0, 0, 1.0, 1.0 ),
+ );
+ is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)),
+ 7, "i_plinf - scalar");
+ is_deeply(\@scalar_plinf,
+ [ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ],
+ "check colors were written");
+
+ is_deeply([ Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ]) ],
+ [ (0, 0) x 5, (255, 255), (0, 0) x 4 ],
+ "i_gsamp list context");
+ is("0000" x 5 . "FFFF" . "0000" x 4,
+ uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ])),
+ "i_gsamp scalar context");
+ is_deeply([ Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ]) ],
+ [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
+ (1.0, 1.0, 1.0) ], "i_gsampf - list context");
+ is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ])) ],
+ [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
+ (1.0, 1.0, 1.0) ], "i_gsampf - scalar context");
+ print "# end low-level scan-line function tests\n";
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+ print "# psamp\n";
+ my $imraw = Imager::ImgRaw::new(10, 20, 3);
+ {
+ is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+ "i_psamp def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+ "i_psamp def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+ "check color written");
+ is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+ "i_psamp channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+ "i_psamp channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 63, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+ 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+ is(Imager::i_psamp($imraw, 4, 6, undef, [ 0 .. 18 ], 1), 18,
+ "psamp with offset");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
+ [ (0) x 12, 1 .. 18 ],
+ "check result");
+ is(Imager::i_psamp($imraw, 4, 11, undef, [ 0 .. 18 ], 1, 3), 9,
+ "psamp with offset and width");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
+ [ (0) x 12, 1 .. 9, (0) x 9 ],
+ "check result");
+ }
+ { # errors we catch
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psamp($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ }
+ { # test the im_sample_list typemap
+ ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], undef); 1 },
+ "pass undef as the sample list");
+ like($@, qr/data must be a scalar or an arrayref/,
+ "check message");
+ ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
+ "hashref as the sample list");
+ like($@, qr/data must be a scalar or an arrayref/,
+ "check message");
+ ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], []); 1 },
+ "empty sample list");
+ like($@, qr/i_psamp: no samples provided in data/,
+ "check message");
+ ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], ""); 1 },
+ "empty scalar sample list");
+ like($@, qr/i_psamp: no samples provided in data/,
+ "check message");
+
+ # not the typemap
+ is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
+ "negative offset");
+ is(_get_error(), "offset must be non-negative",
+ "check message");
+
+ is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
+ "too high offset");
+ is(_get_error(), "offset greater than number of samples supplied",
+ "check message");
+ }
+ print "# end psamp tests\n";
+}
+
+{ # psampf
+ print "# psampf\n";
+ my $imraw = Imager::ImgRaw::new(10, 20, 3);
+ {
+ is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+ "i_psampf def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+ "check color written");
+ is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+ "i_psampf channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 64, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+ 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+ is(Imager::i_psampf($imraw, 4, 6, undef, [ map $_/254.9, 0 .. 18 ], 1), 18,
+ "psampf with offset");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
+ [ (0) x 12, 1 .. 18 ],
+ "check result");
+ is(Imager::i_psampf($imraw, 4, 11, undef, [ map $_/254.9, 0 .. 18 ], 1, 3), 9,
+ "psampf with offset and width");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
+ [ (0) x 12, 1 .. 9, (0) x 9 ],
+ "check result");
+ }
+ { # errors we catch
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psampf($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ }
+ { # test the im_fsample_list typemap
+ ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], undef); 1 },
+ "pass undef as the sample list");
+ like($@, qr/data must be a scalar or an arrayref/,
+ "check message");
+ ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
+ "hashref as the sample list");
+ like($@, qr/data must be a scalar or an arrayref/,
+ "check message");
+ ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], []); 1 },
+ "empty sample list");
+ like($@, qr/i_psampf: no samples provided in data/,
+ "check message");
+ ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], ""); 1 },
+ "empty scalar sample list");
+ like($@, qr/i_psampf: no samples provided in data/,
+ "check message");
+
+ # not the typemap
+ is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
+ "negative offset");
+ is(_get_error(), "offset must be non-negative",
+ "check message");
+
+ is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
+ "too high offset");
+ is(_get_error(), "offset greater than number of samples supplied",
+ "check message");
+ }
+ print "# end psampf tests\n";
+}
+
+{
+ print "# OO level scanline function tests\n";
+ my $im = Imager->new(xsize=>10, ysize=>10, channels=>4);
+ $im->setpixel(color=>$red, 'x'=>5, 'y'=>0);
+ ok(!$im->getscanline(), "getscanline() - supply nothing, get nothing");
+ is($im->errstr, "missing y parameter", "check message");
+ is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0) ],
+ [ ([ 0,0,0,0]) x 5, [ 255, 0, 0, 255 ], ([ 0,0,0,0]) x 4 ],
+ "getscanline, list context, default x, width");
+ is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>3) ],
+ [ ([0,0,0,0]) x 2, [ 255, 0, 0, 255 ], ([0,0,0,0]) x 4 ],
+ "getscanline, list context, default width");
+ is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>4, width=>4) ],
+ [ [0,0,0,0], [ 255, 0, 0, 255 ], ([0,0,0,0]) x 2 ],
+ "getscanline, list context, no defaults");
+ is(uc unpack("H*", $im->getscanline('y'=>0)),
+ "00000000" x 5 . "FF0000FF" . "00000000" x 4,
+ "getscanline, scalar context, default x, width");
+ is_deeply([ map [ $_->rgba ],
+ $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
+ [ [0,0,0,0], [ 1.0, 0, 0, 1.0 ], ([0,0,0,0]) x 2 ],
+ "getscanline float, list context, no defaults");
+ is_deeply([ unpack "d*",
+ $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
+ [ (0,0,0,0), ( 1.0, 0, 0, 1.0 ), (0,0,0,0) x 2 ],
+ "getscanline float, scalar context, no defaults");
+
+ ok(!$im->getscanline('y'=>0, type=>'invalid'),
+ "check invalid type checking");
+ like($im->errstr, qr/invalid type parameter/,
+ "check message for invalid type");
+
+ my @plin_colors = (($black) x 4, $red, $blue, ($green) x 4);
+ is($im->setscanline('y'=>1, pixels=>\@plin_colors), 10,
+ "setscanline - arrayref, default x");
+ is_deeply([ map [ $_->rgba ], @plin_colors ],
+ [ map [ $_->rgba ], $im->getscanline('y'=>1) ],
+ "check colors were written");
+
+ my @plin_colors2 = ( $green, $red, $blue, $red );
+ is($im->setscanline('y'=>2, 'x'=>3, pixels=>\@plin_colors2), 4,
+ "setscanline - arrayref");
+
+ # using map instead of x here due to a bug in some versions of Test::More
+ # fixed in the latest Test::More
+ is_deeply([ ( map [ 0,0,0,0 ], 1..3), (map [ $_->rgba ], @plin_colors2),
+ ( map [ 0,0,0,0 ], 1..3) ],
+ [ map [ $_->rgba ], $im->getscanline('y'=>2) ],
+ "check write to middle of line");
+
+ my $raw_colors = pack "H*", "FF00FFFF"."FF0000FF"."FFFFFFFF";
+ is($im->setscanline('y'=>3, 'x'=>2, pixels=>$raw_colors), 3,
+ "setscanline - scalar, default raw type")
+ or print "# ",$im->errstr,"\n";
+ is(uc unpack("H*", $im->getscanline('y'=>3, 'x'=>1, 'width'=>5)),
+ "00000000".uc(unpack "H*", $raw_colors)."00000000",
+ "check write");
+
+ # float colors
+ my @fcolors = ( $f_red, $f_blue, $f_black, $f_green );
+ is($im->setscanline('y'=>4, 'x'=>3, pixels=>\@fcolors), 4,
+ "setscanline - float arrayref");
+ is_deeply([ map [ $_->rgba ], @fcolors ],
+ [ map [ $_->rgba ], $im->getscanline('y'=>4, 'x'=>3, width=>4, type=>'float') ],
+ "check write");
+ # packed
+ my $packed_fcolors = pack "d*", map $_->rgba, @fcolors;
+ is($im->setscanline('y'=>5, 'x'=>4, pixels=>$packed_fcolors, type=>'float'), 4,
+ "setscanline - float scalar");
+ is_deeply([ map [ $_->rgba ], @fcolors ],
+ [ map [ $_->rgba ], $im->getscanline('y'=>5, 'x'=>4, width=>4, type=>'float') ],
+ "check write");
+
+ # get samples
+ is_deeply([ $im->getsamples('y'=>1, channels=>[ 0 ]) ],
+ [ map +($_->rgba)[0], @plin_colors ],
+ "get channel 0, list context, default x, width");
+ is_deeply([ unpack "C*", $im->getsamples('y'=>1, channels=>[0, 2]) ],
+ [ map { ($_->rgba)[0, 2] } @plin_colors ],
+ "get channel 0, 1, scalar context");
+ is_deeply([ $im->getsamples('y'=>4, 'x'=>3, width=>4, type=>'float',
+ channels=>[1,3]) ],
+ [ map { ($_->rgba)[1,3] } @fcolors ],
+ "get channels 1,3, list context, float samples");
+ is_deeply([ unpack "d*",
+ $im->getsamples('y'=>4, 'x'=>3, width=>4,
+ type=>'float', channels=>[3,2,1,0]) ],
+ [ map { ($_->rgba)[3,2,1,0] } @fcolors ],
+ "get channels 3..0 as scalar, float samples");
+
+ print "# end OO level scanline function tests\n";
+}
+
+{ # RT 74882
+ # for the non-gsamp_bits case with a target parameter it was
+ # treating the target parameter as a hashref
+ {
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ my $c1 = NC(0, 63, 255);
+ my $c2 = NC(255, 128, 255);
+ is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
+ 10, "set some test data")
+ or diag "setscanline: ", $im->errstr;
+ my @target;
+ is($im->getsamples(y => 1, x => 1, target => \@target, width => 3),
+ 9, "getsamples to target");
+ is_deeply(\@target, [ 255, 128, 255, 0, 63, 255, 255, 128, 255 ],
+ "check result");
+ }
+ {
+ my $im = Imager->new(xsize => 10, ysize => 10, bits => "double");
+ my $c1 = NCF(0, 0.25, 1.0);
+ my $c2 = NCF(1.0, 0.5, 1.0);
+ is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
+ 10, "set some test data")
+ or diag "setscanline: ", $im->errstr;
+ my @target;
+ is($im->getsamples(y => 1, x => 1, target => \@target, width => 3, type => "float"),
+ 9, "getsamples to target");
+ is_deeply(\@target, [ 1.0, 0.5, 1.0, 0, 0.25, 1.0, 1.0, 0.5, 1.0 ],
+ "check result");
+ }
+}
+
+{ # to avoid confusion, i_glin/i_glinf modified to return 0 in unused
+ # channels at the perl level
+ my $im = Imager->new(xsize => 4, ysize => 4, channels => 2);
+ my $fill = Imager::Color->new(128, 255, 0, 0);
+ ok($im->box(filled => 1, color => $fill), 'fill it up');
+ my $data = $im->getscanline('y' => 0);
+ is(unpack("H*", $data), "80ff000080ff000080ff000080ff0000",
+ "check we get zeros");
+ my @colors = $im->getscanline('y' => 0);
+ is_color4($colors[0], 128, 255, 0, 0, "check object interface[0]");
+ is_color4($colors[1], 128, 255, 0, 0, "check object interface[1]");
+ is_color4($colors[2], 128, 255, 0, 0, "check object interface[2]");
+ is_color4($colors[3], 128, 255, 0, 0, "check object interface[3]");
+
+ my $dataf = $im->getscanline('y' => 0, type => 'float');
+ # the extra pack/unpack is to force double precision rather than long
+ # double, otherwise the test fails
+ is_deeply([ unpack("d*", $dataf) ],
+ [ unpack("d*", pack("d*", ( 128.0 / 255.0, 1.0, 0, 0, ) x 4)) ],
+ "check we get zeroes (double)");
+ my @fcolors = $im->getscanline('y' => 0, type => 'float');
+ is_fcolor4($fcolors[0], 128.0/255.0, 1.0, 0, 0, "check object interface[0]");
+ is_fcolor4($fcolors[1], 128.0/255.0, 1.0, 0, 0, "check object interface[1]");
+ is_fcolor4($fcolors[2], 128.0/255.0, 1.0, 0, 0, "check object interface[2]");
+ is_fcolor4($fcolors[3], 128.0/255.0, 1.0, 0, 0, "check object interface[3]");
+}
+
+{ # check the channel mask function
+
+ my $im = Imager->new(xsize => 10, ysize=>10, bits=>8);
+
+ mask_tests($im, 0.005);
+}
+
+{ # check bounds checking
+ my $im = Imager->new(xsize => 10, ysize => 10);
+
+ image_bounds_checks($im);
+}
+
+{ # setsamples() interface to psamp()
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ is($im->setsamples(y => 1, x => 2, data => [ 1 .. 6 ]), 6,
+ "simple put (array), default channels");
+ is_deeply([ $im->getsamples(y => 1, x => 0) ],
+ [ (0) x 6, 1 .. 6, (0) x 18 ], "check they were stored");
+ is($im->setsamples(y => 3, x => 3, data => pack("C*", 2 .. 10 )), 9,
+ "simple put (scalar), default channels")
+ or diag $im->errstr;
+ is_deeply([ $im->getsamples(y => 3, x => 0) ],
+ [ (0) x 9, 2 .. 10, (0) x 12 ], "check they were stored");
+ is($im->setsamples(y => 4, x => 4, data => [ map $_ / 254.5, 1 .. 6 ], type => 'float'),
+ 6, "simple put (float array), default channels");
+ is_deeply([ $im->getsamples(y => 4, x => 0) ],
+ [ (0) x 12, 1 .. 6, (0) x 12 ], "check they were stored");
+
+ is($im->setsamples(y => 5, x => 3, data => pack("d*", map $_ / 254.5, 1 .. 6), type => 'float'),
+ 6, "simple put (float scalar), default channels");
+ is_deeply([ $im->getsamples(y => 5, x => 0) ],
+ [ (0) x 9, 1 .. 6, (0) x 15 ], "check they were stored");
+
+ is($im->setsamples(y => 7, x => 3, data => [ 0 .. 18 ], offset => 1), 18,
+ "setsamples offset");
+ is_deeply([ $im->getsamples(y => 7) ],
+ [ (0) x 9, 1 .. 18, (0) x 3 ],
+ "check result");
+
+ is($im->setsamples(y => 8, x => 3, data => [ map $_ / 254.9, 0 .. 18 ],
+ offset => 1, type => 'float'),
+ 18, "setsamples offset (float)");
+ is_deeply([ $im->getsamples(y => 8) ],
+ [ (0) x 9, 1 .. 18, (0) x 3 ],
+ "check result");
+
+ is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ]) ],
+ [], "check out of range result (8bit)");
+ is($im->errstr, $psamp_outside_error, "check error message");
+
+ is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ], type => "float") ],
+ [], "check out of range result (float)");
+ is($im->errstr, $psamp_outside_error, "check error message");
+
+ is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
+ data => [ (0) x 3 ]) ],
+ [], "check bad channels (8bit)");
+ is($im->errstr, "No channel 3 in this image",
+ "check error message");
+
+ is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
+ data => [ (0) x 3 ], type => "float") ],
+ [], "check bad channels (float)");
+ is($im->errstr, "No channel 3 in this image",
+ "check error message");
+
+ is($im->setsamples(y => 5, data => [ (0) x 3 ], type => "bad"),
+ undef, "setsamples with bad type");
+ is($im->errstr, "setsamples: type parameter invalid",
+ "check error message");
+ is($im->setsamples(y => 5),
+ undef, "setsamples with no data");
+ is($im->errstr, "setsamples: data parameter missing",
+ "check error message");
+
+ is($im->setsamples(y => 5, data => undef),
+ undef, "setsamples with undef data");
+ is($im->errstr, "setsamples: data parameter not defined",
+ "check error message");
+
+ my $imempty = Imager->new;
+ is($imempty->setsamples(y => 0, data => [ (0) x 3 ]), undef,
+ "setsamples to empty image");
+ is($imempty->errstr, "setsamples: empty input image",
+ "check error message");
+}
+
+{ # getpixel parameters
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ $im->box(filled => 1, xmax => 4, color => NC(255, 0, 0));
+ $im->box(filled => 1, xmin => 5, ymax => 4, color => NC(0, 255, 255));
+ $im->box(filled => 1, xmin => 5, ymin => 5, color => NC(255, 0, 255));
+ { # error handling
+ my $empty = Imager->new;
+ ok(!$empty->getpixel(x => 0, y => 0), "getpixel empty image");
+ is($empty->errstr, "getpixel: empty input image", "check message");
+
+ ok(!$im->getpixel(y => 0), "missing x");
+ is($im->errstr, "getpixel: missing x or y parameter", "check message");
+
+ $im->_set_error("something different");
+ ok(!$im->getpixel(x => 0), "missing y");
+ is($im->errstr, "getpixel: missing x or y parameter", "check message");
+
+ ok(!$im->getpixel(x => [], y => 0), "empty x array ref");
+ is($im->errstr, "getpixel: x is a reference to an empty array",
+ "check message");
+
+ ok(!$im->getpixel(x => 0, y => []), "empty y array ref");
+ is($im->errstr, "getpixel: y is a reference to an empty array",
+ "check message");
+
+ ok(!$im->getpixel(x => 0, y => 0, type => "bad"), "bad type (scalar path)");
+ is($im->errstr, "getpixel: type must be '8bit' or 'float'",
+ "check message");
+
+ $im->_set_error("something different");
+ ok(!$im->getpixel(x => [ 0 ], y => [ 0 ], type => "bad"),
+ "bad type (array path)");
+ is($im->errstr, "getpixel: type must be '8bit' or 'float'",
+ "check message");
+ }
+
+ # simple calls
+ is_color3($im->getpixel(x => 1, y => 0), 255, 0, 0,
+ "getpixel(1, 0)");
+ is_color3($im->getpixel(x => 8, y => 1), 0, 255, 255,
+ "getpixel(8, 1)");
+ is_color3($im->getpixel(x => 8, y => 7), 255, 0, 255,
+ "getpixel(8, 7)");
+
+ {
+ # simple arrayrefs
+ my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ]);
+ is(@colors, 3, "getpixel 2 3 element array refs");
+ is_color3($colors[0], 255, 0, 0, "check first color");
+ is_color3($colors[1], 255, 0, 255, "check second color");
+ is_color3($colors[2], 0, 255, 255, "check third color");
+ }
+
+ # array and scalar
+ {
+ my @colors = $im->getpixel(x => 5, y => [ 4, 5, 9 ]);
+ is(@colors, 3, "getpixel x scalar, y arrayref of 3");
+ is_color3($colors[0], 0, 255, 255, "check first color");
+ is_color3($colors[1], 255, 0, 255, "check second color");
+ is_color3($colors[2], 255, 0, 255, "check third color");
+ }
+
+ {
+ my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => 2);
+ is(@colors, 3, "getpixel y scalar, x arrayref of 3");
+ is_color3($colors[0], 255, 0, 0, "check first color");
+ is_color3($colors[1], 255, 0, 0, "check second color");
+ is_color3($colors[2], 0, 255, 255, "check third color");
+ }
+
+ { # float
+ is_fcolor3($im->getpixel(x => 1, y => 0, type => 'float'),
+ 1.0, 0, 0, "getpixel(1,0) float");
+ is_fcolor3($im->getpixel(x => 8, y => 1, type => 'float'),
+ 0, 1.0, 1.0, "getpixel(8,1) float");
+ is_fcolor3($im->getpixel(x => 8, y => 7, type => 'float'),
+ 1.0, 0, 1.0, "getpixel(8,7) float");
+
+ my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], type => 'float');
+ is(@colors, 3, "getpixel 2 3 element array refs (float)");
+ is_fcolor3($colors[0], 1, 0, 0, "check first color");
+ is_fcolor3($colors[1], 1, 0, 1, "check second color");
+ is_fcolor3($colors[2], 0, 1, 1, "check third color");
+ }
+
+ { # out of bounds
+ my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0);
+ is(@colors, 4, "should be 4 entries")
+ or diag $im->errstr;
+ is_color3($colors[0], 255, 0, 0, "first red");
+ is($colors[1], undef, "second undef");
+ is_color3($colors[2], 0, 255, 255, "third cyan");
+ is($colors[3], undef, "fourth undef");
+ }
+
+ { # out of bounds
+ my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0, type => "float");
+ is(@colors, 4, "should be 4 entries")
+ or diag $im->errstr;
+ is_fcolor3($colors[0], 1.0, 0, 0, "first red");
+ is($colors[1], undef, "second undef");
+ is_fcolor3($colors[2], 0, 1.0, 1.0, "third cyan");
+ is($colors[3], undef, "fourth undef");
+ }
+}
+
+{ # setpixel
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ { # errors
+ my $empty = Imager->new;
+ ok(!$empty->setpixel(x => 0, y => 0, color => $red),
+ "setpixel on empty image");
+ is($empty->errstr, "setpixel: empty input image", "check message");
+
+ ok(!$im->setpixel(y => 0, color => $red), "missing x");
+ is($im->errstr, "setpixel: missing x or y parameter", "check message");
+
+ $im->_set_error("something different");
+ ok(!$im->setpixel(x => 0, color => $red), "missing y");
+ is($im->errstr, "setpixel: missing x or y parameter", "check message");
+
+ ok(!$im->setpixel(x => [], y => 0, color => $red), "empty x array ref");
+ is($im->errstr, "setpixel: x is a reference to an empty array",
+ "check message");
+
+ ok(!$im->setpixel(x => 0, y => [], color => $red), "empty y array ref");
+ is($im->errstr, "setpixel: y is a reference to an empty array",
+ "check message");
+
+ ok(!$im->setpixel(x => 0, y => 0, color => "not really a color"),
+ "color not a color");
+ is($im->errstr, "setpixel: No color named not really a color found",
+ "check message");
+ }
+
+ # simple set
+ is($im->setpixel(x => 0, y => 0, color => $red), $im,
+ "simple setpixel")
+ or diag "simple set float: ", $im->errstr;
+ is_color3($im->getpixel(x => 0, y => 0), 255, 0, 0, "check stored pixel");
+
+ is($im->setpixel(x => 1, y => 2, color => $f_red), $im,
+ "simple setpixel (float)")
+ or diag "simple set float: ", $im->errstr;
+ is_color3($im->getpixel(x => 1, y => 2), 255, 0, 0, "check stored pixel");
+
+ is($im->setpixel(x => -1, y => 0, color => $red), undef,
+ "simple setpixel outside of image");
+ is($im->setpixel(x => 0, y => -1, color => $f_red), undef,
+ "simple setpixel (float) outside of image");
+
+ # simple arrayrefs
+ is($im->setpixel( x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], color => $blue),
+ 3, "setpixel with 3 element array refs");
+ my @colors = $im->getpixel(x => [ 8, 7, 0 ], y => [ 7, 3, 0 ]);
+ is_color3($colors[0], 0, 0, 255, "check first color");
+ is_color3($colors[1], 0, 0, 255, "check second color");
+ is_color3($colors[2], 0, 0, 255, "check third color");
+
+ # array and scalar
+ {
+ is($im->setpixel(x => 5, y => [ 4, 5, 9 ], color => $green), 3,
+ "setpixel with x scalar, y arrayref of 3");
+ my @colors = $im->getpixel(x => [ 5, 5, 5 ], y => [ 4, 5, 9 ]);
+ is_color3($colors[0], 0, 255, 0, "check first color");
+ is_color3($colors[1], 0, 255, 0, "check second color");
+ is_color3($colors[2], 0, 255, 0, "check third color");
+ }
+
+ {
+ is($im->setpixel(x => [ 0, 4, 5 ], y => 2, color => $blue), 3,
+ "setpixel with y scalar, x arrayref of 3");
+ my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => [ 2, 2, 2 ]);
+ is_color3($colors[0], 0, 0, 255, "check first color");
+ is_color3($colors[1], 0, 0, 255, "check second color");
+ is_color3($colors[2], 0, 0, 255, "check third color");
+ }
+
+ {
+ is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $blue), 3,
+ "set array with two bad locations")
+ or diag "set array bad locations: ", $im->errstr;
+ my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
+ is_color3($colors[0], 0, 0, 255, "check first color");
+ is_color3($colors[1], 0, 0, 255, "check second color");
+ is_color3($colors[2], 0, 0, 255, "check third color");
+ }
+ {
+ is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $f_green), 3,
+ "set array with two bad locations (float)")
+ or diag "set array bad locations (float): ", $im->errstr;
+ my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
+ is_color3($colors[0], 0, 255, 0, "check first color");
+ is_color3($colors[1], 0, 255, 0, "check second color");
+ is_color3($colors[2], 0, 255, 0, "check third color");
+ }
+ { # default color
+ is($im->setpixel(x => 0, y => 9), $im, "setpixel() default color")
+ or diag "setpixel default color: ", $im->errstr;
+ is_color3($im->getpixel(x => 0, y => 9), 255, 255, 255,
+ "check color set");
+ }
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->addtag(name => "foo", value => 1),
+ "can't addtag on an empty image");
+ is($empty->errstr, "addtag: empty input image",
+ "check error message");
+ ok(!$empty->settag(name => "foo", value => 1),
+ "can't settag on an empty image");
+ is($empty->errstr, "settag: empty input image",
+ "check error message");
+ ok(!$empty->deltag(name => "foo"), "can't deltag on an empty image");
+ is($empty->errstr, "deltag: empty input image",
+ "check error message");
+ ok(!$empty->tags(name => "foo"), "can't tags on an empty image");
+ is($empty->errstr, "tags: empty input image",
+ "check error message");
+}
+
+Imager->close_log();
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t01introvert.log";
+}
+
+sub check_add {
+ my ($im, $color, $expected) = @_;
+ my $index = Imager::i_addcolors($im, $color);
+ ok($index, "got index");
+ print "# $index\n";
+ is(0+$index, $expected, "index matched expected");
+ my ($new) = Imager::i_getcolors($im, $index);
+ ok($new, "got the color");
+ ok(color_cmp($new, $color) == 0, "color matched what was added");
+
+ $index;
+}
+
+# sub array_ncmp {
+# my ($a1, $a2) = @_;
+# my $len = @$a1 < @$a2 ? @$a1 : @$a2;
+# for my $i (0..$len-1) {
+# my $diff = $a1->[$i] <=> $a2->[$i]
+# and return $diff;
+# }
+# return @$a1 <=> @$a2;
+# }
+
+sub dump_colors {
+ for my $col (@_) {
+ print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
+ }
+}
+
+sub _get_error {
+ my @errors = Imager::i_errors();
+ return join(": ", map $_->[0], @errors);
+}
--- /dev/null
+#!perl -w
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+use Test::More tests => 70;
+
+use Imager;
+use Imager::Test qw(is_fcolor4);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t15color.log");
+
+my $c1 = Imager::Color->new(100, 150, 200, 250);
+ok(test_col($c1, 100, 150, 200, 250), 'simple 4-arg');
+my $c2 = Imager::Color->new(100, 150, 200);
+ok(test_col($c2, 100, 150, 200, 255), 'simple 3-arg');
+my $c3 = Imager::Color->new("#6496C8");
+ok(test_col($c3, 100, 150, 200, 255), 'web color');
+# crashes in Imager-0.38pre8 and earlier
+my @foo;
+for (1..1000) {
+ push(@foo, Imager::Color->new("#FFFFFF"));
+}
+my $fail;
+for (@foo) {
+ Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
+ Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
+ test_col($_, 128, 128, 128, 128) or ++$fail;
+}
+ok(!$fail, 'consitency check');
+
+# test the new OO methods
+color_ok('r g b',, 100, 150, 200, 255, Imager::Color->new(r=>100, g=>150, b=>200));
+color_ok('red green blue', 101, 151, 201, 255,
+ Imager::Color->new(red=>101, green=>151, blue=>201));
+color_ok('grey', 102, 255, 255, 255, Imager::Color->new(grey=>102));
+color_ok('gray', 103, 255, 255, 255, Imager::Color->new(gray=>103));
+SKIP:
+{
+ skip "no X rgb.txt found", 1
+ unless grep -r, Imager::Color::_test_x_palettes();
+ color_ok('xname', 0, 0, 255, 255, Imager::Color->new(xname=>'blue'));
+}
+color_ok('gimp', 255, 250, 250, 255,
+ Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal'));
+color_ok('h s v', 255, 255, 255, 255, Imager::Color->new(h=>0, 's'=>0, 'v'=>1.0));
+color_ok('h s v again', 255, 0, 0, 255, Imager::Color->new(h=>0, 's'=>1, v=>1));
+color_ok('web 6 digit', 128, 129, 130, 255, Imager::Color->new(web=>'#808182'));
+color_ok('web 3 digit', 0x11, 0x22, 0x33, 255, Imager::Color->new(web=>'#123'));
+color_ok('rgb arrayref', 255, 150, 121, 255, Imager::Color->new(rgb=>[ 255, 150, 121 ]));
+color_ok('rgba arrayref', 255, 150, 121, 128,
+ Imager::Color->new(rgba=>[ 255, 150, 121, 128 ]));
+color_ok('hsv arrayref', 255, 0, 0, 255, Imager::Color->new(hsv=>[ 0, 1, 1 ]));
+color_ok('channel0-3', 129, 130, 131, 134,
+ Imager::Color->new(channel0=>129, channel1=>130, channel2=>131,
+ channel3=>134));
+color_ok('c0-3', 129, 130, 131, 134,
+ Imager::Color->new(c0=>129, c1=>130, c2=>131, c3=>134));
+color_ok('channels arrayref', 200, 201, 203, 204,
+ Imager::Color->new(channels=>[ 200, 201, 203, 204 ]));
+color_ok('name', 255, 250, 250, 255,
+ Imager::Color->new(name=>'snow', palette=>'testimg/test_gimp_pal'));
+
+# test the internal HSV <=> RGB conversions
+# these values were generated using the GIMP
+# all but hue is 0..360, saturation and value from 0 to 1
+# rgb from 0 to 255
+my @hsv_vs_rgb =
+ (
+ { hsv => [ 0, 0.2, 0.1 ], rgb=> [ 25, 20, 20 ] },
+ { hsv => [ 0, 0.5, 1.0 ], rgb => [ 255, 127, 127 ] },
+ { hsv => [ 100, 0.5, 1.0 ], rgb => [ 170, 255, 127 ] },
+ { hsv => [ 100, 1.0, 1.0 ], rgb=> [ 85, 255, 0 ] },
+ { hsv => [ 335, 0.5, 0.5 ], rgb=> [127, 63, 90 ] },
+ );
+
+use Imager::Color::Float;
+my $test_num = 23;
+my $index = 0;
+for my $entry (@hsv_vs_rgb) {
+ print "# color index $index\n";
+ my $hsv = $entry->{hsv};
+ my $rgb = $entry->{rgb};
+ my $fhsvo = Imager::Color::Float->new($hsv->[0]/360.0, $hsv->[1], $hsv->[2]);
+ my $fc = Imager::Color::Float::i_hsv_to_rgb($fhsvo);
+ fcolor_close_enough("i_hsv_to_rgbf $index", $rgb->[0]/255, $rgb->[1]/255,
+ $rgb->[2]/255, $fc);
+ my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
+ fcolor_close_enough("i_rgbf_to_hsv $index", $hsv->[0]/360.0, $hsv->[1], $hsv->[2],
+ $fc2);
+
+ my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255,
+ $hsv->[2] * 255);
+ my $c = Imager::Color::i_hsv_to_rgb($hsvo);
+ color_close_enough("i_hsv_to_rgb $index", @$rgb, $c);
+ my $c2 = Imager::Color::i_rgb_to_hsv($c);
+ color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255,
+ $hsv->[2] * 255, $c2);
+ ++$index;
+}
+
+# check the built-ins table
+color_ok('builtin black', 0, 0, 0, 255,
+ Imager::Color->new(builtin=>'black'));
+
+{
+ my $c1 = Imager::Color->new(255, 255, 255, 0);
+ my $c2 = Imager::Color->new(255, 255, 255, 255);
+ ok(!$c1->equals(other=>$c2), "not equal no ignore alpha");
+ ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)),
+ "equal with ignore alpha");
+ ok($c1->equals(other=>$c1), "equal to itself");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=13143
+ # Imager::Color->new(color_name) warning if HOME environment variable not set
+ local $ENV{HOME};
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, "@_" };
+
+ # presumably no-one will name a color like this.
+ my $c1 = Imager::Color->new(gimp=>"ABCDEFGHIJKLMNOP");
+ is(@warnings, 0, "Should be no warnings")
+ or do { print "# $_" for @warnings };
+}
+
+{
+ # float color from hex triple
+ my $f3white = Imager::Color::Float->new("#FFFFFF");
+ is_fcolor4($f3white, 1.0, 1.0, 1.0, 1.0, "check color #FFFFFF");
+ my $f3black = Imager::Color::Float->new("#000000");
+ is_fcolor4($f3black, 0, 0, 0, 1.0, "check color #000000");
+ my $f3grey = Imager::Color::Float->new("#808080");
+ is_fcolor4($f3grey, 0x80/0xff, 0x80/0xff, 0x80/0xff, 1.0, "check color #808080");
+
+ my $f4white = Imager::Color::Float->new("#FFFFFF80");
+ is_fcolor4($f4white, 1.0, 1.0, 1.0, 0x80/0xff, "check color #FFFFFF80");
+}
+
+{
+ # fail to make a color
+ ok(!Imager::Color::Float->new("-unknown-"), "try to make float color -unknown-");
+}
+
+{
+ # set after creation
+ my $c = Imager::Color::Float->new(0, 0, 0);
+ is_fcolor4($c, 0, 0, 0, 1.0, "check simple init of float color");
+ ok($c->set(1.0, 0.5, 0.25, 1.0), "set() the color");
+ is_fcolor4($c, 1.0, 0.5, 0.25, 1.0, "check after set");
+
+ ok(!$c->set("-unknown-"), "set to unknown");
+}
+
+{
+ # test ->hsv
+ my $c = Imager::Color->new(255, 0, 0);
+ my($h,$s,$v) = $c->hsv;
+ is($h,0,'red hue');
+ is($s,1,'red saturation');
+ is($v,1,'red value');
+
+ $c = Imager::Color->new(0, 255, 0);
+ ($h,$s,$v) = $c->hsv;
+ is($h,120,'green hue');
+ is($s,1,'green saturation');
+ is($v,1,'green value');
+
+ $c = Imager::Color->new(0, 0, 255);
+ ($h,$s,$v) = $c->hsv;
+ is($h,240,'blue hue');
+ is($s,1,'blue saturation');
+ is($v,1,'blue value');
+
+ $c = Imager::Color->new(255, 255, 255);
+ ($h,$s,$v) = $c->hsv;
+ is($h,0,'white hue');
+ is($s,0,'white saturation');
+ is($v,1,'white value');
+
+ $c = Imager::Color->new(0, 0, 0);
+ ($h,$s,$v) = $c->hsv;
+ is($h,0,'black hue');
+ is($s,0,'black saturation');
+ is($v,0,'black value');
+}
+
+sub test_col {
+ my ($c, $r, $g, $b, $a) = @_;
+ unless ($c) {
+ print "# $Imager::ERRSTR\n";
+ return 0;
+ }
+ my ($cr, $cg, $cb, $ca) = $c->rgba;
+ return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
+}
+
+sub color_close_enough {
+ my ($name, $r, $g, $b, $c) = @_;
+
+ my ($cr, $cg, $cb) = $c->rgba;
+ ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5,
+ "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
+}
+
+sub color_close_enough_hsv {
+ my ($name, $h, $s, $v, $c) = @_;
+
+ my ($ch, $cs, $cv) = $c->rgba;
+ if ($ch < 5 && $h > 250) {
+ $ch += 255;
+ }
+ elsif ($ch > 250 && $h < 5) {
+ $h += 255;
+ }
+ ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5,
+ "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)");
+}
+
+sub fcolor_close_enough {
+ my ($name, $r, $g, $b, $c) = @_;
+
+ my ($cr, $cg, $cb) = $c->rgba;
+ ok(abs($cr-$r) <= 0.01 && abs($cg-$g) <= 0.01 && abs($cb-$b) <= 0.01,
+ "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
+}
+
+sub color_ok {
+ my ($name, $r, $g, $b, $a, $c) = @_;
+
+ unless (ok(test_col($c, $r, $g, $b, $a), $name)) {
+ print "# ($r,$g,$b,$a) != (".join(",", $c ? $c->rgba: ()).")\n";
+ }
+}
+
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 22;
+
+use Imager;
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t90cc.log');
+
+{
+ my $img=Imager->new();
+ ok($img->open(file=>'testimg/scale.ppm'), 'load test image')
+ or print "failed: ",$img->{ERRSTR},"\n";
+
+ ok(defined($img->getcolorcount(maxcolors=>10000)), 'check color count is small enough');
+ print "# color count: ".$img->getcolorcount()."\n";
+ is($img->getcolorcount(), 86, 'expected number of colors');
+ is($img->getcolorcount(maxcolors => 50), undef, 'check overflow handling');
+}
+
+{
+ my $black = Imager::Color->new(0, 0, 0);
+ my $blue = Imager::Color->new(0, 0, 255);
+ my $red = Imager::Color->new(255, 0, 0);
+
+ my $im = Imager->new(xsize=>50, ysize=>50);
+
+ my $count = $im->getcolorcount();
+ is ($count, 1, "getcolorcount is 1");
+ my @colour_usage = $im->getcolorusage();
+ is_deeply (\@colour_usage, [2500], "2500 are in black");
+
+ $im->box(filled=>1, color=>$blue, xmin=>25);
+
+ $count = $im->getcolorcount();
+ is ($count, 2, "getcolorcount is 2");
+ @colour_usage = $im->getcolorusage();
+ is_deeply(\@colour_usage, [1250, 1250] , "1250, 1250: Black and blue");
+
+ $im->box(filled=>1, color=>$red, ymin=>25);
+
+ $count = $im->getcolorcount();
+ is ($count, 3, "getcolorcount is 3");
+ @colour_usage = $im->getcolorusage();
+ is_deeply(\@colour_usage, [625, 625, 1250] ,
+ "625, 625, 1250: Black blue and red");
+ @colour_usage = $im->getcolorusage(maxcolors => 2);
+ is(@colour_usage, 0, 'test overflow check');
+
+ my $colour_usage = $im->getcolorusagehash();
+ my $red_pack = pack("CCC", 255, 0, 0);
+ my $blue_pack = pack("CCC", 0, 0, 255);
+ my $black_pack = pack("CCC", 0, 0, 0);
+ is_deeply( $colour_usage,
+ { $black_pack => 625, $blue_pack => 625, $red_pack => 1250 },
+ "625, 625, 1250: Black blue and red (hash)");
+ is($im->getcolorusagehash(maxcolors => 2), undef,
+ 'test overflow check');
+
+ # test with a greyscale image
+ my $im_g = $im->convert(preset => 'grey');
+ # since the grey preset scales each source channel differently
+ # each of the original colors will be converted to different colors
+ is($im_g->getcolorcount, 3, '3 colors (grey)');
+ is_deeply([ $im_g->getcolorusage ], [ 625, 625, 1250 ],
+ 'color counts (grey)');
+ is_deeply({ "\x00" => 625, "\x12" => 625, "\x38" => 1250 },
+ $im_g->getcolorusagehash,
+ 'color usage hash (grey)');
+}
+
+{
+ my $empty = Imager->new;
+ is($empty->getcolorcount, undef, "can't getcolorcount an empty image");
+ is($empty->errstr, "getcolorcount: empty input image",
+ "check error message");
+ is($empty->getcolorusagehash, undef, "can't getcolorusagehash an empty image");
+ is($empty->errstr, "getcolorusagehash: empty input image",
+ "check error message");
+ is($empty->getcolorusage, undef, "can't getcolorusage an empty image");
+ is($empty->errstr, "getcolorusage: empty input image",
+ "check error message");
+}
--- /dev/null
+#!perl -w
+# regression test for RT issue 18561
+#
+use strict;
+use Test::More tests => 1;
+eval {
+ use Imager;
+
+ my $i = Imager->new(
+ xsize => 50,
+ ysize => 50,
+ );
+
+ $i->setpixel(
+ x => 10,
+ y => 10,
+ color => [0, 0, 0],
+ );
+};
+ok(!$@, "shouldn't crash")
+ or print "# $@\n";
--- /dev/null
+#!perl -w
+# variant on the code that produces 18561
+# the old _color() code could return floating colors in some cases
+# but in most cases the caller couldn't handle it
+use strict;
+use Test::More tests => 1;
+eval {
+ use Imager;
+ use Imager::Color::Float; # prevent the actual 18561 crash
+ my $i = Imager->new(
+ xsize => 50,
+ ysize => 50,
+ );
+ $i->line(x1 => 0, y1 => 0, x2 => 99, y2=>99, color => [ 0, 0, 0 ]);
+};
+ok(!$@, "shouldn't crash")
+ or print "# $@\n";
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 155;
+
+BEGIN { use_ok(Imager=>qw(:all :handy)) }
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t021sixteen.log");
+
+use Imager::Color::Float;
+use Imager::Test qw(test_image is_image image_bounds_checks test_colorf_gpix
+ test_colorf_glin mask_tests is_color3);
+
+my $im_g = Imager::i_img_16_new(100, 101, 1);
+
+is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
+ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
+ok(!Imager::i_img_virtual($im_g), "shouldn't be marked virtual");
+is(Imager::i_img_bits($im_g), 16, "1 channel image has bits == 16");
+is(Imager::i_img_type($im_g), 0, "1 channel image isn't direct");
+
+my @ginfo = i_img_info($im_g);
+is($ginfo[0], 100, "1 channel image width");
+is($ginfo[1], 101, "1 channel image height");
+
+undef $im_g;
+
+my $im_rgb = Imager::i_img_16_new(100, 101, 3);
+
+is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
+ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image mask");
+is(Imager::i_img_bits($im_rgb), 16, "3 channel image bits");
+is(Imager::i_img_type($im_rgb), 0, "3 channel image type");
+
+my $redf = NCF(1, 0, 0);
+my $greenf = NCF(0, 1, 0);
+my $bluef = NCF(0, 0, 1);
+
+# fill with red
+for my $y (0..101) {
+ Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
+}
+pass("fill with red");
+# basic sanity
+test_colorf_gpix($im_rgb, 0, 0, $redf, 0, "top-left");
+test_colorf_gpix($im_rgb, 99, 0, $redf, 0, "top-right");
+test_colorf_gpix($im_rgb, 0, 100, $redf, 0, "bottom left");
+test_colorf_gpix($im_rgb, 99, 100, $redf, 0, "bottom right");
+test_colorf_glin($im_rgb, 0, 0, [ ($redf) x 100 ], "first line");
+test_colorf_glin($im_rgb, 0, 100, [ ($redf) x 100 ], "last line");
+
+Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
+test_colorf_glin($im_rgb, 0, 1,
+ [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
+ "added some green in the middle");
+{
+ my @samples;
+ is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0 .. 2 ]), 12,
+ "i_gsamp_bits all channels - count")
+ or print "# ", Imager->_error_as_msg(), "\n";
+ is_deeply(\@samples, [ 65535, 0, 0, 65535, 0, 0,
+ 0, 65535, 0, 0, 65535, 0 ],
+ "check samples retrieved");
+ @samples = ();
+ is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0, 2 ]), 8,
+ "i_gsamp_bits some channels - count")
+ or print "# ", Imager->_error_as_msg(), "\n";
+ is_deeply(\@samples, [ 65535, 0, 65535, 0,
+ 0, 0, 0, 0 ],
+ "check samples retrieved");
+ # fail gsamp
+ is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0, 3 ]), undef,
+ "i_gsamp_bits fail bad channel");
+ is(Imager->_error_as_msg(), 'No channel 3 in this image', 'check message');
+
+ is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 17, \@samples, 0, [ 0, 2 ]), 8,
+ "i_gsamp_bits succeed high bits");
+ is($samples[0], 131071, "check correct with high bits");
+
+ # write some samples back
+ my @wr_samples =
+ (
+ 0, 0, 65535,
+ 65535, 0, 0,
+ 0, 65535, 0,
+ 65535, 65535, 0
+ );
+ is(Imager::i_psamp_bits($im_rgb, 18, 2, 16, [ 0 .. 2 ], \@wr_samples),
+ 12, "write 16-bit samples")
+ or print "# ", Imager->_error_as_msg(), "\n";
+ @samples = ();
+ is(Imager::i_gsamp_bits($im_rgb, 18, 22, 2, 16, \@samples, 0, [ 0 .. 2 ]), 12,
+ "read them back")
+ or print "# ", Imager->_error_as_msg(), "\n";
+ is_deeply(\@samples, \@wr_samples, "check they match");
+ my $c = Imager::i_get_pixel($im_rgb, 18, 2);
+ is_color3($c, 0, 0, 255, "check it write to the right places");
+}
+
+# basic OO tests
+my $oo16img = Imager->new(xsize=>200, ysize=>201, bits=>16);
+ok($oo16img, "make a 16-bit oo image");
+is($oo16img->bits, 16, "test bits");
+isnt($oo16img->is_bilevel, "should not be considered mono");
+# make sure of error handling
+ok(!Imager->new(xsize=>0, ysize=>1, bits=>16),
+ "fail to create a 0 pixel wide image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>0, bits=>16),
+ "fail to create a 0 pixel high image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+
+ok(!Imager->new(xsize=>-1, ysize=>1, bits=>16),
+ "fail to create a negative width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>-1, bits=>16),
+ "fail to create a negative height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+
+ok(!Imager->new(xsize=>-1, ysize=>-1, bits=>16),
+ "fail to create a negative width/height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>0),
+ "fail to create a zero channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+ "and correct error message");
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>5),
+ "fail to create a five channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+ "and correct error message");
+
+{
+ # https://rt.cpan.org/Ticket/Display.html?id=8213
+ # check for handling of memory allocation of very large images
+ # only test this on 32-bit machines - on a 64-bit machine it may
+ # result in trying to allocate 4Gb of memory, which is unfriendly at
+ # least and may result in running out of memory, causing a different
+ # type of exit
+ SKIP: {
+ use Config;
+ $Config{ptrsize} == 4
+ or skip("don't want to allocate 4Gb", 10);
+ my $uint_range = 256 ** $Config{intsize};
+ print "# range $uint_range\n";
+ my $dim1 = int(sqrt($uint_range/2))+1;
+
+ my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>16);
+ is($im_b, undef, "integer overflow check - 1 channel");
+
+ $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>16);
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>16);
+ ok($im_b, "but same height ok");
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+
+ # do a similar test with a 3 channel image, so we're sure we catch
+ # the same case where the third dimension causes the overflow
+ my $dim3 = int(sqrt($uint_range / 3 / 2))+1;
+
+ $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>16);
+ is($im_b, undef, "integer overflow check - 3 channel");
+
+ $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, bits=>16);
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, bits=>16);
+ ok($im_b, "but same height ok");
+
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+
+ # check we can allocate a scanline, unlike double images the scanline
+ # in the image itself is smaller than a line of i_fcolor
+ # divide by 2 to get to int range, by 2 for 2 bytes/pixel, by 3 to
+ # fit the image allocation in, but for the floats to overflow
+ my $dim4 = $uint_range / 2 / 2 / 3;
+ my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>1, bits=>16);
+ is($im_o, undef, "integer overflow check - scanline");
+ cmp_ok(Imager->errstr, '=~',
+ qr/integer overflow calculating scanline allocation/,
+ "check error message");
+ }
+}
+
+{ # check the channel mask function
+
+ my $im = Imager->new(xsize => 10, ysize=>10, bits=>16);
+
+ mask_tests($im, 1.0/65535);
+}
+
+{ # convert to rgb16
+ my $im = test_image();
+ my $im16 = $im->to_rgb16;
+ print "# check conversion to 16 bit\n";
+ is($im16->bits, 16, "check bits");
+ is_image($im, $im16, "check image data matches");
+}
+
+{ # empty image handling
+ my $im = Imager->new;
+ ok($im, "make empty image");
+ ok(!$im->to_rgb16, "convert empty image to 16-bit");
+ is($im->errstr, "to_rgb16: empty input image", "check message");
+}
+
+{ # bounds checks
+ my $im = Imager->new(xsize => 10, ysize => 10, bits => 16);
+ image_bounds_checks($im);
+}
+
+{
+ my $im = Imager->new(xsize => 10, ysize => 10, bits => 16, channels => 3);
+ my @wr_samples = map int(rand 65536), 1..30;
+ is($im->setsamples('y' => 1, data => \@wr_samples, type => '16bit'),
+ 30, "write 16-bit to OO image")
+ or print "# ", $im->errstr, "\n";
+ my @samples;
+ is($im->getsamples(y => 1, target => \@samples, type => '16bit'),
+ 30, "read 16-bit from OO image")
+ or print "# ", $im->errstr, "\n";
+ is_deeply(\@wr_samples, \@samples, "check it matches");
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+ print "# psamp\n";
+ my $imraw = Imager::i_img_16_new(10, 10, 3);
+ {
+ is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+ "i_psamp def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+ "i_psamp def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+ "check color written");
+ is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+ "i_psamp channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+ "i_psamp channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 63, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+ 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ }
+ print "# end psamp tests\n";
+}
+
+{ # psampf
+ print "# psampf\n";
+ my $imraw = Imager::i_img_16_new(10, 10, 3);
+ {
+ is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+ "i_psampf def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 127, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+ "check color written");
+ is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+ "i_psampf channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 127, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (127, 64, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+ 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error,
+ "check error message");
+ }
+ print "# end psampf tests\n";
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t021sixteen.log";
+}
+
+sub _get_error {
+ my @errors = Imager::i_errors();
+ return join(": ", map $_->[0], @errors);
+}
+
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 136;
+BEGIN { use_ok(Imager => qw(:all :handy)) }
+
+use Imager::Test qw(test_image is_image is_color3);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t022double.log");
+
+use Imager::Test qw(image_bounds_checks test_colorf_gpix test_colorf_glin mask_tests);
+
+use Imager::Color::Float;
+
+my $im_g = Imager::i_img_double_new(100, 101, 1);
+
+ok(Imager::i_img_getchannels($im_g) == 1,
+ "1 channel image channel count mismatch");
+ok(Imager::i_img_getmask($im_g) & 1, "1 channel image bad mask");
+ok(Imager::i_img_virtual($im_g) == 0,
+ "1 channel image thinks it is virtual");
+my $double_bits = length(pack("d", 1)) * 8;
+print "# $double_bits double bits\n";
+ok(Imager::i_img_bits($im_g) == $double_bits,
+ "1 channel image has bits != $double_bits");
+ok(Imager::i_img_type($im_g) == 0, "1 channel image isn't direct");
+
+my @ginfo = i_img_info($im_g);
+ok($ginfo[0] == 100, "1 channel image width incorrect");
+ok($ginfo[1] == 101, "1 channel image height incorrect");
+
+undef $im_g;
+
+my $im_rgb = Imager::i_img_double_new(100, 101, 3);
+
+ok(Imager::i_img_getchannels($im_rgb) == 3,
+ "3 channel image channel count mismatch");
+ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image bad mask");
+ok(Imager::i_img_bits($im_rgb) == $double_bits,
+ "3 channel image has bits != $double_bits");
+ok(Imager::i_img_type($im_rgb) == 0, "3 channel image isn't direct");
+
+my $redf = NCF(1, 0, 0);
+my $greenf = NCF(0, 1, 0);
+my $bluef = NCF(0, 0, 1);
+
+# fill with red
+for my $y (0..101) {
+ Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
+}
+
+# basic sanity
+test_colorf_gpix($im_rgb, 0, 0, $redf);
+test_colorf_gpix($im_rgb, 99, 0, $redf);
+test_colorf_gpix($im_rgb, 0, 100, $redf);
+test_colorf_gpix($im_rgb, 99, 100, $redf);
+test_colorf_glin($im_rgb, 0, 0, [ ($redf) x 100 ], 'sanity glin @0');
+test_colorf_glin($im_rgb, 0, 100, [ ($redf) x 100 ], 'sanity glin @100');
+
+Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
+test_colorf_glin($im_rgb, 0, 1,
+ [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
+ 'check after write');
+
+# basic OO tests
+my $ooimg = Imager->new(xsize=>200, ysize=>201, bits=>'double');
+ok($ooimg, "couldn't make double image");
+is($ooimg->bits, 'double', "oo didn't give double image");
+ok(!$ooimg->is_bilevel, 'not monochrome');
+
+# check that the image is copied correctly
+my $oocopy = $ooimg->copy;
+is($oocopy->bits, 'double', "oo copy didn't give double image");
+
+ok(!Imager->new(xsize=>0, ysize=>1, bits=>'double'),
+ "fail making 0 width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>0, bits=>'double'),
+ "fail making 0 height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct message");
+ok(!Imager->new(xsize=>-1, ysize=>1, bits=>'double'),
+ "fail making -ve width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>-1, bits=>'double'),
+ "fail making -ve height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>0),
+ "fail making 0 channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+ "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>5),
+ "fail making 5 channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+ "and correct message");
+
+{
+ # https://rt.cpan.org/Ticket/Display.html?id=8213
+ # check for handling of memory allocation of very large images
+ # only test this on 32-bit machines - on a 64-bit machine it may
+ # result in trying to allocate 4Gb of memory, which is unfriendly at
+ # least and may result in running out of memory, causing a different
+ # type of exit
+ use Config;
+ SKIP:
+ {
+ $Config{ptrsize} == 4
+ or skip "don't want to allocate 4Gb", 8;
+ my $uint_range = 256 ** $Config{intsize};
+ my $dbl_size = $Config{doublesize} || 8;
+ my $dim1 = int(sqrt($uint_range/$dbl_size))+1;
+
+ my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>'double');
+ is($im_b, undef, "integer overflow check - 1 channel");
+
+ $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>'double');
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>'double');
+ ok($im_b, "but same height ok");
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+
+ # do a similar test with a 3 channel image, so we're sure we catch
+ # the same case where the third dimension causes the overflow
+ my $dim3 = int(sqrt($uint_range / 3 / $dbl_size))+1;
+
+ $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>'double');
+ is($im_b, undef, "integer overflow check - 3 channel");
+
+ $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, bits=>'double');
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, bits=>'double');
+ ok($im_b, "but same height ok");
+
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+ }
+}
+
+{ # check the channel mask function
+
+ my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
+
+ mask_tests($im);
+}
+
+{ # bounds checking
+ my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
+ image_bounds_checks($im);
+}
+
+
+{ # convert to rgb double
+ my $im = test_image();
+ my $imdb = $im->to_rgb_double;
+ print "# check conversion to double\n";
+ is($imdb->bits, "double", "check bits");
+ is_image($im, $imdb, "check image data matches");
+}
+
+{ # empty image handling
+ my $im = Imager->new;
+ ok($im, "make empty image");
+ ok(!$im->to_rgb_double, "convert empty image to double");
+ is($im->errstr, "to_rgb_double: empty input image", "check message");
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+ print "# psamp\n";
+ my $imraw = Imager::i_img_double_new(10, 10, 3);
+ {
+ is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+ "i_psamp def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+ "i_psamp def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+ "check color written");
+ is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+ "i_psamp channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+ "i_psamp channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 63, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+ 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ }
+ print "# end psamp tests\n";
+}
+
+{ # psampf
+ print "# psampf\n";
+ my $imraw = Imager::i_img_double_new(10, 10, 3);
+ {
+ is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+ "i_psampf def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+ "check color written");
+ is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+ "i_psampf channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 64, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+ 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ }
+ print "# end psampf tests\n";
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t022double.log";
+}
+
+sub _get_error {
+ my @errors = Imager::i_errors();
+ return join(": ", map $_->[0], @errors);
+}
--- /dev/null
+#!perl -w
+# some of this is tested in t01introvert.t too
+use strict;
+use Test::More tests => 226;
+BEGIN { use_ok("Imager", ':handy'); }
+
+use Imager::Test qw(image_bounds_checks test_image is_color3 isnt_image is_color4 is_fcolor3);
+
+Imager->open_log(log => "testout/t023palette.log");
+
+sub isbin($$$);
+
+my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
+
+ok($img, "paletted image created");
+
+is($img->type, 'paletted', "got a paletted image");
+
+my $black = Imager::Color->new(0,0,0);
+my $red = Imager::Color->new(255,0,0);
+my $green = Imager::Color->new(0,255,0);
+my $blue = Imager::Color->new(0,0,255);
+
+my $white = Imager::Color->new(255,255,255);
+
+# add some color
+my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
+
+print "# blacki $blacki\n";
+ok(defined $blacki && $blacki == 0, "we got the first color");
+
+is($img->colorcount(), 4, "should have 4 colors");
+is($img->maxcolors, 256, "maxcolors always 256");
+
+my ($redi, $greeni, $bluei) = 1..3;
+
+my @all = $img->getcolors;
+ok(@all == 4, "all colors is 4");
+coloreq($all[0], $black, "first black");
+coloreq($all[1], $red, "then red");
+coloreq($all[2], $green, "then green");
+coloreq($all[3], $blue, "and finally blue");
+
+# keep this as an assignment, checking for scalar context
+# we don't want the last color, otherwise if the behaviour changes to
+# get all up to the last (count defaulting to size-index) we'd get a
+# false positive
+my $one_color = $img->getcolors(start=>$redi);
+ok($one_color->isa('Imager::Color'), "check scalar context");
+coloreq($one_color, $red, "and that it's what we want");
+
+# make sure we can find colors
+ok(!defined($img->findcolor(color=>$white)),
+ "shouldn't be able to find white");
+ok($img->findcolor(color=>$black) == $blacki, "find black");
+ok($img->findcolor(color=>$red) == $redi, "find red");
+ok($img->findcolor(color=>$green) == $greeni, "find green");
+ok($img->findcolor(color=>$blue) == $bluei, "find blue");
+
+# various failure tests for setcolors
+ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
+ "expect failure: low index");
+ok(!defined($img->setcolors(start=>1, colors=>[])),
+ "expect failure: no colors");
+ok(!defined($img->setcolors(start=>5, colors=>[$white])),
+ "expect failure: high index");
+
+# set the green index to white
+ok($img->setcolors(start => $greeni, colors => [$white]),
+ "set a color");
+# and check it
+coloreq(scalar($img->getcolors(start=>$greeni)), $white,
+ "make sure it was set");
+ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
+ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
+
+# write a few colors
+ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
+ "save multiple");
+coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
+coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
+
+# put it back
+$img->setcolors(start=>$red, colors=>[$red, $green]);
+
+# draw on the image, make sure it stays paletted when it should
+ok($img->box(color=>$red, filled=>1), "fill with red");
+is($img->type, 'paletted', "paletted after fill");
+ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
+ xmax=>40, ymax=>40), "green box");
+is($img->type, 'paletted', 'still paletted after box');
+# an AA line will almost certainly convert the image to RGB, don't use
+# an AA line here
+ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
+ "draw a line");
+is($img->type, 'paletted', 'still paletted after line');
+
+# draw with white - should convert to direct
+ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
+ xmax=>30, ymax=>30), "white box");
+is($img->type, 'direct', "now it should be direct");
+
+# various attempted to make a paletted image from our now direct image
+my $palimg = $img->to_paletted;
+ok($palimg, "we got an image");
+# they should be the same pixel for pixel
+ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
+
+# strange case: no color picking, and no colors
+# this was causing a segmentation fault
+$palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
+ok(!defined $palimg, "to paletted with an empty palette is an error");
+print "# ",$img->errstr,"\n";
+ok(scalar($img->errstr =~ /no colors available for translation/),
+ "and got the correct msg");
+
+ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
+ "fail on -ve height");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
+ "fail on -ve width");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
+ "fail on -ve width/height");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+ "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
+ "fail on 0 channels");
+cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
+ "and correct error message");
+ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
+ "fail on 5 channels");
+cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
+ "and correct error message");
+
+{
+ # https://rt.cpan.org/Ticket/Display.html?id=8213
+ # check for handling of memory allocation of very large images
+ # only test this on 32-bit machines - on a 64-bit machine it may
+ # result in trying to allocate 4Gb of memory, which is unfriendly at
+ # least and may result in running out of memory, causing a different
+ # type of exit
+ use Config;
+ SKIP:
+ {
+ skip("don't want to allocate 4Gb", 10)
+ unless $Config{ptrsize} == 4;
+
+ my $uint_range = 256 ** $Config{intsize};
+ my $dim1 = int(sqrt($uint_range))+1;
+
+ my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
+ is($im_b, undef, "integer overflow check - 1 channel");
+
+ $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
+ ok($im_b, "but same height ok");
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+
+ # do a similar test with a 3 channel image, so we're sure we catch
+ # the same case where the third dimension causes the overflow
+ # for paletted images the third dimension can't cause an overflow
+ # but make sure we didn't anything too dumb in the checks
+ my $dim3 = $dim1;
+
+ $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
+ is($im_b, undef, "integer overflow check - 3 channel");
+
+ $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
+ ok($im_b, "but same width ok");
+ $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
+ ok($im_b, "but same height ok");
+
+ cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+ "check the error message");
+
+ # test the scanline allocation check
+ # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
+ # doesn't integer overflow, but the scanline of i_color (4/pixel) does
+ my $dim4 = $uint_range / 3;
+ my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
+ is($im_o, undef, "integer overflow check - scanline size");
+ cmp_ok(Imager->errstr, '=~',
+ qr/integer overflow calculating scanline allocation/,
+ "check error message");
+ }
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ my $img = Imager->new(xsize=>10, ysize=>10);
+ $img->to_paletted();
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 'palette\\.t', "correct file");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=12676
+ # setcolors() has a fencepost error
+ my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
+
+ is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
+ "add test colors");
+ ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
+ ok(!$img->setcolors(start=>2, colors=>[ $black ]),
+ "set after the last color");
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=20056
+ # added named color support to addcolor/setcolor
+ my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+ is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
+ "add colors as strings instead of objects");
+ my @colors = $img->getcolors;
+ iscolor($colors[0], $black, "check first color");
+ iscolor($colors[1], $red, "check second color");
+ ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
+ "setcolors as strings instead of objects");
+ @colors = $img->getcolors;
+ iscolor($colors[0], $green, "check first color");
+ iscolor($colors[1], $blue, "check second color");
+
+ # make sure we handle bad colors correctly
+ is($img->colorcount, 2, "start from a known state");
+ is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
+ "fail to add unknown color");
+ is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
+ is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
+ "fail to set to unknown color");
+ is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=20338
+ # OO interface to i_glin/i_plin
+ my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+ is($im->addcolors(colors => [ "#000", "#F00", "#0F0", "#00F" ]), "0 but true",
+ "add some test colors")
+ or print "# ", $im->errstr, "\n";
+ # set a pixel to check
+ $im->setpixel(x => 1, 'y' => 0, color => "#0F0");
+ is_deeply([ $im->getscanline('y' => 0, type=>'index') ],
+ [ 0, 2, (0) x 8 ], "getscanline index in list context");
+ isbin($im->getscanline('y' => 0, type=>'index'),
+ "\x00\x02" . "\x00" x 8,
+ "getscanline index in scalar context");
+ is($im->setscanline('y' => 0, pixels => [ 1, 2, 0, 3 ], type => 'index'),
+ 4, "setscanline with list");
+ is($im->setscanline('y' => 0, x => 4, pixels => pack("C*", 3, 2, 1, 0, 3),
+ type => 'index'),
+ 5, "setscanline with pv");
+ is_deeply([ $im->getscanline(type => 'index', 'y' => 0) ],
+ [ 1, 2, 0, 3, 3, 2, 1, 0, 3, 0 ],
+ "check values set");
+ eval { # should croak on OOR index
+ $im->setscanline('y' => 1, pixels => [ 255 ], type=>'index');
+ };
+ ok($@, "croak on setscanline() to invalid index");
+ eval { # same again with pv
+ $im->setscanline('y' => 1, pixels => "\xFF", type => 'index');
+ };
+ ok($@, "croak on setscanline() with pv to invalid index");
+}
+
+{
+ print "# make_colors => mono\n";
+ # test mono make_colors
+ my $imrgb = Imager->new(xsize => 10, ysize => 10);
+ $imrgb->setpixel(x => 0, 'y' => 0, color => '#FFF');
+ $imrgb->setpixel(x => 1, 'y' => 0, color => '#FF0');
+ $imrgb->setpixel(x => 2, 'y' => 0, color => '#000');
+ my $mono = $imrgb->to_paletted(make_colors => 'mono',
+ translate => 'closest');
+ is($mono->type, 'paletted', "check we get right image type");
+ is($mono->colorcount, 2, "only 2 colors");
+ my ($is_mono, $ziw) = $mono->is_bilevel;
+ ok($is_mono, "check monochrome check true");
+ is($ziw, 0, "check ziw false");
+ my @colors = $mono->getcolors;
+ iscolor($colors[0], $black, "check first entry");
+ iscolor($colors[1], $white, "check second entry");
+ my @pixels = $mono->getscanline(x => 0, 'y' => 0, width => 3, type=>'index');
+ is($pixels[0], 1, "check white pixel");
+ is($pixels[1], 1, "check yellow pixel");
+ is($pixels[2], 0, "check black pixel");
+}
+
+{ # check for the various mono images we accept
+ my $mono_8_bw_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
+ type => 'paletted');
+ ok($mono_8_bw_3->addcolors(colors => [ qw/000000 FFFFFF/ ]),
+ "mono8bw3 - add colors");
+ ok($mono_8_bw_3->is_bilevel, "it's mono");
+ is(($mono_8_bw_3->is_bilevel)[1], 0, 'zero not white');
+
+ my $mono_8_wb_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
+ type => 'paletted');
+ ok($mono_8_wb_3->addcolors(colors => [ qw/FFFFFF 000000/ ]),
+ "mono8wb3 - add colors");
+ ok($mono_8_wb_3->is_bilevel, "it's mono");
+ is(($mono_8_wb_3->is_bilevel)[1], 1, 'zero is white');
+
+ my $mono_8_bw_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
+ type => 'paletted');
+ ok($mono_8_bw_1->addcolors(colors => [ qw/000000 FFFFFF/ ]),
+ "mono8bw - add colors");
+ ok($mono_8_bw_1->is_bilevel, "it's mono");
+ is(($mono_8_bw_1->is_bilevel)[1], 0, 'zero not white');
+
+ my $mono_8_wb_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
+ type => 'paletted');
+ ok($mono_8_wb_1->addcolors(colors => [ qw/FFFFFF 000000/ ]),
+ "mono8wb - add colors");
+ ok($mono_8_wb_1->is_bilevel, "it's mono");
+ is(($mono_8_wb_1->is_bilevel)[1], 1, 'zero is white');
+}
+
+{ # check bounds checking
+ my $im = Imager->new(xsize => 10, ysize => 10, type=>'paletted');
+ ok($im->addcolors(colors => [ $black ]), "add color of pixel bounds check writes");
+
+ image_bounds_checks($im);
+}
+
+{ # test colors array returns colors
+ my $data;
+ my $im = test_image();
+ my @colors;
+ my $imp = $im->to_paletted(colors => \@colors,
+ make_colors => 'webmap',
+ translate => 'closest');
+ ok($imp, "made paletted");
+ is(@colors, 216, "should be 216 colors in the webmap");
+ is_color3($colors[0], 0, 0, 0, "first should be 000000");
+ is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
+ is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
+}
+
+{ # RT 68508
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ $im->box(filled => 1, color => Imager::Color->new(255, 0, 0));
+ my $palim = $im->to_paletted(make_colors => "mono", translate => "errdiff");
+ ok($palim, "convert to mono with error diffusion");
+ my $blank = Imager->new(xsize => 10, ysize => 10);
+ isnt_image($palim, $blank, "make sure paletted isn't all black");
+}
+
+{ # check validation of palette entries
+ my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+ $im->addcolors(colors => [ $black, $red ]);
+ {
+ my $no_croak = eval {
+ $im->setscanline(y => 0, type => 'index', pixels => [ 0, 1 ]);
+ 1;
+ };
+ ok($no_croak, "valid values don't croak");
+ }
+ {
+ my $no_croak = eval {
+ $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 0, 1));
+ 1;
+ };
+ ok($no_croak, "valid values don't croak (packed)");
+ }
+ {
+ my $no_croak = eval {
+ $im->setscanline(y => 0, type => 'index', pixels => [ 2, 255 ]);
+ 1;
+ };
+ ok(!$no_croak, "invalid values do croak");
+ }
+ {
+ my $no_croak = eval {
+ $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 2, 255));
+ 1;
+ };
+ ok(!$no_croak, "invalid values do croak (packed)");
+ }
+}
+
+{
+ my $im = Imager->new(xsize => 1, ysize => 1);
+ my $im_bad = Imager->new;
+ {
+ my @map = Imager->make_palette({});
+ ok(!@map, "make_palette should fail with no images");
+ is(Imager->errstr, "make_palette: supply at least one image",
+ "check error message");
+ }
+ {
+ my @map = Imager->make_palette({}, $im, $im_bad, $im);
+ ok(!@map, "make_palette should fail with an empty image");
+ is(Imager->errstr, "make_palette: image 2 is empty",
+ "check error message");
+ }
+ {
+ my @map = Imager->make_palette({ make_colors => "mono" }, $im);
+ is(@map, 2, "mono should make 2 color palette")
+ or skip("unexpected color count", 2);
+ is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+ is_color4($map[1], 255, 255, 255, 255, "check map[1]");
+ }
+ {
+ my @map = Imager->make_palette({ make_colors => "gray4" }, $im);
+ is(@map, 4, "gray4 should make 4 color palette")
+ or skip("unexpected color count", 4);
+ is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+ is_color4($map[1], 85, 85, 85, 255, "check map[1]");
+ is_color4($map[2], 170, 170, 170, 255, "check map[2]");
+ is_color4($map[3], 255, 255, 255, 255, "check map[3]");
+ }
+ {
+ my @map = Imager->make_palette({ make_colors => "gray16" }, $im);
+ is(@map, 16, "gray16 should make 16 color palette")
+ or skip("unexpected color count", 4);
+ is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+ is_color4($map[1], 17, 17, 17, 255, "check map[1]");
+ is_color4($map[2], 34, 34, 34, 255, "check map[2]");
+ is_color4($map[15], 255, 255, 255, 255, "check map[15]");
+ }
+ {
+ my @map = Imager->make_palette({ make_colors => "gray" }, $im);
+ is(@map, 256, "gray16 should make 256 color palette")
+ or skip("unexpected color count", 4);
+ is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+ is_color4($map[1], 1, 1, 1, 255, "check map[1]");
+ is_color4($map[33], 33, 33, 33, 255, "check map[2]");
+ is_color4($map[255], 255, 255, 255, 255, "check map[15]");
+ }
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+ print "# psamp\n";
+ my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
+ my @colors =
+ (
+ NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
+ NC(64, 0, 192), NC(255, 128, 0), NC(64, 32, 0),
+ NC(128, 63, 32), NC(255, 128, 32), NC(64, 32, 16),
+ );
+ is(Imager::i_addcolors($imraw, @colors), "0 but true",
+ "add colors needed for testing");
+ {
+ is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+ "i_psamp def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+ "i_psamp def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+ "check color written");
+ is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+ "i_psamp channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+ "i_psamp channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 63, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+ 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error, "check message");
+ is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error, "check message");
+ is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error, "check message");
+ is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error, "check message");
+ }
+ ok(Imager::i_img_type($imraw), "still paletted");
+ print "# end psamp tests\n";
+}
+
+{ # psampf
+ print "# psampf\n";
+ my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
+ my @colors =
+ (
+ NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
+ NC(64, 0, 191), NC(255, 128, 0), NC(64, 32, 0),
+ NC(128, 64, 32), NC(255, 128, 32), NC(64, 32, 16),
+ );
+ is(Imager::i_addcolors($imraw, @colors), "0 but true",
+ "add colors needed for testing");
+ {
+ is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+ "i_psampf def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+ "check color written");
+ is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+ "i_psampf channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 64, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+ 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error, "check message");
+ is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error, "check message");
+ is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error, "check message");
+ is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error, "check message");
+ }
+ ok(Imager::i_img_type($imraw), "still paletted");
+ print "# end psampf tests\n";
+}
+
+{ # 75258 - gpixf() broken for paletted images
+ my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
+ ok($im, "make a test image");
+ my @colors = ( $black, $red, $green, $blue );
+ is($im->addcolors(colors => \@colors), "0 but true",
+ "add some colors");
+ $im->setpixel(x => 0, y => 0, color => $red);
+ $im->setpixel(x => 1, y => 0, color => $green);
+ $im->setpixel(x => 2, y => 0, color => $blue);
+ is_fcolor3($im->getpixel(x => 0, y => 0, type => "float"),
+ 1.0, 0, 0, "get a pixel in float form, make sure it's red");
+ is_fcolor3($im->getpixel(x => 1, y => 0, type => "float"),
+ 0, 1.0, 0, "get a pixel in float form, make sure it's green");
+ is_fcolor3($im->getpixel(x => 2, y => 0, type => "float"),
+ 0, 0, 1.0, "get a pixel in float form, make sure it's blue");
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->to_paletted, "can't convert an empty image");
+ is($empty->errstr, "to_paletted: empty input image",
+ "check error message");
+
+ is($empty->addcolors(colors => [ $black ]), -1,
+ "can't addcolors() to an empty image");
+ is($empty->errstr, "addcolors: empty input image",
+ "check error message");
+
+ ok(!$empty->setcolors(colors => [ $black ]),
+ "can't setcolors() to an empty image");
+ is($empty->errstr, "setcolors: empty input image",
+ "check error message");
+
+ ok(!$empty->getcolors(),
+ "can't getcolors() from an empty image");
+ is($empty->errstr, "getcolors: empty input image",
+ "check error message");
+
+ is($empty->colorcount, -1, "can't colorcount() an empty image");
+ is($empty->errstr, "colorcount: empty input image",
+ "check error message");
+
+ is($empty->maxcolors, -1, "can't maxcolors() an empty image");
+ is($empty->errstr, "maxcolors: empty input image",
+ "check error message");
+
+ is($empty->findcolor(color => $blue), undef,
+ "can't findcolor an empty image");
+ is($empty->errstr, "findcolor: empty input image",
+ "check error message");
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t023palette.log"
+}
+
+sub iscolor {
+ my ($c1, $c2, $msg) = @_;
+
+ my $builder = Test::Builder->new;
+ my @c1 = $c1->rgba;
+ my @c2 = $c2->rgba;
+ if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
+ $msg)) {
+ $builder->diag(<<DIAG);
+ got color: [ @c1 ]
+ expected color: [ @c2 ]
+DIAG
+ }
+}
+
+sub isbin ($$$) {
+ my ($got, $expected, $msg) = @_;
+
+ my $builder = Test::Builder->new;
+ if (!$builder->ok($got eq $expected, $msg)) {
+ (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
+ (my $exp_dec = $expected) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
+ $builder->diag(<<DIAG);
+ got: "$got_dec"
+ expected: "$exp_dec"
+DIAG
+ }
+}
+
+sub coloreq {
+ my ($left, $right, $comment) = @_;
+
+ my ($rl, $gl, $bl, $al) = $left->rgba;
+ my ($rr, $gr, $br, $ar) = $right->rgba;
+
+ print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
+ ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
+ $comment);
+}
+
+sub _get_error {
+ my @errors = Imager::i_errors();
+ return join(": ", map $_->[0], @errors);
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 244;
+use Imager qw(:all :handy);
+use Imager::Test qw(is_color3 is_fcolor3);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t020masked.log");
+
+my $base_rgb = Imager::ImgRaw::new(100, 100, 3);
+# put something in there
+my $black = NC(0, 0, 0);
+my $red = NC(255, 0, 0);
+my $green = NC(0, 255, 0);
+my $blue = NC(0, 0, 255);
+my $white = NC(255, 255, 255);
+my $grey = NC(128, 128, 128);
+use Imager::Color::Float;
+my $redf = Imager::Color::Float->new(1, 0, 0);
+my $greenf = Imager::Color::Float->new(0, 1, 0);
+my $bluef = Imager::Color::Float->new(0, 0, 1);
+my $greyf = Imager::Color::Float->new(0.5, 0.5, 0.5);
+my @cols = ($red, $green, $blue);
+for my $y (0..99) {
+ Imager::i_plin($base_rgb, 0, $y, ($cols[$y % 3] ) x 100);
+}
+
+# first a simple subset image
+my $s_rgb = Imager::i_img_masked_new($base_rgb, undef, 25, 25, 50, 50);
+
+is(Imager::i_img_getchannels($s_rgb), 3,
+ "1 channel image channel count match");
+ok(Imager::i_img_getmask($s_rgb) & 1,
+ "1 channel image mask");
+ok(Imager::i_img_virtual($s_rgb),
+ "1 channel image thinks it isn't virtual");
+is(Imager::i_img_bits($s_rgb), 8,
+ "1 channel image has bits == 8");
+is(Imager::i_img_type($s_rgb), 0, # direct
+ "1 channel image is direct");
+
+my @ginfo = i_img_info($s_rgb);
+is($ginfo[0], 50, "check width");
+is($ginfo[1], 50, "check height");
+
+# sample some pixels through the subset
+my $c = Imager::i_get_pixel($s_rgb, 0, 0);
+is_color3($c, 0, 255, 0, "check (0,0)");
+$c = Imager::i_get_pixel($s_rgb, 49, 49);
+# (25+49)%3 = 2
+is_color3($c, 0, 0, 255, "check (49,49)");
+
+# try writing to it
+for my $y (0..49) {
+ Imager::i_plin($s_rgb, 0, $y, ($cols[$y % 3]) x 50);
+}
+pass("managed to write to it");
+# and checking the target image
+$c = Imager::i_get_pixel($base_rgb, 25, 25);
+is_color3($c, 255, 0, 0, "check (25,25)");
+$c = Imager::i_get_pixel($base_rgb, 29, 29);
+is_color3($c, 0, 255, 0, "check (29,29)");
+
+undef $s_rgb;
+
+# a basic background
+for my $y (0..99) {
+ Imager::i_plin($base_rgb, 0, $y, ($red ) x 100);
+}
+my $mask = Imager::ImgRaw::new(50, 50, 1);
+# some venetian blinds
+for my $y (4..20) {
+ Imager::i_plin($mask, 5, $y*2, ($white) x 40);
+}
+# with a strip down the middle
+for my $y (0..49) {
+ Imager::i_plin($mask, 20, $y, ($white) x 8);
+}
+my $m_rgb = Imager::i_img_masked_new($base_rgb, $mask, 25, 25, 50, 50);
+ok($m_rgb, "make masked with mask");
+for my $y (0..49) {
+ Imager::i_plin($m_rgb, 0, $y, ($green) x 50);
+}
+my @color_tests =
+ (
+ [ 25+0, 25+0, $red ],
+ [ 25+19, 25+0, $red ],
+ [ 25+20, 25+0, $green ],
+ [ 25+27, 25+0, $green ],
+ [ 25+28, 25+0, $red ],
+ [ 25+49, 25+0, $red ],
+ [ 25+19, 25+7, $red ],
+ [ 25+19, 25+8, $green ],
+ [ 25+19, 25+9, $red ],
+ [ 25+0, 25+8, $red ],
+ [ 25+4, 25+8, $red ],
+ [ 25+5, 25+8, $green ],
+ [ 25+44, 25+8, $green ],
+ [ 25+45, 25+8, $red ],
+ [ 25+49, 25+49, $red ],
+ );
+my $test_num = 15;
+for my $test (@color_tests) {
+ my ($x, $y, $testc) = @$test;
+ my ($r, $g, $b) = $testc->rgba;
+ my $c = Imager::i_get_pixel($base_rgb, $x, $y);
+ is_color3($c, $r, $g, $b, "at ($x, $y)");
+}
+
+{
+ # tests for the OO versions, fairly simple, since the basic functionality
+ # is covered by the low-level interface tests
+
+ my $base = Imager->new(xsize=>100, ysize=>100);
+ ok($base, "make base OO image");
+ $base->box(color=>$blue, filled=>1); # fill it all
+ my $mask = Imager->new(xsize=>80, ysize=>80, channels=>1);
+ $mask->box(color=>$white, filled=>1, xmin=>5, xmax=>75, ymin=>5, ymax=>75);
+ my $m_img = $base->masked(mask=>$mask, left=>5, top=>5);
+ ok($m_img, "make masked OO image");
+ is($m_img->getwidth, 80, "check width");
+ $m_img->box(color=>$green, filled=>1);
+ my $c = $m_img->getpixel(x=>0, y=>0);
+ is_color3($c, 0, 0, 255, "check (0,0)");
+ $c = $m_img->getpixel(x => 5, y => 5);
+ is_color3($c, 0, 255, 0, "check (5,5)");
+
+ # older versions destroyed the Imager::ImgRaw object manually in
+ # Imager::DESTROY rather than letting Imager::ImgRaw::DESTROY
+ # destroy the object
+ # so we test here by destroying the base and mask objects and trying
+ # to draw to the masked wrapper
+ # you may need to test with ElectricFence to trigger the problem
+ undef $mask;
+ undef $base;
+ $m_img->box(color=>$blue, filled=>1);
+ pass("didn't crash unreffing base or mask for masked image");
+}
+
+# 35.7% cover on maskimg.c up to here
+
+{ # error handling:
+ my $base = Imager->new(xsize => 100, ysize => 100);
+ ok($base, "make base");
+ { # make masked image subset outside of the base image
+ my $masked = $base->masked(left => 100);
+ ok (!$masked, "fail to make empty masked");
+ is($base->errstr, "subset outside of target image", "check message");
+ }
+}
+
+{ # size limiting
+ my $base = Imager->new(xsize => 10, ysize => 10);
+ ok($base, "make base for size limit tests");
+ {
+ my $masked = $base->masked(left => 5, right => 15);
+ ok($masked, "make masked");
+ is($masked->getwidth, 5, "check width truncated");
+ }
+ {
+ my $masked = $base->masked(top => 5, bottom => 15);
+ ok($masked, "make masked");
+ is($masked->getheight, 5, "check height truncated");
+ }
+}
+# 36.7% up to here
+
+$mask = Imager->new(xsize => 80, ysize => 80, channels => 1);
+$mask->box(filled => 1, color => $white, xmax => 39, ymax => 39);
+$mask->box(fill => { hatch => "check1x1" }, ymin => 40, xmax => 39);
+
+{
+ my $base = Imager->new(xsize => 100, ysize => 100, bits => "double");
+ ok($base, "base for single pixel tests");
+ is($base->type, "direct", "check type");
+ my $masked = $base->masked(mask => $mask, left => 1, top => 2);
+ my $limited = $base->masked(left => 1, top => 2);
+
+ is($masked->type, "direct", "check masked is same type as base");
+ is($limited->type, "direct", "check limited is same type as base");
+
+ {
+ # single pixel writes, masked
+ {
+ ok($masked->setpixel(x => 1, y => 3, color => $green),
+ "set (1,3) in masked (2, 5) in based");
+ my $c = $base->getpixel(x => 2, y => 5);
+ is_color3($c, 0, 255, 0, "check it wrote through");
+ ok($masked->setpixel(x => 45, y => 2, color => $red),
+ "set (45,2) in masked (46,4) in base (no mask)");
+ $c = $base->getpixel(x => 46, y => 4);
+ is_color3($c, 0, 0, 0, "shouldn't have written through");
+ }
+ {
+ ok($masked->setpixel(x => 2, y => 3, color => $redf),
+ "write float red to (2,3) base(3,5)");
+ my $c = $base->getpixel(x => 3, y => 5);
+ is_color3($c, 255, 0, 0, "check it wrote through");
+ ok($masked->setpixel(x => 45, y => 3, color => $greenf),
+ "set float (45,3) in masked (46,5) in base (no mask)");
+ $c = $base->getpixel(x => 46, y => 5);
+ is_color3($c, 0, 0, 0, "check it didn't write");
+ }
+ {
+ # write out of range should fail
+ ok(!$masked->setpixel(x => 80, y => 0, color => $green),
+ "write 8-bit color out of range");
+ ok(!$masked->setpixel(x => 0, y => 80, color => $greenf),
+ "write float color out of range");
+ }
+ }
+
+ # 46.9
+
+ {
+ print "# plin coverage\n";
+ {
+ $base->box(filled => 1, color => $black);
+ # plin masked
+ # simple path
+ is($masked->setscanline(x => 76, y => 1, pixels => [ ($red, $green) x 3 ]),
+ 4, "try to write 6 pixels, but only write 4");
+ is_deeply([ $base->getsamples(x => 77, y => 3, width => 4) ],
+ [ ( 0 ) x 12 ],
+ "check not written through");
+ # !simple path
+ is($masked->setscanline(x => 4, y => 2, pixels => [ ($red, $green, $blue, $grey) x (72/4) ]),
+ 72, "write many pixels (masked)");
+ is_deeply([ $base->getsamples(x => 5, y => 4, width => 72) ],
+ [ ( (255, 0, 0), (0, 255, 0), (0, 0, 255), (128, 128, 128)) x 9,
+ ( 0, 0, 0 ) x 36 ],
+ "check written through to base");
+
+ # simple path, due to number of transitions
+ is($masked->setscanline(x => 0, y => 40, pixels => [ ($red, $green, $blue, $grey) x 5 ]),
+ 20, "try to write 20 pixels, with alternating write through");
+ is_deeply([ $base->getsamples(x => 1, y => 42, width => 20) ],
+ [ ( (0, 0, 0), (0,255,0), (0,0,0), (128,128,128) ) x 5 ],
+ "check correct pixels written through");
+ }
+
+ {
+ $base->box(filled => 1, color => $black);
+ # plin, non-masked path
+ is($limited->setscanline(x => 4, y => 2, pixels => [ ($red, $green, $blue, $grey) x (72/4) ]),
+ 72, "write many pixels (limited)");
+ is_deeply([ $base->getsamples(x => 5, y => 4, width => 72) ],
+ [ ( (255, 0, 0), (0, 255, 0), (0, 0, 255), (128, 128, 128)) x 18 ],
+ "check written through to based");
+ }
+
+ {
+ # draw outside fails
+ is($masked->setscanline(x => 80, y => 2, pixels => [ $red, $green ]),
+ 0, "check writing no pixels");
+ }
+ }
+
+ {
+ print "# plinf coverage\n";
+ {
+ $base->box(filled => 1, color => $black);
+ # plinf masked
+ # simple path
+ is($masked->setscanline(x => 76, y => 1, pixels => [ ($redf, $greenf) x 3 ]),
+ 4, "try to write 6 pixels, but only write 4");
+ is_deeply([ $base->getsamples(x => 77, y => 3, width => 4, type => "float") ],
+ [ ( 0 ) x 12 ],
+ "check not written through");
+ # !simple path
+ is($masked->setscanline(x => 4, y => 2, pixels => [ ($redf, $greenf, $bluef, $greyf) x (72/4) ]),
+ 72, "write many pixels (masked)");
+ is_deeply([ $base->getsamples(x => 5, y => 4, width => 72, type => "float") ],
+ [ ( (1, 0, 0), (0, 1, 0), (0, 0, 1), (0.5, 0.5, 0.5)) x 9,
+ ( 0, 0, 0 ) x 36 ],
+ "check written through to base");
+
+ # simple path, due to number of transitions
+ is($masked->setscanline(x => 0, y => 40, pixels => [ ($redf, $greenf, $bluef, $greyf) x 5 ]),
+ 20, "try to write 20 pixels, with alternating write through");
+ is_deeply([ $base->getsamples(x => 1, y => 42, width => 20, type => "float") ],
+ [ ( (0, 0, 0), (0,1,0), (0,0,0), (0.5,0.5,0.5) ) x 5 ],
+ "check correct pixels written through");
+ }
+
+ {
+ $base->box(filled => 1, color => $black);
+ # plinf, non-masked path
+ is($limited->setscanline(x => 4, y => 2, pixels => [ ($redf, $greenf, $bluef, $greyf) x (72/4) ]),
+ 72, "write many pixels (limited)");
+ is_deeply([ $base->getsamples(x => 5, y => 4, width => 72, type => "float") ],
+ [ ( (1, 0, 0), (0, 1, 0), (0, 0, 1), (0.5, 0.5, 0.5)) x 18 ],
+ "check written through to based");
+ }
+
+ {
+ # draw outside fails
+ is($masked->setscanline(x => 80, y => 2, pixels => [ $redf, $greenf ]),
+ 0, "check writing no pixels");
+ }
+ }
+ # 71.4%
+ {
+ {
+ print "# gpix\n";
+ # gpix
+ $base->box(filled => 1, color => $black);
+ ok($base->setpixel(x => 4, y => 10, color => $red),
+ "set base(4,10) to red");
+ is_fcolor3($masked->getpixel(x => 3, y => 8),
+ 255, 0, 0, "check pixel written");
+
+ # out of range
+ is($masked->getpixel(x => -1, y => 1),
+ undef, "check failure to left");
+ is($masked->getpixel(x => 0, y => -1),
+ undef, "check failure to top");
+ is($masked->getpixel(x => 80, y => 1),
+ undef, "check failure to right");
+ is($masked->getpixel(x => 0, y => 80),
+ undef, "check failure to bottom");
+ }
+ {
+ print "# gpixf\n";
+ # gpixf
+ $base->box(filled => 1, color => $black);
+ ok($base->setpixel(x => 4, y => 10, color => $redf),
+ "set base(4,10) to red");
+ is_fcolor3($masked->getpixel(x => 3, y => 8, type => "float"),
+ 1.0, 0, 0, 0, "check pixel written");
+
+ # out of range
+ is($masked->getpixel(x => -1, y => 1, type => "float"),
+ undef, "check failure to left");
+ is($masked->getpixel(x => 0, y => -1, type => "float"),
+ undef, "check failure to top");
+ is($masked->getpixel(x => 80, y => 1, type => "float"),
+ undef, "check failure to right");
+ is($masked->getpixel(x => 0, y => 80, type => "float"),
+ undef, "check failure to bottom");
+ }
+ }
+ # 74.5
+ {
+ {
+ print "# glin\n";
+ $base->box(filled => 1, color => $black);
+ is($base->setscanline(x => 31, y => 3,
+ pixels => [ ( $red, $green) x 10 ]),
+ 20, "write 20 pixels to base image");
+ my @colors = $masked->
+ getscanline(x => 30, y => 1, width => 20);
+ is(@colors, 20, "check we got right number of colors");
+ is_color3($colors[0], 255, 0, 0, "check first pixel");
+ is_color3($colors[19], 0, 255, 0, "check last pixel");
+
+ @colors = $masked->getscanline(x => 76, y => 2, width => 10);
+ is(@colors, 4, "read line from right edge");
+ is_color3($colors[0], 0, 0, 0, "check pixel");
+
+ is_deeply([ $masked->getscanline(x => -1, y => 0, width => 1) ],
+ [], "fail read left of image");
+ is_deeply([ $masked->getscanline(x => 0, y => -1, width => 1) ],
+ [], "fail read top of image");
+ is_deeply([$masked->getscanline(x => 80, y => 0, width => 1)],
+ [], "fail read right of image");
+ is_deeply([$masked->getscanline(x => 0, y => 80, width => 1)],
+ [], "fail read bottom of image");
+ }
+ {
+ print "# glinf\n";
+ $base->box(filled => 1, color => $black);
+ is($base->setscanline(x => 31, y => 3,
+ pixels => [ ( $redf, $greenf) x 10 ]),
+ 20, "write 20 pixels to base image");
+ my @colors = $masked->
+ getscanline(x => 30, y => 1, width => 20, type => "float");
+ is(@colors, 20, "check we got right number of colors");
+ is_fcolor3($colors[0], 1.0, 0, 0, 0, "check first pixel");
+ is_fcolor3($colors[19], 0, 1.0, 0, 0, "check last pixel");
+
+ @colors = $masked->
+ getscanline(x => 76, y => 2, width => 10, type => "float");
+ is(@colors, 4, "read line from right edge");
+ is_fcolor3($colors[0], 0, 0, 0, 0, "check pixel");
+
+ is_deeply([ $masked->getscanline(x => -1, y => 0, width => 1, type => "float") ],
+ [], "fail read left of image");
+ is_deeply([ $masked->getscanline(x => 0, y => -1, width => 1, type => "float") ],
+ [], "fail read top of image");
+ is_deeply([$masked->getscanline(x => 80, y => 0, width => 1, type => "float")],
+ [], "fail read right of image");
+ is_deeply([$masked->getscanline(x => 0, y => 80, width => 1, type => "float")],
+ [], "fail read bottom of image");
+ }
+ }
+ # 81.6%
+ {
+ {
+ print "# gsamp\n";
+ $base->box(filled => 1, color => $black);
+ is($base->setscanline(x => 31, y => 3,
+ pixels => [ ( $red, $green) x 10 ]),
+ 20, "write 20 pixels to base image");
+ my @samps = $masked->
+ getsamples(x => 30, y => 1, width => 20);
+ is(@samps, 60, "check we got right number of samples");
+ is_deeply(\@samps,
+ [ (255, 0, 0, 0, 255, 0) x 10 ],
+ "check it");
+
+ @samps = $masked->
+ getsamples(x => 76, y => 2, width => 10);
+ is(@samps, 12, "read line from right edge");
+ is_deeply(\@samps, [ (0, 0, 0) x 4], "check result");
+
+ is_deeply([ $masked->getsamples(x => -1, y => 0, width => 1) ],
+ [], "fail read left of image");
+ is_deeply([ $masked->getsamples(x => 0, y => -1, width => 1) ],
+ [], "fail read top of image");
+ is_deeply([$masked->getsamples(x => 80, y => 0, width => 1)],
+ [], "fail read right of image");
+ is_deeply([$masked->getsamples(x => 0, y => 80, width => 1)],
+ [], "fail read bottom of image");
+ }
+ {
+ print "# gsampf\n";
+ $base->box(filled => 1, color => $black);
+ is($base->setscanline(x => 31, y => 3,
+ pixels => [ ( $redf, $greenf) x 10 ]),
+ 20, "write 20 pixels to base image");
+ my @samps = $masked->
+ getsamples(x => 30, y => 1, width => 20, type => "float");
+ is(@samps, 60, "check we got right number of samples");
+ is_deeply(\@samps,
+ [ (1.0, 0, 0, 0, 1.0, 0) x 10 ],
+ "check it");
+
+ @samps = $masked->
+ getsamples(x => 76, y => 2, width => 10, type => "float");
+ is(@samps, 12, "read line from right edge");
+ is_deeply(\@samps, [ (0, 0, 0) x 4], "check result");
+
+ is_deeply([ $masked->getsamples(x => -1, y => 0, width => 1, type => "float") ],
+ [], "fail read left of image");
+ is_deeply([ $masked->getsamples(x => 0, y => -1, width => 1, type => "float") ],
+ [], "fail read top of image");
+ is_deeply([$masked->getsamples(x => 80, y => 0, width => 1, type => "float")],
+ [], "fail read right of image");
+ is_deeply([$masked->getsamples(x => 0, y => 80, width => 1, type => "float")],
+ [], "fail read bottom of image");
+ }
+ }
+ # 86.2%
+}
+
+{
+ my $base = Imager->new(xsize => 100, ysize => 100, type => "paletted");
+ ok($base, "make paletted base");
+ is($base->type, "paletted", "check we got paletted");
+ is($base->addcolors(colors => [ $black, $red, $green, $blue ]),
+ "0 but true",
+ "add some colors to base");
+ my $masked = $base->masked(mask => $mask, left => 1, top => 2);
+ my $limited = $base->masked(left => 1, top => 2);
+
+ is($masked->type, "paletted", "check masked is same type as base");
+ is($limited->type, "paletted", "check limited is same type as base");
+
+ {
+ # make sure addcolors forwarded
+ is($masked->addcolors(colors => [ $grey ]), 4,
+ "test addcolors forwarded");
+ my @colors = $masked->getcolors();
+ is(@colors, 5, "check getcolors forwarded");
+ is_color3($colors[1], 255, 0, 0, "check color from palette");
+ }
+
+ my ($blacki, $redi, $greeni, $bluei, $greyi) = 0 .. 4;
+
+ { # gpal
+ print "# gpal\n";
+ $base->box(filled => 1, color => $black);
+ is($base->setscanline(x => 0, y => 5, type => "index",
+ pixels => [ ( $redi, $greeni, $bluei, $greyi) x 25 ]),
+ 100, "write some pixels to base");
+ my @indexes = $masked->getscanline(y => 3, type => "index", width => "81");
+ is(@indexes, 80, "got 80 indexes");
+ is_deeply(\@indexes,
+ [ ( $greeni, $bluei, $greyi, $redi) x 20 ],
+ "check values");
+
+ is_deeply([ $masked->getscanline(x => -1, y => 3, type => "index") ],
+ [], "fail read left of image");
+ }
+ # 89.8%
+
+ { # ppal, unmasked
+ print "# ppal\n";
+ $base->box(filled => 1, color => $black);
+ is($limited->setscanline(x => 1, y => 1, type => "index",
+ pixels => [ ( $redi, $greeni, $bluei) x 3 ]),
+ 9, "ppal limited");
+ is_deeply([ $base->getscanline(x => 2, y => 3, type => "index",
+ width => 9) ],
+ [ ( $redi, $greeni, $bluei) x 3 ],
+ "check set in base");
+ }
+ { # ppal, masked
+ $base->box(filled => 1, color => $black);
+ is($masked->setscanline(x => 1, y => 2, type => "index",
+ pixels => [ ( $redi, $greeni, $bluei, $greyi) x 12 ]),
+ 48, "ppal masked");
+ is_deeply([ $base->getscanline(x => 0, y => 4, type => "index") ],
+ [ 0, 0,
+ ( $redi, $greeni, $bluei, $greyi ) x 9,
+ $redi, $greeni, $bluei, ( 0 ) x 59 ],
+ "check written");
+ }
+ {
+ # ppal, errors
+ is($masked->setscanline(x => -1, y => 0, type => "index",
+ pixels => [ $redi, $bluei ]),
+ 0, "fail to write ppal");
+
+ is($masked->setscanline(x => 78, y => 0, type => "index",
+ pixels => [ $redi, $bluei, $greeni, $greyi ]),
+ 2, "write over right side");
+ }
+}
+
+my $full_mask = Imager->new(xsize => 10, ysize => 10, channels => 1);
+$full_mask->box(filled => 1, color => NC(255, 0, 0));
+
+# no mask and mask with full coverage should behave the same
+my $psamp_outside_error = "Image position outside of image";
+for my $masked (0, 1){ # psamp
+ print "# psamp masked: $masked\n";
+ my $imback = Imager::ImgRaw::new(20, 20, 3);
+ my $mask;
+ if ($masked) {
+ $mask = $full_mask->{IMG};
+ }
+ my $imraw = Imager::i_img_masked_new($imback, $mask, 3, 4, 10, 10);
+ {
+ is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+ "i_psamp def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+ "i_psamp def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+ "check color written");
+ is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+ "i_psamp channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+ "i_psamp channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 63, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+ 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+ undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ }
+ print "# end psamp tests\n";
+}
+
+for my $masked (0, 1) { # psampf
+ print "# psampf\n";
+ my $imback = Imager::ImgRaw::new(20, 20, 3);
+ my $mask;
+ if ($masked) {
+ $mask = $full_mask->{IMG};
+ }
+ my $imraw = Imager::i_img_masked_new($imback, $mask, 3, 4, 10, 10);
+ {
+ is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+ "i_psampf def channels, 3 samples");
+ is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+ "check color written");
+ Imager::i_img_setmask($imraw, 5);
+ is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf def channels, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+ "check color written");
+ is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+ "i_psampf channels listed, 3 samples, masked");
+ is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+ "check color written");
+ Imager::i_img_setmask($imraw, ~0);
+ is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+ "i_psampf channels [0, 1], 4 samples");
+ is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+ "check first color written");
+ is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+ "check second color written");
+ is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+ "write a full row");
+ is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+ [ (128, 64, 32) x 10 ],
+ "check full row");
+ is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+ [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+ 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+ }
+ { # errors we catch
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel 3 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+ undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+ is(_get_error(), "No channel -1 in this image",
+ "check error message");
+ is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+ "negative y");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+ "y overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+ "negative x");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+ "x overflow");
+ is(_get_error(), $psamp_outside_error, "check error message");
+ }
+ print "# end psampf tests\n";
+}
+
+{
+ my $sub_mask = $full_mask->copy;
+ $sub_mask->box(filled => 1, color => NC(0,0,0), xmin => 4, xmax => 6);
+ my $base = Imager::ImgRaw::new(20, 20, 3);
+ my $masked = Imager::i_img_masked_new($base, $sub_mask->{IMG}, 3, 4, 10, 10);
+
+ is(Imager::i_psamp($masked, 0, 2, undef, [ ( 0, 127, 255) x 10 ]), 30,
+ "psamp() to masked image");
+ is_deeply([ Imager::i_gsamp($base, 0, 20, 6, undef) ],
+ [ ( 0, 0, 0 ) x 3, # left of mask
+ ( 0, 127, 255 ) x 4, # masked area
+ ( 0, 0, 0 ) x 3, # unmasked area
+ ( 0, 127, 255 ) x 3, # masked area
+ ( 0, 0, 0 ) x 7 ], # right of mask
+ "check values written");
+ is(Imager::i_psampf($masked, 0, 2, undef, [ ( 0, 0.5, 1.0) x 10 ]), 30,
+ "psampf() to masked image");
+ is_deeply([ Imager::i_gsamp($base, 0, 20, 6, undef) ],
+ [ ( 0, 0, 0 ) x 3, # left of mask
+ ( 0, 128, 255 ) x 4, # masked area
+ ( 0, 0, 0 ) x 3, # unmasked area
+ ( 0, 128, 255 ) x 3, # masked area
+ ( 0, 0, 0 ) x 7 ], # right of mask
+ "check values written");
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->masked, "fail to make a masked image from an empty");
+ is($empty->errstr, "masked: empty input image",
+ "check error message");
+}
+
+Imager->close_log();
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t020masked.log";
+}
+
+sub _get_error {
+ my @errors = Imager::i_errors();
+ return join(": ", map $_->[0], @errors);
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 274;
+use Imager::Test qw(is_image);
+# for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
+use IO::Seekable;
+use Config;
+
+BEGIN { use_ok(Imager => ':all') };
+
+-d "testout" or mkdir "testout";
+
+$| = 1;
+
+Imager->open_log(log => "testout/t07iolayer.log");
+
+undef($/);
+# start by testing io buffer
+
+my $data="P2\n2 2\n255\n 255 0\n0 255\n";
+my $IO = Imager::io_new_buffer($data);
+my $im = Imager::i_readpnm_wiol($IO, -1);
+
+ok($im, "read from data io");
+
+open(FH, ">testout/t07.ppm") or die $!;
+binmode(FH);
+my $fd = fileno(FH);
+my $IO2 = Imager::io_new_fd( $fd );
+Imager::i_writeppm_wiol($im, $IO2);
+close(FH);
+undef($im);
+
+open(FH, "<testimg/penguin-base.ppm");
+binmode(FH);
+$data = <FH>;
+close(FH);
+my $IO3 = Imager::IO->new_buffer($data);
+#undef($data);
+$im = Imager::i_readpnm_wiol($IO3, -1);
+
+ok($im, "read from buffer, for compare");
+undef $IO3;
+
+open(FH, "<testimg/penguin-base.ppm") or die $!;
+binmode(FH);
+$fd = fileno(FH);
+my $IO4 = Imager::IO->new_fd( $fd );
+my $im2 = Imager::i_readpnm_wiol($IO4, -1);
+close(FH);
+undef($IO4);
+
+ok($im2, "read from file, for compare");
+
+is(i_img_diff($im, $im2), 0, "compare images");
+undef($im2);
+
+my $IO5 = Imager::io_new_bufchain();
+Imager::i_writeppm_wiol($im, $IO5);
+my $data2 = Imager::io_slurp($IO5);
+undef($IO5);
+
+ok($data2, "check we got data from bufchain");
+
+my $IO6 = Imager::io_new_buffer($data2);
+my $im3 = Imager::i_readpnm_wiol($IO6, -1);
+
+is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
+
+my $work = $data;
+my $pos = 0;
+sub io_reader {
+ my ($size, $maxread) = @_;
+ my $out = substr($work, $pos, $maxread);
+ $pos += length $out;
+ $out;
+}
+sub io_reader2 {
+ my ($size, $maxread) = @_;
+ my $out = substr($work, $pos, $maxread);
+ $pos += length $out;
+ $out;
+}
+my $IO7 = Imager::IO->new_cb(undef, \&io_reader, undef, undef);
+ok($IO7, "making readcb object");
+my $im4 = Imager::i_readpnm_wiol($IO7, -1);
+ok($im4, "read from cb");
+ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
+
+$pos = 0;
+$IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
+ok($IO7, "making short readcb object");
+my $im5 = Imager::i_readpnm_wiol($IO7, -1);
+ok($im4, "read from cb2");
+is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
+
+sub io_writer {
+ my ($what) = @_;
+ substr($work, $pos, $pos+length $what) = $what;
+ $pos += length $what;
+
+ 1;
+}
+
+my $did_close;
+sub io_close {
+ ++$did_close;
+}
+
+my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
+ok($IO8, "making writecb object");
+$pos = 0;
+$work = '';
+ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
+# I originally compared this to $data, but that doesn't include the
+# Imager header
+is($work, $data2, "write image match");
+ok($did_close, "did close");
+
+# with a short buffer, no closer
+my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
+ok($IO9, "making short writecb object");
+$pos = 0;
+$work = '';
+ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
+is($work, $data2, "short write image match");
+
+{
+ my $buf_data = "Test data";
+ my $io9 = Imager::io_new_buffer($buf_data);
+ is(ref $io9, "Imager::IO", "check class");
+ my $work;
+ is($io9->raw_read($work, 4), 4, "read 4 from buffer object");
+ is($work, "Test", "check data read");
+ is($io9->raw_read($work, 5), 5, "read the rest");
+ is($work, " data", "check data read");
+ is($io9->raw_seek(5, SEEK_SET), 5, "seek");
+ is($io9->raw_read($work, 5), 4, "short read");
+ is($work, "data", "check data read");
+ is($io9->raw_seek(-1, SEEK_CUR), 8, "seek relative");
+ is($io9->raw_seek(-5, SEEK_END), 4, "seek relative to end");
+ is($io9->raw_seek(-10, SEEK_CUR), -1, "seek failure");
+ undef $io9;
+}
+{
+ my $io = Imager::IO->new_bufchain();
+ is(ref $io, "Imager::IO", "check class");
+ is($io->raw_write("testdata"), 8, "check write");
+ is($io->raw_seek(-8, SEEK_CUR), 0, "seek relative");
+ my $work;
+ is($io->raw_read($work, 8), 8, "check read");
+ is($work, "testdata", "check data read");
+ is($io->raw_seek(-3, SEEK_END), 5, "seek end relative");
+ is($io->raw_read($work, 5), 3, "short read");
+ is($work, "ata", "check read data");
+ is($io->raw_seek(4, SEEK_SET), 4, "absolute seek to write some");
+ is($io->raw_write("testdata"), 8, "write");
+ is($io->raw_seek(0, SEEK_CUR), 12, "check size");
+ $io->raw_close();
+
+ # grab the data
+ my $data = Imager::io_slurp($io);
+ is($data, "testtestdata", "check we have the right data");
+}
+
+{ # callback failure checks
+ my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
+ # scalar context
+ my $buffer;
+ my $read_result = $fail_io->raw_read($buffer, 10);
+ is($read_result, undef, "read failure undef in scalar context");
+ my @read_result = $fail_io->raw_read($buffer, 10);
+ is(@read_result, 0, "empty list in list context");
+ $read_result = $fail_io->raw_read2(10);
+ is($read_result, undef, "raw_read2 failure (scalar)");
+ @read_result = $fail_io->raw_read2(10);
+ is(@read_result, 0, "raw_read2 failure (list)");
+
+ my $write_result = $fail_io->raw_write("test");
+ is($write_result, -1, "failed write");
+
+ my $seek_result = $fail_io->raw_seek(-1, SEEK_SET);
+ is($seek_result, -1, "failed seek");
+}
+
+{ # callback success checks
+ my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
+ # scalar context
+ my $buffer;
+ my $read_result = $good_io->raw_read($buffer, 10);
+ is($read_result, 8, "read success (scalar)");
+ is($buffer, "testdata", "check data");
+ my @read_result = $good_io->raw_read($buffer, 10);
+ is_deeply(\@read_result, [ 8 ], "read success (list)");
+ is($buffer, "testdata", "check data");
+ $read_result = $good_io->raw_read2(10);
+ is($read_result, "testdata", "read2 success (scalar)");
+ @read_result = $good_io->raw_read2(10);
+ is_deeply(\@read_result, [ "testdata" ], "read2 success (list)");
+}
+
+{ # end of file
+ my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
+ my $buffer;
+ my $read_result = $eof_io->raw_read($buffer, 10);
+ is($read_result, 0, "read eof (scalar)");
+ is($buffer, '', "check data");
+ my @read_result = $eof_io->raw_read($buffer, 10);
+ is_deeply(\@read_result, [ 0 ], "read eof (list)");
+ is($buffer, '', "check data");
+}
+
+{ # no callbacks
+ my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
+ is($none_io->raw_write("test"), -1, "write with no writecb should fail");
+ my $buffer;
+ is($none_io->raw_read($buffer, 10), undef, "read with no readcb should fail");
+ is($none_io->raw_seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
+}
+
+SKIP:
+{ # make sure we croak when trying to write a string with characters over 0xff
+ # the write callback shouldn't get called
+ skip("no native UTF8 support in this version of perl", 2)
+ unless $] >= 5.006;
+ my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
+ my $data = chr(0x100);
+ is(ord $data, 0x100, "make sure we got what we expected");
+ my $result =
+ eval {
+ $io->raw_write($data);
+ 1;
+ };
+ ok(!$result, "should have croaked")
+ and print "# $@\n";
+}
+
+{ # 0.52 left some debug code in a path that wasn't tested, make sure
+ # that path is tested
+ # http://rt.cpan.org/Ticket/Display.html?id=20705
+ my $io = Imager::io_new_cb
+ (
+ sub {
+ print "# write $_[0]\n";
+ 1
+ },
+ sub {
+ print "# read $_[0], $_[1]\n";
+ "x" x $_[1]
+ },
+ sub { print "# seek\n"; 0 },
+ sub { print "# close\n"; 1 });
+ my $buffer;
+ is($io->raw_read($buffer, 10), 10, "read 10");
+ is($buffer, "xxxxxxxxxx", "read value");
+ ok($io->raw_write("foo"), "write");
+ is($io->raw_close, 0, "close");
+}
+
+SKIP:
+{ # fd_seek write failure
+ -c "/dev/full"
+ or skip("No /dev/full", 3);
+ open my $fh, "> /dev/full"
+ or skip("Can't open /dev/full: $!", 3);
+ my $io = Imager::io_new_fd(fileno($fh));
+ ok($io, "make fd io for /dev/full");
+ Imager::i_clear_error();
+ is($io->raw_write("test"), -1, "fail to write");
+ my $msg = Imager->_error_as_msg;
+ like($msg, qr/^write\(\) failure: /, "check error message");
+ print "# $msg\n";
+
+ # /dev/full succeeds on seek on Linux
+
+ undef $io;
+}
+
+SKIP:
+{ # fd_seek seek failure
+ my $seekfail = "testout/t07seekfail.dat";
+ open my $fh, "> $seekfail"
+ or skip("Can't open $seekfail: $!", 3);
+ my $io = Imager::io_new_fd(fileno($fh));
+ ok($io, "make fd io for $seekfail");
+
+ Imager::i_clear_error();
+ is($io->raw_seek(-1, SEEK_SET), -1, "shouldn't be able to seek to -1");
+ my $msg = Imager->_error_as_msg;
+ like($msg, qr/^lseek\(\) failure: /, "check error message");
+ print "# $msg\n";
+
+ undef $io;
+ close $fh;
+ unlink $seekfail;
+}
+
+SKIP:
+{ # fd_seek read failure
+ open my $fh, "> testout/t07writeonly.txt"
+ or skip("Can't open testout/t07writeonly.txt: $!", 3);
+ my $io = Imager::io_new_fd(fileno($fh));
+ ok($io, "make fd io for write-only");
+
+ Imager::i_clear_error();
+ my $buf;
+ is($io->raw_read($buf, 10), undef,
+ "file open for write shouldn't be readable");
+ my $msg = Imager->_error_as_msg;
+ like($msg, qr/^read\(\) failure: /, "check error message");
+ print "# $msg\n";
+
+ undef $io;
+}
+
+SKIP:
+{ # fd_seek eof
+ open my $fh, "> testout/t07readeof.txt"
+ or skip("Can't open testout/t07readeof.txt: $!", 5);
+ binmode $fh;
+ print $fh "test";
+ close $fh;
+ open my $fhr, "< testout/t07readeof.txt",
+ or skip("Can't open testout/t07readeof.txt: $!", 5);
+ my $io = Imager::io_new_fd(fileno($fhr));
+ ok($io, "make fd io for read eof");
+
+ Imager::i_clear_error();
+ my $buf;
+ is($io->raw_read($buf, 10), 4,
+ "10 byte read on 4 byte file should return 4");
+ my $msg = Imager->_error_as_msg;
+ is($msg, "", "should be no error message")
+ or print STDERR "# read(4) message is: $msg\n";
+
+ Imager::i_clear_error();
+ $buf = '';
+ is($io->raw_read($buf, 10), 0,
+ "10 byte read at end of 4 byte file should return 0 (eof)");
+
+ $msg = Imager->_error_as_msg;
+ is($msg, "", "should be no error message")
+ or print STDERR "# read(4), eof message is: $msg\n";
+
+ undef $io;
+}
+
+{ # buffered I/O
+ my $data="P2\n2 2\n255\n 255 0\n0 255\n";
+ my $io = Imager::io_new_buffer($data);
+
+ my $c = $io->getc();
+
+ is($c, ord "P", "getc");
+ my $peekc = $io->peekc();
+
+ is($peekc, ord "2", "peekc");
+
+ my $peekn = $io->peekn(2);
+ is($peekn, "2\n", "peekn");
+
+ $c = $io->getc();
+ is($c, ord "2", "getc after peekc/peekn");
+
+ is($io->seek(0, SEEK_SET), "0", "seek");
+ is($io->getc, ord "P", "check we got back to the start");
+}
+
+{ # test closecb result is propagated
+ my $success_cb = sub { 1 };
+ my $failure_cb = sub { 0 };
+
+ {
+ my $io = Imager::io_new_cb(undef, $success_cb, undef, $success_cb);
+ is($io->close(), 0, "test successful close");
+ }
+ {
+ my $io = Imager::io_new_cb(undef, $success_cb, undef, $failure_cb);
+ is($io->close(), -1, "test failed close");
+ }
+}
+
+{ # buffered coverage/function tests
+ # some data to play with
+ my $base = pack "C*", map rand(26) + ord("a"), 0 .. 20_001;
+
+ { # buffered accessors
+ my $io = Imager::io_new_buffer($base);
+ ok($io->set_buffered(0), "set unbuffered");
+ ok(!$io->is_buffered, "verify unbuffered");
+ ok($io->set_buffered(1), "set buffered");
+ ok($io->is_buffered, "verify buffered");
+ }
+
+ { # initial i_io_read(), buffered
+ my $pos = 0;
+ my $ops = "";
+ my $work = $base;
+ my $read = sub {
+ my ($size) = @_;
+
+ my $req_size = $size;
+
+ if ($pos + $size > length $work) {
+ $size = length($work) - $pos;
+ }
+
+ my $result = substr($work, $pos, $size);
+ $pos += $size;
+ $ops .= "R$req_size>$size;";
+
+ print "# read $req_size>$size\n";
+
+ return $result;
+ };
+ my $write = sub {
+ my ($data) = @_;
+
+ substr($work, $pos, length($data), $data);
+
+ return 1;
+ };
+ {
+ my $io = Imager::io_new_cb(undef, $read, undef, undef);
+ my $buf;
+ is($io->read($buf, 1000), 1000, "read initial 1000");
+ is($buf, substr($base, 0, 1000), "check data read");
+ is($ops, "R8192>8192;", "check read op happened to buffer size");
+
+ undef $buf;
+ is($io->read($buf, 1001), 1001, "read another 1001");
+ is($buf, substr($base, 1000, 1001), "check data read");
+ is($ops, "R8192>8192;", "should be no further reads");
+
+ undef $buf;
+ is($io->read($buf, 40_000), length($base) - 2001,
+ "read the rest in one chunk");
+ is($buf, substr($base, 2001), "check the data read");
+ my $buffer_left = 8192 - 2001;
+ my $after_buffer = length($base) - 8192;
+ is($ops, "R8192>8192;R".(40_000 - $buffer_left).">$after_buffer;R21999>0;",
+ "check we tried to read the remainder");
+ }
+ {
+ # read after write errors
+ my $io = Imager::io_new_cb($write, $read, undef, undef);
+ is($io->write("test"), 4, "write 4 bytes, io in write mode");
+ is($io->read2(10), undef, "read should fail");
+ is($io->peekn(10), undef, "peekn should fail");
+ is($io->getc(), -1, "getc should fail");
+ is($io->peekc(), -1, "peekc should fail");
+ }
+ }
+
+ {
+ my $io = Imager::io_new_buffer($base);
+ print "# buffer fill check\n";
+ ok($io, "make memory io");
+ my $buf;
+ is($io->read($buf, 4096), 4096, "read 4k");
+ is($buf, substr($base, 0, 4096), "check data is correct");
+
+ # peek a bit
+ undef $buf;
+ is($io->peekn(5120), substr($base, 4096, 5120),
+ "peekn() 5120, which should exceed the buffer, and only read the left overs");
+ }
+
+ { # initial peekn
+ my $io = Imager::io_new_buffer($base);
+ is($io->peekn(10), substr($base, 0, 10),
+ "make sure initial peekn() is sane");
+ is($io->read2(10), substr($base, 0, 10),
+ "and that reading 10 gets the expected data");
+ }
+
+ { # oversize peekn
+ my $io = Imager::io_new_buffer($base);
+ is($io->peekn(10_000), substr($base, 0, 8192),
+ "peekn() larger than buffer should return buffer-size bytes");
+ }
+
+ { # small peekn then large peekn with a small I/O back end
+ # this might happen when reading from a socket
+ my $work = $base;
+ my $pos = 0;
+ my $ops = '';
+ my $reader = sub {
+ my ($size) = @_;
+
+ my $req_size = $size;
+ # do small reads, to trigger a possible bug
+ if ($size > 10) {
+ $size = 10;
+ }
+
+ if ($pos + $size > length $work) {
+ $size = length($work) - $pos;
+ }
+
+ my $result = substr($work, $pos, $size);
+ $pos += $size;
+ $ops .= "R$req_size>$size;";
+
+ print "# read $req_size>$size\n";
+
+ return $result;
+ };
+ my $io = Imager::io_new_cb(undef, $reader, undef, undef);
+ ok($io, "small reader io");
+ is($io->peekn(25), substr($base, 0, 25), "peek 25");
+ is($ops, "R8192>10;R8182>10;R8172>10;",
+ "check we got the raw calls expected");
+ is($io->peekn(65), substr($base, 0, 65), "peek 65");
+ is($ops, "R8192>10;R8182>10;R8172>10;R8162>10;R8152>10;R8142>10;R8132>10;",
+ "check we got the raw calls expected");
+ }
+ for my $buffered (1, 0) { # peekn followed by errors
+ my $buffered_desc = $buffered ? "buffered" : "unbuffered";
+ my $read = 0;
+ my $base = "abcdef";
+ my $pos = 0;
+ my $reader = sub {
+ my $size = shift;
+ my $req_size = $size;
+ if ($pos + $size > length $base) {
+ $size = length($base) - $pos;
+ }
+ # error instead of eof
+ if ($size == 0) {
+ print "# read $req_size>error\n";
+ return;
+ }
+ my $result = substr($base, $pos, $size);
+ $pos += $size;
+
+ print "# read $req_size>$size\n";
+
+ return $result;
+ };
+ my $io = Imager::io_new_cb(undef, $reader, undef, undef);
+ ok($io, "make $buffered_desc cb with error after 6 bytes");
+ is($io->peekn(5), "abcde",
+ "peekn until just before error ($buffered_desc)");
+ is($io->peekn(6), "abcdef", "peekn until error ($buffered_desc)");
+ is($io->peekn(7), "abcdef", "peekn past error ($buffered_desc)");
+ ok(!$io->error,
+ "should be no error indicator, since data buffered ($buffered_desc)");
+ ok(!$io->eof,
+ "should be no eof indicator, since data buffered ($buffered_desc)");
+
+ # consume it
+ is($io->read2(6), "abcdef", "consume the buffer ($buffered_desc)");
+ is($io->peekn(10), undef,
+ "peekn should get an error indicator ($buffered_desc)");
+ ok($io->error, "should be an error state ($buffered_desc)");
+ ok(!$io->eof, "but not eof ($buffered_desc)");
+ }
+ { # peekn on an empty file
+ my $io = Imager::io_new_buffer("");
+ is($io->peekn(10), "", "peekn on empty source");
+ ok($io->eof, "should be in eof state");
+ ok(!$io->error, "but not error");
+ }
+ { # peekn on error source
+ my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+ is($io->peekn(10), undef, "peekn on empty source");
+ ok($io->error, "should be in error state");
+ ok(!$io->eof, "but not eof");
+ }
+ { # peekn on short source
+ my $io = Imager::io_new_buffer("abcdef");
+ is($io->peekn(4), "abcd", "peekn 4 on 6 byte source");
+ is($io->peekn(10), "abcdef", "followed by peekn 10 on 6 byte source");
+ is($io->peekn(10), "abcdef", "and again, now eof is set");
+ }
+ { # peekn(0)
+ Imager::i_clear_error();
+ my $io = Imager::io_new_buffer("abcdef");
+ is($io->peekn(0), undef, "peekn 0 on 6 byte source");
+ my $msg = Imager->_error_as_msg;
+ is($msg, "peekn size must be positive");
+ }
+ { # getc through a whole file (buffered)
+ my $io = Imager::io_new_buffer($base);
+ my $out = '';
+ while ((my $c = $io->getc()) != -1) {
+ $out .= chr($c);
+ }
+ is($out, $base, "getc should return the file byte by byte (buffered)");
+ is($io->getc, -1, "another getc after eof should fail too");
+ ok($io->eof, "should be marked eof");
+ ok(!$io->error, "shouldn't be marked in error");
+ }
+ { # getc through a whole file (unbuffered)
+ my $io = Imager::io_new_buffer($base);
+ $io->set_buffered(0);
+ my $out = '';
+ while ((my $c = $io->getc()) != -1) {
+ $out .= chr($c);
+ }
+ is($out, $base, "getc should return the file byte by byte (unbuffered)");
+ is($io->getc, -1, "another getc after eof should fail too");
+ ok($io->eof, "should be marked eof");
+ ok(!$io->error, "shouldn't be marked in error");
+ }
+ { # buffered getc with an error
+ my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+ is($io->getc, -1, "buffered getc error");
+ ok($io->error, "io marked in error");
+ ok(!$io->eof, "but not eof");
+ }
+ { # unbuffered getc with an error
+ my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+ $io->set_buffered(0);
+ is($io->getc, -1, "unbuffered getc error");
+ ok($io->error, "io marked in error");
+ ok(!$io->eof, "but not eof");
+ }
+ { # initial peekc - buffered
+ my $io = Imager::io_new_buffer($base);
+ my $c = $io->peekc;
+ is($c, ord($base), "buffered peekc matches");
+ is($io->peekc, $c, "duplicate peekc matchess");
+ }
+ { # initial peekc - unbuffered
+ my $io = Imager::io_new_buffer($base);
+ $io->set_buffered(0);
+ my $c = $io->peekc;
+ is($c, ord($base), "unbuffered peekc matches");
+ is($io->peekc, $c, "duplicate peekc matchess");
+ }
+ { # initial peekc eof - buffered
+ my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
+ my $c = $io->peekc;
+ is($c, -1, "buffered eof peekc is -1");
+ is($io->peekc, $c, "duplicate matches");
+ ok($io->eof, "io marked eof");
+ ok(!$io->error, "but not error");
+ }
+ { # initial peekc eof - unbuffered
+ my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
+ $io->set_buffered(0);
+ my $c = $io->peekc;
+ is($c, -1, "buffered eof peekc is -1");
+ is($io->peekc, $c, "duplicate matches");
+ ok($io->eof, "io marked eof");
+ ok(!$io->error, "but not error");
+ }
+ { # initial peekc error - buffered
+ my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+ my $c = $io->peekc;
+ is($c, -1, "buffered error peekc is -1");
+ is($io->peekc, $c, "duplicate matches");
+ ok($io->error, "io marked error");
+ ok(!$io->eof, "but not eof");
+ }
+ { # initial peekc error - unbuffered
+ my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+ $io->set_buffered(0);
+ my $c = $io->peekc;
+ is($c, -1, "unbuffered error peekc is -1");
+ is($io->peekc, $c, "duplicate matches");
+ ok($io->error, "io marked error");
+ ok(!$io->eof, "but not eof");
+ }
+ { # initial putc
+ my $io = Imager::io_new_bufchain();
+ is($io->putc(ord "A"), ord "A", "initial putc buffered");
+ is($io->close, 0, "close it");
+ is(Imager::io_slurp($io), "A", "check it was written");
+ }
+ { # initial putc - unbuffered
+ my $io = Imager::io_new_bufchain();
+ $io->set_buffered(0);
+ is($io->putc(ord "A"), ord "A", "initial putc unbuffered");
+ is($io->close, 0, "close it");
+ is(Imager::io_slurp($io), "A", "check it was written");
+ }
+ { # putc unbuffered with error
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ $io->set_buffered(0);
+ is($io->putc(ord "A"), -1, "initial putc unbuffered error");
+ ok($io->error, "io in error");
+ is($io->putc(ord "B"), -1, "still in error");
+ }
+ { # writes while in read state
+ my $io = Imager::io_new_cb(sub { 1 }, sub { return "AA" }, undef, undef);
+ is($io->getc, ord "A", "read to setup read buffer");
+ is($io->putc(ord "B"), -1, "putc should fail");
+ is($io->write("test"), -1, "write should fail");
+ }
+ { # buffered putc error handling
+ # tests the check for error state in the buffered putc code
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ $io->putc(ord "A");
+ ok(!$io->flush, "flush should fail");
+ ok($io->error, "should be in error state");
+ is($io->putc(ord "B"), -1, "check for error");
+ }
+ { # buffered putc flush error handling
+ # test handling of flush failure and of the error state resulting
+ # from that
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ my $i = 0;
+ while (++$i < 100_000 && $io->putc(ord "A") == ord "A") {
+ # until we have to flush and fail doing do
+ }
+ is($i, 8193, "should have failed on 8193rd byte");
+ ok($io->error, "should be in error state");
+ is($io->putc(ord "B"), -1, "next putc should fail");
+ }
+ { # buffered write flush error handling
+ # test handling of flush failure and of the error state resulting
+ # from that
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ my $i = 0;
+ while (++$i < 100_000 && $io->write("A") == 1) {
+ # until we have to flush and fail doing do
+ }
+ is($i, 8193, "should have failed on 8193rd byte");
+ ok($io->error, "should be in error state");
+ is($io->write("B"), -1, "next write should fail");
+ }
+ { # buffered read error
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ is($io->read2(10), undef, "initial read returning error");
+ ok($io->error, "should be in error state");
+ }
+ { # unbuffered read error
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ $io->set_buffered(0);
+ is($io->read2(10), undef, "initial read returning error");
+ ok($io->error, "should be in error state");
+ }
+ { # unbuffered write error
+ my $count = 0;
+ my $io = Imager::io_new_cb(sub { return $count++; }, undef, undef, undef);
+ $io->set_buffered(0);
+ is($io->write("A"), -1, "unbuffered write failure");
+ ok($io->error, "should be in error state");
+ is($io->write("BC"), -1, "should still fail");
+ }
+ { # buffered write + large write
+ my $io = Imager::io_new_bufchain();
+ is($io->write(substr($base, 0, 4096)), 4096,
+ "should be buffered");
+ is($io->write(substr($base, 4096)), length($base) - 4096,
+ "large write, should fill buffer and fall back to direct write");
+ is($io->close, 0, "close it");
+ is(Imager::io_slurp($io), $base, "make sure the data is correct");
+ }
+ { # initial large write with failure
+ # tests error handling for the case where we bypass the buffer
+ # when the write is too large to fit
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ ok($io->flush, "flush with nothing buffered should succeed");
+ is($io->write($base), -1, "large write failure");
+ ok($io->error, "should be in error state");
+ is($io->close, -1, "should fail to close");
+ }
+ { # write that causes a flush then fills the buffer a bit
+ my $io = Imager::io_new_bufchain();
+ is($io->write(substr($base, 0, 6000)), 6000, "fill the buffer a bit");
+ is($io->write(substr($base, 6000, 4000)), 4000,
+ "cause it to flush and then fill some more");
+ is($io->write(substr($base, 10000)), length($base)-10000,
+ "write out the rest of our test data");
+ is($io->close, 0, "close the stream");
+ is(Imager::io_slurp($io), $base, "make sure the data is right");
+ }
+ { # failure on flush on close
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ is($io->putc(ord "A"), ord "A", "something in the buffer");
+ ok(!$io->error, "should be no error yet");
+ is($io->close, -1, "close should failure due to flush error");
+ }
+ { # seek failure
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ is($io->seek(0, SEEK_SET), -1, "seek failure");
+ }
+ { # read a little and seek
+ my $io = Imager::io_new_buffer($base);
+ is($io->getc, ord $base, "read one");
+ is($io->getc, ord substr($base, 1, 1), "read another");
+ is($io->seek(-1, SEEK_CUR), 1, "seek relative back to origin+1");
+ is($io->getc, ord substr($base, 1, 1), "read another again");
+ }
+ { # seek with failing flush
+ my $io = Imager::io_new_cb(undef, undef, undef, undef);
+ is($io->putc(ord "A"), ord "A", "write one");
+ ok(!$io->error, "not in error mode (yet)");
+ is($io->seek(0, SEEK_SET), -1, "seek failure due to flush");
+ ok($io->error, "in error mode");
+ }
+ { # gets()
+ my $data = "test1\ntest2\ntest3";
+ my $io = Imager::io_new_buffer($data);
+ is($io->gets(6), "test1\n", "gets(6)");
+ is($io->gets(5), "test2", "gets(5) (short for the line)");
+ is($io->gets(10), "\n", "gets(10) the rest of the line (the newline)");
+ is($io->gets(), "test3", "gets(default) unterminated line");
+ }
+ { # more gets()
+ my $data = "test1\ntest2\ntest3";
+ my $io = Imager::io_new_buffer($data);
+ is($io->gets(6, ord("1")), "test1", "gets(6) (line terminator 1)");
+ is($io->gets(6, ord("2")), "\ntest2", "gets(6) (line terminator 2)");
+ is($io->gets(6, ord("3")), "\ntest3", "gets(6) (line terminator 3)");
+ is($io->getc, -1, "should be eof");
+ }
+}
+
+{ # based on discussion on IRC, user was attempting to write a TIFF
+ # image file with only a write callback, but TIFF requires seek and
+ # read callbacks when writing.
+ # https://rt.cpan.org/Ticket/Display.html?id=76782
+ my $cb = Imager::io_new_cb(undef, undef, undef, undef);
+ {
+ Imager::i_clear_error();
+ my $data;
+ is($cb->read($data, 10), undef, "default read callback should fail");
+ is(Imager->_error_as_msg(), "read callback called but no readcb supplied",
+ "check error message");
+ }
+ {
+ Imager::i_clear_error();
+ is($cb->raw_write("abc"), -1, "default write callback should fail");
+ is(Imager->_error_as_msg(), "write callback called but no writecb supplied",
+ "check error message");
+ }
+ {
+ Imager::i_clear_error();
+ is($cb->seek(0, 0), -1, "default seek callback should fail");
+ is(Imager->_error_as_msg(), "seek callback called but no seekcb supplied",
+ "check error message");
+ }
+}
+
+SKIP:
+{
+ $Config{useperlio}
+ or skip "PerlIO::scalar requires perlio", 13;
+
+ my $foo;
+ open my $fh, "+<", \$foo;
+ my $io = Imager::IO->_new_perlio($fh);
+ ok($io, "perlio: make a I/O object for a perl scalar fh");
+ is($io->write("test"), 4, "perlio: check we can write");
+ is($io->seek(2, SEEK_SET), 2, "perlio: check we can seek");
+ is($io->write("more"), 4, "perlio: write some more");
+ is($io->seek(0, SEEK_SET), 0, "perlio: seek back to start");
+ my $data;
+ is($io->read($data, 10), 6, "perlio: read everything back");
+ is($data, "temore", "perlio: check we read back what we wrote");
+ is($io->close, 0, "perlio: close it");
+ is($foo, "temore", "perlio: check it got to the scalar properly");
+
+ my $io2 = Imager::IO->new_fh($fh);
+ ok($io2, "new_fh() can make an I/O layer object from a scalar fh");
+ close $fh;
+
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ $foo = "";
+ open my $fh2, ">", \$foo;
+ ok($im->write(fh => $fh2, type => "pnm"), "can write image to scalar fh")
+ or print "# ", $im->errstr, "\n";
+
+ close $fh2;
+ open my $fh3, "<", \$foo;
+ my $im2 = Imager->new(fh => $fh3);
+ ok($im2, "read image from a scalar fh");
+ is_image($im, $im2, "check they match");
+}
+
+{
+ tie *FOO, "IO::Tied";
+ my $io = Imager::IO->new_fh(\*FOO);
+ ok($io, "tied: make a I/O object for a tied fh");
+ is($io->write("test"), 4, "tied: check we can write");
+ is($io->seek(2, SEEK_SET), 2, "tied: check we can seek");
+ is($io->write("more"), 4, "tied: write some more");
+ is($io->seek(0, SEEK_SET), 0, "tied: seek back to start");
+ my $data;
+ is($io->read($data, 10), 6, "tied: read everything back");
+ is($data, "temore", "tied: check we read back what we wrote");
+ is($io->close, 0, "tied: close it");
+ is(tied(*FOO)->[0], "temore", "tied: check it got to the output properly");
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t07.ppm", "testout/t07iolayer.log";
+}
+
+sub eof_read {
+ my ($max_len) = @_;
+
+ return '';
+}
+
+sub good_read {
+ my ($max_len) = @_;
+
+ my $data = "testdata";
+ length $data <= $max_len or substr($data, $max_len) = '';
+
+ print "# good_read ($max_len) => $data\n";
+
+ return $data;
+}
+
+sub fail_write {
+ return;
+}
+
+sub fail_read {
+ return;
+}
+
+sub fail_seek {
+ return -1;
+}
+
+package IO::Tied;
+use base 'Tie::Handle';
+use IO::Seekable;
+
+sub TIEHANDLE {
+ return bless [ "", 0 ];
+}
+
+sub PRINT {
+ for my $entry (@_[1 .. $#_]) {
+ substr($_[0][0], $_[0][1], length $entry, $entry);
+ $_[0][1] += length $entry;
+ }
+
+ return 1;
+}
+
+sub SEEK {
+ my ($self, $offset, $whence) = @_;
+
+ my $newpos;
+ if ($whence == SEEK_SET) {
+ $newpos = $offset;
+ }
+ elsif ($whence == SEEK_CUR) {
+ $newpos = $self->[1] + $offset;
+ }
+ elsif ($whence == SEEK_END) {
+ $newpos = length($self->[0]) + $newpos;
+ }
+ else {
+ return -1;
+ }
+
+ if ($newpos < 0) {
+ return 0;
+ }
+
+ $self->[1] = $newpos;
+
+ return 1;
+}
+
+sub TELL {
+ return $_[0][1];
+}
+
+sub READ {
+ my $self = shift;
+ my $outlen = $_[1];
+ my $offset = @_ > 2 ? $_[2] : 0;
+ if ($self->[1] + $outlen > length $self->[0]) {
+ $outlen = length($self->[0]) - $self->[1];
+ $outlen <= 0
+ and return "";
+ }
+ defined $_[0] or $_[0] = "";
+ substr($_[0], $offset, $outlen) = substr($self->[0], $self->[1], $outlen);
+ $self->[1] += $outlen;
+
+ return $outlen;
+}
--- /dev/null
+#!perl -w
+
+# This file is for testing file functionality that is independent of
+# the file format
+
+use strict;
+use Test::More tests => 89;
+use Imager;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t1000files.log");
+
+SKIP:
+{
+ # Test that i_test_format_probe() doesn't pollute stdout
+
+ # Initally I tried to write this test using open to redirect files,
+ # but there was a buffering problem that made it so the data wasn't
+ # being written to the output file. This external perl call avoids
+ # that problem
+
+ my $test_script = 'testout/t1000files_probe.pl';
+
+ # build a temp test script to use
+ ok(open(SCRIPT, "> $test_script"), "open test script")
+ or skip("no test script $test_script: $!", 2);
+ print SCRIPT <<'PERL';
+#!perl
+use Imager;
+use strict;
+my $file = shift or die "No file supplied";
+open FH, "< $file" or die "Cannot open file: $!";
+binmode FH;
+my $io = Imager::io_new_fd(fileno(FH));
+Imager::i_test_format_probe($io, -1);
+PERL
+ close SCRIPT;
+ my $perl = $^X;
+ $perl = qq/"$perl"/ if $perl =~ / /;
+
+ print "# script: $test_script\n";
+ my $cmd = "$perl -Mblib $test_script t/200-file/100-files.t";
+ print "# command: $cmd\n";
+
+ my $out = `$cmd`;
+ is($?, 0, "command successful");
+ is($out, '', "output should be empty");
+}
+
+# test the file limit functions
+# by default the limits are zero (unlimited)
+print "# image file limits\n";
+is_deeply([ Imager->get_file_limits() ], [0, 0, 0x40000000 ],
+ "check defaults");
+ok(Imager->set_file_limits(width=>100), "set only width");
+is_deeply([ Imager->get_file_limits() ], [100, 0, 0x40000000 ],
+ "check width set");
+ok(Imager->set_file_limits(height=>150, bytes=>10000),
+ "set height and bytes");
+is_deeply([ Imager->get_file_limits() ], [ 100, 150, 10000 ],
+ "check all values now set");
+ok(Imager->check_file_limits(width => 100, height => 30),
+ "check 100 x 30 (def channels, sample_size) ok")
+ or diag(Imager->errstr);
+ok(Imager->check_file_limits(width => 100, height => 100, channels => 1),
+ "check 100 x 100 x 1 (def sample_size) ok")
+ or diag(Imager->errstr);
+ok(Imager->check_file_limits(width => 100, height => 100, channels => 1),
+ "check 100 x 100 x 1 (def sample_size) ok")
+ or diag(Imager->errstr);
+ok(!Imager->check_file_limits(width => 100, height => 100, channels => 1, sample_size => "float"),
+ "check 100 x 100 x 1 x float should fail");
+ok(!Imager->check_file_limits(width => 100, height => 100, channels => 0),
+ "0 channels should fail");
+is(Imager->errstr, "file size limit - channels 0 out of range",
+ "check error message");
+ok(!Imager->check_file_limits(width => 0, height => 100),
+ "0 width should fail");
+is(Imager->errstr, "file size limit - image width of 0 is not positive",
+ "check error message");
+ok(!Imager->check_file_limits(width => 100, height => 0),
+ "0 height should fail");
+is(Imager->errstr, "file size limit - image height of 0 is not positive",
+ "check error message");
+ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 0),
+ "0 sample_size should fail");
+is(Imager->errstr, "file size limit - sample_size 0 out of range",
+ "check error message");
+ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 1000),
+ "1000 sample_size should fail");
+is(Imager->errstr, "file size limit - sample_size 1000 out of range",
+ "check error message");
+ok(Imager->set_file_limits(reset=>1, height => 99),
+ "set height and reset");
+is_deeply([ Imager->get_file_limits() ], [ 0, 99, 0x40000000 ],
+ "check only height is set");
+ok(Imager->set_file_limits(reset=>1),
+ "just reset");
+is_deeply([ Imager->get_file_limits() ], [ 0, 0, 0x40000000 ],
+ "check all are reset");
+
+# bad parameters
+is_deeply([ Imager->check_file_limits() ], [],
+ "missing size paramaters");
+is(Imager->errstr, "check_file_limits: width must be defined",
+ "check message");
+is_deeply([ Imager->check_file_limits(width => 100.5) ], [],
+ "non-integer parameter");
+is(Imager->errstr, "check_file_limits: width must be a positive integer",
+ "check message");
+
+# test error handling for loading file handers
+{
+ # first, no module at all
+ {
+ my $data = "abc";
+ ok(!Imager->new(data => $data, filetype => "unknown"),
+ "try to read an unknown file type");
+ like(Imager->errstr, qr(^format 'unknown' not supported - formats .* - Can't locate Imager/File/UNKNOWN.pm or Imager/File/UNKNOWNReader.pm$),
+ "check error message");
+ }
+ {
+ my $data;
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ ok(!$im->write(data => \$data, type => "unknown"),
+ "try to write an unknown file type");
+ like($im->errstr, qr(^format 'unknown' not supported - formats .* - Can't locate Imager/File/UNKNOWN.pm or Imager/File/UNKNOWNWriter.pm$),
+ "check error message");
+ }
+ push @INC, "t/t1000lib";
+ {
+ my $data = "abc";
+ ok(!Imager->new(data => $data, filetype => "bad"),
+ "try to read an bad (other load failure) file type");
+ like(Imager->errstr, qr(^format 'bad' not supported - formats .* available for reading - This module fails to load loading Imager/File/BAD.pm$),
+ "check error message");
+ }
+ {
+ my $data;
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ ok(!$im->write(data => \$data, type => "bad"),
+ "try to write an bad file type");
+ like($im->errstr, qr(^format 'bad' not supported - formats .* available for writing - This module fails to load loading Imager/File/BAD.pm$),
+ "check error message");
+ }
+}
+
+{ # test empty image handling for write()/write_multi()
+ my $empty = Imager->new;
+ my $data;
+ ok(!$empty->write(data => \$data, type => "pnm"),
+ "fail to write an empty image");
+ is($empty->errstr, "write: empty input image", "check error message");
+ my $good = Imager->new(xsize => 1, ysize => 1);
+ ok(!Imager->write_multi({ data => \$data, type => "pnm" }, $good, $empty),
+ "fail to write_multi an empty image");
+ is(Imager->errstr, "write_multi: empty input image (image 2)");
+}
+
+# check file type probe
+probe_ok("49492A41", undef, "not quite tiff");
+probe_ok("4D4D0041", undef, "not quite tiff");
+probe_ok("49492A00", "tiff", "tiff intel");
+probe_ok("4D4D002A", "tiff", "tiff motorola");
+probe_ok("474946383961", "gif", "gif 89");
+probe_ok("474946383761", "gif", "gif 87");
+probe_ok(<<TGA, "tga", "TGA");
+00 00 0A 00 00 00 00 00 00 00 00 00 96 00 96 00
+18 20 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
+00 00 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
+00 00 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
+TGA
+
+probe_ok(<<TGA, "tga", "TGA 32-bit");
+00 00 0A 00 00 00 00 00 00 00 00 00 0A 00 0A 00
+20 08 84 00 00 00 00 84 FF FF FF FF 84 00 00 00
+00 84 FF FF FF FF 84 00 00 00 00 84 FF FF FF FF
+TGA
+
+probe_ok(<<ICO, "ico", "Windows Icon");
+00 00 01 00 02 00 20 20 10 00 00 00 00 00 E8 02
+00 00 26 00 00 00 20 20 00 00 00 00 00 00 A8 08
+00 00 0E 03 00 00 28 00 00 00 20 00 00 00 40 00
+ICO
+
+probe_ok(<<ICO, "cur", "Windows Cursor");
+00 00 02 00 02 00 20 20 10 00 00 00 00 00 E8 02
+00 00 26 00 00 00 20 20 00 00 00 00 00 00 A8 08
+00 00 0E 03 00 00 28 00 00 00 20 00 00 00 40 00
+ICO
+
+probe_ok(<<SGI, "sgi", "SGI RGB");
+01 DA 01 01 00 03 00 96 00 96 00 03 00 00 00 00
+00 00 00 FF 00 00 00 00 6E 6F 20 6E 61 6D 65 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+SGI
+
+probe_ok(<<ILBM, "ilbm", "ILBM");
+46 4F 52 4D 00 00 60 7A 49 4C 42 4D 42 4D 48 44
+00 00 00 14 00 96 00 96 00 00 00 00 18 00 01 80
+00 00 0A 0A 00 96 00 96 42 4F 44 59 00 00 60 51
+ILBM
+
+probe_ok(<<XPM, "xpm", "XPM");
+2F 2A 20 58 50 4D 20 2A 2F 0A 73 74 61 74 69 63
+20 63 68 61 72 20 2A 6E 6F 6E 61 6D 65 5B 5D 20
+3D 20 7B 0A 2F 2A 20 77 69 64 74 68 20 68 65 69
+XPM
+
+probe_ok(<<PCX, "pcx", 'PCX');
+0A 05 01 08 00 00 00 00 95 00 95 00 96 00 96 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+PCX
+
+probe_ok(<<FITS, "fits", "FITS");
+53 49 4D 50 4C 45 20 20 3D 20 20 20 20 20 20 20
+20 20 20 20 20 20 20 20 20 20 20 20 20 54 20 20
+20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
+FITS
+
+probe_ok(<<PSD, "psd", "Photoshop");
+38 42 50 53 00 01 00 00 00 00 00 00 00 06 00 00
+00 3C 00 00 00 96 00 08 00 03 00 00 00 00 00 00
+0B E6 38 42 49 4D 03 ED 00 00 00 00 00 10 00 90
+PSD
+
+probe_ok(<<EPS, "eps", "Encapsulated Postscript");
+25 21 50 53 2D 41 64 6F 62 65 2D 32 2E 30 20 45
+50 53 46 2D 32 2E 30 0A 25 25 43 72 65 61 74 6F
+72 3A 20 70 6E 6D 74 6F 70 73 0A 25 25 54 69 74
+EPS
+
+probe_ok(<<UTAH, "utah", "Utah RLE");
+52 CC 00 00 00 00 0A 00 0A 00 0A 03 08 00 08 00
+2F 00 48 49 53 54 4F 52 59 3D 70 6E 6D 74 6F 72
+6C 65 20 6F 6E 20 54 68 75 20 4D 61 79 20 31 31
+20 31 36 3A 33 35 3A 34 33 20 32 30 30 36 0A 09
+UTAH
+
+probe_ok(<<XWD, "xwd", "X Window Dump");
+00 00 00 69 00 00 00 07 00 00 00 02 00 00 00 18
+00 00 01 E4 00 00 01 3C 00 00 00 00 00 00 00 00
+00 00 00 20 00 00 00 00 00 00 00 20 00 00 00 20
+00 00 07 90 00 00 00 04 00 FF 00 00 00 00 FF 00
+XWD
+
+probe_ok(<<GZIP, "gzip", "gzip compressed");
+1F 8B 08 08 C2 81 BD 44 02 03 49 6D 61 67 65 72
+2D 30 2E 35 31 5F 30 33 2E 74 61 72 00 EC 5B 09
+40 53 C7 BA 9E 24 AC 01 D9 44 04 44 08 8B B2 8A
+C9 C9 42 92 56 41 50 20 A0 02 41 41 01 17 48 80
+GZIP
+
+probe_ok(<<BZIP2, "bzip2", "bzip2 compressed");
+42 5A 68 39 31 41 59 26 53 59 0F D8 8C 09 00 03
+28 FF FF FF FF FB 7F FB 77 FF EF BF 6B 7F BE FF
+FF DF EE C8 0F FF F3 FF FF FF FC FF FB B1 FF FB
+F4 07 DF D0 03 B8 03 60 31 82 05 2A 6A 06 83 20
+BZIP2
+
+probe_ok(<<WEBP, "webp", "Google WEBP");
+52 49 46 46 2C 99 00 00 57 45 42 50 56 50 38 20
+20 99 00 00 70 7A 02 9D 01 2A E0 01 80 02 00 87
+08 85 85 88 85 84 88 88 83 AF E2 F7 64 1F 98 55
+1B 6A 70 F5 8A 45 09 95 0C 09 7E 25 D9 2E 46 44
+07 84 FB 01 FD 2C 8A 2F 97 CC ED DB 50 0F 11 3B
+WEBP
+
+probe_ok(<<JPEG2K, "jp2", "JPEG 2000");
+00 00 00 0C 6A 50 20 20 0D 0A 87 0A 00 00 00 14
+66 74 79 70 6A 70 32 20 00 00 00 00 6A 70 32 20
+00 00 00 2D 6A 70 32 68 00 00 00 16 69 68 64 72
+00 00 02 80 00 00 01 E0 00 03 07 07 00 00 00 00
+00 0F 63 6F 6C 72 01 00 00 00 00 00 10 00 00 00
+00 6A 70 32 63 FF 4F FF 51 00 2F 00 00 00 00 01
+JPEG2K
+
+{ # RT 72475
+ # check error messages from read/read_multi
+ my $data = "nothing useful";
+ my @mult_data = Imager->read_multi(data => $data);
+ is(@mult_data, 0, "read_multi with non-image input data should fail");
+ is(Imager->errstr,
+ "type parameter missing and it couldn't be determined from the file contents",
+ "check the error message");
+
+ my @mult_file = Imager->read_multi(file => "t/200-file/100-files.t");
+ is(@mult_file, 0, "read_multi with non-image filename should fail");
+ is(Imager->errstr,
+ "type parameter missing and it couldn't be determined from the file contents or file name",
+ "check the error message");
+
+ my $im = Imager->new;
+ ok(!$im->read(data => $data), "read from non-image data should fail");
+ is($im->errstr,
+ "type parameter missing and it couldn't be determined from the file contents",
+ "check the error message");
+
+ ok(!$im->read(file => "t/200-file/100-files.t"),
+ "read from non-image file should fail");
+ is($im->errstr,
+ "type parameter missing and it couldn't be determined from the file contents or file name",
+ "check the error message");
+}
+
+{
+ # test def_guess_type
+ my @tests =
+ (
+ pnm => "pnm",
+ GIF => "gif",
+ tif => "tiff",
+ TIFF => "tiff",
+ JPG => "jpeg",
+ rle => "utah",
+ bmp => "bmp",
+ dib => "bmp",
+ rgb => "sgi",
+ BW => "sgi",
+ TGA => "tga",
+ CUR => "cur",
+ ico => "ico",
+ ILBM => "ilbm",
+ pcx => "pcx",
+ psd => "psd",
+ );
+
+ while (my ($ext, $expect) = splice(@tests, 0, 2)) {
+ my $filename = "foo.$ext";
+ is(Imager::def_guess_type($filename), $expect,
+ "type for $filename should be $expect");
+ }
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t1000files.log";
+}
+
+sub probe_ok {
+ my ($packed, $exp_type, $name) = @_;
+
+ my $builder = Test::Builder->new;
+ $packed =~ tr/ \r\n//d; # remove whitespace used for layout
+ my $data = pack("H*", $packed);
+
+ my $io = Imager::io_new_buffer($data);
+ my $result = Imager::i_test_format_probe($io, -1);
+
+ return $builder->is_eq($result, $exp_type, $name)
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+use Imager qw(:all);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t101jpeg.log");
+
+$Imager::formats{"jpeg"}
+ and plan skip_all => "have jpeg support - this tests the lack of it";
+
+plan tests => 6;
+
+my $im = Imager->new;
+ok(!$im->read(file=>"testimg/base.jpg"), "should fail to read jpeg");
+cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
+$im = Imager->new(xsize=>2, ysize=>2);
+ok(!$im->write(file=>"testout/nojpeg.jpg"), "should fail to write jpeg");
+cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
+ok(!grep($_ eq 'jpeg', Imager->read_types), "check jpeg not in read types");
+ok(!grep($_ eq 'jpeg', Imager->write_types), "check jpeg not in write types");
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t101jpeg.log";
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager qw(:all);
+use Test::More;
+
+$Imager::formats{"png"}
+ and plan skip_all => "png available, and this tests the lack of it";
+
+plan tests => 6;
+
+my $im = Imager->new;
+ok(!$im->read(file=>"testimg/test.png"), "should fail to read png");
+cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
+$im = Imager->new(xsize=>2, ysize=>2);
+ok(!$im->write(file=>"testout/nopng.png"), "should fail to write png");
+cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
+ok(!grep($_ eq 'png', Imager->read_types), "check png not in read types");
+ok(!grep($_ eq 'png', Imager->write_types), "check png not in write types");
+
--- /dev/null
+#!perl -w
+use strict;
+$|=1;
+use Test::More;
+use Imager qw(:all);
+
+$Imager::formats{"gif"}
+ and plan skip_all => "gif support available and this tests the lack of it";
+
+plan tests => 12;
+
+my $im = Imager->new;
+ok(!$im->read(file=>"GIF/testimg/scale.gif"), "should fail to read gif");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+ "check no gif message");
+ok(!Imager->read_multi(file=>"GIF/testimg/scale.gif"),
+ "should fail to read multi gif");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+ "check no gif message");
+
+$im = Imager->new(xsize=>2, ysize=>2);
+
+ok(!$im->write(file=>"testout/nogif.gif"), "should fail to write gif");
+ok(!-e "testout/nogif.gif", "shouldn't create the file");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+ "check no gif message");
+
+ok(!Imager->write_multi({file => "testout/nogif.gif"}, $im, $im),
+ "should fail to write multi gif");
+ok(!-e "testout/nogif.gif", "shouldn't create the file");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+ "check no gif message");
+
+ok(!grep($_ eq 'gif', Imager->read_types), "check gif not in read types");
+ok(!grep($_ eq 'gif', Imager->write_types), "check gif not in write types");
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+use Imager qw(:all);
+
+$Imager::formats{"tiff"}
+ and plan skip_all => "tiff support available - this tests the lack of it";
+
+plan tests => 12;
+
+my $im = Imager->new;
+
+ok(!$im->read(file=>"TIFF/testimg/comp4.tif"), "should fail to read tif");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+ "check no tiff message");
+
+ok(!$im->read_multi(file => "TIFF/testimg/comp4.tif"),
+ "should fail to read multi tiff");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+ "check no tiff message");
+
+$im = Imager->new(xsize=>2, ysize=>2);
+
+ok(!$im->write(file=>"testout/notiff.tif"), "should fail to write tiff");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+ "check no tiff message");
+ok(!-e "testout/notiff.tif", "file shouldn't be created");
+
+ok(!Imager->write_multi({file=>"testout/notiff.tif"}, $im, $im),
+ "should fail to write multi tiff");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+ "check no tiff message");
+ok(!-e "testout/notiff.tif", "file shouldn't be created");
+
+ok(!grep($_ eq 'tiff', Imager->read_types), "check tiff not in read types");
+ok(!grep($_ eq 'tiff', Imager->write_types), "check tiff not in write types");
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 53;
+use Imager qw(:all);
+use Imager::Test qw/is_color3 is_color4 test_image test_image_mono/;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t103raw.log");
+
+$| = 1;
+
+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 $img=Imager::ImgRaw::new(150,150,3);
+my $cmpimg=Imager::ImgRaw::new(150,150,3);
+
+i_box_filled($img,70,25,130,125,$green);
+i_box_filled($img,20,25,80,125,$blue);
+i_arc($img,75,75,30,0,361,$red);
+i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
+
+my $timg = Imager::ImgRaw::new(20, 20, 4);
+my $trans = i_color_new(255, 0, 0, 127);
+i_box_filled($timg, 0, 0, 20, 20, $green);
+i_box_filled($timg, 2, 2, 18, 18, $trans);
+
+open(FH,">testout/t103.raw") || die "Cannot open testout/t103.raw for writing\n";
+binmode(FH);
+my $IO = Imager::io_new_fd( fileno(FH) );
+ok(i_writeraw_wiol($img, $IO), "write raw low") or
+ print "# Cannot write testout/t103.raw\n";
+close(FH);
+
+open(FH,"testout/t103.raw") || die "Cannot open testout/t103.raw\n";
+binmode(FH);
+$IO = Imager::io_new_fd( fileno(FH) );
+$cmpimg = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
+ok($cmpimg, "read raw low")
+ or print "# Cannot read testout/t103.raw\n";
+close(FH);
+
+print "# raw average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
+
+# I could have kept the raw images for these tests in binary files in
+# testimg/, but I think keeping them as hex encoded data in here makes
+# it simpler to add more if necessary
+# Later we may change this to read from a scalar instead
+save_data('testout/t103_base.raw');
+save_data('testout/t103_3to4.raw');
+save_data('testout/t103_line_int.raw');
+save_data('testout/t103_img_int.raw');
+
+# load the base image
+open FH, "testout/t103_base.raw"
+ or die "Cannot open testout/t103_base.raw: $!";
+binmode FH;
+$IO = Imager::io_new_fd( fileno(FH) );
+
+my $baseimg = i_readraw_wiol( $IO, 4, 4, 3, 3, 0);
+ok($baseimg, "read base raw image")
+ or die "Cannot read base raw image";
+close FH;
+
+# the actual read tests
+# each read_test() call does 2 tests:
+# - check if the read succeeds
+# - check if it matches $baseimg
+read_test('testout/t103_3to4.raw', 4, 4, 4, 3, 0, $baseimg);
+read_test('testout/t103_line_int.raw', 4, 4, 3, 3, 1, $baseimg);
+# intrl==2 is documented in raw.c but doesn't seem to be implemented
+#read_test('testout/t103_img_int.raw', 4, 4, 3, 3, 2, $baseimg, 7);
+
+# paletted images
+SKIP:
+{
+ my $palim = Imager::i_img_pal_new(20, 20, 3, 256);
+ ok($palim, "make paletted image")
+ or skip("couldn't make paletted image", 2);
+ my $redindex = Imager::i_addcolors($palim, $red);
+ my $blueindex = Imager::i_addcolors($palim, $blue);
+ for my $y (0..9) {
+ Imager::i_ppal($palim, 0, $y, ($redindex) x 20);
+ }
+ for my $y (10..19) {
+ Imager::i_ppal($palim, 0, $y, ($blueindex) x 20);
+ }
+ open FH, "> testout/t103_pal.raw"
+ or die "Cannot create testout/t103_pal.raw: $!";
+ binmode FH;
+ $IO = Imager::io_new_fd(fileno(FH));
+ ok(i_writeraw_wiol($palim, $IO), "write low paletted");
+ close FH;
+
+ open FH, "testout/t103_pal.raw"
+ or die "Cannot open testout/t103_pal.raw: $!";
+ binmode FH;
+ my $data = do { local $/; <FH> };
+ is($data, "\x0" x 200 . "\x1" x 200, "compare paletted data written");
+ close FH;
+}
+
+# 16-bit image
+# we don't have 16-bit reads yet
+SKIP:
+{
+ my $img16 = Imager::i_img_16_new(150, 150, 3);
+ ok($img16, "make 16-bit/sample image")
+ or skip("couldn't make 16 bit/sample image", 1);
+ i_box_filled($img16,70,25,130,125,$green);
+ i_box_filled($img16,20,25,80,125,$blue);
+ i_arc($img16,75,75,30,0,361,$red);
+ i_conv($img16,[0.1, 0.2, 0.4, 0.2, 0.1]);
+
+ open FH, "> testout/t103_16.raw"
+ or die "Cannot create testout/t103_16.raw: $!";
+ binmode FH;
+ $IO = Imager::io_new_fd(fileno(FH));
+ ok(i_writeraw_wiol($img16, $IO), "write low 16 bit image");
+ close FH;
+}
+
+# try a simple virtual image
+SKIP:
+{
+ my $maskimg = Imager::i_img_masked_new($img, undef, 0, 0, 150, 150);
+ ok($maskimg, "make masked image")
+ or skip("couldn't make masked image", 3);
+
+ open FH, "> testout/t103_virt.raw"
+ or die "Cannot create testout/t103_virt.raw: $!";
+ binmode FH;
+ $IO = Imager::io_new_fd(fileno(FH));
+ ok(i_writeraw_wiol($maskimg, $IO), "write virtual raw");
+ close FH;
+
+ open FH, "testout/t103_virt.raw"
+ or die "Cannot open testout/t103_virt.raw: $!";
+ binmode FH;
+ $IO = Imager::io_new_fd(fileno(FH));
+ my $cmpimgmask = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
+ ok($cmpimgmask, "read result of masked write");
+ my $diff = i_img_diff($maskimg, $cmpimgmask);
+ print "# difference for virtual image $diff\n";
+ is($diff, 0, "compare masked to read");
+
+ # check that i_format is set correctly
+ my $index = Imager::i_tags_find($cmpimgmask, 'i_format', 0);
+ if ($index) {
+ my $value = Imager::i_tags_get($cmpimgmask, $index);
+ is($value, 'raw', "check i_format value");
+ }
+ else {
+ fail("couldn't find i_format tag");
+ }
+}
+
+{ # error handling checks
+ # should get an error writing to a open for read file
+ # make a empty file
+ open RAW, "> testout/t103_empty.raw"
+ or die "Cannot create testout/t103_empty.raw: $!";
+ close RAW;
+ open RAW, "< testout/t103_empty.raw"
+ or die "Cannot open testout/t103_empty.raw: $!";
+ my $im = Imager->new(xsize => 50, ysize=>50);
+ ok(!$im->write(fh => \*RAW, type => 'raw', buffered => 0),
+ "write to open for read handle");
+ cmp_ok($im->errstr, '=~', '^Could not write to file: write\(\) failure',
+ "check error message");
+ close RAW;
+
+ # should get an error reading an empty file
+ ok(!$im->read(file => 'testout/t103_empty.raw', xsize => 50, ysize=>50, type=>'raw', interleave => 1),
+ 'read an empty file');
+ is($im->errstr, 'premature end of file', "check message");
+ SKIP:
+ {
+ # see 862083f7e40bc2a9e3b94aedce56c1336e7bdb25 in perl5 git
+ $] >= 5.010
+ or skip "5.8.x and earlier don't treat a read on a WRONLY file as an error", 2;
+ open RAW, "> testout/t103_empty.raw"
+ or die "Cannot create testout/t103_empty.raw: $!";
+ ok(!$im->read(fh => \*RAW, , xsize => 50, ysize=>50, type=>'raw', interleave => 1),
+ 'read a file open for write');
+ cmp_ok($im->errstr, '=~', '^error reading file: read\(\) failure', "check message");
+ }
+}
+
+
+{
+ ok(grep($_ eq 'raw', Imager->read_types), "check raw in read types");
+ ok(grep($_ eq 'raw', Imager->write_types), "check raw in write types");
+}
+
+
+{ # OO no interleave warning
+ my $im = Imager->new;
+ my $msg;
+ local $SIG{__WARN__} = sub { $msg = "@_" };
+ ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4,
+ type => "raw"),
+ "read without interleave parameter")
+ or print "# ", $im->errstr, "\n";
+ ok($msg, "should have warned");
+ like($msg, qr/interleave/, "check warning is ok");
+ # check we got the right value
+ is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
+ "check the image was read correctly");
+
+ # check no warning if either is supplied
+ $im = Imager->new;
+ undef $msg;
+ ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", interleave => 0),
+ "read with interleave 0");
+ is($msg, undef, "no warning");
+ is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
+ "check read non-interleave");
+
+ $im = Imager->new;
+ undef $msg;
+ ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 0),
+ "read with raw_interleave 0");
+ is($msg, undef, "no warning");
+ is_color3($im->getpixel(x => 1, y => 0), 0x01, 0x12, 0x23,
+ "check read non-interleave");
+
+ # make sure set to 1 is sane
+ $im = Imager->new;
+ undef $msg;
+ ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 1),
+ "read with raw_interleave 1");
+ is($msg, undef, "no warning");
+ is_color3($im->getpixel(x => 2, y => 0), 0x02, 0x13, 0x24,
+ "check read interleave = 1");
+}
+
+{ # invalid interleave error handling
+ my $im = Imager->new;
+ ok(!$im->read(file => "testout/t103_base.raw", raw_interleave => 2, type => "raw", xsize => 4, ysize => 4),
+ "invalid interleave");
+ is($im->errstr, "raw_interleave must be 0 or 1", "check message");
+}
+
+{ # store/data channel behaviour
+ my $im = Imager->new;
+ ok($im->read(file => "testout/t103_3to4.raw", xsize => 4, ysize => 4,
+ raw_datachannels => 4, raw_interleave => 0, type => "raw"),
+ "read 4 channel file as 3 channels")
+ or print "# ", $im->errstr, "\n";
+ is_color3($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34,
+ "check read correctly");
+}
+
+{ # should fail to read with storechannels > 4
+ my $im = Imager->new;
+ ok(!$im->read(file => "testout/t103_line_int.raw", type => "raw",
+ raw_interleave => 1, xsize => 4, ysize => 4,
+ raw_storechannels => 5),
+ "read with large storechannels");
+ is($im->errstr, "raw_storechannels must be between 1 and 4",
+ "check error message");
+}
+
+{ # should zero spare channels if storechannels > datachannels
+ my $im = Imager->new;
+ ok($im->read(file => "testout/t103_base.raw", type => "raw",
+ raw_interleave => 0, xsize => 4, ysize => 4,
+ raw_storechannels => 4),
+ "read with storechannels > datachannels");
+ is($im->getchannels, 4, "should have 4 channels");
+ is_color4($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34, 0x00,
+ "check last channel zeroed");
+}
+
+{
+ my @ims = ( basic => test_image(), mono => test_image_mono() );
+ push @ims, masked => test_image()->masked();
+
+ my $fail_close = sub {
+ Imager::i_push_error(0, "synthetic close failure");
+ return 0;
+ };
+
+ while (my ($type, $im) = splice(@ims, 0, 2)) {
+ my $io = Imager::io_new_cb(sub { 1 }, undef, undef, $fail_close);
+ ok(!$im->write(io => $io, type => "raw"),
+ "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/t103raw.log";
+ unlink(qw(testout/t103_base.raw testout/t103_3to4.raw
+ testout/t103_line_int.raw testout/t103_img_int.raw))
+}
+
+sub read_test {
+ my ($in, $xsize, $ysize, $data, $store, $intrl, $base) = @_;
+ open FH, $in or die "Cannot open $in: $!";
+ binmode FH;
+ my $IO = Imager::io_new_fd( fileno(FH) );
+
+ my $img = i_readraw_wiol($IO, $xsize, $ysize, $data, $store, $intrl);
+ SKIP:
+ {
+ ok($img, "read_test $in read")
+ or skip("couldn't read $in", 1);
+ is(i_img_diff($img, $baseimg), 0, "read_test $in compare");
+ }
+}
+
+sub save_data {
+ my $outname = shift;
+ my $data = load_data();
+ open FH, "> $outname" or die "Cannot create $outname: $!";
+ binmode FH;
+ print FH $data;
+ close FH;
+}
+
+sub load_data {
+ my $hex = '';
+ while (<DATA>) {
+ next if /^#/;
+ last if /^EOF/;
+ chomp;
+ $hex .= $_;
+ }
+ $hex =~ tr/ //d;
+ my $result = pack("H*", $hex);
+ #print unpack("H*", $result),"\n";
+ return $result;
+}
+
+# FIXME: may need tests for 1,2,4 channel images
+
+__DATA__
+# we keep some packed raw images here
+# we decode this in the code, ignoring lines starting with #, a subfile
+# ends with EOF, data is HEX encoded (spaces ignored)
+
+# basic 3 channel version of the image
+001122 011223 021324 031425
+102132 112233 122334 132435
+203142 213243 223344 233445
+304152 314253 324354 334455
+EOF
+
+# test image for reading a 4 channel image into a 3 channel image
+# 4 x 4 pixels
+00112233 01122334 02132435 03142536
+10213243 11223344 12233445 13243546
+20314253 21324354 22334455 23344556
+30415263 31425364 32435465 33445566
+EOF
+
+# test image for line based interlacing
+# 4 x 4 pixels
+# first line
+00 01 02 03
+11 12 13 14
+22 23 24 25
+
+# second line
+10 11 12 13
+21 22 23 24
+32 33 34 35
+
+# third line
+20 21 22 23
+31 32 33 34
+42 43 44 45
+
+# fourth line
+30 31 32 33
+41 42 43 44
+52 53 54 55
+
+EOF
+
+# test image for image based interlacing
+# first channel
+00 01 02 03
+10 11 12 13
+20 21 22 23
+30 31 32 33
+
+# second channel
+11 12 13 14
+21 22 23 24
+31 32 33 34
+41 42 43 44
+
+# third channel
+22 23 24 25
+32 33 34 35
+42 43 44 45
+52 53 54 55
+
+EOF
--- /dev/null
+#!perl -w
+use Imager ':all';
+use Test::More tests => 205;
+use strict;
+use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image test_image_named);
+
+$| = 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";
+close($fh);
+
+$IO = Imager::io_new_bufchain();
+ok(i_writeppm_wiol($img, $IO), "write to bufchain")
+ or die "Cannot write to bufchain";
+my $data = Imager::io_slurp($IO);
+
+$fh = openimage("testout/t104.ppm");
+$IO = Imager::io_new_fd( fileno($fh) );
+my $cmpimg = i_readpnm_wiol($IO,-1);
+ok($cmpimg, "read image we wrote")
+ or die "Cannot read testout/t104.ppm\n";
+close($fh);
+
+is(i_img_diff($img, $cmpimg), 0, "compare written and read images");
+
+my $rdata = slurp("testout/t104.ppm");
+is($data, $rdata, "check data read from file and bufchain data");
+
+# build a grayscale image
+my $gimg = Imager::ImgRaw::new(150, 150, 1);
+my $gray = i_color_new(128, 0, 0, 255);
+my $dgray = i_color_new(64, 0, 0, 255);
+my $white = i_color_new(255, 0, 0, 255);
+i_box_filled($gimg, 20, 20, 130, 130, $gray);
+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));
+ok(i_writeppm_wiol($gimg, $IO), "write grayscale");
+close FH;
+
+open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
+binmode FH;
+$IO = Imager::io_new_fd(fileno(FH));
+my $gcmpimg = i_readpnm_wiol($IO, -1);
+ok($gcmpimg, "read grayscale");
+is(i_img_diff($gimg, $gcmpimg), 0,
+ "compare written and read greyscale images");
+
+my $ooim = Imager->new;
+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_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 0), 255);
+check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 1), 0);
+is($ooim->type, 'paletted', "check pbm read as paletted");
+is($ooim->tags(name=>'pnm_type'), 1, "check pnm_type tag");
+
+{
+ # https://rt.cpan.org/Ticket/Display.html?id=7465
+ # the pnm reader ignores the maxval that it reads from the pnm file
+ my $maxval = Imager->new;
+ ok($maxval->read(file=>"testimg/maxval.ppm"),
+ "read testimg/maxval.ppm");
+
+ # this image contains three pixels, with each sample from 0 to 63
+ # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
+
+ # check basic parameters
+ is($maxval->getchannels, 3, "channel count");
+ is($maxval->getwidth, 3, "width");
+ is($maxval->getheight, 1, "height");
+
+ # check the pixels
+ ok(my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
+ is_color3($white, 255, 255, 255, "white pixel");
+ is_color3($grey, 130, 130, 130, "grey pixel");
+ is_color3($green, 125, 125, 0, "green pixel");
+ is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
+
+ # and do the same for ASCII images
+ my $maxval_asc = Imager->new;
+ ok($maxval_asc->read(file=>"testimg/maxval_asc.ppm"),
+ "read testimg/maxval_asc.ppm");
+
+ # this image contains three pixels, with each sample from 0 to 63
+ # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
+
+ # check basic parameters
+ is($maxval_asc->getchannels, 3, "channel count");
+ is($maxval_asc->getwidth, 3, "width");
+ is($maxval_asc->getheight, 1, "height");
+
+ is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
+
+ # check the pixels
+ ok(my ($white_asc, $grey_asc, $green_asc) = $maxval_asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
+ is_color3($white_asc, 255, 255, 255, "white asc pixel");
+ is_color3($grey_asc, 130, 130, 130, "grey asc pixel");
+ is_color3($green_asc, 125, 125, 0, "green asc pixel");
+}
+
+{ # previously we didn't validate maxval at all, make sure it's
+ # validated now
+ my $maxval0 = Imager->new;
+ ok(!$maxval0->read(file=>'testimg/maxval_0.ppm'),
+ "should fail to read maxval 0 image");
+ print "# ", $maxval0->errstr, "\n";
+ like($maxval0->errstr, qr/maxval is zero - invalid pnm file/,
+ "error expected from reading maxval_0.ppm");
+
+ my $maxval65536 = Imager->new;
+ ok(!$maxval65536->read(file=>'testimg/maxval_65536.ppm'),
+ "should fail reading maxval 65536 image");
+ print "# ",$maxval65536->errstr, "\n";
+ like($maxval65536->errstr, qr/maxval of 65536 is over 65535 - invalid pnm file/,
+ "error expected from reading maxval_65536.ppm");
+
+ # maxval of 256 is valid, and handled as of 0.56
+ my $maxval256 = Imager->new;
+ ok($maxval256->read(file=>'testimg/maxval_256.ppm'),
+ "should succeed reading maxval 256 image");
+ is_color3($maxval256->getpixel(x => 0, 'y' => 0),
+ 0, 0, 0, "check black in maxval_256");
+ is_color3($maxval256->getpixel(x => 0, 'y' => 1),
+ 255, 255, 255, "check white in maxval_256");
+ is($maxval256->bits, 16, "check bits/sample on maxval 256");
+
+ # make sure we handle maxval > 255 for ascii
+ my $maxval4095asc = Imager->new;
+ ok($maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'),
+ "read maxval_4095_asc.ppm");
+ is($maxval4095asc->getchannels, 3, "channels");
+ is($maxval4095asc->getwidth, 3, "width");
+ is($maxval4095asc->getheight, 1, "height");
+ is($maxval4095asc->bits, 16, "check bits/sample on maxval 4095");
+
+ ok(my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
+ is_color3($white, 255, 255, 255, "white 4095 pixel");
+ is_color3($grey, 128, 128, 128, "grey 4095 pixel");
+ is_color3($green, 127, 127, 0, "green 4095 pixel");
+}
+
+{ # check i_format is set when reading a pnm file
+ # doesn't really matter which file.
+ my $maxval = Imager->new;
+ ok($maxval->read(file=>"testimg/maxval.ppm"),
+ "read test file");
+ my ($type) = $maxval->tags(name=>'i_format');
+ is($type, 'pnm', "check i_format");
+}
+
+{ # check file limits are checked
+ my $limit_file = "testout/t104.ppm";
+ ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
+ my $im = Imager->new;
+ ok(!$im->read(file=>$limit_file),
+ "should fail read due to size limits");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/image width/, "check message");
+
+ ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
+ ok(!$im->read(file=>$limit_file),
+ "should fail read due to size limits");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/image height/, "check message");
+
+ ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside width limit");
+ ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside height limit");
+
+ # 150 x 150 x 3 channel image uses 67500 bytes
+ ok(Imager->set_file_limits(reset=>1, bytes=>67499),
+ "set bytes limit 67499");
+ ok(!$im->read(file=>$limit_file),
+ "should fail - too many bytes");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/storage size/, "check error message");
+ ok(Imager->set_file_limits(reset=>1, bytes=>67500),
+ "set bytes limit 67500");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside bytes limit");
+ Imager->set_file_limits(reset=>1);
+}
+
+{
+ # check we correctly sync with the data stream
+ my $im = Imager->new;
+ ok($im->read(file => 'testimg/pgm.pgm', type => 'pnm'),
+ "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;
+ ok(!$im->read(file=>'t/200-file/310-pnm.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'),
+ "fail to read short bin ppm");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/short_bin16.ppm', type=>'pnm'),
+ "fail to read short bin ppm (maxval 65535)");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/short_bin.pgm', type=>'pnm'),
+ "fail to read short bin pgm");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/short_bin16.pgm', type=>'pnm'),
+ "fail to read short bin pgm (maxval 65535)");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/short_bin.pbm', type => 'pnm'),
+ "fail to read a short bin pbm");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/short_asc.ppm', type => 'pnm'),
+ "fail to read a short asc ppm");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/short_asc.pgm', type => 'pnm'),
+ "fail to read a short asc pgm");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/short_asc.pbm', type => 'pnm'),
+ "fail to read a short asc pbm");
+ cmp_ok($im->errstr, '=~', 'short read - file truncated',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/bad_asc.ppm', type => 'pnm'),
+ "fail to read a bad asc ppm");
+ cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/bad_asc.pgm', type => 'pnm'),
+ "fail to read a bad asc pgm");
+ cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok(!$im->read(file => 'testimg/bad_asc.pbm', type => 'pnm'),
+ "fail to read a bad asc pbm");
+ cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
+ "check error message");
+}
+
+{
+ my $im = Imager->new;
+ ok($im->read(file => 'testimg/short_bin.ppm', type => 'pnm',
+ 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_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");
+ is($im->bits, 16, "check correct bits");
+}
+
+{
+ my $im = Imager->new;
+ ok($im->read(file => 'testimg/short_bin.pgm', type => 'pnm',
+ 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_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_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_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_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_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_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_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_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, 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");
+
+ # check it
+ my $imread = Imager->new;
+ ok($imread->read(file => 'testout/t104_mono.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");
+}
+
+{
+ 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");
+}
+
+{
+ print "# 16-bit output\n";
+ my $data;
+ my $im = test_image_16();
+
+ # without tag, it should do 8-bit output
+ ok($im->write(data => \$data, type => 'pnm'),
+ "write 16-bit image as 8-bit/sample ppm");
+ my $im8 = Imager->new;
+ ok($im8->read(data => $data), "read it back");
+ is($im8->tags(name => 'pnm_maxval'), 255, "check maxval");
+ is_image($im, $im8, "check image matches");
+
+ # try 16-bit output
+ $im->settag(name => 'pnm_write_wide_data', value => 1);
+ $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);
+ open(FH, $fname) or die "Cannot open $fname: $!\n";
+ binmode(FH);
+ return *FH;
+}
+
+sub slurp {
+ my $fh = openimage(shift);
+ local $/;
+ my $data = <$fh>;
+ close($fh);
+ return $data;
+}
+
+sub check_gray {
+ my ($c, $gray) = @_;
+
+ my ($g) = $c->rgba;
+ is($g, $gray, "compare gray");
+}
+
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 215;
+use Imager qw(:all);
+use Imager::Test qw(test_image_raw is_image is_color3 test_image);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t107bmp.log");
+
+my @files;
+my $debug_writes = 0;
+
+my $base_diff = 0;
+# if you change this make sure you generate new compressed versions
+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 $img = test_image_raw();
+
+Imager::i_tags_add($img, 'i_xres', 0, '300', 0);
+Imager::i_tags_add($img, 'i_yres', 0, undef, 300);
+write_test($img, "testout/t107_24bit.bmp");
+push @files, "t107_24bit.bmp";
+# 'webmap' is noticably faster than the default
+my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
+ translate=>'errdiff'});
+write_test($im8, "testout/t107_8bit.bmp");
+push @files, "t107_8bit.bmp";
+# use a fixed palette so we get reproducible results for the compressed
+# version
+my @pal16 = map { NC($_) }
+ qw(605844 966600 0148b2 00f800 bf0a33 5e009e
+ 2ead1b 0000f8 004b01 fd0000 0e1695 000002);
+my $im4 = Imager::i_img_to_pal($img, { colors=>\@pal16, make_colors=>'none' });
+write_test($im4, "testout/t107_4bit.bmp");
+push @files, "t107_4bit.bmp";
+my $im1 = Imager::i_img_to_pal($img, { colors=>[ NC(0, 0, 0), NC(176, 160, 144) ],
+ make_colors=>'none', translate=>'errdiff' });
+write_test($im1, "testout/t107_1bit.bmp");
+push @files, "t107_1bit.bmp";
+my $bi_rgb = 0;
+my $bi_rle8 = 1;
+my $bi_rle4 = 2;
+my $bi_bitfields = 3;
+read_test("testout/t107_24bit.bmp", $img,
+ bmp_compression=>0, bmp_bit_count => 24);
+read_test("testout/t107_8bit.bmp", $im8,
+ bmp_compression=>0, bmp_bit_count => 8);
+read_test("testout/t107_4bit.bmp", $im4,
+ bmp_compression=>0, bmp_bit_count => 4);
+read_test("testout/t107_1bit.bmp", $im1, bmp_compression=>0,
+ bmp_bit_count=>1);
+# the following might have slight differences
+$base_diff = i_img_diff($img, $im8) * 2;
+print "# base difference $base_diff\n";
+read_test("testimg/comp4.bmp", $im4,
+ bmp_compression=>$bi_rle4, bmp_bit_count => 4);
+read_test("testimg/comp8.bmp", $im8,
+ bmp_compression=>$bi_rle8, bmp_bit_count => 8);
+
+my $imoo = Imager->new;
+# read via OO
+ok($imoo->read(file=>'testout/t107_24bit.bmp'), "read via OO")
+ or print "# ",$imoo->errstr,"\n";
+
+ok($imoo->write(file=>'testout/t107_oo.bmp'), "write via OO")
+ or print "# ",$imoo->errstr,"\n";
+push @files, "t107_oo.bmp";
+
+# various invalid format tests
+# we have so many different test images to try to detect all the possible
+# failure paths in the code, adding these did detect real problems
+print "# catch various types of invalid bmp files\n";
+my @tests =
+ (
+ # entries in each array ref are:
+ # - basename of an invalid BMP file
+ # - error message that should be produced
+ # - description of what is being tested
+ # - possible flag to indicate testing only on 32-bit machines
+ [ 'badplanes.bmp', 'not a BMP file', "invalid planes value" ],
+ [ 'badbits.bmp', 'unknown bit count for BMP file (5)',
+ 'should fail to read invalid bits' ],
+
+ # 1-bit/pixel BMPs
+ [ 'badused1.bmp', 'out of range colors used (3)',
+ 'out of range palette size (1-bit)' ],
+ [ 'badcomp1.bmp', 'unknown 1-bit BMP compression (1)',
+ 'invalid compression value (1-bit)' ],
+ [ 'bad1wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (1-bit)' ],
+ [ 'bad4oflow.bmp',
+ 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (1-bit)', '32bitonly' ],
+ [ 'short1.bmp', 'failed reading 1-bit bmp data',
+ 'short 1-bit' ],
+
+ # 4-bit/pixel BMPs
+ [ 'badused4a.bmp', 'out of range colors used (272)',
+ 'should fail to read invalid pal size (272) (4-bit)' ],
+ [ 'badused4b.bmp', 'out of range colors used (17)',
+ 'should fail to read invalid pal size (17) (4-bit)' ],
+ [ 'badcomp4.bmp', 'unknown 4-bit BMP compression (1)',
+ 'invalid compression value (4-bit)' ],
+ [ 'short4.bmp', 'failed reading 4-bit bmp data',
+ 'short uncompressed 4-bit' ],
+ [ 'short4rle.bmp', 'missing data during decompression',
+ 'short compressed 4-bit' ],
+ [ 'bad4wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (4-bit)' ],
+ [ 'bad4widbig.bmp', 'file size limit - image width of -2147483628 is not positive',
+ 'width big (4-bit)' ],
+ [ 'bad4oflow.bmp', 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (4-bit)', '32bitonly' ],
+
+ # 8-bit/pixel BMPs
+ [ 'bad8useda.bmp', 'out of range colors used (257)',
+ 'should fail to read invalid pal size (8-bit)' ],
+ [ 'bad8comp.bmp', 'unknown 8-bit BMP compression (2)',
+ 'invalid compression value (8-bit)' ],
+ [ 'short8.bmp', 'failed reading 8-bit bmp data',
+ 'short uncompressed 8-bit' ],
+ [ 'short8rle.bmp', 'missing data during decompression',
+ 'short compressed 8-bit' ],
+ [ 'bad8wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (8-bit)' ],
+ [ 'bad8oflow.bmp', 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (8-bit)', '32bitonly' ],
+
+ # 24-bit/pixel BMPs
+ [ 'short24.bmp', 'failed reading image data',
+ 'short 24-bit' ],
+ [ 'bad24wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (24-bit)' ],
+ [ 'bad24oflow.bmp', 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (24-bit)', '32bitonly' ],
+ [ 'bad24comp.bmp', 'unknown 24-bit BMP compression (4)',
+ 'bad compression (24-bit)' ],
+ );
+use Config;
+my $ptrsize = $Config{ptrsize};
+for my $test (@tests) {
+ my ($file, $error, $comment, $bit32only) = @$test;
+ SKIP:
+ {
+ skip("only tested on 32-bit machines", 2)
+ if $bit32only && $ptrsize != 4;
+ ok(!$imoo->read(file=>"testimg/$file"), $comment);
+ print "# ", $imoo->errstr, "\n";
+ is($imoo->errstr, $error, "check error message");
+ }
+}
+
+# previously we didn't seek to the offbits position before reading
+# the image data, check we handle it correctly
+# in each case the first is an original image with a given number of
+# bits and the second is the same file with data inserted before the
+# image bits and the offset modified to suit
+my @comp =
+ (
+ [ 'winrgb2.bmp', 'winrgb2off.bmp', 1 ],
+ [ 'winrgb4.bmp', 'winrgb4off.bmp', 4 ],
+ [ 'winrgb8.bmp', 'winrgb8off.bmp', 8 ],
+ [ 'winrgb24.bmp', 'winrgb24off.bmp', 24 ],
+ );
+
+for my $comp (@comp) {
+ my ($base_file, $off_file, $bits) = @$comp;
+
+ my $base_im = Imager->new;
+ my $got_base =
+ ok($base_im->read(file=>"testimg/$base_file"),
+ "read original")
+ or print "# ",$base_im->errstr,"\n";
+ my $off_im = Imager->new;
+ my $got_off =
+ ok($off_im->read(file=>"testimg/$off_file"),
+ "read offset file")
+ or print "# ",$off_im->errstr,"\n";
+ SKIP:
+ {
+ skip("missed one file", 1)
+ unless $got_base && $got_off;
+ is(i_img_diff($base_im->{IMG}, $off_im->{IMG}), 0,
+ "compare base and offset image ($bits bits)");
+ }
+}
+
+{ # check file limits are checked
+ my $limit_file = "testout/t107_24bit.bmp";
+ ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
+ my $im = Imager->new;
+ ok(!$im->read(file=>$limit_file),
+ "should fail read due to size limits");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/image width/, "check message");
+
+ ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
+ ok(!$im->read(file=>$limit_file),
+ "should fail read due to size limits");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/image height/, "check message");
+
+ ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside width limit");
+ ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside height limit");
+
+ # 150 x 150 x 3 channel image uses 67500 bytes
+ ok(Imager->set_file_limits(reset=>1, bytes=>67499),
+ "set bytes limit 67499");
+ ok(!$im->read(file=>$limit_file),
+ "should fail - too many bytes");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/storage size/, "check error message");
+ ok(Imager->set_file_limits(reset=>1, bytes=>67500),
+ "set bytes limit 67500");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside bytes limit");
+ Imager->set_file_limits(reset=>1);
+}
+
+{ # various short read failure tests, each entry has:
+ # source filename, size, expected error
+ # these have been selected based on code coverage, to check each
+ # failure path is checked, where practical
+ my @tests =
+ (
+ [
+ "file truncated inside header",
+ "winrgb2.bmp",
+ 20, "file too short to be a BMP file"
+ ],
+ [
+ "1-bit, truncated inside palette",
+ "winrgb2.bmp",
+ 56, "reading BMP palette"
+ ],
+ [
+ "1-bit, truncated in offset region",
+ "winrgb2off.bmp", 64, "failed skipping to image data offset"
+ ],
+ [
+ "1-bit, truncated in image data",
+ "winrgb2.bmp", 96, "failed reading 1-bit bmp data"
+ ],
+ [
+ "4-bit, truncated inside palette",
+ "winrgb4.bmp",
+ 56, "reading BMP palette"
+ ],
+ [
+ "4-bit, truncated in offset region",
+ "winrgb4off.bmp", 120, "failed skipping to image data offset",
+ ],
+ [
+ "4-bit, truncate in image data",
+ "winrgb4.bmp", 120, "failed reading 4-bit bmp data"
+ ],
+ [
+ "4-bit RLE, truncate in uncompressed data",
+ "comp4.bmp", 0x229, "missing data during decompression"
+ ],
+ [
+ "8-bit, truncated in palette",
+ "winrgb8.bmp", 1060, "reading BMP palette"
+ ],
+ [
+ "8-bit, truncated in offset region",
+ "winrgb8off.bmp", 1080, "failed skipping to image data offset"
+ ],
+ [
+ "8-bit, truncated in image data",
+ "winrgb8.bmp", 1080, "failed reading 8-bit bmp data"
+ ],
+ [
+ "8-bit RLE, truncate in uncompressed data",
+ "comp8.bmp", 0x68C, "missing data during decompression"
+ ],
+ [
+ "24-bit, truncate in offset region",
+ "winrgb24off.bmp", 56, "failed skipping to image data offset",
+ ],
+ [
+ "24-bit, truncate in image data",
+ "winrgb24.bmp", 100, "failed reading image data",
+ ],
+ );
+
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($desc, $srcfile, $size, $error) = @$test;
+ my $im = Imager->new;
+ open IMDATA, "< testimg/$srcfile"
+ or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
+ binmode IMDATA;
+ my $data;
+ read(IMDATA, $data, $size) == $size
+ or die "$test_index - $desc: Could not read $size data from $srcfile";
+ close IMDATA;
+ ok(!$im->read(data => $data, type =>'bmp'),
+ "$test_index - $desc: Should fail to read");
+ is($im->errstr, $error, "$test_index - $desc: check message");
+ ++$test_index;
+ }
+}
+
+{ # various short read success tests, each entry has:
+ # source filename, size, expected tags
+ print "# allow_incomplete tests\n";
+ my @tests =
+ (
+ [
+ "1-bit",
+ "winrgb2.bmp", 96,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 2,
+ i_lines_read => 8,
+ },
+ ],
+ [
+ "4-bit",
+ "winrgb4.bmp", 250,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 16,
+ i_lines_read => 11,
+ },
+ ],
+ [
+ "4-bit RLE - uncompressed seq",
+ "comp4.bmp", 0x229,
+ {
+ bmp_compression_name => 'BI_RLE4',
+ bmp_compression => 2,
+ bmp_used_colors => 16,
+ i_lines_read => 44,
+ },
+ ],
+ [
+ "4-bit RLE - start seq",
+ "comp4.bmp", 0x97,
+ {
+ bmp_compression_name => 'BI_RLE4',
+ bmp_compression => 2,
+ bmp_used_colors => 16,
+ i_lines_read => 8,
+ },
+ ],
+ [
+ "8-bit",
+ "winrgb8.bmp", 1250,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 256,
+ i_lines_read => 8,
+ },
+ ],
+ [
+ "8-bit RLE - uncompressed seq",
+ "comp8.bmp", 0x68C,
+ {
+ bmp_compression_name => 'BI_RLE8',
+ bmp_compression => 1,
+ bmp_used_colors => 256,
+ i_lines_read => 27,
+ },
+ ],
+ [
+ "8-bit RLE - initial seq",
+ "comp8.bmp", 0x487,
+ {
+ bmp_compression_name => 'BI_RLE8',
+ bmp_compression => 1,
+ bmp_used_colors => 256,
+ i_lines_read => 20,
+ },
+ ],
+ [
+ "24-bit",
+ "winrgb24.bmp", 800,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 0,
+ i_lines_read => 12,
+ },
+ ],
+ );
+
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($desc, $srcfile, $size, $tags) = @$test;
+ my $im = Imager->new;
+ open IMDATA, "< testimg/$srcfile"
+ or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
+ binmode IMDATA;
+ my $data;
+ read(IMDATA, $data, $size) == $size
+ or die "$test_index - $desc: Could not read $size data from $srcfile";
+ close IMDATA;
+ ok($im->read(data => $data, type =>'bmp', allow_incomplete => 1),
+ "$test_index - $desc: Should read successfully");
+ # check standard tags are set
+ is($im->tags(name => 'i_format'), 'bmp',
+ "$test_index - $desc: i_format set");
+ is($im->tags(name => 'i_incomplete'), 1,
+ "$test_index - $desc: i_incomplete set");
+ my %check_tags;
+ for my $key (keys %$tags) {
+ $check_tags{$key} = $im->tags(name => $key);
+ }
+ is_deeply(\%check_tags, $tags, "$test_index - $desc: check tags");
+ ++$test_index;
+ }
+}
+
+{ # check handling of reading images with negative height
+ # each entry is:
+ # source file, description
+ print "# check handling of negative height values\n";
+ my @tests =
+ (
+ [ "winrgb2.bmp", "1-bit, uncompressed" ],
+ [ "winrgb4.bmp", "4-bit, uncompressed" ],
+ [ "winrgb8.bmp", "8-bit, uncompressed" ],
+ [ "winrgb24.bmp", "24-bit, uncompressed" ],
+ [ "comp4.bmp", "4-bit, RLE" ],
+ [ "comp8.bmp", "8-bit, RLE" ],
+ );
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($file, $desc) = @$test;
+ open IMDATA, "< testimg/$file"
+ or die "$test_index - Cannot open $file: $!";
+ binmode IMDATA;
+ my $data = do { local $/; <IMDATA> };
+ close IMDATA;
+ my $im_orig = Imager->new;
+ $im_orig->read(data => $data)
+ or die "Cannot load original $file: ", $im_orig->errstr;
+
+ # now negate the height
+ my $orig_height = unpack("V", substr($data, 0x16, 4));
+ my $neg_height = 0xFFFFFFFF & ~($orig_height - 1);
+ substr($data, 0x16, 4) = pack("V", $neg_height);
+
+ # and read the modified image
+ my $im = Imager->new;
+ ok($im->read(data => $data),
+ "$test_index - $desc: read negated height image")
+ or print "# ", $im->errstr, "\n";
+
+ # flip orig to match what we should get
+ $im_orig->flip(dir => 'v');
+
+ # check it out
+ is_image($im, $im_orig, "$test_index - $desc: check image");
+
+ ++$test_index;
+ }
+}
+
+{ print "# patched data read failure tests\n";
+ # like the "various invalid format" tests, these generate fail
+ # images from other images included with Imager without providing a
+ # full bmp source, saving on dist size and focusing on the changes needed
+ # to cause the failure
+ # each entry is: source file, patches, expected error, description
+
+ my @tests =
+ (
+ # low image data offsets
+ [
+ "winrgb2.bmp",
+ { 10 => "3d 00 00 00" },
+ "image data offset too small (61)",
+ "1-bit, small image offset"
+ ],
+ [
+ "winrgb4.bmp",
+ { 10 => "75 00 00 00" },
+ "image data offset too small (117)",
+ "4-bit, small image offset"
+ ],
+ [
+ "winrgb8.bmp",
+ { 10 => "35 04 00 00" },
+ "image data offset too small (1077)",
+ "8-bit, small image offset"
+ ],
+ [
+ "winrgb24.bmp",
+ { 10 => "35 00 00 00" },
+ "image data offset too small (53)",
+ "24-bit, small image offset"
+ ],
+ # compression issues
+ [
+ "comp8.bmp",
+ { 0x436 => "97" },
+ "invalid data during decompression",
+ "8bit, RLE run beyond edge of image"
+ ],
+ [
+ # caused glibc malloc or valgrind to complain
+ "comp8.bmp",
+ { 0x436 => "94 00 00 03" },
+ "invalid data during decompression",
+ "8bit, literal run beyond edge of image"
+ ],
+ [
+ "comp4.bmp",
+ { 0x76 => "FF bb FF BB" },
+ "invalid data during decompression",
+ "4bit - RLE run beyond edge of image"
+ ],
+ [
+ "comp4.bmp",
+ { 0x76 => "94 bb 00 FF" },
+ "invalid data during decompression",
+ "4bit - literal run beyond edge of image"
+ ],
+ );
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($filename, $patches, $error, $desc) = @$test;
+
+ my $data = load_patched_file("testimg/$filename", $patches);
+ my $im = Imager->new;
+ ok(!$im->read(data => $data, type=>'bmp'),
+ "$test_index - $desc:should fail to read");
+ is($im->errstr, $error, "$test_index - $desc:check message");
+ ++$test_index;
+ }
+}
+
+{ # various write failure tests
+ # each entry is:
+ # source, limit, expected error, description
+ my @tests =
+ (
+ [
+ "winrgb2.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "1-bit, writing header"
+ ],
+ [
+ "winrgb4.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "4-bit, writing header"
+ ],
+ [
+ "winrgb8.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "8-bit, writing header"
+ ],
+ [
+ "winrgb24.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "24-bit, writing header"
+ ],
+ [
+ "winrgb2.bmp", 0x38,
+ "cannot write palette entry: limit reached",
+ "1-bit, writing palette"
+ ],
+ [
+ "winrgb4.bmp", 0x38,
+ "cannot write palette entry: limit reached",
+ "4-bit, writing palette"
+ ],
+ [
+ "winrgb8.bmp", 0x38,
+ "cannot write palette entry: limit reached",
+ "8-bit, writing palette"
+ ],
+ [
+ "winrgb2.bmp", 0x40,
+ "writing 1 bit/pixel packed data: limit reached",
+ "1-bit, writing image data"
+ ],
+ [
+ "winrgb4.bmp", 0x80,
+ "writing 4 bit/pixel packed data: limit reached",
+ "4-bit, writing image data"
+ ],
+ [
+ "winrgb8.bmp", 0x440,
+ "writing 8 bit/pixel packed data: limit reached",
+ "8-bit, writing image data"
+ ],
+ [
+ "winrgb24.bmp", 0x39,
+ "writing image data: limit reached",
+ "24-bit, writing image data"
+ ],
+ );
+ print "# write failure tests\n";
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($file, $limit, $error, $desc) = @$test;
+
+ my $im = Imager->new;
+ $im->read(file => "testimg/$file")
+ or die "Cannot read $file: ", $im->errstr;
+
+ my $io = Imager::io_new_cb(limited_write($limit), undef, undef, undef, 1);
+ $io->set_buffered(0);
+ print "# writing with limit of $limit\n";
+ ok(!$im->write(type => 'bmp', io => $io),
+ "$test_index - $desc: write should fail");
+ is($im->errstr, $error, "$test_index - $desc: check error message");
+
+ ++$test_index;
+ }
+}
+
+{
+ ok(grep($_ eq 'bmp', Imager->read_types), "check bmp in read types");
+ ok(grep($_ eq 'bmp', Imager->write_types), "check bmp in write types");
+}
+
+{
+ # RT #30075
+ # give 4/2 channel images a background color when saving to BMP
+ 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);
+ ok($im->write(file=>"testout/t107_alpha.bmp", type=>'bmp'),
+ "should succeed writing 4 channel image");
+ push @files, "t107_alpha.bmp";
+ my $imread = Imager->new;
+ ok($imread->read(file => 'testout/t107_alpha.bmp'), "read it back");
+ 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 => 'bmp', i_background => '#FF0000'),
+ "write with red background");
+ ok($imread->read(data => $data, type => 'bmp'),
+ "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");
+}
+
+{ # RT 41406
+ my $data;
+ my $im = test_image();
+ ok($im->write(data => \$data, type => 'bmp'), "write using OO");
+ my $size = unpack("V", substr($data, 34, 4));
+ is($size, 67800, "check data size");
+}
+
+{ # check close failures are handled correctly
+ my $im = test_image();
+ my $fail_close = sub {
+ Imager::i_push_error(0, "synthetic close failure");
+ return 0;
+ };
+ ok(!$im->write(type => "bmp", callback => sub { 1 },
+ closecb => $fail_close),
+ "check failing close fails");
+ like($im->errstr, qr/synthetic close failure/,
+ "check error message");
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink map "testout/$_", @files;
+ unlink "testout/t107bmp.log";
+}
+
+sub write_test {
+ my ($im, $filename) = @_;
+ local *FH;
+
+ if (open FH, "> $filename") {
+ binmode FH;
+ my $IO = Imager::io_new_fd(fileno(FH));
+ unless (ok(Imager::i_writebmp_wiol($im, $IO), $filename)) {
+ print "# ",Imager->_error_as_msg(),"\n";
+ }
+ undef $IO;
+ close FH;
+ }
+ else {
+ fail("could not open $filename: $!");
+ }
+}
+
+sub read_test {
+ my ($filename, $im, %tags) = @_;
+ local *FH;
+
+ print "# read_test: $filename\n";
+
+ $tags{i_format} = "bmp";
+
+ if (open FH, "< $filename") {
+ binmode FH;
+ my $IO = Imager::io_new_fd(fileno(FH));
+ my $im_read = Imager::i_readbmp_wiol($IO);
+ if ($im_read) {
+ my $diff = i_img_diff($im, $im_read);
+ if ($diff > $base_diff) {
+ fail("image mismatch reading $filename");
+ }
+ else {
+ my $tags_ok = 1;
+ for my $tag (keys %tags) {
+ if (my $index = Imager::i_tags_find($im_read, $tag, 0)) {
+ my ($name, $value) = Imager::i_tags_get($im_read, $index);
+ my $exp_value = $tags{$tag};
+ print "# tag $name = '$value' - expect '$exp_value'\n";
+ if ($exp_value =~ /\d/) {
+ if ($value != $tags{$tag}) {
+ print "# tag $tag value mismatch $tags{$tag} != $value\n";
+ $tags_ok = 0;
+ }
+ }
+ else {
+ if ($value ne $tags{$tag}) {
+ print "# tag $tag value mismatch $tags{$tag} != $value\n";
+ $tags_ok = 0;
+ }
+ }
+ }
+ }
+ ok($tags_ok, "reading $filename");
+ # for my $i (0 .. Imager::i_tags_count($im_read)-1) {
+ # my ($name, $value) = Imager::i_tags_get($im_read, $i);
+ # print "# tag '$name' => '$value'\n";
+ #}
+ }
+ }
+ else {
+ fail("could not read $filename: ".Imager->_error_as_msg());
+ }
+ undef $IO;
+ close FH;
+ }
+ else {
+ fail("could not open $filename: $!");
+ }
+}
+
+sub limited_write {
+ my ($limit) = @_;
+
+ return
+ sub {
+ my ($data) = @_;
+ $limit -= length $data;
+ if ($limit >= 0) {
+ print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
+ return 1;
+ }
+ else {
+ print "# write of ", length $data, " bytes failed\n";
+ Imager::i_push_error(0, "limit reached");
+ return;
+ }
+ };
+}
+
+sub load_patched_file {
+ my ($filename, $patches) = @_;
+
+ open IMDATA, "< $filename"
+ or die "Cannot open $filename: $!";
+ binmode IMDATA;
+ my $data = do { local $/; <IMDATA> };
+ for my $offset (keys %$patches) {
+ (my $hdata = $patches->{$offset}) =~ tr/ //d;
+ my $pdata = pack("H*", $hdata);
+ substr($data, $offset, length $pdata) = $pdata;
+ }
+
+ return $data;
+}
--- /dev/null
+#!perl -w
+use Imager qw(:all);
+use strict;
+use Test::More tests=>68;
+use Imager::Test qw(is_color4 is_image test_image);
+
+-d "testout" or mkdir "testout";
+
+init_log("testout/t108tga.log",1);
+
+my $img = create_test_image();
+my $base_diff = 0;
+
+write_test($img, "testout/t108_24bit.tga", 0, 0, "");
+write_test($img, "testout/t108_24bit_rle.tga", 0, 1, "");
+write_test($img, "testout/t108_15bit.tga", 1, 1, "");
+write_test($img, "testout/t108_15bit_rle.tga", 1, 1, "");
+
+# 'webmap' is noticably faster than the default
+my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
+ translate=>'errdiff'});
+
+write_test($im8, "testout/t108_8bit.tga", 0, 0, "");
+write_test($im8, "testout/t108_8bit_rle.tga", 0, 1, "");
+write_test($im8, "testout/t108_8_15bit.tga", 1, 0, "");
+write_test($im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
+
+
+# use a fixed palette so we get reproducible results for the compressed
+# version
+
+my @bit4 = map { NC($_) }
+ qw(605844 966600 0148b2 00f800 bf0a33 5e009e
+ 2ead1b 0000f8 004b01 fd0000 0e1695 000002);
+
+my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
+
+my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
+ make_colors=>'none' });
+
+my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
+ make_colors=>'none',
+ translate=>'errdiff' });
+
+write_test($im4, "testout/t108_4bit.tga", 0, 1, "");
+write_test($im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
+
+read_test("testout/t108_24bit.tga", $img);
+read_test("testout/t108_8bit.tga", $im8);
+read_test("testout/t108_4bit.tga", $im4);
+read_test("testout/t108_1bit.tga", $im1);
+
+# the following might have slight differences
+
+$base_diff = i_img_diff($img, $im8) * 2;
+
+print "# base difference $base_diff\n";
+
+my $imoo = Imager->new;
+ok($imoo->read(file=>'testout/t108_24bit.tga'),
+ "OO read image")
+ or print "# ",$imoo->errstr,"\n";
+
+ok($imoo->write(file=>'testout/t108_oo.tga'),
+ "OO write image")
+ or print "# ",$imoo->errstr,"\n";
+
+my ($type) = $imoo->tags(name=>'i_format');
+is($type, 'tga', "check i_format tag");
+
+# in 0.44 and earlier, reading an image with an idstring of 128 or more
+# bytes would result in an allocation error, if the platform char type
+# was signed
+$imoo = Imager->new;
+ok($imoo->read(file=>'testimg/longid.tga'), "read long id image");
+my ($id) = $imoo->tags(name=>'tga_idstring');
+is($id, "X" x 128, "check tga_idstring tag");
+my ($bitspp) = $imoo->tags(name=>'tga_bitspp');
+is($bitspp, 24, "check tga_bitspp tag");
+my ($compressed) = $imoo->tags(name=>'compressed');
+is($compressed, 1, "check compressed tag");
+
+{ # check file limits are checked
+ my $limit_file = "testout/t108_24bit.tga";
+ ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
+ my $im = Imager->new;
+ ok(!$im->read(file=>$limit_file),
+ "should fail read due to size limits");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/image width/, "check message");
+
+ ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
+ ok(!$im->read(file=>$limit_file),
+ "should fail read due to size limits");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/image height/, "check message");
+
+ ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside width limit");
+ ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside height limit");
+
+ # 150 x 150 x 3 channel image uses 67500 bytes
+ ok(Imager->set_file_limits(reset=>1, bytes=>67499),
+ "set bytes limit 67499");
+ ok(!$im->read(file=>$limit_file),
+ "should fail - too many bytes");
+ print "# ",$im->errstr,"\n";
+ like($im->errstr, qr/storage size/, "check error message");
+ ok(Imager->set_file_limits(reset=>1, bytes=>67500),
+ "set bytes limit 67500");
+ ok($im->read(file=>$limit_file),
+ "should succeed - just inside bytes limit");
+ Imager->set_file_limits(reset=>1);
+}
+
+{ # Issue # 18397
+ # the issue is for 4 channel images to jpeg, but 2 channel images have
+ # a similar problem on tga
+ my $im = Imager->new(xsize=>100, ysize=>100, channels => 2);
+ my $data;
+ ok(!$im->write(data => \$data, type=>'tga'),
+ "check failure of writing a 2 channel image");
+ is($im->errstr, "Cannot store 2 channel image in targa format",
+ "check the error message");
+}
+
+{
+ ok(grep($_ eq 'tga', Imager->read_types), "check tga in read types");
+ ok(grep($_ eq 'tga', Imager->write_types), "check tga in write types");
+}
+
+{ # Issue #32926
+ # a sample image was read as all transparent
+ # it had bitsperpixel = 16 and atribute channel set to 1, so it
+ # should have an alpha channel.
+ # So we'll do what the gimp does and treat a zero value as opaque.
+
+ my $im = Imager->new;
+ ok($im->read(file => 'testimg/alpha16.tga'),
+ "read 16-bit/pixel alpha image");
+ my $c1 = $im->getpixel('x' => 0, 'y' => 0);
+ is_color4($c1, 0, 0, 0, 0, "check transparent pixel");
+ my $c2 = $im->getpixel('x' => 19, 'y' => 0);
+ is_color4($c2, 255, 0, 0, 255, "check opaque pixel");
+
+ # since this has an effect on writing too, write,it, read it, check it
+ my $data;
+ ok($im->write(data => \$data, type => 'tga', wierdpack => 1),
+ "write 16-bit/pixel w/alpha");
+ my $im2 = Imager->new;
+ ok($im2->read(data => $data), "read it back");
+ is_image($im, $im2, "check they match");
+}
+
+{ # prior to the types re-work we treated the tga xsize/ysize as
+ # signed short, which is wrong
+ SKIP:
+ {
+ my $im = Imager->new(xsize => 40960, ysize => 1);
+ my $data;
+ ok($im->write(data => \$data, type => "tga"),
+ "write a wide (but not too wide) image out");
+ my $im2 = Imager->new(data => $data);
+ ok($im2, "read it back in")
+ or skip("Couldn't read the wide image", 2);
+ is($im2->getwidth, 40960, "make sure the width survived the trip");
+ is($im2->getheight, 1, "make sure the height survived the trip");
+ }
+
+ SKIP:
+ {
+ my $im = Imager->new(xsize => 1, ysize => 40960);
+ my $data;
+ ok($im->write(data => \$data, type => "tga"),
+ "write a tall (but not too tall) image out");
+ my $im2 = Imager->new(data => $data);
+ ok($im2, "read it back in")
+ or skip("Couldn't read the tall image", 2);
+ is($im2->getwidth, 1, "make sure the width survived the trip");
+ is($im2->getheight, 40960, "make sure the height survived the trip");
+ }
+}
+
+{
+ # TGA files are limited to 0xFFFF x 0xFFFF pixels
+ my $max_dim = 0xFFFF;
+ {
+ my $im = Imager->new(xsize => 1+$max_dim, ysize => 1);
+ my $data = '';
+ ok(!$im->write(data => \$data, type => "tga"),
+ "fail to write too wide an image");
+ is($im->errstr, "image too large for TGA",
+ "check error message");
+ }
+ SKIP:
+ {
+ my $im = Imager->new(xsize => $max_dim, ysize => 1);
+ $im->box(fill => { hatch => "check4x4" });
+ my $data = '';
+ ok($im->write(data => \$data, type => "tga"),
+ "write image at width limit")
+ or print "# ", $im->errstr, "\n";
+ my $im2 = Imager->new(data => $data, ftype => "tga");
+ ok($im2, "read it ok")
+ or skip("cannot load the wide image", 1);
+ is($im->getwidth, $max_dim, "check width");
+ is($im->getheight, 1, "check height");
+ }
+ {
+ my $im = Imager->new(xsize => 1, ysize => 1+$max_dim);
+ my $data = '';
+ ok(!$im->write(data => \$data, type => "tga"),
+ "fail to write too tall an image");
+ is($im->errstr, "image too large for TGA",
+ "check error message");
+ }
+ SKIP:
+ {
+ my $im = Imager->new(xsize => 1, ysize => $max_dim);
+ $im->box(fill => { hatch => "check2x2" });
+ my $data = '';
+ ok($im->write(data => \$data, type => "tga"),
+ "write image at width limit");
+ my $im2 = Imager->new(data => $data, ftype => "tga");
+ ok($im2, "read it ok")
+ or skip("cannot load the wide image", 1);
+ is($im->getwidth, 1, "check width");
+ is($im->getheight, $max_dim, "check height");
+ }
+}
+
+{ # check close failures are handled correctly
+ my $im = test_image();
+ my $fail_close = sub {
+ Imager::i_push_error(0, "synthetic close failure");
+ return 0;
+ };
+ ok(!$im->write(type => "tga", callback => sub { 1 },
+ closecb => $fail_close),
+ "check failing close fails");
+ like($im->errstr, qr/synthetic close failure/,
+ "check error message");
+}
+
+sub write_test {
+ my ($im, $filename, $wierdpack, $compress, $idstring) = @_;
+ local *FH;
+
+ if (open FH, "> $filename") {
+ binmode FH;
+ my $IO = Imager::io_new_fd(fileno(FH));
+ ok(Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring),
+ "write $filename")
+ or print "# ",Imager->_error_as_msg(),"\n";
+ undef $IO;
+ close FH;
+ } else {
+ fail("write $filename: open failed: $!");
+ }
+}
+
+
+sub read_test {
+ my ($filename, $im, %tags) = @_;
+ local *FH;
+
+ if (open FH, "< $filename") {
+ binmode FH;
+ my $IO = Imager::io_new_fd(fileno(FH));
+ my $im_read = Imager::i_readtga_wiol($IO,-1);
+ if ($im_read) {
+ my $diff = i_img_diff($im, $im_read);
+ cmp_ok($diff, '<=', $base_diff,
+ "check read image vs original");
+ } else {
+ fail("read $filename ".Imager->_error_as_msg());
+ }
+ undef $IO;
+ close FH;
+ } else {
+ fail("read $filename, open failure: $!");
+ }
+}
+
+sub create_test_image {
+
+ 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 $img = Imager::ImgRaw::new(150,150,3);
+
+ i_box_filled($img, 70, 25, 130, 125, $green);
+ i_box_filled($img, 20, 25, 80, 125, $blue);
+ i_arc($img, 75, 75, 30, 0, 361, $red);
+ i_conv($img, [0.1, 0.2, 0.4, 0.2, 0.1]);
+
+ return $img;
+}
--- /dev/null
+#!perl -w
+######################### We start with some black magic to print on failure.
+
+# this used to do the check for the load of Imager, but I want to be able
+# to count tests, which means I need to load Imager first
+# since many of the early tests already do this, we don't really need to
+
+use strict;
+use Imager;
+use IO::Seekable;
+
+my $buggy_giflib_file = "buggy_giflib.txt";
+
+-d "testout" or mkdir "testout";
+
+Imager::init("log"=>"testout/t50basicoo.log");
+
+# single image/file types
+my @types = qw( jpeg png raw pnm gif tiff bmp tga );
+
+# multiple image/file formats
+my @mtypes = qw(tiff gif);
+
+my %hsh=%Imager::formats;
+
+my $test_num = 0;
+my $count;
+for my $type (@types) {
+ $count += 31 if $hsh{$type};
+}
+for my $type (@mtypes) {
+ $count += 7 if $hsh{$type};
+}
+
+print "1..$count\n";
+
+print "# avaliable formats:\n";
+for(keys %hsh) { print "# $_\n"; }
+
+#print Dumper(\%hsh);
+
+my $img = Imager->new();
+
+my %files;
+@files{@types} = ({ file => "JPEG/testimg/209_yonge.jpg" },
+ { file => "testimg/test.png" },
+ { file => "testimg/test.raw", xsize=>150, ysize=>150, type=>'raw', interleave => 0},
+ { file => "testimg/penguin-base.ppm" },
+ { file => "GIF/testimg/expected.gif" },
+ { file => "TIFF/testimg/comp8.tif" },
+ { file => "testimg/winrgb24.bmp" },
+ { file => "testimg/test.tga" }, );
+my %writeopts =
+ (
+ gif=> { make_colors=>'webmap', translate=>'closest', gifquant=>'gen',
+ gif_delay=>20 },
+ );
+
+for my $type (@types) {
+ next unless $hsh{$type};
+ print "# type $type\n";
+ my %opts = %{$files{$type}};
+ my @a = map { "$_=>${opts{$_}}" } keys %opts;
+ print "#opening Format: $type, options: @a\n";
+ ok($img->read( %opts ), "reading from file", $img);
+ #or die "failed: ",$img->errstr,"\n";
+
+ my %mopts = %opts;
+ delete $mopts{file};
+
+ # read from a file handle
+ my $fh = IO::File->new($opts{file}, "r");
+ if (ok($fh, "opening $opts{file}")) {
+ binmode $fh;
+ my $fhimg = Imager->new;
+ if (ok($fhimg->read(fh=>$fh, %mopts), "read from fh")) {
+ ok($fh->seek(0, SEEK_SET), "seek after read");
+ if (ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "read from fh")) {
+ ok(Imager::i_img_diff($img->{IMG}, $fhimg->{IMG}) == 0,
+ "image comparison after fh read");
+ }
+ else {
+ skip("no image to compare");
+ }
+ ok($fh->seek(0, SEEK_SET), "seek after read");
+ }
+
+ # read from a fd
+ my $fdimg = Imager->new;
+ if (ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")) {
+ ok(Imager::i_img_diff($img->{IMG}, $fdimg->{IMG}) == 0,
+ "image comparistion after fd read");
+ }
+ else {
+ skip("no image to compare");
+ }
+ ok($fh->seek(0, SEEK_SET), "seek after fd read");
+ ok($fh->close, "close fh after reads");
+ }
+ else {
+ skip("couldn't open the damn file: $!", 7);
+ }
+
+ # read from a memory buffer
+ open DATA, "< $opts{file}"
+ or die "Cannot open $opts{file}: $!";
+ binmode DATA;
+ my $data = do { local $/; <DATA> };
+ close DATA;
+ my $bimg = Imager->new;
+
+ if (ok($bimg->read(data=>$data, %mopts, type=>$type), "read from buffer",
+ $img)) {
+ ok(Imager::i_img_diff($img->{IMG}, $bimg->{IMG}) == 0,
+ "comparing buffer read image");
+ }
+ else {
+ skip("nothing to compare");
+ }
+
+ # read from callbacks, both with minimum and maximum reads
+ my $buf = $data;
+ my $seekpos = 0;
+ my $reader_min =
+ sub {
+ my ($size, $maxread) = @_;
+ my $out = substr($buf, $seekpos, $size);
+ $seekpos += length $out;
+ $out;
+ };
+ my $reader_max =
+ sub {
+ my ($size, $maxread) = @_;
+ my $out = substr($buf, $seekpos, $maxread);
+ $seekpos += length $out;
+ $out;
+ };
+ my $seeker =
+ sub {
+ my ($offset, $whence) = @_;
+ #print "io_seeker($offset, $whence)\n";
+ if ($whence == SEEK_SET) {
+ $seekpos = $offset;
+ }
+ elsif ($whence == SEEK_CUR) {
+ $seekpos += $offset;
+ }
+ else { # SEEK_END
+ $seekpos = length($buf) + $offset;
+ }
+ #print "-> $seekpos\n";
+ $seekpos;
+ };
+ my $cbimg = Imager->new;
+ ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts),
+ "read from callback min", $cbimg);
+ ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
+ "comparing mincb image");
+ $seekpos = 0;
+ ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts),
+ "read from callback max", $cbimg);
+ ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
+ "comparing maxcb image");
+}
+
+for my $type (@types) {
+ next unless $hsh{$type};
+
+ print "# write tests for $type\n";
+ # test writes
+ next unless $hsh{$type};
+ my $file = "testout/t50out.$type";
+ my $wimg = Imager->new;
+ # if this doesn't work, we're so screwed up anyway
+
+ ok($wimg->read(file=>"testimg/penguin-base.ppm"),
+ "cannot read base file", $wimg);
+
+ # first to a file
+ print "# writing $type to a file\n";
+ my %extraopts;
+ %extraopts = %{$writeopts{$type}} if $writeopts{$type};
+ ok($wimg->write(file=>$file, %extraopts),
+ "writing $type to a file $file", $wimg);
+
+ print "# writing $type to a FH\n";
+ # to a FH
+ my $fh = IO::File->new($file, "w+")
+ or die "Could not create $file: $!";
+ binmode $fh;
+ ok($wimg->write(fh=>$fh, %extraopts, type=>$type),
+ "writing $type to a FH", $wimg);
+ ok($fh->seek(0, SEEK_END) > 0,
+ "seek after writing $type to a FH");
+ ok(print($fh "SUFFIX\n"),
+ "write to FH after writing $type");
+ ok($fh->close, "closing FH after writing $type");
+
+ if (ok(open(DATA, "< $file"), "opening data source")) {
+ binmode DATA;
+ my $data = do { local $/; <DATA> };
+ close DATA;
+
+ # writing to a buffer
+ print "# writing $type to a buffer\n";
+ my $buf = '';
+ ok($wimg->write(data=>\$buf, %extraopts, type=>$type),
+ "writing $type to a buffer", $wimg);
+ $buf .= "SUFFIX\n";
+ open DATA, "> testout/t50_buf.$type"
+ or die "Cannot create $type buffer file: $!";
+ binmode DATA;
+ print DATA $buf;
+ close DATA;
+ ok($data eq $buf, "comparing file data to buffer");
+
+ $buf = '';
+ my $seekpos = 0;
+ my $did_close;
+ my $writer =
+ sub {
+ my ($what) = @_;
+ if ($seekpos > length $buf) {
+ $buf .= "\0" x ($seekpos - length $buf);
+ }
+ substr($buf, $seekpos, length $what) = $what;
+ $seekpos += length $what;
+ $did_close = 0; # the close must be last
+ 1;
+ };
+ my $reader_min =
+ sub {
+ my ($size, $maxread) = @_;
+ my $out = substr($buf, $seekpos, $size);
+ $seekpos += length $out;
+ $out;
+ };
+ my $reader_max =
+ sub {
+ my ($size, $maxread) = @_;
+ my $out = substr($buf, $seekpos, $maxread);
+ $seekpos += length $out;
+ $out;
+ };
+ use IO::Seekable;
+ my $seeker =
+ sub {
+ my ($offset, $whence) = @_;
+ #print "io_seeker($offset, $whence)\n";
+ if ($whence == SEEK_SET) {
+ $seekpos = $offset;
+ }
+ elsif ($whence == SEEK_CUR) {
+ $seekpos += $offset;
+ }
+ else { # SEEK_END
+ $seekpos = length($buf) + $offset;
+ }
+ #print "-> $seekpos\n";
+ $seekpos;
+ };
+
+ my $closer = sub { ++$did_close; };
+
+ print "# writing $type via callbacks (mb=1)\n";
+ ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer,
+ readcb=>$reader_min,
+ %extraopts, type=>$type, maxbuffer=>1),
+ "writing $type to callback (mb=1)", $wimg);
+
+ ok($did_close, "checking closecb called");
+ $buf .= "SUFFIX\n";
+ ok($data eq $buf, "comparing callback output to file data");
+ print "# writing $type via callbacks (no mb)\n";
+ $buf = '';
+ $did_close = 0;
+ $seekpos = 0;
+ # we don't use the closecb here - used to make sure we don't get
+ # a warning/error on an attempt to call an undef close sub
+ ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min,
+ %extraopts, type=>$type),
+ "writing $type to callback (no mb)", $wimg);
+ $buf .= "SUFFIX\n";
+ ok($data eq $buf, "comparing callback output to file data");
+ }
+ else {
+ skip("couldn't open data source", 7);
+ }
+}
+
+my $img2 = $img->crop(width=>50, height=>50);
+$img2 -> write(file=> 'testout/t50.ppm', type=>'pnm');
+
+undef($img);
+
+# multi image/file tests
+print "# multi-image write tests\n";
+for my $type (@mtypes) {
+ next unless $hsh{$type};
+ print "# $type\n";
+
+ my $file = "testout/t50out.$type";
+ my $wimg = Imager->new;
+
+ # if this doesn't work, we're so screwed up anyway
+ ok($wimg->read(file=>"testout/t50out.$type"),
+ "reading base file", $wimg);
+
+ ok(my $wimg2 = $wimg->copy, "copying base image", $wimg);
+ ok($wimg2->flip(dir=>'h'), "flipping base image", $wimg2);
+
+ my @out = ($wimg, $wimg2);
+ my %extraopts;
+ %extraopts = %{$writeopts{$type}} if $writeopts{$type};
+ ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts },
+ @out),
+ "writing multiple to a file", "Imager");
+
+ # make sure we get the same back
+ my @images = Imager->read_multi(file=>"testout/t50_multi.$type");
+ if (ok(@images == @out, "checking read image count")) {
+ for my $i (0 .. $#out) {
+ my $diff = Imager::i_img_diff($out[$i]{IMG}, $images[$i]{IMG});
+ print "# diff $diff\n";
+ ok($diff == 0, "comparing image $i");
+ }
+ }
+ else {
+ skip("wrong number of images read", 2);
+ }
+}
+
+
+Imager::malloc_state();
+
+#print "ok 2\n";
+
+sub ok {
+ my ($ok, $msg, $img, $why, $skipcount) = @_;
+
+ ++$test_num;
+ if ($ok) {
+ print "ok $test_num # $msg\n";
+ Imager::i_log_entry("ok $test_num # $msg\n", 0);
+ }
+ else {
+ my $err;
+ $err = $img->errstr if $img;
+ # VMS (if we ever support it) wants the whole line in one print
+ my $line = "not ok $test_num # line ".(caller)[2].": $msg";
+ $line .= ": $err" if $err;
+ print $line, "\n";
+ Imager::i_log_entry($line."\n", 0);
+ }
+ skip($why, $skipcount) if defined $why;
+ $ok;
+}
+
+sub skip {
+ my ($why, $skipcount) = @_;
+
+ $skipcount ||= 1;
+ for (1.. $skipcount) {
+ ++$test_num;
+ print "ok $test_num # skipped $why\n";
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 256;
+use Imager ':all';
+use Imager::Test qw(is_color3 is_image);
+use constant PI => 3.14159265358979;
+
+-d "testout" or mkdir "testout";
+
+init_log("testout/t21draw.log",1);
+
+my $redobj = NC(255, 0, 0);
+my $red = 'FF0000';
+my $greenobj = NC(0, 255, 0);
+my $green = [ 0, 255, 0 ];
+my $blueobj = NC(0, 0, 255);
+my $blue = { hue=>240, saturation=>1, value=>1 };
+my $white = '#FFFFFF';
+
+{
+ my $img = Imager->new(xsize=>100, ysize=>500);
+
+ ok($img->box(color=>$blueobj, xmin=>10, ymin=>10, xmax=>48, ymax=>18),
+ "box with color obj");
+ ok($img->box(color=>$blue, xmin=>10, ymin=>20, xmax=>48, ymax=>28),
+ "box with color");
+ ok($img->box(color=>$redobj, xmin=>10, ymin=>30, xmax=>28, ymax=>48, filled=>1),
+ "filled box with color obj");
+ ok($img->box(color=>$red, xmin=>30, ymin=>30, xmax=>48, ymax=>48, filled=>1),
+ "filled box with color");
+
+ ok($img->arc('x'=>75, 'y'=>25, r=>24, color=>$redobj),
+ "filled arc with colorobj");
+
+ ok($img->arc('x'=>75, 'y'=>25, r=>20, color=>$green),
+ "filled arc with colorobj");
+ ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$white, d1=>325, d2=>225),
+ "filled arc with color");
+
+ ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$blue, d1=>225, d2=>325),
+ "filled arc with color");
+ ok($img->arc('x'=>75, 'y'=>25, r=>15, color=>$green, aa=>1),
+ "filled arc with color");
+
+ ok($img->line(color=>$blueobj, x1=>5, y1=>55, x2=>35, y2=>95),
+ "line with colorobj");
+
+ # FIXME - neither the start nor end-point is set for a non-aa line
+ my $c = Imager::i_get_pixel($img->{IMG}, 5, 55);
+ ok(color_cmp($c, $blueobj) == 0, "# TODO start point not set");
+
+ ok($img->line(color=>$red, x1=>10, y1=>55, x2=>40, y2=>95, aa=>1),
+ "aa line with color");
+ ok($img->line(color=>$green, x1=>15, y1=>55, x2=>45, y2=>95, antialias=>1),
+ "antialias line with color");
+
+ ok($img->polyline(points=>[ [ 55, 55 ], [ 90, 60 ], [ 95, 95] ],
+ color=>$redobj),
+ "polyline points with color obj");
+ ok($img->polyline('x'=>[ 55, 85, 90 ], 'y'=>[60, 65, 95], color=>$green, aa=>1),
+ "polyline xy with color aa");
+ ok($img->polyline('x'=>[ 55, 80, 85 ], 'y'=>[65, 70, 95], color=>$green,
+ antialias=>1),
+ "polyline xy with color antialias");
+
+ ok($img->setpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], color=>$red),
+ "set array of pixels");
+ ok($img->setpixel('x'=>39, 'y'=>55, color=>$green),
+ "set single pixel");
+ use Imager::Color::Float;
+ my $flred = Imager::Color::Float->new(1, 0, 0, 0);
+ my $flgreen = Imager::Color::Float->new(0, 1, 0, 0);
+ ok($img->setpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59], color=>$flred),
+ "set array of float pixels");
+ ok($img->setpixel('x'=>45, 'y'=>55, color=>$flgreen),
+ "set single float pixel");
+ my @gp = $img->getpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59]);
+ ok(grep($_->isa('Imager::Color'), @gp) == 3, "check getpixel result type");
+ ok(grep(color_cmp($_, NC(255, 0, 0)) == 0, @gp) == 3,
+ "check getpixel result colors");
+ my $gp = $img->getpixel('x'=>45, 'y'=>55);
+ ok($gp->isa('Imager::Color'), "check scalar getpixel type");
+ ok(color_cmp($gp, NC(0, 255, 0)) == 0, "check scalar getpixel color");
+ @gp = $img->getpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], type=>'float');
+ ok(grep($_->isa('Imager::Color::Float'), @gp) == 3,
+ "check getpixel float result type");
+ ok(grep(color_cmp($_, $flred) == 0, @gp) == 3,
+ "check getpixel float result type");
+ $gp = $img->getpixel('x'=>39, 'y'=>55, type=>'float');
+ ok($gp->isa('Imager::Color::Float'), "check scalar float getpixel type");
+ ok(color_cmp($gp, $flgreen) == 0, "check scalar float getpixel color");
+
+ # more complete arc tests
+ ok($img->arc(x=>25, 'y'=>125, r=>20, d1=>315, d2=>45, color=>$greenobj),
+ "color arc through angle 0");
+ # use diff combine here to make sure double writing is noticable
+ ok($img->arc(x=>75, 'y'=>125, r=>20, d1=>315, d2=>45,
+ fill => { solid=>$blueobj, combine => 'diff' }),
+ "fill arc through angle 0");
+ ok($img->arc(x=>25, 'y'=>175, r=>20, d1=>315, d2=>225, color=>$redobj),
+ "concave color arc");
+ angle_marker($img, 25, 175, 23, 315, 225);
+ ok($img->arc(x=>75, 'y'=>175, r=>20, d1=>315, d2=>225,
+ fill => { solid=>$greenobj, combine=>'diff' }),
+ "concave fill arc");
+ angle_marker($img, 75, 175, 23, 315, 225);
+ ok($img->arc(x=>25, y=>225, r=>20, d1=>135, d2=>45, color=>$redobj),
+ "another concave color arc");
+ angle_marker($img, 25, 225, 23, 45, 135);
+ ok($img->arc(x=>75, y=>225, r=>20, d1=>135, d2=>45,
+ fill => { solid=>$blueobj, combine=>'diff' }),
+ "another concave fillarc");
+ angle_marker($img, 75, 225, 23, 45, 135);
+ ok($img->arc(x=>25, y=>275, r=>20, d1=>135, d2=>45, color=>$redobj, aa=>1),
+ "concave color arc aa");
+ ok($img->arc(x=>75, y=>275, r=>20, d1=>135, d2=>45,
+ fill => { solid=>$blueobj, combine=>'diff' }, aa=>1),
+ "concave fill arc aa");
+
+ ok($img->circle(x=>25, y=>325, r=>20, color=>$redobj),
+ "color circle no aa");
+ ok($img->circle(x=>75, y=>325, r=>20, color=>$redobj, aa=>1),
+ "color circle aa");
+ ok($img->circle(x=>25, 'y'=>375, r=>20,
+ fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
+ "fill circle no aa");
+ ok($img->circle(x=>75, 'y'=>375, r=>20, aa=>1,
+ fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
+ "fill circle aa");
+
+ ok($img->arc(x=>50, y=>450, r=>45, d1=>135, d2=>45,
+ fill => { solid=>$blueobj, combine=>'diff' }),
+ "another concave fillarc");
+ angle_marker($img, 50, 450, 47, 45, 135);
+
+ ok($img->write(file=>'testout/t21draw.ppm'),
+ "saving output");
+}
+
+{
+ my $im = Imager->new(xsize => 400, ysize => 400);
+ ok($im->arc(x => 200, y => 202, r => 10, filled => 0),
+ "draw circle outline");
+ is_color3($im->getpixel(x => 200, y => 202), 0, 0, 0,
+ "check center not filled");
+ ok($im->arc(x => 198, y => 200, r => 13, filled => 0, color => "#f88"),
+ "draw circle outline");
+ is_color3($im->getpixel(x => 198, y => 200), 0, 0, 0,
+ "check center not filled");
+ ok($im->arc(x => 200, y => 200, r => 24, filled => 0, color => "#0ff"),
+ "draw circle outline");
+ my $r = 40;
+ while ($r < 180) {
+ ok($im->arc(x => 200, y => 200, r => $r, filled => 0, color => "#ff0"),
+ "draw circle outline r $r");
+ $r += 15;
+ }
+ ok($im->write(file => "testout/t21circout.ppm"),
+ "save arc outline");
+}
+
+{
+ my $im = Imager->new(xsize => 400, ysize => 400);
+ {
+ my $lc = Imager::Color->new(32, 32, 32);
+ my $an = 0;
+ while ($an < 360) {
+ my $an_r = $an * PI / 180;
+ my $ca = cos($an_r);
+ my $sa = sin($an_r);
+ $im->line(aa => 1, color => $lc,
+ x1 => 198 + 5 * $ca, y1 => 202 + 5 * $sa,
+ x2 => 198 + 190 * $ca, y2 => 202 + 190 * $sa);
+ $an += 5;
+ }
+ }
+ my $d1 = 0;
+ my $r = 20;
+ while ($d1 < 350) {
+ ok($im->arc(x => 198, y => 202, r => $r, d1 => $d1, d2 => $d1+300, filled => 0),
+ "draw arc outline r$r d1$d1 len 300");
+ ok($im->arc(x => 198, y => 202, r => $r+3, d1 => $d1, d2 => $d1+40, filled => 0, color => '#FFFF00'),
+ "draw arc outline r$r d1$d1 len 40");
+ $d1 += 15;
+ $r += 6;
+ }
+ is_color3($im->getpixel(x => 198, y => 202), 0, 0, 0,
+ "check center not filled");
+ ok($im->write(file => "testout/t21arcout.ppm"),
+ "save arc outline");
+}
+
+{
+ my $im = Imager->new(xsize => 400, ysize => 400);
+ ok($im->arc(x => 197, y => 201, r => 10, filled => 0, aa => 1, color => 'white'),
+ "draw circle outline");
+ is_color3($im->getpixel(x => 197, y => 201), 0, 0, 0,
+ "check center not filled");
+ ok($im->arc(x => 197, y => 205, r => 13, filled => 0, color => "#f88", aa => 1),
+ "draw circle outline");
+ is_color3($im->getpixel(x => 197, y => 205), 0, 0, 0,
+ "check center not filled");
+ ok($im->arc(x => 190, y => 215, r => 24, filled => 0, color => [0,0, 255, 128], aa => 1),
+ "draw circle outline");
+ my $r = 40;
+ while ($r < 190) {
+ ok($im->arc(x => 197, y => 201, r => $r, filled => 0, aa => 1, color => '#ff0'), "draw aa circle rad $r");
+ $r += 7;
+ }
+ ok($im->write(file => "testout/t21aacircout.ppm"),
+ "save arc outline");
+}
+
+{
+ my $im = Imager->new(xsize => 400, ysize => 400);
+ {
+ my $lc = Imager::Color->new(32, 32, 32);
+ my $an = 0;
+ while ($an < 360) {
+ my $an_r = $an * PI / 180;
+ my $ca = cos($an_r);
+ my $sa = sin($an_r);
+ $im->line(aa => 1, color => $lc,
+ x1 => 198 + 5 * $ca, y1 => 202 + 5 * $sa,
+ x2 => 198 + 190 * $ca, y2 => 202 + 190 * $sa);
+ $an += 5;
+ }
+ }
+ my $d1 = 0;
+ my $r = 20;
+ while ($d1 < 350) {
+ ok($im->arc(x => 198, y => 202, r => $r, d1 => $d1, d2 => $d1+300, filled => 0, aa => 1),
+ "draw aa arc outline r$r d1$d1 len 300");
+ ok($im->arc(x => 198, y => 202, r => $r+3, d1 => $d1, d2 => $d1+40, filled => 0, color => '#FFFF00', aa => 1),
+ "draw aa arc outline r$r d1$d1 len 40");
+ $d1 += 15;
+ $r += 6;
+ }
+ is_color3($im->getpixel(x => 198, y => 202), 0, 0, 0,
+ "check center not filled");
+ ok($im->write(file => "testout/t21aaarcout.ppm"),
+ "save arc outline");
+}
+
+{
+ my $im = Imager->new(xsize => 400, ysize => 400);
+
+ my $an = 0;
+ my $step = 15;
+ while ($an <= 360-$step) {
+ my $cx = int(200 + 20 * cos(($an+$step/2) * PI / 180));
+ my $cy = int(200 + 20 * sin(($an+$step/2) * PI / 180));
+
+ ok($im->arc(x => $cx, y => $cy, aa => 1, color => "#fff",
+ d1 => $an, d2 => $an+$step, filled => 0, r => 170),
+ "angle starting from $an");
+ ok($im->arc(x => $cx+0.5, y => $cy+0.5, aa => 1, color => "#ff0",
+ d1 => $an, d2 => $an+$step, r => 168),
+ "filled angle starting from $an");
+
+ $an += $step;
+ }
+ ok($im->write(file => "testout/t21aaarcs.ppm"),
+ "save arc outline");
+}
+
+{
+ # we document that drawing from d1 to d2 where d2 > d1 will draw an
+ # arc going through 360 degrees, test that
+ my $im = Imager->new(xsize => 200, ysize => 200);
+ ok($im->arc(x => 100, y => 100, aa => 0, filled => 0, color => '#fff',
+ d1 => 270, d2 => 90, r => 90), "draw non-aa arc through 0");
+ ok($im->arc(x => 100, y => 100, aa => 1, filled => 0, color => '#fff',
+ d1 => 270, d2 => 90, r => 80), "draw aa arc through 0");
+ ok($im->write(file => "testout/t21arc0.ppm"),
+ "save arc through 0");
+}
+
+{
+ # test drawing color defaults
+ {
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ ok($im->box(), "default outline the image"); # should outline the image
+ is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
+ "check outline default color TL");
+ is_color3($im->getpixel(x => 9, y => 5), 255, 255, 255,
+ "check outline default color MR");
+ }
+
+ {
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ ok($im->box(filled => 1), "default fill the image"); # should fill the image
+ is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
+ "check fill default color TL");
+ is_color3($im->getpixel(x => 5, y => 5), 255, 255, 255,
+ "check fill default color MM");
+ }
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->box(), "can't draw box to empty image");
+ is($empty->errstr, "box: empty input image", "check error message");
+ ok(!$empty->arc(), "can't draw arc to empty image");
+ is($empty->errstr, "arc: empty input image", "check error message");
+ ok(!$empty->line(x1 => 0, y1 => 0, x2 => 10, y2 => 0),
+ "can't draw line to empty image");
+ is($empty->errstr, "line: empty input image", "check error message");
+ ok(!$empty->polyline(points => [ [ 0, 0 ], [ 10, 0 ] ]),
+ "can't draw polyline to empty image");
+ is($empty->errstr, "polyline: empty input image", "check error message");
+ ok(!$empty->polygon(points => [ [ 0, 0 ], [ 10, 0 ], [ 0, 10 ] ]),
+ "can't draw polygon to empty image");
+ is($empty->errstr, "polygon: empty input image", "check error message");
+ ok(!$empty->flood_fill(x => 0, y => 0), "can't flood fill to empty image");
+ is($empty->errstr, "flood_fill: empty input image", "check error message");
+}
+
+
+malloc_state();
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t21draw.ppm";
+ unlink "testout/t21circout.ppm";
+ unlink "testout/t21aacircout.ppm";
+ unlink "testout/t21arcout.ppm";
+ unlink "testout/t21aaarcout.ppm";
+ unlink "testout/t21aaarcs.ppm";
+ unlink "testout/t21arc0.ppm";
+}
+
+sub color_cmp {
+ my ($l, $r) = @_;
+ my @l = $l->rgba;
+ my @r = $r->rgba;
+ # print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
+ return $l[0] <=> $r[0]
+ || $l[1] <=> $r[1]
+ || $l[2] <=> $r[2];
+}
+
+sub angle_marker {
+ my ($img, $x, $y, $radius, @angles) = @_;
+
+ for my $angle (@angles) {
+ my $x1 = int($x + $radius * cos($angle * PI / 180) + 0.5);
+ my $y1 = int($y + $radius * sin($angle * PI / 180) + 0.5);
+ my $x2 = int($x + (5+$radius) * cos($angle * PI / 180) + 0.5);
+ my $y2 = int($y + (5+$radius) * sin($angle * PI / 180) + 0.5);
+
+ $img->line(x1=>$x1, y1=>$y1, x2=>$x2, y2=>$y2, color=>'#FFF');
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 15;
+use Imager;
+use Imager::Test qw(is_image);
+
+-d "testout" or mkdir "testout";
+
+{ # flood_fill wouldn't fill to the right if the area was just a
+ # single scan-line
+ my $im = Imager->new(xsize => 5, ysize => 3);
+ ok($im, "make flood_fill test image");
+ ok($im->line(x1 => 0, y1 => 1, x2 => 4, y2 => 1, color => "white"),
+ "create fill area");
+ ok($im->flood_fill(x => 3, y => 1, color => "blue"),
+ "fill it");
+ my $cmp = Imager->new(xsize => 5, ysize => 3);
+ ok($cmp, "make test image");
+ ok($cmp->line(x1 => 0, y1 => 1, x2 => 4, y2 => 1, color => "blue"),
+ "synthezied filled area");
+ is_image($im, $cmp, "flood_fill filled horizontal line");
+}
+
+SKIP:
+{ # flood_fill won't fill entire line below if line above is shorter
+ my $im = Imager->new(file => "testimg/filltest.ppm");
+ ok($im, "Load test image")
+ or skip("Couldn't load test image: " . Imager->errstr, 3);
+
+ # fill from first bad place
+ my $fill1 = $im->copy;
+ ok($fill1->flood_fill(x => 8, y => 2, color => "#000000"),
+ "fill from a top most spot");
+ my $cmp = Imager->new(xsize => $im->getwidth, ysize => $im->getheight);
+ is_image($fill1, $cmp, "check it filled the lot");
+ ok($fill1->write(file => "testout/t22fill1.ppm"), "save");
+
+ # second bad place
+ my $fill2 = $im->copy;
+ ok($fill2->flood_fill(x => 17, y => 3, color => "#000000"),
+ "fill from not quite top most spot");
+ is_image($fill2, $cmp, "check it filled the lot");
+ ok($fill2->write(file => "testout/t22fill2.ppm"), "save");
+}
+
+{ # verticals
+ my $im = vimage("FFFFFF");
+ my $cmp = vimage("FF0000");
+
+ ok($im->flood_fill(x => 4, y=> 8, color => "FF0000"),
+ "fill at bottom of vertical well");
+ is_image($im, $cmp, "check the result");
+}
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t22fill1.ppm";
+ unlink "testout/t22fill2.ppm";
+}
+
+# make a vertical test image
+sub vimage {
+ my $c = shift;
+
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ $im->line(x1 => 1, y1 => 1, x2 => 8, y2 => 1, color => $c);
+ $im->line(x1 => 4, y1 => 2, x2 => 4, y2 => 8, color => $c);
+
+ return $im;
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 60;
+
+use Imager;
+use Imager::Test qw(is_image);
+
+#$Imager::DEBUG=1;
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t66paste.log');
+
+# the original smoke tests
+my $img=Imager->new() || die "unable to create image object\n";
+
+ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'), "load test img");
+
+my $nimg=Imager->new() or die "Unable to create image object\n";
+ok($nimg->open(file=>'testimg/scale.ppm',type=>'pnm'), "load test img again");
+
+ok($img->paste(img=>$nimg, top=>30, left=>30), "paste it")
+ or print "# ", $img->errstr, "\n";;
+
+ok($img->write(type=>'pnm',file=>'testout/t66.ppm'), "save it")
+ or print "# ", $img->errstr, "\n";
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->paste(src => $nimg), "paste into empty image");
+ is($empty->errstr, "paste: empty input image",
+ "check error message");
+
+ ok(!$img->paste(src => $empty), "paste from empty image");
+ is($img->errstr, "paste: empty input image (for src)",
+ "check error message");
+
+ ok(!$img->paste(), "no source image");
+ is($img->errstr, "no source image");
+}
+
+# more stringent tests
+{
+ my $src = Imager->new(xsize => 100, ysize => 110);
+ $src->box(filled=>1, color=>'FF0000');
+
+ $src->box(filled=>1, color=>'0000FF', xmin => 20, ymin=>20,
+ xmax=>79, ymax=>79);
+
+ my $targ = Imager->new(xsize => 100, ysize => 110);
+ $targ->box(filled=>1, color =>'00FFFF');
+ $targ->box(filled=>1, color=>'00FF00', xmin=>20, ymin=>20, xmax=>79,
+ ymax=>79);
+ my $work = $targ->copy;
+ ok($work->paste(src=>$src, left => 15, top => 10), "paste whole image");
+ # build comparison image
+ my $cmp = $targ->copy;
+ $cmp->box(filled=>1, xmin=>15, ymin => 10, color=>'FF0000');
+ $cmp->box(filled=>1, xmin=>35, ymin => 30, xmax=>94, ymax=>89,
+ color=>'0000FF');
+
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "compare pasted and expected");
+
+ $work = $targ->copy;
+ ok($work->paste(src=>$src, left=>2, top=>7, src_minx => 10, src_miny => 15),
+ "paste from inside src");
+ $cmp = $targ->copy;
+ $cmp->box(filled=>1, xmin=>2, ymin=>7, xmax=>91, ymax=>101, color=>'FF0000');
+ $cmp->box(filled=>1, xmin=>12, ymin=>12, xmax=>71, ymax=>71,
+ color=>'0000FF');
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "compare pasted and expected");
+
+ # paste part source
+ $work = $targ->copy;
+ ok($work->paste(src=>$src, left=>15, top=>20,
+ src_minx=>10, src_miny=>15, src_maxx=>80, src_maxy =>70),
+ "paste src cropped all sides");
+ $cmp = $targ->copy;
+ $cmp->box(filled=>1, xmin=>15, ymin=>20, xmax=>84, ymax=>74,
+ color=>'FF0000');
+ $cmp->box(filled=>1, xmin=>25, ymin=>25, xmax=>84, ymax=>74,
+ color=>'0000FF');
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "compare pasted and expected");
+
+ # go by width instead
+ $work = $targ->copy;
+ ok($work->paste(src=>$src, left=>15, top=>20,
+ src_minx=>10, src_miny => 15, width => 70, height => 55),
+ "same but specify width/height instead");
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "compare pasted and expected");
+
+ # use src_coords
+ $work = $targ->copy;
+ ok($work->paste(src=>$src, left => 15, top => 20,
+ src_coords => [ 10, 15, 80, 70 ]),
+ "using src_coords");
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "compare pasted and expected");
+
+ {
+ # Issue #18712
+ # supplying just src_maxx would set the internal maxy to undef
+ # supplying just src_maxy would be ignored
+ # src_maxy (or it's derived value) was being bounds checked against
+ # the image width instead of the image height
+ $work = $targ->copy;
+ my @warns;
+ local $SIG{__WARN__} = sub { push @warns, "@_"; print "# @_"; };
+
+ ok($work->paste(src=>$src, left => 15, top => 20,
+ src_maxx => 50),
+ "paste with just src_maxx");
+ ok(!@warns, "shouldn't warn");
+ my $cmp = $targ->copy;
+ $cmp->box(filled=>1, color => 'FF0000', xmin => 15, ymin => 20,
+ xmax => 64, ymax => 109);
+ $cmp->box(filled=>1, color => '0000FF', xmin => 35, ymin => 40,
+ xmax => 64, ymax => 99);
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "check correctly pasted");
+
+ $work = $targ->copy;
+ @warns = ();
+ ok($work->paste(src=>$src, left=>15, top=>20,
+ src_maxy => 60),
+ "paste with just src_maxy");
+ ok(!@warns, "shouldn't warn");
+ $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => 'FF0000', xmin => 15, ymin => 20,
+ xmax => 99, ymax => 79);
+ $cmp->box(filled => 1, color => '0000FF', xmin => 35, ymin => 40,
+ xmax => 94, ymax => 79);
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "check pasted correctly");
+
+ $work = $targ->copy;
+ @warns = ();
+ ok($work->paste(src=>$src, left=>15, top=>20,
+ src_miny => 20, src_maxy => 105),
+ "paste with src_maxy > source width");
+
+ $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => 'FF0000', xmin => 15, ymin => 20,
+ ymax => 104);
+ $cmp->box(filled => 1, color => '0000FF', xmin => 35, ymin => 20,
+ xmax => 94, ymax => 79);
+ is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+ "check pasted correctly");
+ }
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=30908
+ # we now adapt the source channels to the target
+ # check each combination works as expected
+
+ # various source images
+ my $src1 = Imager->new(xsize => 50, ysize => 50, channels => 1);
+ my $g_grey_full = Imager::Color->new(128, 255, 0, 0);
+ my $g_white_50 = Imager::Color->new(255, 128, 0, 0);
+ $src1->box(filled => 1, xmax => 24, color => $g_grey_full);
+
+ my $src2 = Imager->new(xsize => 50, ysize => 50, channels => 2);
+ $src2->box(filled => 1, xmax => 24, color => $g_grey_full);
+ $src2->box(filled => 1, xmin => 25, color => $g_white_50);
+
+ my $c_red_full = Imager::Color->new(255, 0, 0);
+ my $c_blue_full = Imager::Color->new(0, 0, 255);
+ my $src3 = Imager->new(xsize => 50, ysize => 50, channels => 3);
+ $src3->box(filled => 1, xmax => 24, color => $c_red_full);
+ $src3->box(filled => 1, xmin => 25, color => $c_blue_full);
+
+ my $c_green_50 = Imager::Color->new(0, 255, 0, 127);
+ my $src4 = Imager->new(xsize => 50, ysize => 50, channels => 4);
+ $src4->box(filled => 1, xmax => 24, color => $c_blue_full);
+ $src4->box(filled => 1, xmin => 25, color => $c_green_50);
+
+ my @left_box = ( box => [ 25, 25, 49, 74 ] );
+ my @right_box = ( box => [ 50, 25, 74, 74 ] );
+
+ { # 1 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 1);
+ $base->box(filled => 1, color => Imager::Color->new(64, 255, 0, 0));
+
+ my $work = $base->copy;
+ ok($work->paste(left => 25, top => 25, src => $src1), "paste 1 to 1");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => $g_grey_full, @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(left => 25, top => 25, src => $src2), "paste 2 to 1");
+ $comp = $base->copy;
+ $comp->box(filled => 1, @left_box, color => $g_grey_full);
+ $comp->box(filled => 1, @right_box, color => [ 128, 0, 0, 0 ]);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(left => 25, top => 25, src => $src3), "paste 3 to 1");
+ $comp = $base->copy;
+ $comp->box(filled => 1, @left_box, color => [ 57, 255, 0, 0 ]);
+ $comp->box(filled => 1, @right_box, color => [ 18, 255, 0, 0 ]);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(left => 25, top => 25, src => $src4), "paste 4 to 1");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 90, 255, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+ }
+
+ { # 2 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 2);
+ $base->box(filled => 1, color => [ 128, 128, 0, 0 ]);
+
+ my $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 2");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => $g_grey_full, @left_box);
+ $comp->box(filled => 1, color => [ 0, 255, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 2");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => $g_grey_full, @left_box);
+ $comp->box(filled => 1, color => $g_white_50, @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 2");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 57, 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 2");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 180, 127, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+ }
+
+ { # 3 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 3);
+ $base->box(filled => 1, color => [ 128, 255, 0, 0 ]);
+
+ my $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 3");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 3");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 3");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 3");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 0, 0, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 127, 0 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+ }
+
+ { # 4 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 4);
+ $base->box(filled => 1, color => [ 128, 255, 64, 128 ]);
+
+ my $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 4");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 0, 255 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 4");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 255, 255, 255, 128 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 4");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+
+ $work = $base->copy;
+ ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 4");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => $c_blue_full, @left_box);
+ $comp->box(filled => 1, color => $c_green_50, @right_box);
+ is_image($work, $comp, "compare paste target to expected");
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 76;
+use Imager qw(:all :handy);
+use Imager::Test qw(is_image);
+
+-d "testout" or mkdir "testout";
+
+init_log("testout/t69rubthru.log", 1);
+
+my $src_height = 80;
+my $src_width = 80;
+
+# raw interface
+my $targ = Imager::ImgRaw::new(100, 100, 3);
+my $src = Imager::ImgRaw::new($src_height, $src_width, 4);
+my $halfred = NC(255, 0, 0, 128);
+i_box_filled($src, 20, 20, 60, 60, $halfred);
+ok(i_rubthru($targ, $src, 10, 10, 0, 0, $src_width, $src_height),
+ "low level rubthrough");
+my $c = Imager::i_get_pixel($targ, 10, 10);
+ok($c, "get pixel at (10, 10)");
+ok(color_cmp($c, NC(0, 0, 0)) == 0, "check for correct color");
+$c = Imager::i_get_pixel($targ, 30, 30);
+ok($c, "get pixel at (30, 30)");
+ok(color_cmp($c, NC(128, 0, 0)) == 0, "check color");
+
+my $black = NC(0, 0, 0);
+# reset the target and try a grey+alpha source
+i_box_filled($targ, 0, 0, 100, 100, $black);
+my $gsrc = Imager::ImgRaw::new($src_width, $src_height, 2);
+my $halfwhite = NC(255, 128, 0);
+i_box_filled($gsrc, 20, 20, 60, 60, $halfwhite);
+ok(i_rubthru($targ, $gsrc, 10, 10, 0, 0, $src_width, $src_height),
+ "low level with grey/alpha source");
+$c = Imager::i_get_pixel($targ, 15, 15);
+ok($c, "get at (15, 15)");
+ok(color_cmp($c, NC(0, 0, 0)) == 0, "check color");
+$c = Imager::i_get_pixel($targ, 30, 30);
+ok($c, "get pixel at (30, 30)");
+ok(color_cmp($c, NC(128, 128, 128)) == 0, "check color");
+
+# try grey target and grey alpha source
+my $gtarg = Imager::ImgRaw::new(100, 100, 1);
+ok(i_rubthru($gtarg, $gsrc, 10, 10, 0, 0, $src_width, $src_height),
+ "low level with grey target and gray/alpha source");
+$c = Imager::i_get_pixel($gtarg, 10, 10);
+ok($c, "get pixel at 10, 10");
+is(($c->rgba)[0], 0, "check grey level");
+is((Imager::i_get_pixel($gtarg, 30, 30)->rgba)[0], 128,
+ "check grey level at 30, 30");
+
+# simple test for 16-bit/sample images
+my $targ16 = Imager::i_img_16_new(100, 100, 3);
+ok(i_rubthru($targ16, $src, 10, 10, 0, 0, $src_width, $src_height),
+ "smoke test vs 16-bit/sample image");
+$c = Imager::i_get_pixel($targ16, 30, 30);
+ok($c, "get pixel at 30, 30");
+ok(color_cmp($c, NC(128, 0, 0)) == 0, "check color");
+
+# check the OO interface
+my $ootarg = Imager->new(xsize=>100, ysize=>100);
+my $oosrc = Imager->new(xsize=>80, ysize=>80, channels=>4);
+$oosrc->box(color=>$halfred, xmin=>20, ymin=>20, xmax=>60, ymax=>60,
+ filled=>1);
+ok($ootarg->rubthrough(src=>$oosrc, tx=>10, ty=>10),
+ "oo rubthrough");
+ok(color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 10, 10), NC(0, 0, 0)) == 0,
+ "check pixel at 10, 10");
+ok(color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 30, 30), NC(128, 0, 0)) == 0,
+ "check pixel at 30, 30");
+
+my $oogtarg = Imager->new(xsize=>100, ysize=>100, channels=>1);
+
+{ # check empty image errors
+ my $empty = Imager->new;
+ ok(!$empty->rubthrough(src => $oosrc), "check empty target");
+ is($empty->errstr, 'rubthrough: empty input image', "check error message");
+ ok(!$oogtarg->rubthrough(src=>$empty), "check empty source");
+ is($oogtarg->errstr, 'rubthrough: empty input image (for src)',
+ "check error message");
+}
+
+{
+ # alpha source and target
+ for my $method (qw/rubthrough compose/) {
+
+ my $src = Imager->new(xsize => 10, ysize => 1, channels => 4);
+ my $targ = Imager->new(xsize => 10, ysize => 2, channels => 4);
+
+ # simple initialization
+ $targ->setscanline('y' => 1, x => 1,
+ pixels =>
+ [
+ NC(255, 128, 0, 255),
+ NC(255, 128, 0, 128),
+ NC(255, 128, 0, 0),
+ NC(255, 128, 0, 255),
+ NC(255, 128, 0, 128),
+ NC(255, 128, 0, 0),
+ NC(255, 128, 0, 255),
+ NC(255, 128, 0, 128),
+ NC(255, 128, 0, 0),
+ ]);
+ $src->setscanline('y' => 0,
+ pixels =>
+ [
+ NC(0, 128, 255, 0),
+ NC(0, 128, 255, 0),
+ NC(0, 128, 255, 0),
+ NC(0, 128, 255, 128),
+ NC(0, 128, 255, 128),
+ NC(0, 128, 255, 128),
+ NC(0, 128, 255, 255),
+ NC(0, 128, 255, 255),
+ NC(0, 128, 255, 255),
+ ]);
+ ok($targ->$method(src => $src, combine => 'normal',
+ tx => 1, ty => 1), "do 4 on 4 $method");
+ iscolora($targ->getpixel(x => 1, 'y' => 1), NC(255, 128, 0, 255),
+ "check at zero source coverage on full targ coverage");
+ iscolora($targ->getpixel(x => 2, 'y' => 1), NC(255, 128, 0, 128),
+ "check at zero source coverage on half targ coverage");
+ iscolora($targ->getpixel(x => 3, 'y' => 1), NC(255, 128, 0, 0),
+ "check at zero source coverage on zero targ coverage");
+ iscolora($targ->getpixel(x => 4, 'y' => 1), NC(127, 128, 128, 255),
+ "check at half source_coverage on full targ coverage");
+ iscolora($targ->getpixel(x => 5, 'y' => 1), NC(85, 128, 170, 191),
+ "check at half source coverage on half targ coverage");
+ iscolora($targ->getpixel(x => 6, 'y' => 1), NC(0, 128, 255, 128),
+ "check at half source coverage on zero targ coverage");
+ iscolora($targ->getpixel(x => 7, 'y' => 1), NC(0, 128, 255, 255),
+ "check at full source_coverage on full targ coverage");
+ iscolora($targ->getpixel(x => 8, 'y' => 1), NC(0, 128, 255, 255),
+ "check at full source coverage on half targ coverage");
+ iscolora($targ->getpixel(x => 9, 'y' => 1), NC(0, 128, 255, 255),
+ "check at full source coverage on zero targ coverage");
+ }
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=30908
+ # we now adapt the source channels to the target
+ # check each combination works as expected
+
+ # various source images
+ my $src1 = Imager->new(xsize => 50, ysize => 50, channels => 1);
+ my $g_grey_full = Imager::Color->new(128, 255, 0, 0);
+ my $g_white_50 = Imager::Color->new(255, 128, 0, 0);
+ $src1->box(filled => 1, xmax => 24, color => $g_grey_full);
+
+ my $src2 = Imager->new(xsize => 50, ysize => 50, channels => 2);
+ $src2->box(filled => 1, xmax => 24, color => $g_grey_full);
+ $src2->box(filled => 1, xmin => 25, color => $g_white_50);
+
+ my $c_red_full = Imager::Color->new(255, 0, 0);
+ my $c_blue_full = Imager::Color->new(0, 0, 255);
+ my $src3 = Imager->new(xsize => 50, ysize => 50, channels => 3);
+ $src3->box(filled => 1, xmax => 24, color => $c_red_full);
+ $src3->box(filled => 1, xmin => 25, color => $c_blue_full);
+
+ my $c_green_50 = Imager::Color->new(0, 255, 0, 127);
+ my $src4 = Imager->new(xsize => 50, ysize => 50, channels => 4);
+ $src4->box(filled => 1, xmax => 24, color => $c_blue_full);
+ $src4->box(filled => 1, xmin => 25, color => $c_green_50);
+
+ my @left_box = ( box => [ 25, 25, 49, 74 ] );
+ my @right_box = ( box => [ 50, 25, 74, 74 ] );
+
+ { # 1 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 1);
+ $base->box(filled => 1, color => Imager::Color->new(64, 255, 0, 0));
+
+ my $work = $base->copy;
+ ok($work->rubthrough(left => 25, top => 25, src => $src1), "rubthrough 1 to 1");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => $g_grey_full, @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(left => 25, top => 25, src => $src2), "rubthrough 2 to 1");
+ $comp = $base->copy;
+ $comp->box(filled => 1, @left_box, color => $g_grey_full);
+ $comp->box(filled => 1, @right_box, color => [ 159, 0, 0, 0 ]);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(left => 25, top => 25, src => $src3), "rubthrough 3 to 1");
+ $comp = $base->copy;
+ $comp->box(filled => 1, @left_box, color => [ 57, 255, 0, 0 ]);
+ $comp->box(filled => 1, @right_box, color => [ 18, 255, 0, 0 ]);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(left => 25, top => 25, src => $src4), "rubthrough 4 to 1");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 121, 255, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+ }
+
+ { # 2 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 2);
+ $base->box(filled => 1, color => [ 128, 128, 0, 0 ]);
+
+ my $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 2");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => $g_grey_full, @left_box);
+ $comp->box(filled => 1, color => [ 0, 255, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 2");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => $g_grey_full, @left_box);
+ $comp->box(filled => 1, color => [ 213, 191, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 2");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 57, 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 2");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 162, 191, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+ }
+
+ { # 3 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 3);
+ $base->box(filled => 1, color => [ 128, 255, 0, 0 ]);
+
+ my $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 3");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 3");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 191, 255, 128, 255 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 3");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 3");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 0, 0, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 64, 255, 0 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+ }
+
+ { # 4 channel output
+ my $base = Imager->new(xsize => 100, ysize => 100, channels => 4);
+ $base->box(filled => 1, color => [ 128, 255, 64, 128 ]);
+
+ my $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 4");
+ my $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 0, 255 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 4");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+ $comp->box(filled => 1, color => [ 213, 255, 192, 191 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 4");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+ $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+
+ $work = $base->copy;
+ ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 4");
+ $comp = $base->copy;
+ $comp->box(filled => 1, color => $c_blue_full, @left_box);
+ $comp->box(filled => 1, color => [ 43, 255, 21, 191], @right_box);
+ is_image($work, $comp, "compare rubthrough target to expected");
+ }
+}
+
+sub color_cmp {
+ my ($l, $r) = @_;
+ my @l = $l->rgba;
+ my @r = $r->rgba;
+ print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
+ return $l[0] <=> $r[0]
+ || $l[1] <=> $r[1]
+ || $l[2] <=> $r[2];
+}
+
+sub iscolora {
+ my ($c1, $c2, $msg) = @_;
+
+ my $builder = Test::Builder->new;
+ my @c1 = $c1->rgba;
+ my @c2 = $c2->rgba;
+ if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2]
+ && $c1[3] == $c2[3],
+ $msg)) {
+ $builder->diag(<<DIAG);
+ got color: [ @c1 ]
+ expected color: [ @c2 ]
+DIAG
+ }
+}
+
--- /dev/null
+#!perl -w
+
+use strict;
+use Test::More tests => 18;
+
+use Imager qw/NC/;
+use Imager::Test qw(is_image is_color3);
+
+sub PI () { 3.14159265358979323846 }
+
+-d "testout" or mkdir "testout";
+
+Imager::init_log("testout/t75aapolyaa.log",1);
+
+my $red = Imager::Color->new(255,0,0);
+my $green = Imager::Color->new(0,255,0);
+my $blue = Imager::Color->new(0,0,255);
+my $white = Imager::Color->new(255,255,255);
+
+{ # artifacts with multiple vertical lobes
+ # https://rt.cpan.org/Ticket/Display.html?id=43518
+ # previously this would have a full coverage pixel at (0,0) caused
+ # by the (20,0.5) point in the right lobe
+
+ my @pts =
+ (
+ [ 0.5, -9 ],
+ [ 10, -9 ],
+ [ 10, 11 ],
+ [ 15, 11 ],
+ [ 15, -9 ],
+ [ 17, -9 ],
+ [ 20, 0.5 ],
+ [ 17, 11 ],
+ [ 0.5, 11 ],
+ );
+ my $im = Imager->new(xsize => 10, ysize => 2);
+ ok($im->polygon(points => \@pts,
+ color => $white),
+ "draw with inside point");
+ ok($im->write(file => "testout/t75inside.ppm"), "save to file");
+ # both scanlines should be the same
+ my $line0 = $im->crop(top => 0, height => 1);
+ my $line1 = $im->crop(top => 1, height => 1);
+ is_image($line0, $line1, "both scanlines should be the same");
+}
+
+{ # check vertical edges are consistent
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ ok($im->polygon(points => [ [ 0.5, 0 ], [ 9.25, 0 ],
+ [ 9.25, 10 ], [ 0.5, 10 ] ],
+ color => $white,
+ aa => 1),
+ "draw polygon with mid pixel vertical edges")
+ or diag $im->errstr;
+ my @line0 = $im->getscanline(y => 0);
+ my $im2 = Imager->new(xsize => 10, ysize => 10);
+ for my $y (0..9) {
+ $im2->setscanline(y => $y, pixels => \@line0);
+ }
+ is_image($im, $im2, "all scan lines should be the same");
+ is_color3($line0[0], 128, 128, 128, "(0,0) should be 50% coverage");
+ is_color3($line0[9], 64, 64, 64, "(9,0) should be 25% coverage");
+}
+
+{ # check horizontal edges are consistent
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ ok($im->polygon(points => [ [ 0, 0.5 ], [ 0, 9.25 ],
+ [ 10, 9.25 ], [ 10, 0.5 ] ],
+ color => $white,
+ aa => 1),
+ "draw polygon with mid-pixel horizontal edges");
+ is_deeply([ $im->getsamples(y => 0, channels => [ 0 ]) ],
+ [ (128) x 10 ],
+ "all of line 0 should be 50% coverage");
+ is_deeply([ $im->getsamples(y => 9, channels => [ 0 ]) ],
+ [ (64) x 10 ],
+ "all of line 9 should be 25% coverage");
+}
+
+{
+ my $img = Imager->new(xsize=>20, ysize=>10);
+ my @data = translate(5.5,5,
+ rotate(0,
+ scale(5, 5,
+ get_polygon(n_gon => 5)
+ )
+ )
+ );
+
+
+ my ($x, $y) = array_to_refpair(@data);
+ ok(Imager::i_poly_aa($img->{IMG}, $x, $y, $white), "primitive poly");
+
+ ok($img->write(file=>"testout/t75.ppm"), "write to file")
+ or diag $img->errstr;
+
+ my $zoom = make_zoom($img, 8, \@data, $red);
+ ok($zoom, "make zoom of primitive");
+ $zoom->write(file=>"testout/t75zoom.ppm") or die $zoom->errstr;
+}
+
+{
+ my $img = Imager->new(xsize=>300, ysize=>100);
+
+ my $good = 1;
+ for my $n (0..55) {
+ my @data = translate(20+20*($n%14),18+20*int($n/14),
+ rotate(15*$n/PI,
+ scale(15, 15,
+ get_polygon('box')
+ )
+ )
+ );
+ my ($x, $y) = array_to_refpair(@data);
+ Imager::i_poly_aa($img->{IMG}, $x, $y, NC(rand(255), rand(255), rand(255)))
+ or $good = 0;
+ }
+
+ $img->write(file=>"testout/t75big.ppm") or die $img->errstr;
+
+ ok($good, "primitive squares");
+}
+
+{
+ my $img = Imager->new(xsize => 300, ysize => 300);
+ ok($img -> polygon(color=>$white,
+ points => [
+ translate(150,150,
+ rotate(45*PI/180,
+ scale(70,70,
+ get_polygon('wavycircle', 32*8, sub { 1.2+1*cos(4*$_) }))))
+ ],
+ ), "method call")
+ or diag $img->errstr();
+
+ $img->write(file=>"testout/t75wave.ppm") or die $img->errstr;
+}
+
+{
+ my $img = Imager->new(xsize=>10,ysize=>6);
+ my @data = translate(165,5,
+ scale(80,80,
+ get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })));
+
+ ok($img -> polygon(color=>$white,
+ points => [
+ translate(165,5,
+ scale(80,80,
+ get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
+ ],
+ ), "bug check")
+ or diag $img->errstr();
+
+ make_zoom($img,20,\@data, $blue)->write(file=>"testout/t75wavebug.ppm") or die $img->errstr;
+
+}
+
+{
+ my $img = Imager->new(xsize=>300, ysize=>300);
+ ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF', dx=>3 },
+ points => [
+ translate(150,150,
+ scale(70,70,
+ get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
+ ],
+ ), "poly filled with hatch")
+ or diag $img->errstr();
+ $img->write(file=>"testout/t75wave_fill.ppm") or die $img->errstr;
+}
+
+{
+ my $img = Imager->new(xsize=>300, ysize=>300, bits=>16);
+ ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF' },
+ points => [
+ translate(150,150,
+ scale(70,70,
+ get_polygon('wavycircle', 32*8, sub { 1+1*cos(5*$_) })))
+ ],
+ ), "hatched to 16-bit image")
+ or diag $img->errstr();
+ $img->write(file=>"testout/t75wave_fill16.ppm") or die $img->errstr;
+}
+
+Imager::malloc_state();
+
+
+#initialized in a BEGIN, later
+my %primitives;
+my %polygens;
+
+sub get_polygon {
+ my $name = shift;
+ if (exists $primitives{$name}) {
+ return @{$primitives{$name}};
+ }
+
+ if (exists $polygens{$name}) {
+ return $polygens{$name}->(@_);
+ }
+
+ die "polygon spec: $name unknown\n";
+}
+
+
+sub make_zoom {
+ my ($img, $sc, $polydata, $linecolor) = @_;
+
+ # scale with nearest neighboor sampling
+ my $timg = $img->scale(scalefactor=>$sc, qtype=>'preview');
+
+ # draw the grid
+ for(my $lx=0; $lx<$timg->getwidth(); $lx+=$sc) {
+ $timg->line(color=>$green, x1=>$lx, x2=>$lx, y1=>0, y2=>$timg->getheight(), antialias=>0);
+ }
+
+ for(my $ly=0; $ly<$timg->getheight(); $ly+=$sc) {
+ $timg->line(color=>$green, y1=>$ly, y2=>$ly, x1=>0, x2=>$timg->getwidth(), antialias=>0);
+ }
+ my @data = scale($sc, $sc, @$polydata);
+ push(@data, $data[0]);
+ my ($x, $y) = array_to_refpair(@data);
+
+ $timg->polyline(color=>$linecolor, 'x'=>$x, 'y'=>$y, antialias=>0);
+ return $timg;
+}
+
+# utility functions to manipulate point data
+
+sub scale {
+ my ($x, $y, @data) = @_;
+ return map { [ $_->[0]*$x , $_->[1]*$y ] } @data;
+}
+
+sub translate {
+ my ($x, $y, @data) = @_;
+ map { [ $_->[0]+$x , $_->[1]+$y ] } @data;
+}
+
+sub rotate {
+ my ($rad, @data) = @_;
+ map { [ $_->[0]*cos($rad)+$_->[1]*sin($rad) , $_->[1]*cos($rad)-$_->[0]*sin($rad) ] } @data;
+}
+
+sub array_to_refpair {
+ my (@x, @y);
+ for (@_) {
+ push(@x, $_->[0]);
+ push(@y, $_->[1]);
+ }
+ return \@x, \@y;
+}
+
+
+
+BEGIN {
+%primitives = (
+ box => [ [-0.5,-0.5], [0.5,-0.5], [0.5,0.5], [-0.5,0.5] ],
+ triangle => [ [0,0], [1,0], [1,1] ],
+ );
+
+%polygens = (
+ wavycircle => sub {
+ my $numv = shift;
+ my $radfunc = shift;
+ my @radians = map { $_*2*PI/$numv } 0..$numv-1;
+ my @radius = map { $radfunc->($_) } @radians;
+ map {
+ [ $radius[$_] * cos($radians[$_]), $radius[$_] * sin($radians[$_]) ]
+ } 0..$#radians;
+ },
+ n_gon => sub {
+ my $N = shift;
+ map {
+ [ cos($_*2*PI/$N), sin($_*2*PI/$N) ]
+ } 0..$N-1;
+ },
+);
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 165;
+
+use Imager ':handy';
+use Imager::Fill;
+use Imager::Color::Float;
+use Imager::Test qw(is_image is_color4 is_fcolor4 is_color3);
+use Config;
+
+-d "testout" or mkdir "testout";
+
+Imager::init_log("testout/t20fill.log", 1);
+
+my $blue = NC(0,0,255);
+my $red = NC(255, 0, 0);
+my $redf = Imager::Color::Float->new(1, 0, 0);
+my $bluef = Imager::Color::Float->new(0, 0, 1);
+my $rsolid = Imager::i_new_fill_solid($blue, 0);
+ok($rsolid, "building solid fill");
+my $raw1 = Imager::ImgRaw::new(100, 100, 3);
+# use the normal filled box
+Imager::i_box_filled($raw1, 0, 0, 99, 99, $blue);
+my $raw2 = Imager::ImgRaw::new(100, 100, 3);
+Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid);
+ok(1, "drawing with solid fill");
+my $diff = Imager::i_img_diff($raw1, $raw2);
+ok($diff == 0, "solid fill doesn't match");
+Imager::i_box_filled($raw1, 0, 0, 99, 99, $red);
+my $rsolid2 = Imager::i_new_fill_solidf($redf, 0);
+ok($rsolid2, "creating float solid fill");
+Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid2);
+$diff = Imager::i_img_diff($raw1, $raw2);
+ok($diff == 0, "float solid fill doesn't match");
+
+# ok solid still works, let's try a hatch
+# hash1 is a 2x2 checkerboard
+my $rhatcha = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 0, 0);
+my $rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 2, 0);
+ok($rhatcha && $rhatchb, "can't build hatched fill");
+
+# the offset should make these match
+Imager::i_box_cfill($raw1, 0, 0, 99, 99, $rhatcha);
+Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
+ok(1, "filling with hatch");
+$diff = Imager::i_img_diff($raw1, $raw2);
+ok($diff == 0, "hatch images different");
+$rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 4, 6);
+Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
+$diff = Imager::i_img_diff($raw1, $raw2);
+ok($diff == 0, "hatch images different");
+
+# I guess I was tired when I originally did this - make sure it keeps
+# acting the way it's meant to
+# I had originally expected these to match with the red and blue swapped
+$rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 2, 2);
+Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
+$diff = Imager::i_img_diff($raw1, $raw2);
+ok($diff == 0, "hatch images different");
+
+# this shouldn't match
+$rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 1, 1);
+Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
+$diff = Imager::i_img_diff($raw1, $raw2);
+ok($diff, "hatch images the same!");
+
+# custom hatch
+# the inverse of the 2x2 checkerboard
+my $hatch = pack("C8", 0x33, 0x33, 0xCC, 0xCC, 0x33, 0x33, 0xCC, 0xCC);
+my $rcustom = Imager::i_new_fill_hatch($blue, $red, 0, 0, $hatch, 0, 0);
+Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rcustom);
+$diff = Imager::i_img_diff($raw1, $raw2);
+ok(!$diff, "custom hatch mismatch");
+
+{
+ # basic test of floating color hatch fills
+ # this will exercise the code that the gcc shipped with OS X 10.4
+ # forgets to generate
+ # the float version is called iff we're working with a non-8-bit image
+ # i_new_fill_hatchf() makes the same object as i_new_fill_hatch() but
+ # we test the other construction code path here
+ my $fraw1 = Imager::i_img_double_new(100, 100, 3);
+ my $fhatch1 = Imager::i_new_fill_hatchf($redf, $bluef, 0, 1, undef, 0, 0);
+ ok($fraw1, "making double image 1");
+ ok($fhatch1, "making float hatch 1");
+ Imager::i_box_cfill($fraw1, 0, 0, 99, 99, $fhatch1);
+ my $fraw2 = Imager::i_img_double_new(100, 100, 3);
+ my $fhatch2 = Imager::i_new_fill_hatchf($bluef, $redf, 0, 1, undef, 0, 2);
+ ok($fraw2, "making double image 2");
+ ok($fhatch2, "making float hatch 2");
+ Imager::i_box_cfill($fraw2, 0, 0, 99, 99, $fhatch2);
+
+ $diff = Imager::i_img_diff($fraw1, $fraw2);
+ ok(!$diff, "float custom hatch mismatch");
+ save($fraw1, "testout/t20hatchf1.ppm");
+ save($fraw2, "testout/t20hatchf2.ppm");
+}
+
+# test the oo interface
+my $im1 = Imager->new(xsize=>100, ysize=>100);
+my $im2 = Imager->new(xsize=>100, ysize=>100);
+
+my $solid = Imager::Fill->new(solid=>'#FF0000');
+ok($solid, "creating oo solid fill");
+ok($solid->{fill}, "bad oo solid fill");
+$im1->box(fill=>$solid);
+$im2->box(filled=>1, color=>$red);
+$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
+ok(!$diff, "oo solid fill");
+
+my $hatcha = Imager::Fill->new(hatch=>'check2x2');
+my $hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2);
+$im1->box(fill=>$hatcha);
+$im2->box(fill=>$hatchb);
+# should be different
+$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
+ok($diff, "offset checks the same!");
+$hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2, dy=>2);
+$im2->box(fill=>$hatchb);
+$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
+ok(!$diff, "offset into similar check should be the same");
+
+# test dymanic build of fill
+$im2->box(fill=>{hatch=>'check2x2', dx=>2, fg=>NC(255,255,255),
+ bg=>NC(0,0,0)});
+$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
+ok(!$diff, "offset and flipped should be the same");
+
+# a simple demo
+my $im = Imager->new(xsize=>200, ysize=>200);
+
+$im->box(xmin=>10, ymin=>10, xmax=>190, ymax=>190,
+ fill=>{ hatch=>'check4x4',
+ fg=>NC(128, 0, 0),
+ bg=>NC(128, 64, 0) })
+ or print "# ",$im->errstr,"\n";
+$im->arc(r=>80, d1=>45, d2=>75,
+ fill=>{ hatch=>'stipple2',
+ combine=>1,
+ fg=>[ 0, 0, 0, 255 ],
+ bg=>{ rgba=>[255,255,255,160] } })
+ or print "# ",$im->errstr,"\n";
+$im->arc(r=>80, d1=>75, d2=>135,
+ fill=>{ fountain=>'radial', xa=>100, ya=>100, xb=>20, yb=>100 })
+ or print "# ",$im->errstr,"\n";
+$im->write(file=>'testout/t20_sample.ppm');
+
+# flood fill tests
+my $rffimg = Imager::ImgRaw::new(100, 100, 3);
+# build a H
+Imager::i_box_filled($rffimg, 10, 10, 20, 90, $blue);
+Imager::i_box_filled($rffimg, 80, 10, 90, 90, $blue);
+Imager::i_box_filled($rffimg, 20, 45, 80, 55, $blue);
+my $black = Imager::Color->new(0, 0, 0);
+Imager::i_flood_fill($rffimg, 15, 15, $red);
+my $rffcmp = Imager::ImgRaw::new(100, 100, 3);
+# build a H
+Imager::i_box_filled($rffcmp, 10, 10, 20, 90, $red);
+Imager::i_box_filled($rffcmp, 80, 10, 90, 90, $red);
+Imager::i_box_filled($rffcmp, 20, 45, 80, 55, $red);
+$diff = Imager::i_img_diff($rffimg, $rffcmp);
+ok(!$diff, "flood fill difference");
+
+my $ffim = Imager->new(xsize=>100, ysize=>100);
+my $yellow = Imager::Color->new(255, 255, 0);
+$ffim->box(xmin=>10, ymin=>10, xmax=>20, ymax=>90, color=>$blue, filled=>1);
+$ffim->box(xmin=>20, ymin=>45, xmax=>80, ymax=>55, color=>$blue, filled=>1);
+$ffim->box(xmin=>80, ymin=>10, xmax=>90, ymax=>90, color=>$blue, filled=>1);
+ok($ffim->flood_fill('x'=>50, 'y'=>50, color=>$red), "flood fill");
+$diff = Imager::i_img_diff($rffcmp, $ffim->{IMG});
+ok(!$diff, "oo flood fill difference");
+$ffim->flood_fill('x'=>50, 'y'=>50,
+ fill=> {
+ hatch => 'check2x2',
+ fg => '0000FF',
+ });
+# fill=>{
+# fountain=>'radial',
+# xa=>50, ya=>50,
+# xb=>10, yb=>10,
+# });
+$ffim->write(file=>'testout/t20_ooflood.ppm');
+
+my $copy = $ffim->copy;
+ok($ffim->flood_fill('x' => 50, 'y' => 50,
+ color => $red, border => '000000'),
+ "border solid flood fill");
+is(Imager::i_img_diff($ffim->{IMG}, $rffcmp), 0, "compare");
+ok($ffim->flood_fill('x' => 50, 'y' => 50,
+ fill => { hatch => 'check2x2', fg => '0000FF', },
+ border => '000000'),
+ "border cfill fill");
+is(Imager::i_img_diff($ffim->{IMG}, $copy->{IMG}), 0,
+ "compare");
+
+# test combining modes
+my $fill = NC(192, 128, 128, 128);
+my $target = NC(64, 32, 64);
+my $trans_target = NC(64, 32, 64, 128);
+my %comb_tests =
+ (
+ none=>
+ {
+ opaque => $fill,
+ trans => $fill,
+ },
+ normal=>
+ {
+ opaque => NC(128, 80, 96),
+ trans => NC(150, 96, 107, 191),
+ },
+ multiply =>
+ {
+ opaque => NC(56, 24, 48),
+ trans => NC(101, 58, 74, 192),
+ },
+ dissolve =>
+ {
+ opaque => [ $target, NC(192, 128, 128, 255) ],
+ trans => [ $trans_target, NC(192, 128, 128, 255) ],
+ },
+ add =>
+ {
+ opaque => NC(159, 96, 128),
+ trans => NC(128, 80, 96, 255),
+ },
+ subtract =>
+ {
+ opaque => NC(0, 0, 0),
+ trans => NC(0, 0, 0, 255),
+ },
+ diff =>
+ {
+ opaque => NC(96, 64, 64),
+ trans => NC(127, 85, 85, 192),
+ },
+ lighten =>
+ {
+ opaque => NC(128, 80, 96),
+ trans => NC(149, 95, 106, 192),
+ },
+ darken =>
+ {
+ opaque => $target,
+ trans => NC(106, 63, 85, 192),
+ },
+ # the following results are based on the results of the tests and
+ # are suspect for that reason (and were broken at one point <sigh>)
+ # but trying to work them out manually just makes my head hurt - TC
+ hue =>
+ {
+ opaque => NC(64, 32, 47),
+ trans => NC(64, 32, 42, 128),
+ },
+ saturation =>
+ {
+ opaque => NC(63, 37, 64),
+ trans => NC(64, 39, 64, 128),
+ },
+ value =>
+ {
+ opaque => NC(127, 64, 128),
+ trans => NC(149, 75, 150, 128),
+ },
+ color =>
+ {
+ opaque => NC(64, 37, 52),
+ trans => NC(64, 39, 50, 128),
+ },
+ );
+
+for my $comb (Imager::Fill->combines) {
+ my $test = $comb_tests{$comb};
+ my $fillobj = Imager::Fill->new(solid=>$fill, combine=>$comb);
+
+ for my $bits (qw(8 double)) {
+ {
+ my $targim = Imager->new(xsize=>4, ysize=>4, bits => $bits);
+ $targim->box(filled=>1, color=>$target);
+ $targim->box(fill=>$fillobj);
+ my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
+ my $allowed = $test->{opaque};
+ $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
+ ok(scalar grep(color_close($_, $c), @$allowed),
+ "opaque '$comb' $bits bits")
+ or print "# got:",join(",", $c->rgba)," allowed: ",
+ join("|", map { join(",", $_->rgba) } @$allowed),"\n";
+ }
+
+ {
+ # make sure the alpha path in the combine function produces the same
+ # or at least as sane a result as the non-alpha path
+ my $targim = Imager->new(xsize=>4, ysize=>4, channels => 4, bits => $bits);
+ $targim->box(filled=>1, color=>$target);
+ $targim->box(fill=>$fillobj);
+ my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
+ my $allowed = $test->{opaque};
+ $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
+ ok(scalar grep(color_close4($_, $c), @$allowed),
+ "opaque '$comb' 4-channel $bits bits")
+ or print "# got:",join(",", $c->rgba)," allowed: ",
+ join("|", map { join(",", $_->rgba) } @$allowed),"\n";
+ }
+
+ {
+ my $transim = Imager->new(xsize => 4, ysize => 4, channels => 4, bits => $bits);
+ $transim->box(filled=>1, color=>$trans_target);
+ $transim->box(fill => $fillobj);
+ my $c = $transim->getpixel(x => 1, 'y' => 1);
+ my $allowed = $test->{trans};
+ $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
+ ok(scalar grep(color_close4($_, $c), @$allowed),
+ "translucent '$comb' $bits bits")
+ or print "# got:",join(",", $c->rgba)," allowed: ",
+ join("|", map { join(",", $_->rgba) } @$allowed),"\n";
+ }
+ }
+}
+
+ok($ffim->arc(r=>45, color=>$blue, aa=>1), "aa circle");
+$ffim->write(file=>"testout/t20_aacircle.ppm");
+
+# image based fills
+my $green = NC(0, 255, 0);
+my $fillim = Imager->new(xsize=>40, ysize=>40, channels=>4);
+$fillim->box(filled=>1, xmin=>5, ymin=>5, xmax=>35, ymax=>35,
+ color=>NC(0, 0, 255, 128));
+$fillim->arc(filled=>1, r=>10, color=>$green, aa=>1);
+my $ooim = Imager->new(xsize=>150, ysize=>150);
+$ooim->box(filled=>1, color=>$green, xmin=>70, ymin=>25, xmax=>130, ymax=>125);
+$ooim->box(filled=>1, color=>$blue, xmin=>20, ymin=>25, xmax=>80, ymax=>125);
+$ooim->arc(r=>30, color=>$red, aa=>1);
+
+my $oocopy = $ooim->copy();
+ok($oocopy->arc(fill=>{image=>$fillim,
+ combine=>'normal',
+ xoff=>5}, r=>40),
+ "image based fill");
+$oocopy->write(file=>'testout/t20_image.ppm');
+
+# a more complex version
+use Imager::Matrix2d ':handy';
+$oocopy = $ooim->copy;
+ok($oocopy->arc(fill=>{
+ image=>$fillim,
+ combine=>'normal',
+ matrix=>m2d_rotate(degrees=>30),
+ xoff=>5
+ }, r=>40),
+ "transformed image based fill");
+$oocopy->write(file=>'testout/t20_image_xform.ppm');
+
+ok(!$oocopy->arc(fill=>{ hatch=>"not really a hatch" }, r=>20),
+ "error handling of automatic fill conversion");
+ok($oocopy->errstr =~ /Unknown hatch type/,
+ "error message for automatic fill conversion");
+
+# previous box fills to float images, or using the fountain fill
+# got into a loop here
+
+SKIP:
+{
+ skip("can't test without alarm()", 1) unless $Config{d_alarm};
+ local $SIG{ALRM} = sub { die; };
+
+ eval {
+ alarm(2);
+ ok($ooim->box(xmin=>20, ymin=>20, xmax=>80, ymax=>40,
+ fill=>{ fountain=>'linear', xa=>20, ya=>20, xb=>80,
+ yb=>20 }), "linear box fill");
+ alarm 0;
+ };
+ $@ and ok(0, "linear box fill $@");
+}
+
+# test that passing in a non-array ref returns an error
+{
+ my $fill = Imager::Fill->new(fountain=>'linear',
+ xa => 20, ya=>20, xb=>20, yb=>40,
+ segments=>"invalid");
+ ok(!$fill, "passing invalid segments produces an error");
+ cmp_ok(Imager->errstr, '=~', 'array reference',
+ "check the error message");
+}
+
+# test that colors in segments are converted
+{
+ my @segs =
+ (
+ [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
+ );
+ my $fill = Imager::Fill->new(fountain=>'linear',
+ xa => 0, ya=>20, xb=>49, yb=>20,
+ segments=>\@segs);
+ ok($fill, "check that color names are converted")
+ or print "# ",Imager->errstr,"\n";
+ my $im = Imager->new(xsize=>50, ysize=>50);
+ $im->box(fill=>$fill);
+ my $left = $im->getpixel('x'=>0, 'y'=>20);
+ ok(color_close($left, Imager::Color->new(0,0,0)),
+ "check black converted correctly");
+ my $right = $im->getpixel('x'=>49, 'y'=>20);
+ ok(color_close($right, Imager::Color->new(255,255,255)),
+ "check white converted correctly");
+
+ # check that invalid colors handled correctly
+
+ my @segs2 =
+ (
+ [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
+ );
+ my $fill2 = Imager::Fill->new(fountain=>'linear',
+ xa => 0, ya=>20, xb=>49, yb=>20,
+ segments=>\@segs2);
+ ok(!$fill2, "check handling of invalid color names");
+ cmp_ok(Imager->errstr, '=~', 'No color named', "check error message");
+}
+
+{ # RT #35278
+ # hatch fills on a grey scale image don't adapt colors
+ for my $bits (8, 'double') {
+ my $im_g = Imager->new(xsize => 10, ysize => 10, channels => 1, bits => $bits);
+ $im_g->box(filled => 1, color => 'FFFFFF');
+ my $fill = Imager::Fill->new
+ (
+ combine => 'normal',
+ hatch => 'weave',
+ fg => '000000',
+ bg => 'FFFFFF'
+ );
+ $im_g->box(fill => $fill);
+ my $im_c = Imager->new(xsize => 10, ysize => 10, channels => 3, bits => $bits);
+ $im_c->box(filled => 1, color => 'FFFFFF');
+ $im_c->box(fill => $fill);
+ my $im_cg = $im_g->convert(preset => 'rgb');
+ is_image($im_c, $im_cg, "check hatch is the same between color and greyscale (bits $bits)");
+
+ # check the same for image fills
+ my $grey_fill = Imager::Fill->new
+ (
+ image => $im_g,
+ combine => 'normal'
+ );
+ my $im_cfg = Imager->new(xsize => 20, ysize => 20, bits => $bits);
+ $im_cfg->box(filled => 1, color => '808080');
+ $im_cfg->box(fill => $grey_fill);
+ my $rgb_fill = Imager::Fill->new
+ (
+ image => $im_cg,
+ combine => 'normal'
+ );
+ my $im_cfc = Imager->new(xsize => 20, ysize => 20, bits => $bits);
+ $im_cfc->box(filled => 1, color => '808080');
+ $im_cfc->box(fill => $rgb_fill);
+ is_image($im_cfg, $im_cfc, "check filling from grey image matches filling from rgb (bits = $bits)");
+
+ my $im_gfg = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
+ $im_gfg->box(filled => 1, color => '808080');
+ $im_gfg->box(fill => $grey_fill);
+ my $im_gfg_c = $im_gfg->convert(preset => 'rgb');
+ is_image($im_gfg_c, $im_cfg, "check grey filled with grey against base (bits = $bits)");
+
+ my $im_gfc = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
+ $im_gfc->box(filled => 1, color => '808080');
+ $im_gfc->box(fill => $rgb_fill);
+ my $im_gfc_c = $im_gfc->convert(preset => 'rgb');
+ is_image($im_gfc_c, $im_cfg, "check grey filled with color against base (bits = $bits)");
+ }
+}
+
+{ # alpha modifying fills
+ { # 8-bit/sample
+ my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4);
+ $base_img->setscanline
+ (
+ x => 0,
+ y => 0,
+ pixels =>
+ [
+ map Imager::Color->new($_),
+ qw/FF000020 00FF0080 00008040 FFFF00FF/,
+ ],
+ );
+ $base_img->setscanline
+ (
+ x => 0,
+ y => 1,
+ pixels =>
+ [
+ map Imager::Color->new($_),
+ qw/FFFF00FF FF000000 00FF0080 00008040/
+ ]
+ );
+ my $base_fill = Imager::Fill->new
+ (
+ image => $base_img,
+ combine => "normal",
+ );
+ ok($base_fill, "make the base image fill");
+ my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
+ or print "# ", Imager->errstr, "\n";
+ ok($fill50, "make 50% alpha translation fill");
+
+ { # 4 channel image
+ my $out = Imager->new(xsize => 10, ysize => 10, channels => 4);
+ $out->box(fill => $fill50);
+ is_color4($out->getpixel(x => 0, y => 0),
+ 255, 0, 0, 16, "check alpha output");
+ is_color4($out->getpixel(x => 2, y => 1),
+ 0, 255, 0, 64, "check alpha output");
+ $out->box(filled => 1, color => "000000");
+ is_color4($out->getpixel(x => 0, y => 0),
+ 0, 0, 0, 255, "check after clear");
+ $out->box(fill => $fill50);
+ is_color4($out->getpixel(x => 4, y => 2),
+ 16, 0, 0, 255, "check drawn against background");
+ is_color4($out->getpixel(x => 6, y => 3),
+ 0, 64, 0, 255, "check drawn against background");
+ }
+ { # 3 channel image
+ my $out = Imager->new(xsize => 10, ysize => 10, channels => 3);
+ $out->box(fill => $fill50);
+ is_color3($out->getpixel(x => 0, y => 0),
+ 16, 0, 0, "check alpha output");
+ is_color3($out->getpixel(x => 2, y => 1),
+ 0, 64, 0, "check alpha output");
+ is_color3($out->getpixel(x => 0, y => 1),
+ 128, 128, 0, "check alpha output");
+ }
+ }
+ { # double/sample
+ use Imager::Color::Float;
+ my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4, bits => "double");
+ $base_img->setscanline
+ (
+ x => 0,
+ y => 0,
+ pixels =>
+ [
+ map Imager::Color::Float->new(@$_),
+ [ 1, 0, 0, 0.125 ],
+ [ 0, 1, 0, 0.5 ],
+ [ 0, 0, 0.5, 0.25 ],
+ [ 1, 1, 0, 1 ],
+ ],
+ );
+ $base_img->setscanline
+ (
+ x => 0,
+ y => 1,
+ pixels =>
+ [
+ map Imager::Color::Float->new(@$_),
+ [ 1, 1, 0, 1 ],
+ [ 1, 0, 0, 0 ],
+ [ 0, 1, 0, 0.5 ],
+ [ 0, 0, 0.5, 0.25 ],
+ ]
+ );
+ my $base_fill = Imager::Fill->new
+ (
+ image => $base_img,
+ combine => "normal",
+ );
+ ok($base_fill, "make the base image fill");
+ my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
+ or print "# ", Imager->errstr, "\n";
+ ok($fill50, "make 50% alpha translation fill");
+ my $out = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => "double");
+ $out->box(fill => $fill50);
+ is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
+ 1, 0, 0, 0.0625, "check alpha output at 0,0");
+ is_fcolor4($out->getpixel(x => 2, y => 1, type => "float"),
+ 0, 1, 0, 0.25, "check alpha output at 2,1");
+ $out->box(filled => 1, color => "000000");
+ is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
+ 0, 0, 0, 1, "check after clear");
+ $out->box(fill => $fill50);
+ is_fcolor4($out->getpixel(x => 4, y => 2, type => "float"),
+ 0.0625, 0, 0, 1, "check drawn against background at 4,2");
+ is_fcolor4($out->getpixel(x => 6, y => 3, type => "float"),
+ 0, 0.25, 0, 1, "check drawn against background at 6,3");
+ }
+ ok(!Imager::Fill->new(type => "opacity"),
+ "should fail to make an opacity fill with no other fill object");
+ is(Imager->errstr, "'other' parameter required to create opacity fill",
+ "check error message");
+ ok(!Imager::Fill->new(type => "opacity", other => "xx"),
+ "should fail to make an opacity fill with a bad other parameter");
+ is(Imager->errstr, "'other' parameter must be an Imager::Fill object to create an opacity fill",
+ "check error message");
+
+ # check auto conversion of hashes
+ ok(Imager::Fill->new(type => "opacity", other => { solid => "FF0000" }),
+ "check we auto-create fills")
+ or print "# ", Imager->errstr, "\n";
+
+ {
+ # fill with combine none was modifying the wrong channel for a
+ # no-alpha target image
+ my $fill = Imager::Fill->new(solid => "#FFF", combine => "none");
+ my $fill2 = Imager::Fill->new
+ (
+ type => "opacity",
+ opacity => 0.5,
+ other => $fill
+ );
+ my $im = Imager->new(xsize => 1, ysize => 1);
+ ok($im->box(fill => $fill2), "fill with replacement opacity fill");
+ is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
+ "check for correct colour");
+ }
+
+ {
+ require Imager::Fountain;
+ my $fount = Imager::Fountain->new;
+ $fount->add(c1 => "FFFFFF"); # simple white to black
+ # base fill is a fountain
+ my $base_fill = Imager::Fill->new
+ (
+ fountain => "linear",
+ segments => $fount,
+ xa => 0,
+ ya => 0,
+ xb => 100,
+ yb => 100,
+ );
+ ok($base_fill, "made fountain fill base");
+ my $op_fill = Imager::Fill->new
+ (
+ type => "opacity",
+ other => $base_fill,
+ opacity => 0.5,
+ );
+ ok($op_fill, "made opacity fountain fill");
+ my $im = Imager->new(xsize => 100, ysize => 100);
+ ok($im->box(fill => $op_fill), "draw with it");
+ }
+}
+
+{ # RT 71309
+ my $fount = Imager::Fountain->simple(colors => [ '#804041', '#804041' ],
+ positions => [ 0, 1 ]);
+ my $im = Imager->new(xsize => 40, ysize => 40);
+ $im->box(filled => 1, color => '#804040');
+ my $fill = Imager::Fill->new
+ (
+ combine => 0,
+ fountain => "linear",
+ segments => $fount,
+ xa => 0, ya => 0,
+ xb => 40, yb => 40,
+ );
+ $im->polygon(fill => $fill,
+ points =>
+ [
+ [ 0, 0 ],
+ [ 40, 20 ],
+ [ 20, 40 ],
+ ]
+ );
+ # the bug magnified the differences between the source and destination
+ # color, blending between the background and fill colors here only allows
+ # for those 2 colors in the result.
+ # with the bug extra colors appeared along the edge of the polygon.
+ is($im->getcolorcount, 2, "only original and fill color");
+}
+
+SKIP:
+{
+ # the wrong image dimension was used for adjusting vs yoff,
+ # producing uncovered parts of the output image
+ my $tx = Imager->new(xsize => 30, ysize => 20);
+ ok($tx, "create texture image")
+ or diag "create texture image", Imager->errstr;
+ $tx or skip "no texture image", 7;
+ ok($tx->box(filled => 1, color => "ff0000"), "fill texture image")
+ or diag "fill texture image", $tx->errstr;
+ my $cmp = Imager->new(xsize => 100, ysize => 100);
+ ok($cmp, "create comparison image")
+ or diag "create comparison image: ", Imager->errstr;
+ $cmp or skip "no comparison image", 5;
+ ok($cmp->box(filled => 1, color => "FF0000"), "fill compare image")
+ or diag "fill compare image: ", $cmp->errstr;
+ my $im = Imager->new(xsize => 100, ysize => 100);
+ ok($im, "make test image")
+ or diag "make test image: ", Imager->errstr;
+ $im or skip "no test image", 3;
+ my $fill = Imager::Fill->new(image => $tx, yoff => 10);
+ ok($fill, "make xoff=10 image fill")
+ or diag "make fill: ", Imager->errstr;
+ $fill or skip "no fill", 2;
+ ok($im->box(fill => $fill), "fill test image")
+ or diag "fill test image: ", $im->errstr;
+ is_image($im, $cmp, "check test image");
+}
+
+sub color_close {
+ my ($c1, $c2) = @_;
+
+ my @c1 = $c1->rgba;
+ my @c2 = $c2->rgba;
+
+ for my $i (0..2) {
+ if (abs($c1[$i]-$c2[$i]) > 2) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+sub color_close4 {
+ my ($c1, $c2) = @_;
+
+ my @c1 = $c1->rgba;
+ my @c2 = $c2->rgba;
+
+ for my $i (0..3) {
+ if (abs($c1[$i]-$c2[$i]) > 2) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+# for use during testing
+sub save {
+ my ($im, $name) = @_;
+
+ open FH, "> $name" or die "Cannot create $name: $!";
+ binmode FH;
+ my $io = Imager::io_new_fd(fileno(FH));
+ Imager::i_writeppm_wiol($im, $io) or die "Cannot save to $name";
+ undef $io;
+ close FH;
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager qw(:handy);
+use Test::More tests => 120;
+use Imager::Test qw(is_image is_imaged);
+
+-d "testout" or mkdir "testout";
+
+Imager::init_log("testout/t62compose.log", 1);
+
+my @files;
+
+my %types =
+ (
+ double =>
+ {
+ blue => NCF(0, 0, 1),
+ red => NCF(1, 0, 0),
+ green2 => NCF(0, 1, 0, 0.5),
+ green2_on_blue => NCF(0, 0.5, 0.5),
+ red3_on_blue => NCF(1/3, 0, 2/3),
+ green6_on_blue => NCF(0, 1/6, 5/6),
+ red2_on_blue => NCF(0.5, 0, 0.5),
+ green4_on_blue => NCF(0, 0.25, 0.75),
+ gray100 => NCF(1.0, 0, 0),
+ gray50 => NCF(0.5, 0, 0),
+ is_image => \&is_imaged,
+ },
+ 8 =>
+ {
+ blue => NC(0, 0, 255),
+ red => NC(255, 0, 0),
+ green2 => NC(0, 255, 0, 128),
+ green2_on_blue => NC(0, 128, 127),
+ red3_on_blue => NC(85, 0, 170),
+ green6_on_blue => NC(0, 42, 213),
+ red2_on_blue => NC(128, 0, 127),
+ green4_on_blue => NC(0, 64, 191),
+ gray100 => NC(255, 0, 0),
+ gray50 => NC(128, 0, 0),
+ is_image => \&is_image,
+ },
+ );
+
+for my $type_id (sort keys %types) {
+ my $type = $types{$type_id};
+ my $blue = $type->{blue};
+ my $red = $type->{red};
+ my $green2 = $type->{green2};
+ my $green2_on_blue = $type->{green2_on_blue};
+ my $red3_on_blue = $type->{red3_on_blue};
+ my $green6_on_blue = $type->{green6_on_blue};
+ my $red2_on_blue = $type->{red2_on_blue};
+ my $green4_on_blue = $type->{green4_on_blue};
+ my $gray100 = $type->{gray100};
+ my $gray50 = $type->{gray50};
+ my $is_image = $type->{is_image};
+
+ print "# type $type_id\n";
+ my $targ = Imager->new(xsize => 100, ysize => 100, bits => $type_id);
+ $targ->box(color => $blue, filled => 1);
+ is($targ->type, "direct", "check target image type");
+ is($targ->bits, $type_id, "check target bits");
+
+ my $src = Imager->new(xsize => 40, ysize => 40, channels => 4, bits => $type_id);
+ $src->box(filled => 1, color => $red, xmax => 19, ymax => 19);
+ $src->box(filled => 1, xmin => 20, color => $green2);
+ save_to($src, "${type_id}_src");
+
+ my $mask_ones = Imager->new(channels => 1, xsize => 40, ysize => 40, bits => $type_id);
+ $mask_ones->box(filled => 1, color => NC(255, 255, 255));
+
+
+ # mask or full mask, should be the same
+ for my $mask_info ([ "nomask" ], [ "fullmask", mask => $mask_ones ]) {
+ my ($mask_type, @mask_extras) = @$mask_info;
+ print "# $mask_type\n";
+ {
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 5, ymin => 10, xmax => 24, ymax => 29);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 25, ymin => 10, xmax => 44, ymax => 49);
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 10, @mask_extras),
+ "$mask_type - simple compose");
+ $is_image->($work, $cmp, "check match");
+ save_to($work, "${type_id}_${mask_type}_simple");
+ }
+ { # >1 opacity
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 10, opacity => 2.0, @mask_extras),
+ "$mask_type - compose with opacity > 1.0 acts like opacity=1.0");
+ $is_image->($work, $cmp, "check match");
+ }
+ { # 0 opacity is a failure
+ my $work = $targ->copy;
+ ok(!$work->compose(src => $src, tx => 5, ty => 10, opacity => 0.0, @mask_extras),
+ "$mask_type - compose with opacity = 0 is an error");
+ is($work->errstr, "opacity must be positive", "check message");
+ }
+ }
+ { # compose at 1/3
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 7, ty => 33, opacity => 1/3, @mask_extras),
+ "$mask_type - simple compose at 1/3");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red3_on_blue,
+ xmin => 7, ymin => 33, xmax => 26, ymax => 52);
+ $cmp->box(filled => 1, color => $green6_on_blue,
+ xmin => 27, ymin => 33, xmax => 46, ymax => 72);
+ $is_image->($work, $cmp, "check match");
+ }
+ { # targ off top left
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => -5, ty => -3, @mask_extras),
+ "$mask_type - compose off top left");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 0, ymin => 0, xmax => 14, ymax => 16);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 15, ymin => 0, xmax => 34, ymax => 36);
+ $is_image->($work, $cmp, "check match");
+ }
+ { # targ off bottom right
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 65, ty => 67, @mask_extras),
+ "$mask_type - targ off bottom right");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 65, ymin => 67, xmax => 84, ymax => 86);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 85, ymin => 67, xmax => 99, ymax => 99);
+ $is_image->($work, $cmp, "check match");
+ }
+ { # src off top left
+ my $work = $targ->copy;
+ my @more_mask_extras;
+ if (@mask_extras) {
+ push @more_mask_extras,
+ (
+ mask_left => -5,
+ mask_top => -15,
+ );
+ }
+ ok($work->compose(src => $src, tx => 10, ty => 20,
+ src_left => -5, src_top => -15,
+ @mask_extras, @more_mask_extras),
+ "$mask_type - source off top left");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 15, ymin => 35, xmax => 34, ymax => 54);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 35, ymin => 35, xmax => 54, ymax => 74);
+ $is_image->($work, $cmp, "check match");
+ }
+ {
+ # src off bottom right
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 10, ty => 20,
+ src_left => 10, src_top => 15,
+ width => 40, height => 40, @mask_extras),
+ "$mask_type - source off bottom right");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin=> 10, ymin => 20, xmax => 19, ymax => 24);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 20, ymin => 20, xmax => 39, ymax => 44);
+ $is_image->($work, $cmp, "check match");
+ }
+ {
+ # simply out of bounds
+ my $work = $targ->copy;
+ ok(!$work->compose(src => $src, tx => 100, @mask_extras),
+ "$mask_type - off the right of the target");
+ $is_image->($work, $targ, "no changes");
+ ok(!$work->compose(src => $src, ty => 100, @mask_extras),
+ "$mask_type - off the bottom of the target");
+ $is_image->($work, $targ, "no changes");
+ ok(!$work->compose(src => $src, tx => -40, @mask_extras),
+ "$mask_type - off the left of the target");
+ $is_image->($work, $targ, "no changes");
+ ok(!$work->compose(src => $src, ty => -40, @mask_extras),
+ "$mask_type - off the top of the target");
+ $is_image->($work, $targ, "no changes");
+ }
+ }
+
+ # masked tests
+ my $mask = Imager->new(xsize => 40, ysize => 40, channels => 1, bits => $type_id);
+ $mask->box(filled => 1, xmax => 19, color => $gray100);
+ $mask->box(filled => 1, xmin => 20, ymax => 14, xmax => 34,
+ color => $gray50);
+ is($mask->bits, $type_id, "check mask bits");
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 7,
+ mask => $mask),
+ "simple draw masked");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin => 5, ymin => 7, xmax => 24, ymax => 26);
+ $cmp->box(filled => 1, color => $green4_on_blue,
+ xmin => 25, ymin => 7, xmax => 39, ymax => 21);
+ $is_image->($work, $cmp, "check match");
+ save_to($work, "${type_id}_simp_masked");
+ save_to($work, "${type_id}_simp_masked_cmp");
+ }
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 7,
+ mask_left => 5, mask_top => 2,
+ mask => $mask),
+ "draw with mask offset");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin => 5, ymin => 7, xmax => 19, ymax => 26);
+ $cmp->box(filled => 1, color => $red2_on_blue,
+ xmin => 20, ymin => 7, xmax => 24, ymax => 19);
+ $cmp->box(filled => 1, color => $green4_on_blue,
+ xmin => 25, ymin => 7, xmax => 34, ymax => 19);
+ $is_image->($work, $cmp, "check match");
+ }
+ {
+ my $work = $targ->copy;
+ ok($work->compose(src => $src, tx => 5, ty => 7,
+ mask_left => -3, mask_top => -2,
+ mask => $mask),
+ "draw with negative mask offsets");
+ my $cmp = $targ->copy;
+ $cmp->box(filled => 1, color => $red,
+ xmin => 8, ymin => 9, xmax => 24, ymax => 26);
+ $cmp->box(filled => 1, color => $green2_on_blue,
+ xmin => 25, ymin => 9, xmax => 27, ymax => 46);
+ $cmp->box(filled => 1, color => $green4_on_blue,
+ xmin => 28, ymin => 9, xmax => 42, ymax => 23);
+ $is_image->($work, $cmp, "check match");
+ }
+}
+
+{
+ my $empty = Imager->new;
+ my $good = Imager->new(xsize => 1, ysize => 1);
+ ok(!$empty->compose(src => $good), "can't compose to empty image");
+ is($empty->errstr, "compose: empty input image",
+ "check error message");
+ ok(!$good->compose(src => $empty), "can't compose from empty image");
+ is($good->errstr, "compose: empty input image (for src)",
+ "check error message");
+ ok(!$good->compose(src => $good, mask => $empty),
+ "can't compose with empty mask");
+ is($good->errstr, "compose: empty input image (for mask)",
+ "check error message");
+}
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink @files;
+}
+
+sub save_to {
+ my ($im, $name) = @_;
+
+ my $type = $ENV{IMAGER_SAVE_TYPE} || "ppm";
+ $name = "testout/t62_$name.$type";
+ $im->write(file => $name,
+ pnm_write_wide_data => 1);
+ push @files, $name;
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 232;
+
+BEGIN { use_ok(Imager=>':all') }
+use Imager::Test qw(is_image is_color4 is_image_similar);
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t40scale.log');
+my $img=Imager->new();
+
+ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'),
+ "load test image") or print "# ",$img->errstr,"\n";
+
+my $scaleimg=$img->scale(scalefactor=>0.25)
+ or print "# ",$img->errstr,"\n";
+ok($scaleimg, "scale it (good mode)");
+
+ok($scaleimg->write(file=>'testout/t40scale1.ppm',type=>'pnm'),
+ "save scaled image") or print "# ",$img->errstr,"\n";
+
+$scaleimg=$img->scale(scalefactor=>0.25,qtype=>'preview');
+ok($scaleimg, "scale it (preview)") or print "# ",$img->errstr,"\n";
+
+ok($scaleimg->write(file=>'testout/t40scale2.ppm',type=>'pnm'),
+ "write preview scaled image") or print "# ",$img->errstr,"\n";
+
+$scaleimg = $img->scale(scalefactor => 0.25, qtype => 'mixing');
+ok($scaleimg, "scale it (mixing)") or print "# ", $img->errstr, "\n";
+ok($scaleimg->write(file=>'testout/t40scale3.ppm', type=>'pnm'),
+ "write mixing scaled image") or print "# ", $img->errstr, "\n";
+
+{ # double image scaling with mixing, since it has code to handle it
+ my $dimg = Imager->new(xsize => $img->getwidth, ysize => $img->getheight,
+ channels => $img->getchannels,
+ bits => 'double');
+ ok($dimg, "create double/sample image");
+ $dimg->paste(src => $img);
+ $scaleimg = $dimg->scale(scalefactor => 0.25, qtype => 'mixing');
+ ok($scaleimg, "scale it (mixing, double)");
+ ok($scaleimg->write(file => 'testout/t40mixdbl.ppm', type => 'pnm'),
+ "write double/mixing scaled image");
+ is($scaleimg->bits, 'double', "got the right image type as output");
+
+ # hscale only, mixing
+ $scaleimg = $dimg->scale(xscalefactor => 0.33, yscalefactor => 1.0,
+ qtype => 'mixing');
+ ok($scaleimg, "scale it (hscale, mixing, double)");
+ is($scaleimg->getheight, $dimg->getheight, "same height");
+ ok($scaleimg->write(file => 'testout/t40hscdmix.ppm', type => 'pnm'),
+ "save it");
+
+ # vscale only, mixing
+ $scaleimg = $dimg->scale(xscalefactor => 1.0, yscalefactor => 0.33,
+ qtype => 'mixing');
+ ok($scaleimg, "scale it (vscale, mixing, double)");
+ is($scaleimg->getwidth, $dimg->getwidth, "same width");
+ ok($scaleimg->write(file => 'testout/t40vscdmix.ppm', type => 'pnm'),
+ "save it");
+}
+
+{
+ # check for a warning when scale() is called in void context
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ $img->scale(scalefactor=>0.25);
+ cmp_ok($warning, '=~', qr/void/, "check warning");
+ cmp_ok($warning, '=~', qr/scale\.t/, "check filename");
+ $warning = '';
+ $img->scaleX(scalefactor=>0.25);
+ cmp_ok($warning, '=~', qr/void/, "check warning");
+ cmp_ok($warning, '=~', qr/scale\.t/, "check filename");
+ $warning = '';
+ $img->scaleY(scalefactor=>0.25);
+ cmp_ok($warning, '=~', qr/void/, "check warning");
+ cmp_ok($warning, '=~', qr/scale\.t/, "check filename");
+}
+{ # https://rt.cpan.org/Ticket/Display.html?id=7467
+ # segfault in Imager 0.43
+ # make sure scale() doesn't let us make an image zero pixels high or wide
+ # it does this by making the given axis as least 1 pixel high
+ my $out = $img->scale(scalefactor=>0.00001);
+ is($out->getwidth, 1, "min scale width");
+ is($out->getheight, 1, "min scale height");
+
+ $out = $img->scale(scalefactor=>0.00001, qtype => 'preview');
+ is($out->getwidth, 1, "min scale width (preview)");
+ is($out->getheight, 1, "min scale height (preview)");
+
+ $out = $img->scale(scalefactor=>0.00001, qtype => 'mixing');
+ is($out->getwidth, 1, "min scale width (mixing)");
+ is($out->getheight, 1, "min scale height (mixing)");
+}
+
+{ # error handling - NULL image
+ my $im = Imager->new;
+ ok(!$im->scale(scalefactor => 0.5), "try to scale empty image");
+ is($im->errstr, "scale: empty input image", "check error message");
+
+ # scaleX/scaleY
+ ok(!$im->scaleX(scalefactor => 0.5), "try to scaleX empty image");
+ is($im->errstr, "scaleX: empty input image", "check error message");
+ ok(!$im->scaleY(scalefactor => 0.5), "try to scaleY empty image");
+ is($im->errstr, "scaleY: empty input image", "check error message");
+}
+
+{ # invalid qtype value
+ my $im = Imager->new(xsize => 100, ysize => 100);
+ ok(!$im->scale(scalefactor => 0.5, qtype=>'unknown'), "unknown qtype");
+ is($im->errstr, "invalid value for qtype parameter", "check error message");
+
+ # invalid type value
+ ok(!$im->scale(xpixels => 10, ypixels=>50, type=>"unknown"), "unknown type");
+ is($im->errstr, "invalid value for type parameter", "check error message");
+}
+
+SKIP:
+{ # Image::Math::Constrain support
+ eval "require Image::Math::Constrain;";
+ $@ and skip "optional module Image::Math::Constrain not installed", 3;
+ my $constrain = Image::Math::Constrain->new(20, 100);
+ my $im = Imager->new(xsize => 160, ysize => 96);
+ my $result = $im->scale(constrain => $constrain);
+ ok($result, "successful scale with Image::Math::Constrain");
+ is($result->getwidth, 20, "check result width");
+ is($result->getheight, 12, "check result height");
+}
+
+{ # scale size checks
+ my $im = Imager->new(xsize => 160, ysize => 96); # some random size
+
+ scale_test($im, 'scale', 80, 48, "48 x 48 def type",
+ xpixels => 48, ypixels => 48);
+ scale_test($im, 'scale', 80, 48, "48 x 48 max type",
+ xpixels => 48, ypixels => 48, type => 'max');
+ scale_test($im, 'scale', 80, 48, "80 x 80 min type",
+ xpixels => 80, ypixels => 80, type => 'min');
+ scale_test($im, 'scale', 80, 48, "no scale parameters (default to 0.5 scalefactor)");
+ scale_test($im, 'scale', 120, 72, "0.75 scalefactor",
+ scalefactor => 0.75);
+ scale_test($im, 'scale', 80, 48, "80 width",
+ xpixels => 80);
+ scale_test($im, 'scale', 120, 72, "72 height",
+ ypixels => 72);
+
+ # new scaling parameters in 0.54
+ scale_test($im, 'scale', 80, 48, "xscale 0.5",
+ xscalefactor => 0.5);
+ scale_test($im, 'scale', 80, 48, "yscale 0.5",
+ yscalefactor => 0.5);
+ scale_test($im, 'scale', 40, 48, "xscale 0.25 yscale 0.5",
+ xscalefactor => 0.25, yscalefactor => 0.5);
+ scale_test($im, 'scale', 160, 48, "xscale 1.0 yscale 0.5",
+ xscalefactor => 1.0, yscalefactor => 0.5);
+ scale_test($im, 'scale', 160, 48, "xpixels 160 ypixels 48 type nonprop",
+ xpixels => 160, ypixels => 48, type => 'nonprop');
+ scale_test($im, 'scale', 160, 96, "xpixels 160 ypixels 96",
+ xpixels => 160, ypixels => 96);
+ scale_test($im, 'scale', 80, 96, "xpixels 80 ypixels 96 type nonprop",
+ xpixels => 80, ypixels => 96, type => 'nonprop');
+
+ # scaleX
+ scale_test($im, 'scaleX', 80, 96, "defaults");
+ scale_test($im, 'scaleX', 40, 96, "0.25 scalefactor",
+ scalefactor => 0.25);
+ scale_test($im, 'scaleX', 120, 96, "pixels 120",
+ pixels => 120);
+
+ # scaleY
+ scale_test($im, 'scaleY', 160, 48, "defaults");
+ scale_test($im, 'scaleY', 160, 192, "2.0 scalefactor",
+ scalefactor => 2.0);
+ scale_test($im, 'scaleY', 160, 144, "pixels 144",
+ pixels => 144);
+}
+
+{ # check proper alpha handling for mixing
+ my $im = Imager->new(xsize => 40, ysize => 40, channels => 4);
+ $im->box(filled => 1, color => 'C0C0C0');
+ my $rot = $im->rotate(degrees => -4)
+ or die;
+ $rot = $rot->to_rgb16;
+ my $sc = $rot->scale(qtype => 'mixing', xpixels => 40);
+ my $out = Imager->new(xsize => $sc->getwidth, ysize => $sc->getheight);
+ $out->box(filled => 1, color => 'C0C0C0');
+ my $cmp = $out->copy;
+ $out->rubthrough(src => $sc);
+ is_image($out, $cmp, "check we get the right image after scaling (mixing)");
+
+ # we now set alpha=0 pixels to zero on scaling
+ is_color4($sc->getpixel('x' => 39, 'y' => 39), 0, 0, 0, 0,
+ "check we set alpha=0 pixels to zero on scaling");
+}
+
+{ # check proper alpha handling for default scaling
+ my $im = Imager->new(xsize => 40, ysize => 40, channels => 4);
+ $im->box(filled => 1, color => 'C0C0C0');
+ my $rot = $im->rotate(degrees => -4)
+ or die;
+ my $sc = $rot->scale(qtype => "normal", xpixels => 40);
+ my $out = Imager->new(xsize => $sc->getwidth, ysize => $sc->getheight);
+ $out->box(filled => 1, color => 'C0C0C0');
+ my $cmp = $out->copy;
+ $out->rubthrough(src => $sc);
+ is_image_similar($out, $cmp, 100, "check we get the right image after scaling (normal)");
+
+ # we now set alpha=0 pixels to zero on scaling
+ is_color4($sc->getpixel('x' => 39, 'y' => 39), 0, 0, 0, 0,
+ "check we set alpha=0 pixels to zero on scaling");
+}
+
+{ # scale_calculate
+ my $im = Imager->new(xsize => 100, ysize => 120);
+ is_deeply([ $im->scale_calculate(scalefactor => 0.5) ],
+ [ 0.5, 0.5, 50, 60 ],
+ "simple scale_calculate");
+ is_deeply([ Imager->scale_calculate(scalefactor => 0.5) ],
+ [], "failed scale_calculate");
+ is_deeply([ Imager->scale_calculate(width => 120, height => 150,
+ xpixels => 240) ],
+ [ 2.0, 2.0, 240, 300 ],
+ "class method scale_factor");
+}
+
+{ # passing a reference for scaling parameters should fail
+ # RT #35172
+ my $im = Imager->new(xsize => 100, ysize => 100);
+ ok(!$im->scale(xpixels => {}), "can't use a reference as a size");
+ cmp_ok($im->errstr, '=~', "xpixels parameter cannot be a reference",
+ "check error message");
+}
+
+sub scale_test {
+ my ($in, $method, $exp_width, $exp_height, $note, @parms) = @_;
+
+ print "# $note: @parms\n";
+ for my $qtype (qw(normal preview mixing)) {
+ SKIP:
+ {
+ my $scaled = $in->$method(@parms, qtype => $qtype);
+ ok($scaled, "$method $note qtype $qtype")
+ or skip("failed to scale", 2);
+ is($scaled->getwidth, $exp_width, "check width");
+ is($scaled->getheight, $exp_height, "check height");
+ }
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager;
+use Test::More tests => 31;
+use Imager::Test qw/test_image test_image_double is_image/;
+
+my $test_im = test_image;
+my $test_im_dbl = test_image_double;
+
+{
+ # split out channels and put it back together
+ my $red = Imager->combine(src => [ $test_im ]);
+ ok($red, "extracted the red channel");
+ is($red->getchannels, 1, "red should be a single channel");
+ my $green = Imager->combine(src => [ $test_im ], channels => [ 1 ]);
+ ok($green, "extracted the green channel");
+ is($green->getchannels, 1, "green should be a single channel");
+ my $blue = $test_im->convert(preset => "blue");
+ ok($blue, "extracted blue (via convert)");
+
+ # put them back together
+ my $combined = Imager->combine(src => [ $red, $green, $blue ]);
+ is($combined->getchannels, 3, "check we got a three channel image");
+ is_image($combined, $test_im, "presto! check it's the same");
+}
+
+{
+ # no src
+ ok(!Imager->combine(), "no src");
+ is(Imager->errstr, "src parameter missing", "check message");
+}
+
+{
+ # bad image error
+ my $im = Imager->new;
+ ok(!Imager->combine(src => [ $im ]), "empty image");
+ is(Imager->errstr, "combine: empty input image (src->[0])",
+ "check message");
+}
+
+{
+ # not an image
+ my $im = {};
+ ok(!Imager->combine(src => [ $im ]), "not an image");
+ is(Imager->errstr, "src must contain image objects", "check message");
+}
+
+{
+ # no images
+ ok(!Imager->combine(src => []), "no images");
+ is(Imager->errstr, "At least one image must be supplied",
+ "check message");
+}
+
+{
+ # too many images
+ ok(!Imager->combine(src => [ ($test_im) x 5 ]), "too many source images");
+ is(Imager->errstr, "Maximum of 4 channels, you supplied 5",
+ "check message");
+}
+
+{
+ # negative channel
+ ok(!Imager->combine(src => [ $test_im ], channels => [ -1 ]),
+ "negative channel");
+ is(Imager->errstr, "Channel numbers must be zero or positive",
+ "check message");
+}
+
+{
+ # channel too high
+ ok(!Imager->combine(src => [ $test_im ], channels => [ 3 ]),
+ "too high channel");
+ is(Imager->errstr, "Channel 3 for image 0 is too high (3 channels)",
+ "check message");
+}
+
+{
+ # make sure we get the higher of the bits
+ my $out = Imager->combine(src => [ $test_im, $test_im_dbl ]);
+ ok($out, "make from 8 and double/sample images");
+ is($out->bits, "double", "check output bits");
+}
+
+{
+ # check high-bit processing
+ # split out channels and put it back together
+ my $red = Imager->combine(src => [ $test_im_dbl ]);
+ ok($red, "extracted the red channel");
+ is($red->getchannels, 1, "red should be a single channel");
+ my $green = Imager->combine(src => [ $test_im_dbl ], channels => [ 1 ]);
+ ok($green, "extracted the green channel");
+ is($green->getchannels, 1, "green should be a single channel");
+ my $blue = $test_im_dbl->convert(preset => "blue");
+ ok($blue, "extracted blue (via convert)");
+
+ # put them back together
+ my $combined = Imager->combine(src => [ $red, $green, $blue ]);
+ is($combined->getchannels, 3, "check we got a three channel image");
+ is_image($combined, $test_im_dbl, "presto! check it's the same");
+ is($combined->bits, "double", "and we got a double image output");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 95;
+use Imager;
+use Imager::Test qw(is_color3 is_image is_imaged test_image_double test_image isnt_image is_image_similar);
+
+#$Imager::DEBUG=1;
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t64copyflip.log');
+
+my $img=Imager->new() or die "unable to create image object\n";
+
+$img->open(file=>'testimg/scale.ppm',type=>'pnm');
+my $nimg = $img->copy();
+ok($nimg, "copy returned something");
+
+# test if ->copy() works
+
+my $diff = Imager::i_img_diff($img->{IMG}, $nimg->{IMG});
+is_image($img, $nimg, "copy matches source");
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->copy, "fail to copy an empty image");
+ is($empty->errstr, "copy: empty input image", "check error message");
+}
+
+# test if ->flip(dir=>'h')->flip(dir=>'h') doesn't alter the image
+$nimg->flip(dir=>"h")->flip(dir=>"h");
+is_image($nimg, $img, "double horiz flipped matches original");
+
+# test if ->flip(dir=>'v')->flip(dir=>'v') doesn't alter the image
+$nimg->flip(dir=>"v")->flip(dir=>"v");
+is_image($nimg, $img, "double vertically flipped image matches original");
+
+
+# test if ->flip(dir=>'h')->flip(dir=>'v') is same as ->flip(dir=>'hv')
+$nimg->flip(dir=>"v")->flip(dir=>"h")->flip(dir=>"hv");;
+is_image($img, $nimg, "check flip with hv matches flip v then flip h");
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->flip(dir => "v"), "fail to flip an empty image");
+ is($empty->errstr, "flip: empty input image", "check error message");
+}
+
+{
+ my $imsrc = test_image_double;
+ my $imcp = $imsrc->copy;
+ is_imaged($imsrc, $imcp, "copy double image");
+ $imcp->flip(dir=>"v")->flip(dir=>"v");
+ is_imaged($imsrc, $imcp, "flip v twice");
+ $imcp->flip(dir=>"h")->flip(dir=>"h");
+ is_imaged($imsrc, $imcp, "flip h twice");
+ $imcp->flip(dir=>"h")->flip(dir=>"v")->flip(dir=>"hv");
+ is_imaged($imsrc, $imcp, "flip h,v,hv twice");
+}
+
+{
+ my $impal = test_image()->to_paletted;
+ my $imcp = $impal->copy;
+ is($impal->type, "paletted", "check paletted test image is");
+ is($imcp->type, "paletted", "check copy test image is paletted");
+ ok($impal->flip(dir => "h"), "flip paletted h");
+ isnt_image($impal, $imcp, "check it changed");
+ ok($impal->flip(dir => "v"), "flip paletted v");
+ ok($impal->flip(dir => "hv"), "flip paletted hv");
+ is_image($impal, $imcp, "should be back to original image");
+ is($impal->type, "paletted", "and still paletted");
+}
+
+rot_test($img, 90, 4);
+rot_test($img, 180, 2);
+rot_test($img, 270, 4);
+rot_test($img, 0, 1);
+
+my $pimg = $img->to_paletted();
+rot_test($pimg, 90, 4);
+rot_test($pimg, 180, 2);
+rot_test($pimg, 270, 4);
+rot_test($pimg, 0, 1);
+
+my $timg = $img->rotate(right=>90)->rotate(right=>270);
+is(Imager::i_img_diff($img->{IMG}, $timg->{IMG}), 0,
+ "check rotate 90 then 270 matches original");
+$timg = $img->rotate(right=>90)->rotate(right=>180)->rotate(right=>90);
+is(Imager::i_img_diff($img->{IMG}, $timg->{IMG}), 0,
+ "check rotate 90 then 180 then 90 matches original");
+
+# this could use more tests
+my $rimg = $img->rotate(degrees=>10);
+ok($rimg, "rotation by 10 degrees gave us an image");
+if (!$rimg->write(file=>"testout/t64_rot10.ppm")) {
+ print "# Cannot save: ",$rimg->errstr,"\n";
+}
+
+# rotate with background
+$rimg = $img->rotate(degrees=>10, back=>Imager::Color->new(builtin=>'red'));
+ok($rimg, "rotate with background gave us an image");
+if (!$rimg->write(file=>"testout/t64_rot10_back.ppm")) {
+ print "# Cannot save: ",$rimg->errstr,"\n";
+}
+
+{
+ # rotate with text background
+ my $rimg = $img->rotate(degrees => 45, back => '#FF00FF');
+ ok($rimg, "rotate with background as text gave us an image");
+
+ # check the color set correctly
+ my $c = $rimg->getpixel(x => 0, 'y' => 0);
+ is_deeply([ 255, 0, 255 ], [ ($c->rgba)[0, 1, 2] ],
+ "check background set correctly");
+
+ # check error handling for background color
+ $rimg = $img->rotate(degrees => 45, back => "some really unknown color");
+ ok(!$rimg, "should fail due to bad back color");
+ cmp_ok($img->errstr, '=~', "^No color named ", "check error message");
+}
+SKIP:
+{ # rotate in double mode
+ my $dimg = $img->to_rgb16;
+ my $rimg = $dimg->rotate(degrees => 10);
+ ok($rimg, "rotate 16-bit image gave us an image")
+ or skip("could not rotate", 3);
+ ok($rimg->write(file => "testout/t64_rotf10.ppm", pnm_write_wide_data => 1),
+ "save wide data rotated")
+ or diag($rimg->errstr);
+
+ # with a background color
+ my $rimgb = $dimg->rotate(degrees => 10, back => "#FF8000");
+ ok($rimgb, "rotate 16-bit image with back gave us an image")
+ or skip("could not rotate", 1);
+ ok($rimgb->write(file => "testout/t64_rotfb10.ppm", pnm_write_wide_data => 1),
+ "save wide data rotated")
+ or diag($rimgb->errstr);
+}
+{ # rotate in paletted mode
+ my $rimg = $pimg->rotate(degrees => 10);
+ ok($rimg, "rotated paletted image 10 degrees");
+ ok($rimg->write(file => "testout/t64_rotp10.ppm"),
+ "save paletted rotated")
+ or diag($rimg->errstr);
+}
+
+my $trimg = $img->matrix_transform(matrix=>[ 1.2, 0, 0,
+ 0, 1, 0,
+ 0, 0, 1]);
+ok($trimg, "matrix_transform() returned an image");
+$trimg->write(file=>"testout/t64_trans.ppm")
+ or print "# Cannot save: ",$trimg->errstr,"\n";
+
+$trimg = $img->matrix_transform(matrix=>[ 1.2, 0, 0,
+ 0, 1, 0,
+ 0, 0, 1],
+ back=>Imager::Color->new(builtin=>'blue'));
+ok($trimg, "matrix_transform() with back returned an image");
+
+$trimg->write(file=>"testout/t64_trans_back.ppm")
+ or print "# Cannot save: ",$trimg->errstr,"\n";
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->matrix_transform(matrix => [ 1, 0, 0,
+ 0, 1, 0,
+ 0, 0, 1 ]),
+ "can't transform an empty image");
+ is($empty->errstr, "matrix_transform: empty input image",
+ "check error message");
+}
+
+sub rot_test {
+ my ($src, $degrees, $count) = @_;
+
+ my $cimg = $src->copy();
+ my $in;
+ for (1..$count) {
+ $in = $cimg;
+ $cimg = $cimg->rotate(right=>$degrees)
+ or last;
+ }
+ SKIP:
+ {
+ ok($cimg, "got a rotated image")
+ or skip("no image to check", 4);
+ my $diff = Imager::i_img_diff($src->{IMG}, $cimg->{IMG});
+ is($diff, 0, "check it matches source")
+ or skip("didn't match", 3);
+
+ # check that other parameters match
+ is($src->type, $cimg->type, "type check");
+ is($src->bits, $cimg->bits, "bits check");
+ is($src->getchannels, $cimg->getchannels, "channels check");
+ }
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ my $img = Imager->new(xsize=>10, ysize=>10);
+ $img->copy();
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 'copyflip\\.t', "correct file");
+ $warning = '';
+ $img->rotate(degrees=>5);
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 'copyflip\\.t', "correct file");
+ $warning = '';
+ $img->matrix_transform(matrix=>[1, 1, 1]);
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 'copyflip\\.t', "correct file");
+}
+
+{
+ # 29936 - matrix_transform() should use fabs() instead of abs()
+ # range checking sz
+
+ # this meant that when sz was < 1 (which it often is for these
+ # transformations), it treated the values out of range, producing a
+ # blank output image
+
+ my $src = Imager->new(xsize => 20, ysize => 20);
+ $src->box(filled => 1, color => 'FF0000');
+ my $out = $src->matrix_transform(matrix => [ 1, 0, 0,
+ 0, 1, 0,
+ 0, 0, 0.9999 ])
+ or print "# ", $src->errstr, "\n";
+ my $blank = Imager->new(xsize => 20, ysize => 20);
+ # they have to be different, surely that would be easy
+ my $diff = Imager::i_img_diff($out->{IMG}, $blank->{IMG});
+ ok($diff, "RT#29936 - check non-blank output");
+}
+
+{
+ my $im = Imager->new(xsize => 10, ysize => 10, channels => 4);
+ $im->box(filled => 1, color => 'FF0000');
+ my $back = Imager::Color->new(0, 0, 0, 0);
+ my $rot = $im->rotate(degrees => 10, back => $back);
+ # drop the alpha and make sure there's only 2 colors used
+ my $work = $rot->convert(preset => 'noalpha');
+ my $im_pal = $work->to_paletted(make_colors => 'mediancut');
+ my @colors = $im_pal->getcolors;
+ is(@colors, 2, "should be only 2 colors")
+ or do {
+ print "# ", join(",", $_->rgba), "\n" for @colors;
+ };
+ @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
+ is_color3($colors[0], 0, 0, 0, "check we got black");
+ is_color3($colors[1], 255, 0, 0, "and red");
+}
+
+{ # RT #77063 rotate with degrees => 270 gives a black border
+ # so be a little less strict about rounding up
+ # I've also:
+ # - improved calculation of the rotation matrix
+ # - added rounding to interpolation for 1/3 channel images
+ my $im = test_image;
+ $im->box(color => "#00F");
+ my $right = $im->rotate(right => 270);
+ my $deg = $im->rotate(degrees => 270, back => "#FFF");
+ is($deg->getwidth, 150, "check degrees => 270 width");
+ is($deg->getheight, 150, "check degrees => 270 height");
+ ok($deg->write(file => "testout/t64rotdeg270.ppm"), "save it");
+ $right->write(file => "testout/t64rotright270.ppm");
+ is_image($deg, $right, "check right and degrees result the same");
+ #$deg = $deg->convert(preset => "addalpha");
+ # $right = $right->convert(preset => "addalpha");
+ # my $diff = $right->difference(other => $deg, mindist => 1);
+ # $diff->write(file => "testout/t64rotdiff.png");
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->rotate(degrees => 90), "can't rotate an empty image");
+ is($empty->errstr, "rotate: empty input image",
+ "check error message");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 66;
+use Imager;
+use Imager::Test qw(test_image);
+
+#$Imager::DEBUG=1;
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t65crop.log');
+
+my $img=Imager->new() || die "unable to create image object\n";
+
+ok($img, "created image ph");
+
+SKIP:
+{
+ skip("couldn't load source image", 2)
+ unless ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'), "loaded source");
+ my $nimg = $img->crop(top=>10, left=>10, bottom=>25, right=>25);
+ ok($nimg, "got an image");
+ ok($nimg->write(file=>"testout/t65.ppm"), "save to file");
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=7578
+ # make sure we get the right type of image on crop
+ my $src = Imager->new(xsize=>50, ysize=>50, channels=>2, bits=>16);
+ is($src->getchannels, 2, "check src channels");
+ is($src->bits, 16, "check src bits");
+ my $out = $src->crop(left=>10, right=>40, top=>10, bottom=>40);
+ is($out->getchannels, 2, "check out channels");
+ is($out->bits, 16, "check out bits");
+}
+{ # https://rt.cpan.org/Ticket/Display.html?id=7578
+ print "# try it for paletted too\n";
+ my $src = Imager->new(xsize=>50, ysize=>50, channels=>3, type=>'paletted');
+ # make sure color index zero is defined so there's something to copy
+ $src->addcolors(colors=>[Imager::Color->new(0,0,0)]);
+ is($src->type, 'paletted', "check source type");
+ my $out = $src->crop(left=>10, right=>40, top=>10, bottom=>40);
+ is($out->type, 'paletted', 'check output type');
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=7581
+ # crop() documentation says width/height takes precedence, but is unclear
+ # from looking at the existing code, setting width/height will go from
+ # the left of the image, even if left/top are provided, despite the
+ # sample in the docs
+ # Let's make sure that things happen as documented
+ my $src = test_image();
+ # make sure we get what we want
+ is($src->getwidth, 150, "src width");
+ is($src->getheight, 150, "src height");
+
+ # the test data is:
+ # - description
+ # - hash ref containing args to crop()
+ # - expected left, top, right, bottom values
+ # we call crop using the given arguments then call it using the
+ # hopefully stable left/top/right/bottom/arguments
+ # this is kind of lame, but I don't want to include a rewritten
+ # crop in this file
+ my @tests =
+ (
+ [
+ "basic",
+ { left=>10, top=>10, right=>70, bottom=>80 },
+ 10, 10, 70, 80,
+ ],
+ [
+ "middle",
+ { width=>50, height=>50 },
+ 50, 50, 100, 100,
+ ],
+ [
+ "lefttop",
+ { left=>20, width=>70, top=>30, height=>90 },
+ 20, 30, 90, 120,
+ ],
+ [
+ "bottomright",
+ { right=>140, width=>50, bottom=>130, height=>60 },
+ 90, 70, 140, 130,
+ ],
+ [
+ "acrossmiddle",
+ { top=>40, bottom=>110 },
+ 0, 40, 150, 110,
+ ],
+ [
+ "downmiddle",
+ { left=>40, right=>110 },
+ 40, 0, 110, 150,
+ ],
+ [
+ "rightside",
+ { left=>80, },
+ 80, 0, 150, 150,
+ ],
+ [
+ "leftside",
+ { right=>40 },
+ 0, 0, 40, 150,
+ ],
+ [
+ "topside",
+ { bottom=>40, },
+ 0, 0, 150, 40,
+ ],
+ [
+ "bottomside",
+ { top=>90 },
+ 0, 90, 150, 150,
+ ],
+ [
+ "overright",
+ { left=>100, right=>200 },
+ 100, 0, 150, 150,
+ ],
+ [
+ "overtop",
+ { bottom=>50, height=>70 },
+ 0, 0, 150, 50,
+ ],
+ [
+ "overleft",
+ { right=>30, width=>60 },
+ 0, 0, 30, 150,
+ ],
+ [
+ "overbottom",
+ { top=>120, height=>60 },
+ 0, 120, 150, 150,
+ ],
+ );
+ for my $test (@tests) {
+ my ($desc, $args, $left, $top, $right, $bottom) = @$test;
+ my $out = $src->crop(%$args);
+ ok($out, "got output for $desc");
+ my $cmp = $src->crop(left=>$left, top=>$top, right=>$right, bottom=>$bottom);
+ ok($cmp, "got cmp for $desc");
+ # make sure they're the same
+ my $diff = Imager::i_img_diff($out->{IMG}, $cmp->{IMG});
+ is($diff, 0, "difference should be 0 for $desc");
+ }
+}
+{ # https://rt.cpan.org/Ticket/Display.html?id=7581
+ # previously we didn't check that the result had some pixels
+ # make sure we do
+ my $src = test_image();
+ ok(!$src->crop(left=>50, right=>50), "nothing across");
+ cmp_ok($src->errstr, '=~', qr/resulting image would have no content/,
+ "and message");
+ ok(!$src->crop(top=>60, bottom=>60), "nothing down");
+ cmp_ok($src->errstr, '=~', qr/resulting image would have no content/,
+ "and message");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ my $img = Imager->new(xsize=>10, ysize=>10);
+ $img->crop(left=>5);
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 'crop\\.t', "correct file");
+}
+
+{
+ my $src = test_image();
+ ok(!$src->crop( top=>1000, bottom=>1500, left=>0, right=>100 ),
+ "outside of image" );
+ cmp_ok($src->errstr, '=~', qr/outside of the image/, "and message");
+ ok(!$src->crop( top=>100, bottom=>1500, left=>1000, right=>1500 ),
+ "outside of image" );
+ cmp_ok($src->errstr, '=~', qr/outside of the image/, "and message");
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->crop(left => 10), "can't crop an empty image");
+ is($empty->errstr, "crop: empty input image", "check message");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager qw(:all :handy);
+use Test::More tests => 31;
+use Imager::Test qw(test_colorf_gpix is_fcolor1 is_fcolor3);
+
+-d "testout" or mkdir "testout";
+
+Imager::init("log"=>'testout/t67convert.log');
+
+my $imbase = Imager::ImgRaw::new(200,300,3);
+
+# first a basic test, make sure the basic things happen ok
+# make a 1 channel image from the above (black) image
+# but with 1 as the 'extra' value
+SKIP:
+{
+ my $im_white = i_convert($imbase, [ [ 0, 0, 0, 1 ] ]);
+ skip("convert to white failed", 3)
+ unless ok($im_white, "convert to white");
+
+ my ($w, $h, $ch) = i_img_info($im_white);
+
+ # the output image should now have one channel
+ is($ch, 1, "one channel image now");
+ # should have the same width and height
+ ok($w == 200 && $h == 300, "check converted size is the same");
+
+ # should be a white image now, let's check
+ my $c = Imager::i_get_pixel($im_white, 20, 20);
+ my @c = $c->rgba;
+ print "# @c\n";
+ is($c[0], 255, "check image is white");
+}
+
+# test the highlevel interface
+# currently this requires visual inspection of the output files
+my $im = Imager->new;
+SKIP:
+{
+ skip("could not load scale.ppm", 3)
+ unless $im->read(file=>'testimg/scale.ppm');
+ my $out = $im->convert(preset=>'gray');
+ ok($out, "convert preset gray");
+ ok($out->write(file=>'testout/t67_gray.ppm', type=>'pnm'),
+ "save grey image");
+ $out = $im->convert(preset=>'blue');
+ ok($out, "convert preset blue");
+
+ ok($out->write(file=>'testout/t67_blue.ppm', type=>'pnm'),
+ "save blue image");
+}
+
+# test against 16-bit/sample images
+{
+ SKIP:
+ {
+ my $imbase16 = Imager::i_img_16_new(200, 200, 3);
+
+ my $im16targ = i_convert($imbase16, [ [ 0, 0, 0, 1 ],
+ [ 0, 0, 0, 0 ],
+ [ 0, 0, 0, 0 ] ]);
+ ok($im16targ, "convert 16/bit sample image")
+ or skip("could not convert 16-bit image", 2);
+
+ # image should still be 16-bit
+ is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");
+
+ # make sure that it's roughly red
+ test_colorf_gpix($im16targ, 0, 0, NCF(1, 0, 0), 0.001, "image roughly red");
+ }
+ SKIP:
+ {
+ my $imbase16 = Imager->new(xsize => 10, ysize => 10, bits => 16);
+ ok($imbase16->setpixel
+ (x => 5, y => 2, color => Imager::Color::Float->new(0.1, 0.2, 0.3)),
+ "set a sample pixel");
+ my $c1 = $imbase16->getpixel(x => 5, y => 2, type => "float");
+ is_fcolor3($c1, 0.1, 0.2, 0.3, "check it was set")
+ or print "#", join(",", $c1->rgba), "\n";
+
+ my $targ16 = $imbase16->convert(matrix => [ [ 0.05, 0.15, 0.01, 0.5 ] ]);
+ ok($targ16, "convert another 16/bit sample image")
+ or skip("could not convert", 3);
+ is($targ16->getchannels, 1, "convert should be 1 channel");
+ is($targ16->bits, 16, "and 16-bits");
+ my $c = $targ16->getpixel(x => 5, y => 2, type => "float");
+ is_fcolor1($c, 0.538, 1/32768, "check grey value");
+ }
+}
+
+# test against palette based images
+my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
+my $black = NC(0, 0, 0);
+my $blackindex = Imager::i_addcolors($impal, $black);
+ok($blackindex, "add black to paletted");
+for my $y (0..299) {
+ Imager::i_ppal($impal, 0, $y, ($blackindex) x 200);
+}
+
+SKIP:
+{
+ my $impalout = i_convert($impal, [ [ 0, 0, 0, 0 ],
+ [ 0, 0, 0, 1 ],
+ [ 0, 0, 0, 0 ] ]);
+ skip("could not convert paletted", 3)
+ unless ok($impalout, "convert paletted");
+ is(Imager::i_img_type($impalout), 1, "image still paletted");
+ is(Imager::i_colorcount($impalout), 1, "still only one colour");
+ my $c = Imager::i_getcolors($impalout, $blackindex);
+ ok($c, "get color from palette");
+ my @ch = $c->rgba;
+ print "# @ch\n";
+ ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0,
+ "colour is as expected");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+ # methods that return a new image should warn in void context
+ my $warning;
+ local $SIG{__WARN__} =
+ sub {
+ $warning = "@_";
+ my $printed = $warning;
+ $printed =~ s/\n$//;
+ $printed =~ s/\n/\n\#/g;
+ print "# ",$printed, "\n";
+ };
+ my $img = Imager->new(xsize=>10, ysize=>10);
+ $img->convert(preset=>"grey");
+ cmp_ok($warning, '=~', 'void', "correct warning");
+ cmp_ok($warning, '=~', 'convert\\.t', "correct file");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=28492
+ # convert() doesn't preserve image sample size
+ my $im = Imager->new(xsize => 20, ysize => 20, channels => 3,
+ bits => 'double');
+ is($im->bits, 'double', 'check source bits');
+ my $conv = $im->convert(preset => 'grey');
+ is($conv->bits, 'double', 'make sure result has extra bits');
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=79922
+ # Segfault in convert with bad params
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ ok(!$im->convert(matrix => [ 10, 10, 10 ]),
+ "this would crash");
+ is($im->errstr, "convert: invalid matrix: element 0 is not an array ref",
+ "check the error message");
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->convert(preset => "addalpha"), "can't convert an empty image");
+ is($empty->errstr, "convert: empty input image", "check error message");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 8;
+
+-d "testout" or mkdir "testout";
+
+Imager::init("log"=>'testout/t68map.log');
+
+use Imager qw(:all :handy);
+
+my $imbase = Imager::ImgRaw::new(200,300,3);
+
+
+my @map1 = map { int($_/2) } 0..255;
+my @map2 = map { 255-int($_/2) } 0..255;
+my @map3 = 0..255;
+my @maps = 0..24;
+my @mapl = 0..400;
+
+my $tst = 1;
+
+ok(i_map($imbase, [ [], [], \@map1 ]), "map1 in ch 3");
+ok(i_map($imbase, [ \@map1, \@map1, \@map1 ]), "map1 in ch1-3");
+
+ok(i_map($imbase, [ \@map1, \@map2, \@map3 ]), "map1-3 in ch 1-3");
+
+ok(i_map($imbase, [ \@maps, \@mapl, \@map3 ]), "incomplete maps");
+
+# test the highlevel interface
+# currently this requires visual inspection of the output files
+
+SKIP: {
+ my $im = Imager->new;
+ $im->read(file=>'testimg/scale.ppm')
+ or skip "Cannot load test image testimg/scale.ppm", 2;
+
+ ok( $im->map(red=>\@map1, green=>\@map2, blue=>\@map3),
+ "test OO interface (maps by color)");
+ ok( $im->map(maps=>[\@map1, [], \@map2]),
+ "test OO interface (maps by maps)");
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->map(maps => [ \@map1, \@map2, \@map3 ]),
+ "can't map an empty image");
+ is($empty->errstr, "map: empty input image", "check error message");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+use Imager;
+
+eval "use Affix::Infix2Postfix; 1;"
+ or plan skip_all => "No Affix::Infix2Postfix";
+
+plan tests => 8;
+
+#$Imager::DEBUG=1;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log('log'=>'testout/t55trans.log');
+
+my $img=Imager->new();
+
+SKIP:
+{
+ ok($img, "make image object")
+ or skip("can't make image object", 5);
+
+ ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'),
+ "read sample image")
+ or skip("couldn't load test image", 4);
+
+ SKIP:
+ {
+ my $nimg=$img->transform(xexpr=>'x',yexpr=>'y+10*sin((x+y)/10)');
+ ok($nimg, "do transformation")
+ or skip ( "warning ".$img->errstr, 1 );
+
+ # xopcodes=>[qw( x y Add)],yopcodes=>[qw( x y Sub)],parm=>[]
+
+ ok($nimg->write(type=>'pnm',file=>'testout/t55.ppm'), "save to file");
+ }
+
+ SKIP:
+ {
+ my $nimg=$img->transform(xexpr=>'x+0.1*y+5*sin(y/10.0+1.57)',
+ yexpr=>'y+10*sin((x+y-0.785)/10)');
+ ok($nimg, "more complex transform")
+ or skip("couldn't make image", 1);
+
+ ok($nimg->write(type=>'pnm',file=>'testout/t55b.ppm'), "save to file");
+ }
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->transform(xexpr => "x", yexpr => "y"),
+ "fail to transform an empty image");
+ is($empty->errstr, "transform: empty input image",
+ "check error message");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 40;
+BEGIN { use_ok('Imager'); }
+use Imager::Test qw(is_color3);
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t58trans2.log');
+
+my $im1 = Imager->new();
+$im1->open(file=>'testimg/penguin-base.ppm', type=>'pnm')
+ || die "Cannot read image";
+my $im2 = Imager->new();
+$im2->open(file=>'testimg/scale.ppm',type=>'pnm')
+ || die "Cannot read testimg/scale.ppm";
+
+# error handling
+my $opts = { rpnexpr=>'x x 10 / sin 10 * y + get1' };
+my $im3 = Imager::transform2($opts);
+ok(!$im3, "returned an image on error");
+ok(defined($Imager::ERRSTR), "No error message on failure");
+
+# image synthesis
+my $im4 = Imager::transform2({
+ width=>300, height=>300,
+ rpnexpr=>'x y cx cy distance !d y cy - x cx - atan2 !a @d 10 / @a + 3.1416 2 * % !a2 @a2 cy * 3.1416 / 1 @a2 sin 1 + 2 / hsv'});
+ok($im4, "synthesis failed");
+
+if ($im4) {
+ $im4->write(type=>'pnm', file=>'testout/t56a.ppm')
+ || die "Cannot write testout/t56a.ppm";
+}
+
+# image distortion
+my $im5 = Imager::transform2({
+ rpnexpr=>'x x 10 / sin 10 * y + getp1'
+}, $im1);
+ok($im5, "image distortion");
+if ($im5) {
+ $im5->write(type=>'pnm', file=>'testout/t56b.ppm')
+ || die "Cannot write testout/t56b.ppm";
+}
+
+# image combination
+$opts = {
+rpnexpr=>'x h / !rat x w2 % y h2 % getp2 !pat x y getp1 @rat * @pat 1 @rat - * +'
+};
+my $im6 = Imager::transform2($opts,$im1,$im2);
+ok($im6, "image combination");
+if ($im6) {
+ $im6->write(type=>'pnm', file=>'testout/t56c.ppm')
+ || die "Cannot write testout/t56c.ppm";
+}
+
+# alpha
+$opts =
+ {
+ rpnexpr => '0 0 255 x y + w h + 2 - / 255 * rgba',
+ channels => 4,
+ width => 50,
+ height => 50,
+ };
+my $im8 = Imager::transform2($opts);
+ok($im8, "alpha output");
+my $c = $im8->getpixel(x=>0, 'y'=>0);
+is(($c->rgba)[3], 0, "zero alpha");
+$c = $im8->getpixel(x=>49, 'y'=>49);
+is(($c->rgba)[3], 255, "max alpha");
+
+$opts = { rpnexpr => 'x 1 + log 50 * y 1 + log 50 * getp1' };
+my $im9 = Imager::transform2($opts, $im1);
+ok($im9, "log function");
+if ($im9) {
+ $im9->write(type=>'pnm', file=>'testout/t56-9.ppm');
+}
+
+# op tests
+sub op_test($$$$$$);
+print "# op tests\n";
+op_test('7F0000', <<EOS, 0, 127, 0, 'value hsv getp1');
+120 1.0
+0 0 getp1 value
+hsv
+EOS
+op_test("7F0000", <<EOS, 255, 0, 0, 'hue');
+0 0 getp1 hue
+1.0 1.0 hsv
+EOS
+op_test("7F0000", <<EOS, 0, 255, 0, 'sat');
+120 0 0 getp1 sat 1.0 hsv
+EOS
+op_test("4060A0", <<'EOS', 128, 128, 128, "add mult sub rgb red green blue");
+0 0 getp1 !p @p red 2 * @p green 32 + @p blue 32 - rgb
+EOS
+op_test('806040', <<'EOS', 64, 64, 64, "div uminus");
+0 0 getp1 !p @p red 2 / @p green 32 uminus add @p blue rgb
+EOS
+op_test('40087f', <<'EOS', 8, 64, 31, 'pow mod');
+0 0 getp1 !p @p red 0.5 pow @p green 2 pow @p blue 32 mod rgb
+EOS
+op_test('202122', '0 0 getp1 4 *', 128, 132, 136, 'multp');
+op_test('404040', '0 0 getp1 1 2 3 rgb +', 65, 66, 67, 'addp');
+op_test('414243', '0 0 getp1 3 2 1 rgb -', 62, 64, 66, 'subp');
+op_test('808040', <<'EOS', 64, 64, 8, 'sin cos pi sqrt');
+0 0 getp1 !p pi 6 / sin @p red * 0.1 + pi 3 / cos @p green * 0.1 +
+@p blue sqrt rgb
+EOS
+op_test('008080', <<'EOS', 0, 0, 0, 'atan2');
+0 0 0 0 getp1 !p @p red 128 / @p green 128 / atan2 hsv
+EOS
+op_test('000000', <<'EOS', 150, 150, 150, 'distance');
+0 100 120 10 distance !d @d @d @d rgb
+EOS
+op_test('000000', <<'EOS', 100, 100, 100, 'int');
+50.75 int 2 * !i @i @i @i rgb
+EOS
+op_test('000100', <<'EOS', 128, 0, 0, 'if');
+0 0 getp1 !p @p red 0 128 if @p green 0 128 if 0 rgb
+EOS
+op_test('FF0000', <<'EOS', 0, 255, 0, 'ifp');
+0 0 0 getp1 0 255 0 rgb ifp
+EOS
+op_test('000000', <<'EOS', 1, 0, 1, 'le lt gt');
+0 1 le 1 0 lt 1 0 gt rgb
+EOS
+op_test('000000', <<'EOS', 0, 1, 0, 'ge eq ne');
+0 1 ge 0 0 eq 0 0 ne rgb
+EOS
+op_test('000000', <<'EOS', 0, 1, 1, 'and or not');
+1 0 and 1 0 or 0 not rgb
+EOS
+op_test('000000', <<'EOS', 255, 0, 255, 'abs');
+-255 abs 0 abs 255 abs rgb
+EOS
+op_test('000000', <<'EOS', 50, 82, 0, 'exp log');
+1 exp log 50 * 0.5 + 0.5 exp 50 * 0 rgb
+EOS
+op_test('800000', <<'EOS', 128, 0, 0, 'det');
+1 0 0 1 det 128 * 1 1 1 1 det 128 * 0 rgb
+EOS
+op_test('FF80C0', <<'EOS', 127, 0, 0, 'sat');
+0 0 getp1 sat 255 * 0.01 + 0 0 rgb
+EOS
+
+
+{
+ my $empty = Imager->new;
+ my $good = Imager->new(xsize => 1, ysize => 1);
+ ok(!Imager::transform2({ rpnexpr => "x y getp1" }, $good, $empty),
+ "can't transform an empty image");
+ is(Imager->errstr, "transform2: empty input image (input image 2)",
+ "check error message");
+}
+
+use Imager::Transform;
+
+# some simple tests
+print "# Imager::Transform\n";
+my @funcs = Imager::Transform->list;
+ok(@funcs, "funcs");
+
+my $tran = Imager::Transform->new($funcs[0]);
+ok($tran, "got tranform");
+ok($tran->describe() eq Imager::Transform->describe($funcs[0]),
+ "description");
+# look for a function that takes inputs (at least one does)
+my @needsinputs = grep Imager::Transform->new($_)->inputs, @funcs;
+# make sure they're
+my @inputs = Imager::Transform->new($needsinputs[0])->inputs;
+ok($inputs[0]{desc}, "input description");
+# at some point I might want to test the actual transformations
+
+# check lower level error handling
+my $im7 = Imager::transform2({rpnexpr=>'x y getp2', width=>100, height=>100});
+ok(!$im7, "expected failure on accessing invalid image");
+print "# ", Imager->errstr, "\n";
+ok(Imager->errstr =~ /not enough images/, "didn't get expected error");
+
+sub op_test ($$$$$$) {
+ my ($in_color, $code, $r, $g, $b, $comment) = @_;
+
+ my $im = Imager->new(xsize => 1, ysize => 1);
+ $im->setpixel(x => 0, y => 0, color => $in_color);
+ SKIP:
+ {
+ my $out = Imager::transform2({ rpnexpr => $code }, $im);
+ unless ($out) {
+ fail("$comment: could not compile $code - ".Imager->errstr);
+ return;
+ }
+ my $found = $out->getpixel(x => 0, y => 0);
+ is_color3($found, $r, $g, $b, $comment);
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 6;
+BEGIN { use_ok('Imager::Expr') }
+
+SKIP:
+{
+ my $expr = Imager::Expr->new({rpnexpr=><<EXPR, variables=>[ qw(x y) ], constants=>{one=>1, two=>2}});
+x two * # see if comments work
+y one +
+getp1
+EXPR
+ ok($expr, "compile postfix")
+ or print "# ", Imager::Expr->error, "\n";
+ $expr
+ or skip("Could not compile", 4);
+
+ # perform some basic validation on the code
+ my $code = $expr->dumpcode();
+ my @code = split /\n/, $code;
+ ok($code[-1] =~ /:\s+ret/, "ret at the end");
+ ok(grep(/:\s+mult.*x/, @code), "found mult");
+ ok(grep(/:\s+add.*y/, @code), "found add");
+ ok(grep(/:\s+getp1/, @code), "found getp1");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 7;
+
+BEGIN { use_ok('Imager::Expr') }
+
+# only test this if Parse::RecDescent was loaded successfully
+SKIP:
+{
+ Imager::Expr->type_registered('expr')
+ or skip("Imager::Expr::Infix not available", 6);
+
+ my $opts = {expr=>'z=0.8;return hsv(x/w*360,y/h,z)', variables=>[ qw(x y) ], constants=>{h=>100,w=>100}};
+ my $expr = Imager::Expr->new($opts);
+ ok($expr, "make infix expression")
+ or skip("Could not make infix expression", 5);
+ my $code = $expr->dumpcode();
+ my @code = split /\n/,$code;
+ #print $code;
+ ok($code[-1] =~ /:\s+ret/, "final op a ret");
+ ok(grep(/:\s+mult.*360/, @code), "mult by 360 found");
+ # strength reduction converts these to mults
+ #print grep(/:\s+div.*x/, @code) ? "ok 5\n" : "not ok 5\n";
+ #print grep(/:\s+div.*y/, @code) ? "ok 6\n" : "not ok 6\n";
+ ok(grep(/:\s+mult.*x/, @code), "mult by x found");
+ ok(grep(/:\s+mult.*y/, @code), "mult by y found");
+ ok(grep(/:\s+hsv.*0\.8/, @code), "hsv op found");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 6;
+
+BEGIN { use_ok('Imager::Expr::Assem') }
+
+SKIP:
+{
+ my $expr = Imager::Expr->new
+ ({assem=><<EOS,
+ var count:n ; var p:p
+ count = 0
+ p = getp1 x y
+loop:
+# this is just a delay
+ count = add count 1
+ var temp:n
+ temp = lt count totalcount
+ jumpnz temp loop
+ ret p
+EOS
+ variables=>[qw(x y)],
+ constants=>{totalcount=>5}
+ });
+ ok($expr, "compile simple assembler")
+ or do {
+ print "# ", Imager::Expr->error, "\n";
+ skip("didn't compile", 4);
+ };
+ my $code = $expr->dumpcode();
+ my @code = split /\n/, $code;
+ ok($code[-1] =~ /:\s+ret/, "last op is a ret");
+ ok($code[0] =~ /:\s+set/, "first op is a set");
+ ok($code[1] =~ /:\s+getp1/, "next is a getp1");
+ ok($code[3] =~ /:\s+lt/, "found comparison");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager;
+use Test::More tests => 14;
+
+unshift @INC, "t";
+
+ok(Imager::Font->register(type => "test",
+ class=>"GoodTestFont",
+ files => "\\.ppm\$"),
+ "register a test font");
+
+ok(Imager::Font->register(type => "bad",
+ class => "BadTestFont",
+ files => "\\.ppm\$"),
+ "register a bad test font");
+
+ok(!Imager::Font->register(), "no register parameters");
+like(Imager->errstr, qr/No type parameter/, "check message");
+
+ok(!Imager::Font->register(type => "bad1"), "no class parameter");
+like(Imager->errstr, qr/No class parameter/, "check message");
+
+ok(!Imager::Font->register(type => "bad2", class => "BadFont", files => "**"),
+ "bad files parameter");
+is(Imager->errstr, "files isn't a valid regexp", "check message");
+
+Imager::Font->priorities("bad", "test");
+
+# RT #62855
+# previously we'd select the first file matched font driver, even if
+# it wasn't available, then crash loading it.
+
+SKIP:
+{
+ my $good;
+ ok(eval {
+ $good = Imager::Font->new(file => "testimg/penguin-base.ppm");
+ }, "load good font avoiding RT 62855")
+ or skip("Failed to load", 1);
+ ok($good->isa("GoodTestFont"), "and it's the right type");
+}
+
+
+use Imager::Font::Test;
+
+# check string() and align_string() handle an empty image
+{
+ my $font = Imager::Font::Test->new;
+ my $empty = Imager->new;
+ ok(!$empty->string(text => "foo", x => 0, y => 10, size => 10, font => $font),
+ "can't draw text on an empty image");
+ is($empty->errstr, "string: empty input image",
+ "check error message");
+ ok(!$empty->align_string(text => "foo", x => 0, y => 10, size => 10, font => $font),
+ "can't draw text on an empty image");
+ is($empty->errstr, "align_string: empty input image",
+ "check error message");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 97;
+
+$|=1;
+
+BEGIN { use_ok(Imager => ':all') }
+use Imager::Test qw(diff_text_with_nul is_color3 is_image);
+
+-d "testout" or mkdir "testout";
+
+init_log("testout/t35ttfont.log",2);
+
+SKIP:
+{
+ skip("freetype 1.x unavailable or disabled", 96)
+ unless $Imager::formats{"tt"};
+ print "# has tt\n";
+
+ my $deffont = './fontfiles/dodge.ttf';
+ my $fontname=$ENV{'TTFONTTEST'} || $deffont;
+
+ if (!ok(-f $fontname, "check test font file exists")) {
+ print "# cannot find fontfile for truetype test $fontname\n";
+ skip('Cannot load test font', 89);
+ }
+
+ #i_init_fonts();
+ # i_tt_set_aa(1);
+
+ my $bgcolor = i_color_new(255,0,0,0);
+ my $overlay = Imager::ImgRaw::new(320,140,3);
+ i_box_filled($overlay, 0, 0, 319, 139, i_color_new(128, 128, 128));
+
+ my $ttraw = Imager::i_tt_new($fontname);
+ ok($ttraw, "create font");
+
+ my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',0);
+ is(@bbox, 8, "bounding box");
+ print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
+
+ ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XM CLH',6,1,0), "cp output");
+ ok(i_tt_cp($ttraw,$overlay,5,120,1,50.0,'XM CLH',6,0,0), "cp output (non AA)");
+ i_line($overlay,0,50,100,50,$bgcolor,1);
+
+ open(FH,">testout/t35ttfont.ppm") || die "cannot open testout/t35ttfont.ppm\n";
+ binmode(FH);
+ my $IO = Imager::io_new_fd( fileno(FH) );
+ ok(i_writeppm_wiol($overlay, $IO), "save t35ttfont.ppm");
+ close(FH);
+
+ $bgcolor=i_color_set($bgcolor,200,200,200,0);
+ my $backgr=Imager::ImgRaw::new(500,300,3);
+
+ # i_tt_set_aa(2);
+
+ ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'te st',5,1,0),
+ "normal output");
+ ok(i_tt_text($ttraw,$backgr,100,200,$bgcolor,50.0,'te st',5,0,0),
+ "normal output (non AA)");
+
+ my $ugly = Imager::i_tt_new("./fontfiles/ImUgly.ttf");
+ ok($ugly, "create ugly font");
+ # older versions were dropping the bottom of g and the right of a
+ ok(i_tt_text($ugly, $backgr,100, 80, $bgcolor, 14, 'g%g', 3, 1, 0),
+ "draw g%g");
+ ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 6, 1, 0),
+ "draw delta");
+ i_line($backgr,0,20,499,20,i_color_new(0,127,0,0),1);
+ ok(i_tt_text($ttraw, $backgr, 20, 20, $bgcolor, 14, 'abcdefghijklmnopqrstuvwxyz{|}', 29, 1, 0), "alphabet");
+ ok(i_tt_text($ttraw, $backgr, 20, 50, $bgcolor, 14, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 26, 1, 0), "ALPHABET");
+
+ # UTF8 tests
+ # for perl < 5.6 we can hand-encode text
+ # the following is "A\x{2010}A"
+ #
+ my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
+ my $alttext = "A-A";
+
+ my @utf8box = i_tt_bbox($ttraw, 50.0, $text, 1);
+ is(@utf8box, 8, "utf8 bbox element count");
+ my @base = i_tt_bbox($ttraw, 50.0, $alttext, 0);
+ is(@base, 8, "alt bbox element count");
+ my $maxdiff = $fontname eq $deffont ? 0 : $base[2] / 3;
+ print "# (@utf8box vs @base)\n";
+ ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
+ "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
+
+ # hand-encoded UTF8 drawing
+ ok(i_tt_text($ttraw, $backgr, 200, 80, $bgcolor, 14, $text, length($text), 1, 1), "draw hand-encoded UTF8");
+
+ ok(i_tt_cp($ttraw, $backgr, 250, 80, 1, 14, $text, length($text), 1, 1),
+ "cp hand-encoded UTF8");
+
+ # ok, try native perl UTF8 if available
+ SKIP:
+ {
+ skip("perl too old to test native UTF8 support", 5) unless $] >= 5.006;
+
+ my $text;
+ # we need to do this in eval to prevent compile time errors in older
+ # versions
+ eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
+ #$text = "A".chr(0x2010)."A"; # this one works too
+ ok(i_tt_text($ttraw, $backgr, 300, 80, $bgcolor, 14, $text, 0, 1, 0),
+ "draw UTF8");
+ ok(i_tt_cp($ttraw, $backgr, 350, 80, 0, 14, $text, 0, 1, 0),
+ "cp UTF8");
+ @utf8box = i_tt_bbox($ttraw, 50.0, $text, 0);
+ is(@utf8box, 8, "native utf8 bbox element count");
+ ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
+ "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
+ eval q{$text = "A\x{0905}\x{0906}\x{0103}A"}; # Devanagari
+ ok(i_tt_text($ugly, $backgr, 100, 160, $bgcolor, 36, $text, 0, 1, 0),
+ "more complex output");
+ }
+
+ open(FH,">testout/t35ttfont2.ppm") || die "cannot open testout/t35ttfont.ppm\n";
+ binmode(FH);
+ $IO = Imager::io_new_fd( fileno(FH) );
+ ok(i_writeppm_wiol($backgr, $IO), "save t35ttfont2.ppm");
+ close(FH);
+
+ my $exists_font = "fontfiles/ExistenceTest.ttf";
+ my $hcfont = Imager::Font->new(file=>$exists_font, type=>'tt');
+ SKIP:
+ {
+ ok($hcfont, "loading existence test font")
+ or skip("could not load test font", 20);
+
+ # list interface
+ my @exists = $hcfont->has_chars(string=>'!A');
+ ok(@exists == 2, "check return count");
+ ok($exists[0], "we have an exclamation mark");
+ ok(!$exists[1], "we have no exclamation mark");
+
+ # scalar interface
+ my $exists = $hcfont->has_chars(string=>'!A');
+ ok(length($exists) == 2, "check return length");
+ ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
+ ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
+
+ my $face_name = Imager::i_tt_face_name($hcfont->{id});
+ print "# face $face_name\n";
+ is($face_name, 'ExistenceTest', "face name (function)");
+ $face_name = $hcfont->face_name;
+ is($face_name, 'ExistenceTest', "face name (OO)");
+
+ # FT 1.x cheats and gives names even if the font doesn't have them
+ my @glyph_names = $hcfont->glyph_names(string=>"!J/");
+ is($glyph_names[0], 'exclam', "check exclam name OO");
+ ok(!defined($glyph_names[1]), "check for no J name OO");
+ is($glyph_names[2], 'slash', "check slash name OO");
+
+ print "# ** name table of the test font **\n";
+ Imager::i_tt_dump_names($hcfont->{id});
+
+ # the test font is known to have a shorter advance width for that char
+ my @bbox = $hcfont->bounding_box(string=>"/", size=>100);
+ is(@bbox, 8, "should be 8 entries");
+ isnt($bbox[6], $bbox[2], "different advance width from pos width");
+ print "# @bbox\n";
+ my $bbox = $hcfont->bounding_box(string=>"/", size=>100);
+ isnt($bbox->pos_width, $bbox->advance_width, "OO check");
+
+ cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
+
+ cmp_ok($bbox->display_width, '>', $bbox->advance_width,
+ "check display width (roughly)");
+
+ # check with a char that fits inside the box
+ $bbox = $hcfont->bounding_box(string=>"!", size=>100);
+ print "# @$bbox\n";
+ print "# pos width ", $bbox->pos_width, "\n";
+ is($bbox->pos_width, $bbox->advance_width,
+ "check backwards compatibility");
+ cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
+ cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
+ cmp_ok($bbox->display_width, '<', $bbox->advance_width,
+ "display smaller than advance");
+ }
+ undef $hcfont;
+
+ my $name_font = "fontfiles/NameTest.ttf";
+ $hcfont = Imager::Font->new(file=>$name_font, type=>'tt');
+ SKIP:
+ {
+ ok($hcfont, "loading name font")
+ or skip("could not load name font $name_font", 3);
+ # make sure a missing string parameter is handled correctly
+ eval {
+ $hcfont->glyph_names();
+ };
+ is($@, "", "correct error handling");
+ cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
+
+ my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
+ my @names = $hcfont->glyph_names(string=>$text, utf8=>1);
+ is($names[0], "hyphentwo", "check utf8 glyph name");
+ }
+
+ undef $hcfont;
+
+ SKIP:
+ { print "# alignment tests\n";
+ my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
+ ok($font, "loaded deffont OO")
+ or skip("could not load font:".Imager->errstr, 4);
+ my $im = Imager->new(xsize=>140, ysize=>150);
+ my %common =
+ (
+ font=>$font,
+ size=>40,
+ aa=>1,
+ );
+ $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
+ $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
+ $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
+ for my $args ([ x=>5, text=>"A", color=>"white" ],
+ [ x=>40, text=>"y", color=>"white" ],
+ [ x=>75, text=>"A", channel=>1 ],
+ [ x=>110, text=>"y", channel=>1 ]) {
+ ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
+ ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
+ ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
+ }
+ ok($im->write(file=>'testout/t35align.ppm'), "save align image");
+ }
+
+ { # Ticket #14804 Imager::Font->new() doesn't report error details
+ # when using freetype 1
+ # make sure we're using C locale for messages
+ use POSIX qw(setlocale LC_ALL);
+ setlocale(LC_ALL, "C");
+
+ my $font = Imager::Font->new(file=>'t/350-font/020-tt.t', type=>'tt');
+ ok(!$font, "font creation should have failed for invalid file");
+ cmp_ok(Imager->errstr, 'eq', 'Invalid file format.',
+ "test error message");
+
+ setlocale(LC_ALL, "");
+ }
+
+ { # check errstr set correctly
+ my $font = Imager::Font->new(file=>$fontname, type=>'tt',
+ size => undef);
+ ok($font, "made size error test font");
+ my $im = Imager->new(xsize=>100, ysize=>100);
+ ok($im, "made size error test image");
+ ok(!$im->string(font=>$font, x=>10, 'y'=>50, string=>"Hello"),
+ "drawing should fail with no size");
+ is($im->errstr, "No font size provided", "check error message");
+
+ # try no string
+ ok(!$im->string(font=>$font, x=>10, 'y'=>50, size=>15),
+ "drawing should fail with no string");
+ is($im->errstr, "missing required parameter 'string'",
+ "check error message");
+ }
+
+ { # introduced in 0.46 - outputting just space crashes
+ my $im = Imager->new(xsize=>100, ysize=>100);
+ my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', size=>14);
+ ok($im->string(font=>$font, x=> 5, 'y' => 50, string=>' '),
+ "outputting just a space was crashing");
+ }
+
+ { # string output cut off at NUL ('\0')
+ # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
+ my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
+ ok($font, "loaded imugly");
+
+ diff_text_with_nul("a\\0b vs a", "a\0b", "a",
+ font => $font, color => '#FFFFFF');
+ diff_text_with_nul("a\\0b vs a", "a\0b", "a",
+ font => $font, channel => 1);
+
+ # UTF8 encoded \x{2010}
+ my $dash = pack("C*", 0xE2, 0x80, 0x90);
+ diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
+ font => $font, color => '#FFFFFF', utf8 => 1);
+ diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
+ font => $font, channel => 1, utf8 => 1);
+ }
+
+ SKIP:
+ { # RT 11972
+ # when rendering to a transparent image the coverage should be
+ # expressed in terms of the alpha channel rather than the color
+ my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
+ ok($font, "loaded fontfiles/ImUgly.ttf")
+ or skip("Could not load test font: ".Imager->errstr, 4);
+ my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
+ ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
+ x => 0, y => 15, font => $font),
+ "draw to transparent image");
+ #$im->write(file => "foo.png");
+ my $im_noalpha = $im->convert(preset => 'noalpha');
+ my $im_pal = $im->to_paletted(make_colors => 'mediancut');
+ my @colors = $im_pal->getcolors;
+ is(@colors, 2, "should be only 2 colors");
+ @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
+ is_color3($colors[0], 0, 0, 0, "check we got black");
+ is_color3($colors[1], 255, 0, 0, "and red");
+ }
+
+ SKIP:
+ { # RT 71564
+ my $noalpha = Imager::Color->new(255, 255, 255, 0);
+ my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt',
+ color => $noalpha);
+ ok($font, "loaded fontfiles/ImUgly.ttf")
+ or skip("Could not load test font: ".Imager->errstr, 4);
+ {
+ my $im = Imager->new(xsize => 40, ysize => 20);
+ my $copy = $im->copy;
+ ok($im->string(string => "AB", size => 20, aa => 1,
+ x => 0, y => 15, font => $font),
+ "draw with transparent color, aa");
+ is_image($im, $copy, "should draw nothing");
+ }
+ {
+ my $im = Imager->new(xsize => 40, ysize => 20);
+ my $copy = $im->copy;
+ ok($im->string(string => "AB", size => 20, aa => 0,
+ x => 0, y => 15, font => $font),
+ "draw with transparent color, non-aa");
+ local $TODO = "RT 73359 - non-AA text isn't normal mode rendered";
+ is_image($im, $copy, "should draw nothing");
+ }
+ }
+
+ ok(1, "end of code");
+}
--- /dev/null
+#!/usr/bin/perl -w
+use strict;
+
+#use lib qw(blib/lib blib/arch);
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+use Test::More tests => 16;
+
+BEGIN { use_ok('Imager') };
+
+BEGIN {
+ require Imager::Test;
+ Imager::Test->import(qw(isnt_image));
+}
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t36oofont.log");
+
+my $fontname_tt=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
+
+my $green=Imager::Color->new(92,205,92,128);
+die $Imager::ERRSTR unless $green;
+my $red=Imager::Color->new(205, 92, 92, 255);
+die $Imager::ERRSTR unless $red;
+
+SKIP:
+{
+ $Imager::formats{"tt"} && -f $fontname_tt
+ or skip("FT1.x missing or disabled", 14);
+
+ my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
+
+ my $font=Imager::Font->new(file=>$fontname_tt,size=>25)
+ or die $img->{ERRSTR};
+
+ ok(1, "create TT font object");
+
+ ok($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
+ "draw text");
+
+ $img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
+
+ my $text="LLySja";
+ my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
+
+ is(@bbox, 8, "bbox list size");
+
+ $img->box(box=>\@bbox, color=>$green);
+
+ $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
+ ok($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1),
+ "draw hand-encoded UTF8 text");
+
+ SKIP:
+ {
+ $] >= 5.006
+ or skip("perl too old for native utf8", 1);
+ eval q{$text = "A\x{2010}A"};
+ ok($img->string(font=>$font, text=>$text, 'x'=>200, 'y'=>50),
+ "draw native UTF8 text");
+ }
+
+ ok($img->write(file=>"testout/t36oofont2.ppm", type=>'pnm'),
+ "write t36oofont2.ppm")
+ or print "# ", $img->errstr,"\n";
+
+ ok($font->utf8, "make sure utf8 method returns true");
+
+ my $has_chars = $font->has_chars(string=>"\x01A");
+ is($has_chars, "\x00\x01", "has_chars scalar");
+ my @has_chars = $font->has_chars(string=>"\x01A");
+ ok(!$has_chars[0], "has_chars list 0");
+ ok($has_chars[1], "has_chars list 1");
+
+ { # RT 71469
+ my $font1 = Imager::Font->new(file => $fontname_tt, type => "tt");
+ my $font2 = Imager::Font::Truetype->new(file => $fontname_tt);
+
+ for my $font ($font1, $font2) {
+ print "# ", join(",", $font->{color}->rgba), "\n";
+
+ my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);
+
+ ok($im->string(text => "T", font => $font, y => 15),
+ "draw with default color")
+ or print "# ", $im->errstr, "\n";
+ my $work = Imager->new(xsize => 20, ysize => 20);
+ my $cmp = $work->copy;
+ $work->rubthrough(src => $im);
+ isnt_image($work, $cmp, "make sure something was drawn");
+ }
+ }
+}
+
+ok(1, "end");
--- /dev/null
+#!perl -w
+use strict;
+use Imager::Test qw(std_font_tests std_font_test_count);
+use Imager::Font;
+use Test::More;
+
+$Imager::formats{tt}
+ or plan skip_all => "No tt available";
+
+Imager->open_log(log => "testout/t37std.log");
+
+plan tests => std_font_test_count();
+
+my $font = Imager::Font->new(file => "fontfiles/dodge.ttf",
+ type => "tt");
+my $name_font =
+ Imager::Font->new(file => "fontfiles/ImUgly.ttf",
+ type => "tt");
+
+SKIP:
+{
+ $font
+ or skip "Cannot load font", std_font_test_count();
+ std_font_tests
+ ({
+ font => $font,
+ has_chars => [ 1, 1, 1 ],
+ glyph_name_font => $name_font,
+ glyph_names => [ qw(A uni2010 A) ],
+ });
+}
+
+Imager->close_log;
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 13;
+
+BEGIN { use_ok('Imager') }
+
+-d "testout" or mkdir "testout";
+
+require_ok('Imager::Font::Wrap');
+
+my $img = Imager->new(xsize=>400, ysize=>400);
+
+my $text = <<EOS;
+This is a test of text wrapping. This is a test of text wrapping. This =
+is a test of text wrapping. This is a test of text wrapping. This is a =
+test of text wrapping. This is a test of text wrapping. This is a test =
+of text wrapping. This is a test of text wrapping. This is a test of =
+text wrapping. XX.
+
+Xxxxxxxxxxxxxxxxxxxxxxxxxxxwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww xxxx.
+
+This is a test of text wrapping. This is a test of text wrapping. This =
+is a test of text wrapping. This is a test of text wrapping. This is a =
+test of text wrapping. This is a test of text wrapping. This is a test =
+of text wrapping. This is a test of text wrapping. This is a test of =
+text wrapping. This is a test of text wrapping. This is a test of text =
+wrapping. This is a test of text wrapping. This is a test of text =
+wrapping. This is a test of text wrapping. This is a test of text =
+wrapping. This is a test of text wrapping. This is a test of text =
+wrapping. XX.
+EOS
+
+$text =~ s/=\n//g;
+
+my $fontfile = $ENV{WRAPTESTFONT} || $ENV{TTFONTTEST} || "fontfiles/ImUgly.ttf";
+
+my $font = Imager::Font->new(file=>$fontfile);
+
+SKIP:
+{
+ $Imager::formats{'tt'} || $Imager::formats{'ft2'}
+ or skip("Need Freetype 1.x or 2.x to test", 11);
+
+ ok($font, "loading font")
+ or skip("Could not load test font", 8);
+
+ Imager::Font->priorities(qw(t1 ft2 tt));
+ ok(scalar Imager::Font::Wrap->wrap_text(string => $text,
+ font=>$font,
+ image=>$img,
+ size=>13,
+ width => 380, aa=>1,
+ x=>10, 'y'=>10,
+ justify=>'fill',
+ color=>'FFFFFF'),
+ "basic test");
+ ok($img->write(file=>'testout/t80wrapped.ppm'), "save to file");
+ ok(scalar Imager::Font::Wrap->wrap_text(string => $text,
+ font=>$font,
+ image=>undef,
+ size=>13,
+ width => 380,
+ x=>10, 'y'=>10,
+ justify=>'left',
+ color=>'FFFFFF'),
+ "no image test");
+ my $bbox = $font->bounding_box(string=>"Xx", size=>13);
+ ok($bbox, "get height for check");
+
+ my $used;
+ ok(scalar Imager::Font::Wrap->wrap_text
+ (string=>$text, font=>$font, image=>undef, size=>13, width=>380,
+ savepos=> \$used, height => $bbox->font_height), "savepos call");
+ ok($used > 20 && $used < length($text), "savepos value");
+ print "# $used\n";
+ my @box = Imager::Font::Wrap->wrap_text
+ (string=>substr($text, 0, $used), font=>$font, image=>undef, size=>13,
+ width=>380);
+
+ ok(@box == 4, "bounds list count");
+ print "# @box\n";
+ ok($box[3] == $bbox->font_height, "check height");
+
+ { # regression
+ # http://rt.cpan.org/Ticket/Display.html?id=29771
+ # the length of the trailing line wasn't included in the text consumed
+ my $used;
+ ok(scalar Imager::Font::Wrap->wrap_text
+ ( string => "test", font => $font, image => undef, size => 12,
+ width => 200, savepos => \$used, height => $bbox->font_height),
+ "regression 29771 - call wrap_text");
+ is($used, 4, "all text should be consumed");
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager qw(:handy);
+use Test::More tests => 122;
+
+-d "testout" or mkdir "testout";
+
+Imager::init_log("testout/t61filters.log", 1);
+use Imager::Test qw(is_image_similar test_image is_image is_color4 is_fcolor4);
+# meant for testing the filters themselves
+
+my $imbase = test_image();
+
+my $im_other = Imager->new(xsize=>150, ysize=>150);
+$im_other->box(xmin=>30, ymin=>60, xmax=>120, ymax=>90, filled=>1);
+
+test($imbase, {type=>'autolevels'}, 'testout/t61_autolev.ppm');
+
+test($imbase, {type=>'contrast', intensity=>0.5},
+ 'testout/t61_contrast.ppm');
+
+# this one's kind of cool
+test($imbase, {type=>'conv', coef=>[ 0.3, 1, 0.3, ], },
+ 'testout/t61_conv_blur.ppm');
+
+{
+ my $work = $imbase->copy;
+ ok(!Imager::i_conv($work->{IMG}, []), "conv should fail with empty array");
+ ok(!$work->filter(type => 'conv', coef => []),
+ "check the conv OO intergave too");
+ is($work->errstr, "there must be at least one coefficient",
+ "check conv error message");
+}
+
+{
+ my $work8 = $imbase->copy;
+ ok(!$work8->filter(type => "conv", coef => "ABC"),
+ "coef not an array");
+}
+{
+ my $work8 = $imbase->copy;
+ ok(!$work8->filter(type => "conv", coef => [ -1, 2, -1 ]),
+ "should fail if sum of coef is 0");
+ is($work8->errstr, "sum of coefficients is zero", "check message");
+}
+
+{
+ my $work8 = $imbase->copy;
+ my $work16 = $imbase->to_rgb16;
+ my $coef = [ -0.2, 1, -0.2 ];
+ ok($work8->filter(type => "conv", coef => $coef),
+ "filter 8 bit image");
+ ok($work16->filter(type => "conv", , coef => $coef),
+ "filter 16 bit image");
+ is_image_similar($work8, $work16, 80000, "8 and 16 bit conv match");
+}
+
+{
+ my $gauss = test($imbase, {type=>'gaussian', stddev=>5 },
+ 'testout/t61_gaussian.ppm');
+
+ my $imbase16 = $imbase->to_rgb16;
+ my $gauss16 = test($imbase16, {type=>'gaussian', stddev=>5 },
+ 'testout/t61_gaussian16.ppm');
+ is_image_similar($gauss, $gauss16, 250000, "8 and 16 gaussian match");
+}
+
+
+test($imbase, { type=>'gradgen', dist=>1,
+ xo=>[ 10, 10, 120 ],
+ yo=>[ 10, 140, 60 ],
+ colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
+ 'testout/t61_gradgen.ppm');
+
+test($imbase, {type=>'mosaic', size=>8}, 'testout/t61_mosaic.ppm');
+
+test($imbase, {type=>'hardinvert'}, 'testout/t61_hardinvert.ppm');
+
+{ # invert - 8 bit
+ my $im = Imager->new(xsize => 1, ysize => 1, channels => 4);
+ ok($im, "make test image for invert test");
+ ok($im->setpixel(x => 0, y => 0, color => "000010C0"),
+ "set a test pixel");
+ my $copy = $im->copy;
+ ok($im->filter(type => "hardinvert"), "hardinvert it");
+ is_color4($im->getpixel(x => 0, y => 0), 255, 255, 0xEF, 0xC0,
+ "check only colour inverted");
+ ok($copy->filter(type => "hardinvertall"), "hardinvertall copy");
+ is_color4($copy->getpixel(x => 0, y => 0), 255, 255, 0xEF, 0x3f,
+ "check all inverted");
+}
+
+{ # invert - double image
+ my $im = Imager->new(xsize => 1, ysize => 1, channels => 4, bits => "double");
+ ok($im, "make double test image for invert test");
+ ok($im->setpixel(x => 0, y => 0, color => Imager::Color::Float->new(0, 0, 0.125, 0.75)),
+ "set a test pixel");
+ my $copy = $im->copy;
+ ok($im->filter(type => "hardinvert"), "hardinvert it");
+ is_fcolor4($im->getpixel(x => 0, y => 0, type => "double"),
+ 1.0, 1.0, 0.875, 0.75, 1e-5,
+ "check only colour inverted");
+ ok($copy->filter(type => "hardinvertall"), "hardinvertall copy");
+ is_fcolor4($copy->getpixel(x => 0, y => 0, type =>"double"),
+ 1.0, 1.0, 0.875, 0.25, 1e-5,
+ "check all inverted");
+}
+
+test($imbase, {type=>'noise'}, 'testout/t61_noise.ppm');
+
+test($imbase, {type=>'radnoise'}, 'testout/t61_radnoise.ppm');
+
+test($imbase, {type=>'turbnoise'}, 'testout/t61_turbnoise.ppm');
+
+test($imbase, {type=>'bumpmap', bump=>$im_other, lightx=>30, lighty=>30},
+ 'testout/t61_bumpmap.ppm');
+
+test($imbase, {type=>'bumpmap_complex', bump=>$im_other}, 'testout/t61_bumpmap_complex.ppm');
+
+test($imbase, {type=>'postlevels', levels=>3}, 'testout/t61_postlevels.ppm');
+
+test($imbase, {type=>'watermark', wmark=>$im_other },
+ 'testout/t61_watermark.ppm');
+
+test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>85, yb=>30,
+ repeat=>'triangle', #ftype=>'radial',
+ super_sample=>'circle', ssample_param => 16,
+ },
+ 'testout/t61_fountain.ppm');
+use Imager::Fountain;
+
+my $f1 = Imager::Fountain->new;
+$f1->add(end=>0.2, c0=>NC(255, 0,0), c1=>NC(255, 255,0));
+$f1->add(start=>0.2, c0=>NC(255,255,0), c1=>NC(0,0,255,0));
+test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
+ #repeat=>'triangle',
+ segments=>$f1
+ },
+ 'testout/t61_fountain2.ppm');
+my $f2 = Imager::Fountain->new
+ ->add(end=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'hueup')
+ ->add(start=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'huedown');
+#use Data::Dumper;
+#print Dumper($f2);
+test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
+ segments=>$f2 },
+ 'testout/t61_fount_hsv.ppm');
+my $f3 = Imager::Fountain->read(gimp=>'testimg/gimpgrad');
+ok($f3, "read gimpgrad");
+test($imbase, { type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
+ segments=>$f3, super_sample=>'grid',
+ ftype=>'radial_square', combine=>'color' },
+ 'testout/t61_fount_gimp.ppm');
+{ # test new fountain with no parameters
+ my $warn = '';
+ local $SIG{__WARN__} = sub { $warn .= "@_" };
+ my $f4 = Imager::Fountain->read();
+ ok(!$f4, "read with no parameters does nothing");
+ like($warn, qr/Nothing to do!/, "check the warning");
+}
+{ # test with missing file
+ my $warn = '';
+ local $SIG{__WARN__} = sub { $warn .= "@_" };
+ my $f = Imager::Fountain->read(gimp => "no-such-file");
+ ok(!$f, "try to read a fountain defintion that doesn't exist");
+ is($warn, "", "should be no warning");
+ like(Imager->errstr, qr/^Cannot open no-such-file: /, "check message");
+}
+SKIP:
+{
+ my $fh = IO::File->new("testimg/gimpgrad", "r");
+ ok($fh, "opened gradient")
+ or skip "Couldn't open gradient: $!", 1;
+ my $f = Imager::Fountain->read(gimp => $fh);
+ ok($f, "read gradient from file handle");
+}
+{
+ # not a gradient
+ my $f = Imager::Fountain->read(gimp => "t/400-filter/010-filters.t");
+ ok(!$f, "fail to read non-gradient");
+ is(Imager->errstr, "t/400-filter/010-filters.t is not a GIMP gradient file",
+ "check error message");
+}
+{ # an invalid gradient file
+ my $f = Imager::Fountain->read(gimp => "testimg/gradbad.ggr");
+ ok(!$f, "fail to read bad gradient (bad seg count)");
+ is(Imager->errstr, "testimg/gradbad.ggr is missing the segment count",
+ "check error message");
+}
+{ # an invalid gradient file
+ my $f = Imager::Fountain->read(gimp => "testimg/gradbad2.ggr");
+ ok(!$f, "fail to read bad gradient (bad segment)");
+ is(Imager->errstr, "Bad segment definition",
+ "check error message");
+}
+test($imbase, { type=>'unsharpmask', stddev=>2.0 },
+ 'testout/t61_unsharp.ppm');
+test($imbase, {type=>'conv', coef=>[ -1, 3, -1, ], },
+ 'testout/t61_conv_sharp.ppm');
+
+test($imbase, { type=>'nearest_color', dist=>1,
+ xo=>[ 10, 10, 120 ],
+ yo=>[ 10, 140, 60 ],
+ colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
+ 'testout/t61_nearest.ppm');
+
+# Regression test: the checking of the segment type was incorrect
+# (the comparison was checking the wrong variable against the wrong value)
+my $f4 = [ [ 0, 0.5, 1, NC(0,0,0), NC(255,255,255), 5, 0 ] ];
+test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
+ segments=>$f4, super_sample=>'grid',
+ ftype=>'linear', combine=>'color' },
+ 'testout/t61_regress_fount.ppm');
+my $im2 = $imbase->copy;
+$im2->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
+$im2->write(file=>'testout/t61_diff_base.ppm');
+my $im3 = Imager->new(xsize=>150, ysize=>150, channels=>3);
+$im3->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
+my $diff = $imbase->difference(other=>$im2);
+ok($diff, "got difference image");
+SKIP:
+{
+ skip(1, "missing comp or diff image") unless $im3 && $diff;
+
+ is(Imager::i_img_diff($im3->{IMG}, $diff->{IMG}), 0,
+ "compare test image and diff image");
+}
+
+# newer versions of gimp add a line to the gradient file
+my $name;
+my $f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr',
+ name => \$name);
+ok($f5, "read newer gimp gradient")
+ or print "# ",Imager->errstr,"\n";
+is($name, "imager test gradient", "check name read correctly");
+$f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr');
+ok($f5, "check we handle case of no name reference correctly")
+ or print "# ",Imager->errstr,"\n";
+
+# test writing of gradients
+ok($f2->write(gimp=>'testout/t61grad1.ggr'), "save a gradient")
+ or print "# ",Imager->errstr,"\n";
+undef $name;
+my $f6 = Imager::Fountain->read(gimp=>'testout/t61grad1.ggr',
+ name=>\$name);
+ok($f6, "read what we wrote")
+ or print "# ",Imager->errstr,"\n";
+ok(!defined $name, "we didn't set the name, so shouldn't get one");
+
+# try with a name
+ok($f2->write(gimp=>'testout/t61grad2.ggr', name=>'test gradient'),
+ "write gradient with a name")
+ or print "# ",Imager->errstr,"\n";
+undef $name;
+my $f7 = Imager::Fountain->read(gimp=>'testout/t61grad2.ggr', name=>\$name);
+ok($f7, "read what we wrote")
+ or print "# ",Imager->errstr,"\n";
+is($name, "test gradient", "check the name matches");
+
+# we attempt to convert color names in segments to segments now
+{
+ my @segs =
+ (
+ [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
+ );
+ my $im = Imager->new(xsize=>50, ysize=>50);
+ ok($im->filter(type=>'fountain', segments => \@segs,
+ xa=>0, ya=>30, xb=>49, yb=>30),
+ "fountain with color names instead of objects in segments");
+ my $left = $im->getpixel('x'=>0, 'y'=>20);
+ ok(color_close($left, Imager::Color->new(0,0,0)),
+ "check black converted correctly");
+ my $right = $im->getpixel('x'=>49, 'y'=>20);
+ ok(color_close($right, Imager::Color->new(255,255,255)),
+ "check white converted correctly");
+
+ # check that invalid color names are handled correctly
+ my @segs2 =
+ (
+ [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
+ );
+ ok(!$im->filter(type=>'fountain', segments => \@segs2,
+ xa=>0, ya=>30, xb=>49, yb=>30),
+ "fountain with invalid color name");
+ cmp_ok($im->errstr, '=~', 'No color named', "check error message");
+}
+
+{
+ # test simple gradient creation
+ my @colors = map Imager::Color->new($_), qw/white blue red/;
+ my $s = Imager::Fountain->simple(positions => [ 0, 0.3, 1.0 ],
+ colors => \@colors);
+ ok($s, "made simple gradient");
+ my $start = $s->[0];
+ is($start->[0], 0, "check start of first correct");
+ is_color4($start->[3], 255, 255, 255, 255, "check color at start");
+}
+{
+ # simple gradient error modes
+ {
+ my $warn = '';
+ local $SIG{__WARN__} = sub { $warn .= "@_" };
+ my $s = Imager::Fountain->simple();
+ ok(!$s, "no parameters to simple()");
+ like($warn, qr/Nothing to do/);
+ }
+ {
+ my $s = Imager::Fountain->simple(positions => [ 0, 1 ],
+ colors => [ NC(0, 0, 0) ]);
+ ok(!$s, "mismatch of positions and colors fails");
+ is(Imager->errstr, "positions and colors must be the same size",
+ "check message");
+ }
+ {
+ my $s = Imager::Fountain->simple(positions => [ 0 ],
+ colors => [ NC(0, 0, 0) ]);
+ ok(!$s, "not enough positions");
+ is(Imager->errstr, "not enough segments");
+ }
+}
+
+{
+ my $im = Imager->new(xsize=>100, ysize=>100);
+ # build the gradient the hard way - linear from black to white,
+ # then back again
+ my @simple =
+ (
+ [ 0, 0.25, 0.5, 'black', 'white', 0, 0 ],
+ [ 0.5. 0.75, 1.0, 'white', 'black', 0, 0 ],
+ );
+ # across
+ my $linear = $im->filter(type => "fountain",
+ ftype => 'linear',
+ repeat => 'sawtooth',
+ xa => 0,
+ ya => $im->getheight / 2,
+ xb => $im->getwidth - 1,
+ yb => $im->getheight / 2);
+ ok($linear, "linear fountain sample");
+ # around
+ my $revolution = $im->filter(type => "fountain",
+ ftype => 'revolution',
+ xa => $im->getwidth / 2,
+ ya => $im->getheight / 2,
+ xb => $im->getwidth / 2,
+ yb => 0);
+ ok($revolution, "revolution fountain sample");
+ # out from the middle
+ my $radial = $im->filter(type => "fountain",
+ ftype => 'radial',
+ xa => $im->getwidth / 2,
+ ya => $im->getheight / 2,
+ xb => $im->getwidth / 2,
+ yb => 0);
+ ok($radial, "radial fountain sample");
+}
+
+{
+ # try a simple custom filter that uses the Perl image interface
+ sub perl_filt {
+ my %args = @_;
+
+ my $im = $args{imager};
+
+ my $channels = $args{channels};
+ unless (@$channels) {
+ $channels = [ reverse(0 .. $im->getchannels-1) ];
+ }
+ my @chans = @$channels;
+ push @chans, 0 while @chans < 4;
+
+ for my $y (0 .. $im->getheight-1) {
+ my $row = $im->getsamples(y => $y, channels => \@chans);
+ $im->setscanline(y => $y, pixels => $row);
+ }
+ }
+ Imager->register_filter(type => 'perl_test',
+ callsub => \&perl_filt,
+ defaults => { channels => [] },
+ callseq => [ qw/imager channels/ ]);
+ test($imbase, { type => 'perl_test' }, 'testout/t61perl.ppm');
+}
+
+{ # check the difference method out
+ my $im1 = Imager->new(xsize => 3, ysize => 2);
+ $im1->box(filled => 1, color => '#FF0000');
+ my $im2 = $im1->copy;
+ $im1->setpixel(x => 1, 'y' => 0, color => '#FF00FF');
+ $im2->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
+ $im1->setpixel(x => 2, 'y' => 0, color => '#FF00FF');
+ $im2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
+
+ my $diff1 = $im1->difference(other => $im2);
+ my $cmp1 = Imager->new(xsize => 3, ysize => 2, channels => 4);
+ $cmp1->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
+ $cmp1->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
+ is_image($diff1, $cmp1, "difference() - check image with mindist 0");
+
+ my $diff2 = $im1->difference(other => $im2, mindist => 1);
+ my $cmp2 = Imager->new(xsize => 3, ysize => 2, channels => 4);
+ $cmp2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
+ is_image($diff2, $cmp2, "difference() - check image with mindist 1");
+}
+
+{
+ # and again with large samples
+ my $im1 = Imager->new(xsize => 3, ysize => 2, bits => 'double');
+ $im1->box(filled => 1, color => '#FF0000');
+ my $im2 = $im1->copy;
+ $im1->setpixel(x => 1, 'y' => 0, color => '#FF00FF');
+ $im2->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
+ $im1->setpixel(x => 2, 'y' => 0, color => '#FF00FF');
+ $im2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
+
+ my $diff1 = $im1->difference(other => $im2);
+ my $cmp1 = Imager->new(xsize => 3, ysize => 2, channels => 4);
+ $cmp1->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
+ $cmp1->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
+ is_image($diff1, $cmp1, "difference() - check image with mindist 0 - large samples");
+
+ my $diff2 = $im1->difference(other => $im2, mindist => 1.1);
+ my $cmp2 = Imager->new(xsize => 3, ysize => 2, channels => 4);
+ $cmp2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
+ is_image($diff2, $cmp2, "difference() - check image with mindist 1.1 - large samples");
+}
+
+{
+ my $empty = Imager->new;
+ ok(!$empty->filter(type => "hardinvert"), "can't filter an empty image");
+ is($empty->errstr, "filter: empty input image",
+ "check error message");
+ ok(!$empty->difference(other => $imbase), "can't difference empty image");
+ is($empty->errstr, "difference: empty input image",
+ "check error message");
+ ok(!$imbase->difference(other => $empty),
+ "can't difference against empty image");
+ is($imbase->errstr, "difference: empty input image (other image)",
+ "check error message");
+}
+
+sub test {
+ my ($in, $params, $out) = @_;
+
+ my $copy = $in->copy;
+ if (ok($copy->filter(%$params), $params->{type})) {
+ ok($copy->write(file=>$out), "write $params->{type}")
+ or print "# ",$copy->errstr,"\n";
+ }
+ else {
+ diag($copy->errstr);
+ SKIP:
+ {
+ skip("couldn't filter", 1);
+ }
+ }
+ $copy;
+}
+
+sub color_close {
+ my ($c1, $c2) = @_;
+
+ my @c1 = $c1->rgba;
+ my @c2 = $c2->rgba;
+
+ for my $i (0..2) {
+ if (abs($c1[$i]-$c2[$i]) > 2) {
+ return 0;
+ }
+ }
+ return 1;
+}
--- /dev/null
+#!perl -w
+#
+# this tests both the Inline interface and the API
+use strict;
+use Test::More;
+use Imager::Test qw(is_color3 is_color4);
+eval "require Inline::C;";
+plan skip_all => "Inline required for testing API" if $@;
+
+eval "require Parse::RecDescent;";
+plan skip_all => "Could not load Parse::RecDescent" if $@;
+
+use Cwd 'getcwd';
+plan skip_all => "Inline won't work in directories with spaces"
+ if getcwd() =~ / /;
+
+plan skip_all => "perl 5.005_04, 5.005_05 too buggy"
+ if $] =~ /^5\.005_0[45]$/;
+
+-d "testout" or mkdir "testout";
+
+print STDERR "Inline version $Inline::VERSION\n";
+
+plan tests => 117;
+require Inline;
+Inline->import(with => 'Imager');
+Inline->import("FORCE"); # force rebuild
+#Inline->import(C => Config => OPTIMIZE => "-g");
+
+Inline->bind(C => <<'EOS');
+#include <math.h>
+
+int pixel_count(Imager::ImgRaw im) {
+ return im->xsize * im->ysize;
+}
+
+int count_color(Imager::ImgRaw im, Imager::Color c) {
+ int count = 0, x, y, chan;
+ i_color read_c;
+
+ for (x = 0; x < im->xsize; ++x) {
+ for (y = 0; y < im->ysize; ++y) {
+ int match = 1;
+ i_gpix(im, x, y, &read_c);
+ for (chan = 0; chan < im->channels; ++chan) {
+ if (read_c.channel[chan] != c->channel[chan]) {
+ match = 0;
+ break;
+ }
+ }
+ if (match)
+ ++count;
+ }
+ }
+
+ return count;
+}
+
+Imager make_10x10() {
+ i_img *im = i_img_8_new(10, 10, 3);
+ i_color c;
+ c.channel[0] = c.channel[1] = c.channel[2] = 255;
+ i_box_filled(im, 0, 0, im->xsize-1, im->ysize-1, &c);
+
+ return im;
+}
+
+/* tests that all of the APIs are visible - most of them anyway */
+Imager do_lots(Imager src) {
+ i_img *im = i_img_8_new(100, 100, 3);
+ i_img *fill_im = i_img_8_new(5, 5, 3);
+ i_img *testim;
+ i_color red, blue, green, black, temp_color;
+ i_fcolor redf, bluef;
+ i_fill_t *hatch, *fhatch_fill;
+ i_fill_t *im_fill;
+ i_fill_t *solid_fill, *fsolid_fill;
+ i_fill_t *fount_fill;
+ void *block;
+ double matrix[9] = /* 30 degree rotation */
+ {
+ 0.866025, -0.5, 0,
+ 0.5, 0.866025, 0,
+ 0, 0, 1,
+ };
+ i_fountain_seg fseg;
+ i_img_tags tags;
+ int entry;
+ double temp_double;
+
+ red.channel[0] = 255; red.channel[1] = 0; red.channel[2] = 0;
+ red.channel[3] = 255;
+ blue.channel[0] = 0; blue.channel[1] = 0; blue.channel[2] = 255;
+ blue.channel[3] = 255;
+ green.channel[0] = 0; green.channel[1] = 255; green.channel[2] = 0;
+ green.channel[3] = 255;
+ black.channel[0] = black.channel[1] = black.channel[2] = 0;
+ black.channel[3] = 255;
+ hatch = i_new_fill_hatch(&red, &blue, 0, 1, NULL, 0, 0);
+
+ i_box(im, 0, 0, 9, 9, &red);
+ i_box_filled(im, 10, 0, 19, 9, &blue);
+ i_box_cfill(im, 20, 0, 29, 9, hatch);
+
+ /* make an image fill, and try it */
+ i_box_cfill(fill_im, 0, 0, 4, 4, hatch);
+ im_fill = i_new_fill_image(fill_im, matrix, 2, 2, 0);
+
+ i_box_cfill(im, 30, 0, 39, 9, im_fill);
+
+ /* make a solid fill and try it */
+ solid_fill = i_new_fill_solid(&red, 0);
+ i_box_cfill(im, 40, 0, 49, 9, solid_fill);
+
+ /* floating fills */
+ redf.channel[0] = 1.0; redf.channel[1] = 0; redf.channel[2] = 0;
+ redf.channel[3] = 1.0;
+ bluef.channel[0] = 0; bluef.channel[1] = 0; bluef.channel[2] = 1.0;
+ bluef.channel[3] = 1.0;
+
+ fsolid_fill = i_new_fill_solidf(&redf, 0);
+ i_box_cfill(im, 50, 0, 59, 9, fsolid_fill);
+
+ fhatch_fill = i_new_fill_hatchf(&redf, &bluef, 0, 2, NULL, 0, 0);
+ i_box_cfill(im, 60, 0, 69, 9, fhatch_fill);
+
+ /* fountain fill */
+ fseg.start = 0;
+ fseg.middle = 0.5;
+ fseg.end = 1.0;
+ fseg.c[0] = redf;
+ fseg.c[1] = bluef;
+ fseg.type = i_fst_linear;
+ fseg.color = i_fc_hue_down;
+ fount_fill = i_new_fill_fount(70, 0, 80, 0, i_ft_linear, i_fr_triangle, 0, i_fts_none, 1, 1, &fseg);
+
+ i_box_cfill(im, 70, 0, 79, 9, fount_fill);
+
+ i_line(im, 0, 10, 10, 15, &blue, 1);
+ i_line_aa(im, 0, 19, 10, 15, &red, 1);
+
+ i_arc(im, 15, 15, 4, 45, 160, &blue);
+ i_arc_aa(im, 25, 15, 4, 75, 280, &red);
+ i_arc_cfill(im, 35, 15, 4, 0, 215, hatch);
+ i_arc_aa_cfill(im, 45, 15, 4, 30, 210, hatch);
+ i_circle_aa(im, 55, 15, 4, &red);
+
+ i_box(im, 61, 11, 68, 18, &red);
+ i_flood_fill(im, 65, 15, &blue);
+ i_box(im, 71, 11, 78, 18, &red);
+ i_flood_cfill(im, 75, 15, hatch);
+
+ i_box_filled(im, 1, 21, 9, 24, &red);
+ i_box_filled(im, 1, 25, 9, 29, &blue);
+ i_flood_fill_border(im, 5, 25, &green, &black);
+
+ i_box_filled(im, 11, 21, 19, 24, &red);
+ i_box_filled(im, 11, 25, 19, 29, &blue);
+ i_flood_cfill_border(im, 15, 25, hatch, &black);
+
+ i_fill_destroy(fount_fill);
+ i_fill_destroy(fhatch_fill);
+ i_fill_destroy(solid_fill);
+ i_fill_destroy(fsolid_fill);
+ i_fill_destroy(hatch);
+ i_fill_destroy(im_fill);
+ i_img_destroy(fill_im);
+
+ /* make sure we can make each image type */
+ testim = i_img_16_new(100, 100, 3);
+ i_img_destroy(testim);
+ testim = i_img_double_new(100, 100, 3);
+ i_img_destroy(testim);
+ testim = i_img_pal_new(100, 100, 3, 256);
+ i_img_destroy(testim);
+ testim = i_sametype(im, 50, 50);
+ i_img_destroy(testim);
+ testim = i_sametype_chans(im, 50, 50, 4);
+ i_img_destroy(testim);
+
+ i_clear_error();
+ i_push_error(0, "Hello");
+ i_push_errorf(0, "%s", "World");
+
+ /* make sure tags create/destroy work */
+ i_tags_new(&tags);
+ i_tags_destroy(&tags);
+
+ block = mymalloc(20);
+ block = myrealloc(block, 50);
+ myfree(block);
+
+ i_tags_set(&im->tags, "lots_string", "foo", -1);
+ i_tags_setn(&im->tags, "lots_number", 101);
+
+ if (!i_tags_find(&im->tags, "lots_number", 0, &entry)) {
+ i_push_error(0, "lots_number tag not found");
+ i_img_destroy(im);
+ return NULL;
+ }
+ i_tags_delete(&im->tags, entry);
+
+ /* these won't delete anything, but it makes sure the macros and function
+ pointers are correct */
+ i_tags_delbyname(&im->tags, "unknown");
+ i_tags_delbycode(&im->tags, 501);
+ i_tags_set_float(&im->tags, "lots_float", 0, 3.14);
+ if (!i_tags_get_float(&im->tags, "lots_float", 0, &temp_double)) {
+ i_push_error(0, "lots_float not found");
+ i_img_destroy(im);
+ return NULL;
+ }
+ if (fabs(temp_double - 3.14) > 0.001) {
+ i_push_errorf(0, "lots_float incorrect %g", temp_double);
+ i_img_destroy(im);
+ return NULL;
+ }
+ i_tags_set_float2(&im->tags, "lots_float2", 0, 100 * sqrt(2.0), 5);
+ if (!i_tags_get_int(&im->tags, "lots_float2", 0, &entry)) {
+ i_push_error(0, "lots_float2 not found as int");
+ i_img_destroy(im);
+ return NULL;
+ }
+ if (entry != 141) {
+ i_push_errorf(0, "lots_float2 unexpected value %d", entry);
+ i_img_destroy(im);
+ return NULL;
+ }
+
+ i_tags_set_color(&im->tags, "lots_color", 0, &red);
+ if (!i_tags_get_color(&im->tags, "lots_color", 0, &temp_color)) {
+ i_push_error(0, "lots_color not found as color");
+ i_img_destroy(im);
+ return NULL;
+ }
+
+ return im;
+}
+
+void
+io_fd(int fd) {
+ Imager::IO io = io_new_fd(fd);
+ i_io_write(io, "test", 4);
+ i_io_close(io);
+ io_glue_destroy(io);
+}
+
+int
+io_bufchain_test() {
+ Imager::IO io = io_new_bufchain();
+ unsigned char *result;
+ size_t size;
+ if (i_io_write(io, "test2", 5) != 5) {
+ fprintf(stderr, "write failed\n");
+ return 0;
+ }
+ if (!i_io_flush(io)) {
+ fprintf(stderr, "flush failed\n");
+ return 0;
+ }
+ if (i_io_close(io) != 0) {
+ fprintf(stderr, "close failed\n");
+ return 0;
+ }
+ size = io_slurp(io, &result);
+ if (size != 5) {
+ fprintf(stderr, "wrong size\n");
+ return 0;
+ }
+ if (memcmp(result, "test2", 5)) {
+ fprintf(stderr, "data mismatch\n");
+ return 0;
+ }
+ if (i_io_seek(io, 0, 0) != 0) {
+ fprintf(stderr, "seek failure\n");
+ return 0;
+ }
+ myfree(result);
+ io_glue_destroy(io);
+
+ return 1;
+}
+
+const char *
+io_buffer_test(SV *in) {
+ STRLEN len;
+ const char *in_str = SvPV(in, len);
+ static char buf[100];
+ Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
+ ssize_t read_size;
+
+ read_size = i_io_read(io, buf, sizeof(buf)-1);
+ io_glue_destroy(io);
+ if (read_size < 0 || read_size >= sizeof(buf)) {
+ return "";
+ }
+
+ buf[read_size] = '\0';
+
+ return buf;
+}
+
+const char *
+io_peekn_test(SV *in) {
+ STRLEN len;
+ const char *in_str = SvPV(in, len);
+ static char buf[100];
+ Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
+ ssize_t read_size;
+
+ read_size = i_io_peekn(io, buf, sizeof(buf)-1);
+ io_glue_destroy(io);
+ if (read_size < 0 || read_size >= sizeof(buf)) {
+ return "";
+ }
+
+ buf[read_size] = '\0';
+
+ return buf;
+}
+
+const char *
+io_gets_test(SV *in) {
+ STRLEN len;
+ const char *in_str = SvPV(in, len);
+ static char buf[100];
+ Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
+ ssize_t read_size;
+
+ read_size = i_io_gets(io, buf, sizeof(buf), 's');
+ io_glue_destroy(io);
+ if (read_size < 0 || read_size >= sizeof(buf)) {
+ return "";
+ }
+
+ return buf;
+}
+
+int
+io_getc_test(SV *in) {
+ STRLEN len;
+ const char *in_str = SvPV(in, len);
+ static char buf[100];
+ Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
+ int result;
+
+ result = i_io_getc(io);
+ io_glue_destroy(io);
+
+ return result;
+}
+
+int
+io_peekc_test(SV *in) {
+ STRLEN len;
+ const char *in_str = SvPV(in, len);
+ static char buf[100];
+ Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
+ int result;
+
+ i_io_set_buffered(io, 0);
+
+ result = i_io_peekc(io);
+ io_glue_destroy(io);
+
+ return result;
+}
+
+
+
+int
+test_render_color(Imager work_8) {
+ i_render *r8;
+ i_color c;
+ unsigned char render_coverage[3];
+
+ render_coverage[0] = 0;
+ render_coverage[1] = 128;
+ render_coverage[2] = 255;
+
+ r8 = i_render_new(work_8, 10);
+ c.channel[0] = 128;
+ c.channel[1] = 255;
+ c.channel[2] = 0;
+ c.channel[3] = 255;
+ i_render_color(r8, 0, 0, sizeof(render_coverage), render_coverage, &c);
+
+ c.channel[3] = 128;
+ i_render_color(r8, 0, 1, sizeof(render_coverage), render_coverage, &c);
+
+ c.channel[3] = 0;
+ i_render_color(r8, 0, 2, sizeof(render_coverage), render_coverage, &c);
+
+ i_render_delete(r8);
+
+ return 1;
+}
+
+int
+raw_psamp(Imager im, int chan_count) {
+ static i_sample_t samps[] = { 0, 127, 255 };
+
+ i_clear_error();
+ return i_psamp(im, 0, 1, 0, samps, NULL, chan_count);
+}
+
+int
+raw_psampf(Imager im, int chan_count) {
+ static i_fsample_t samps[] = { 0, 0.5, 1.0 };
+
+ i_clear_error();
+ return i_psampf(im, 0, 1, 0, samps, NULL, chan_count);
+}
+
+int
+test_mutex() {
+ i_mutex_t m;
+
+ m = i_mutex_new();
+ i_mutex_lock(m);
+ i_mutex_unlock(m);
+ i_mutex_destroy(m);
+
+ return 1;
+}
+
+int
+test_slots() {
+ im_slot_t slot = im_context_slot_new(NULL);
+
+ if (im_context_slot_get(aIMCTX, slot)) {
+ fprintf(stderr, "slots should default to NULL\n");
+ return 0;
+ }
+ if (!im_context_slot_set(aIMCTX, slot, &slot)) {
+ fprintf(stderr, "set slot failed\n");
+ return 0;
+ }
+
+ if (im_context_slot_get(aIMCTX, slot) != &slot) {
+ fprintf(stderr, "get slot didn't match\n");
+ return 0;
+ }
+
+ return 1;
+}
+
+EOS
+
+my $im = Imager->new(xsize=>50, ysize=>50);
+is(pixel_count($im), 2500, "pixel_count");
+
+my $black = Imager::Color->new(0,0,0);
+is(count_color($im, $black), 2500, "count_color black on black image");
+
+my $im2 = make_10x10();
+my $white = Imager::Color->new(255, 255, 255);
+is(count_color($im2, $white), 100, "check new image white count");
+ok($im2->box(filled=>1, xmin=>1, ymin=>1, xmax => 8, ymax=>8, color=>$black),
+ "try new image");
+is(count_color($im2, $black), 64, "check modified black count");
+is(count_color($im2, $white), 36, "check modified white count");
+
+my $im3 = do_lots($im2);
+ok($im3, "do_lots()")
+ or print "# ", Imager->_error_as_msg, "\n";
+ok($im3->write(file=>'testout/t82lots.ppm'), "write t82lots.ppm");
+
+{ # RT #24992
+ # the T_IMAGER_FULL_IMAGE typemap entry was returning a blessed
+ # hash with an extra ref, causing memory leaks
+
+ my $im = make_10x10();
+ my $im2 = Imager->new(xsize => 10, ysize => 10);
+ require B;
+ my $imb = B::svref_2object($im);
+ my $im2b = B::svref_2object($im2);
+ is ($imb->REFCNT, $im2b->REFCNT,
+ "check refcnt of imager object hash between normal and typemap generated");
+}
+
+SKIP:
+{
+ use IO::File;
+ my $fd_filename = "testout/t82fd.txt";
+ {
+ my $fh = IO::File->new($fd_filename, "w")
+ or skip("Can't create file: $!", 1);
+ io_fd(fileno($fh));
+ $fh->close;
+ }
+ {
+ my $fh = IO::File->new($fd_filename, "r")
+ or skip("Can't open file: $!", 1);
+ my $data = <$fh>;
+ is($data, "test", "make sure data written to fd");
+ }
+ unlink $fd_filename;
+}
+
+ok(io_bufchain_test(), "check bufchain functions");
+
+is(io_buffer_test("test3"), "test3", "check io_new_buffer() and i_io_read");
+
+is(io_peekn_test("test5"), "test5", "check i_io_peekn");
+
+is(io_gets_test("test"), "tes", "check i_io_gets()");
+
+is(io_getc_test("ABC"), ord "A", "check i_io_getc(_imp)?");
+
+is(io_getc_test("XYZ"), ord "X", "check i_io_peekc(_imp)?");
+
+for my $bits (8, 16) {
+ print "# bits: $bits\n";
+
+ # the floating point processing is a little more accurate
+ my $bump = $bits == 16 ? 1 : 0;
+ {
+ my $im = Imager->new(xsize => 10, ysize => 10, channels => 3, bits => $bits);
+ ok($im->box(filled => 1, color => '#808080'), "fill work image with gray");
+ ok(test_render_color($im),
+ "call render_color on 3 channel image");
+ is_color3($im->getpixel(x => 0, y => 0), 128, 128, 128,
+ "check zero coverage, alpha 255 color, bits $bits");
+ is_color3($im->getpixel(x => 1, y => 0), 128, 191+$bump, 63+$bump,
+ "check 128 coverage, alpha 255 color, bits $bits");
+ is_color3($im->getpixel(x => 2, y => 0), 128, 255, 0,
+ "check 255 coverage, alpha 255 color, bits $bits");
+
+ is_color3($im->getpixel(x => 0, y => 1), 128, 128, 128,
+ "check zero coverage, alpha 128 color, bits $bits");
+ is_color3($im->getpixel(x => 1, y => 1), 128, 159+$bump, 95+$bump,
+ "check 128 coverage, alpha 128 color, bits $bits");
+ is_color3($im->getpixel(x => 2, y => 1), 128, 191+$bump, 63+$bump,
+ "check 255 coverage, alpha 128 color, bits $bits");
+
+ is_color3($im->getpixel(x => 0, y => 2), 128, 128, 128,
+ "check zero coverage, alpha 0 color, bits $bits");
+ is_color3($im->getpixel(x => 1, y => 2), 128, 128, 128,
+ "check 128 coverage, alpha 0 color, bits $bits");
+ is_color3($im->getpixel(x => 2, y => 2), 128, 128, 128,
+ "check 255 coverage, alpha 0 color, bits $bits");
+ }
+ {
+ my $im = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => $bits);
+ ok($im->box(filled => 1, color => '#808080'), "fill work image with opaque gray");
+ ok(test_render_color($im),
+ "call render_color on 4 channel image");
+ is_color4($im->getpixel(x => 0, y => 0), 128, 128, 128, 255,
+ "check zero coverage, alpha 255 color, bits $bits");
+ is_color4($im->getpixel(x => 1, y => 0), 128, 191+$bump, 63+$bump, 255,
+ "check 128 coverage, alpha 255 color, bits $bits");
+ is_color4($im->getpixel(x => 2, y => 0), 128, 255, 0, 255,
+ "check 255 coverage, alpha 255 color, bits $bits");
+
+ is_color4($im->getpixel(x => 0, y => 1), 128, 128, 128, 255,
+ "check zero coverage, alpha 128 color, bits $bits");
+ is_color4($im->getpixel(x => 1, y => 1), 128, 159+$bump, 95+$bump, 255,
+ "check 128 coverage, alpha 128 color, bits $bits");
+ is_color4($im->getpixel(x => 2, y => 1), 128, 191+$bump, 63+$bump, 255,
+ "check 255 coverage, alpha 128 color, bits $bits");
+
+ is_color4($im->getpixel(x => 0, y => 2), 128, 128, 128, 255,
+ "check zero coverage, alpha 0 color, bits $bits");
+ is_color4($im->getpixel(x => 1, y => 2), 128, 128, 128, 255,
+ "check 128 coverage, alpha 0 color, bits $bits");
+ is_color4($im->getpixel(x => 2, y => 2), 128, 128, 128, 255,
+ "check 255 coverage, alpha 0 color, bits $bits");
+ }
+
+ {
+ my $im = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => $bits);
+ ok($im->box(filled => 1, color => Imager::Color->new(128, 128, 128, 64)), "fill work image with translucent gray");
+ ok(test_render_color($im),
+ "call render_color on 4 channel image");
+ is_color4($im->getpixel(x => 0, y => 0), 128, 128, 128, 64,
+ "check zero coverage, alpha 255 color, bits $bits");
+ is_color4($im->getpixel(x => 1, y => 0), 128, 230, 25+$bump, 159+$bump,
+ "check 128 coverage, alpha 255 color, bits $bits");
+ is_color4($im->getpixel(x => 2, y => 0), 128, 255, 0, 255,
+ "check 255 coverage, alpha 255 color, bits $bits");
+
+ is_color4($im->getpixel(x => 0, y => 1), 128, 128, 128, 64,
+ "check zero coverage, alpha 128 color, bits $bits");
+ is_color4($im->getpixel(x => 1, y => 1), 129-$bump, 202-$bump, 55, 111+$bump,
+ "check 128 coverage, alpha 128 color, bits $bits");
+ is_color4($im->getpixel(x => 2, y => 1), 128, 230, 25+$bump, 159+$bump,
+ "check 255 coverage, alpha 128 color, bits $bits");
+
+ is_color4($im->getpixel(x => 0, y => 2), 128, 128, 128, 64,
+ "check zero coverage, alpha 0 color, bits $bits");
+ is_color4($im->getpixel(x => 1, y => 2), 128, 128, 128, 64,
+ "check 128 coverage, alpha 0 color, bits $bits");
+ is_color4($im->getpixel(x => 2, y => 2), 128, 128, 128, 64,
+ "check 255 coverage, alpha 0 color, bits $bits");
+ }
+}
+
+{
+ my $im = Imager->new(xsize => 10, ysize => 10);
+ is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psamp($im, 0), -1, "bad channel list (0) for psamp should fail");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+}
+
+{
+ my $im = Imager->new(xsize => 10, ysize => 10, bits => 16);
+ is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail (16-bit)");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psamp($im, 0), -1, "bad channel list (0) for psamp should fail (16-bit)");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail (16-bit)");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail (16-bit)");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+}
+
+{
+ my $im = Imager->new(xsize => 10, ysize => 10, bits => 'double');
+ is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail (double)");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psamp($im, 0), -1,, "bad channel list (0) for psamp should fail (double)");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail (double)");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail (double)");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+}
+
+{
+ my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
+ is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail (paletted)");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psamp($im, 0), -1, "bad channel list (0) for psamp should fail (paletted)");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail (paletted)");
+ is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
+ "check message");
+ is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail (paletted)");
+ is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
+ "check message");
+ is($im->type, "paletted", "make sure we kept the image type");
+}
+
+ok(test_mutex(), "call mutex APIs");
+
+ok(test_slots(), "call slot APIs");
+
+sub _get_error {
+ my @errors = Imager::i_errors();
+ return join(": ", map $_->[0], @errors);
+}
--- /dev/null
+#!perl -w
+#
+# this tests both the Inline interface and the API with IMAGER_NO_CONTEXT
+use strict;
+use Test::More;
+use Imager::Test qw(is_color3 is_color4);
+eval "require Inline::C;";
+plan skip_all => "Inline required for testing API" if $@;
+
+eval "require Parse::RecDescent;";
+plan skip_all => "Could not load Parse::RecDescent" if $@;
+
+use Cwd 'getcwd';
+plan skip_all => "Inline won't work in directories with spaces"
+ if getcwd() =~ / /;
+
+plan skip_all => "perl 5.005_04, 5.005_05 too buggy"
+ if $] =~ /^5\.005_0[45]$/;
+
+-d "testout" or mkdir "testout";
+
+plan tests => 5;
+require Inline;
+Inline->import(C => Config => AUTO_INCLUDE => "#define IMAGER_NO_CONTEXT\n");
+Inline->import(with => 'Imager');
+Inline->import("FORCE"); # force rebuild
+#Inline->import(C => Config => OPTIMIZE => "-g");
+
+Inline->bind(C => <<'EOS');
+#include <math.h>
+
+Imager make_10x10() {
+ dIMCTX;
+ i_img *im = i_img_8_new(10, 10, 3);
+ i_color c;
+ c.channel[0] = c.channel[1] = c.channel[2] = 255;
+ i_box_filled(im, 0, 0, im->xsize-1, im->ysize-1, &c);
+
+ return im;
+}
+
+void error_dIMCTX() {
+ dIMCTX;
+ im_clear_error(aIMCTX);
+ im_push_error(aIMCTX, 0, "test1");
+ im_push_errorf(aIMCTX, 0, "test%d", 2);
+
+ im_log((aIMCTX, 0, "test logging\n"));
+}
+
+void error_dIMCTXim(Imager im) {
+ dIMCTXim(im);
+ im_clear_error(aIMCTX);
+ im_push_error(aIMCTX, 0, "test1");
+}
+
+int context_refs() {
+ dIMCTX;
+
+ im_context_refinc(aIMCTX, "context_refs");
+ im_context_refdec(aIMCTX, "context_refs");
+
+ return 1;
+}
+
+EOS
+
+Imager->open_log(log => "testout/t84inlinectx.log");
+
+my $im2 = make_10x10();
+ok($im2, "make an image");
+is_color3($im2->getpixel(x => 0, y => 0), 255, 255, 255,
+ "check the colors");
+error_dIMCTX();
+is(_get_error(), "test2: test1", "check dIMCTX");
+
+my $im = Imager->new(xsize => 1, ysize => 1);
+error_dIMCTXim($im);
+is(_get_error(), "test1", "check dIMCTXim");
+
+ok(context_refs(), "check refcount functions");
+
+Imager->close_log();
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t84inlinectx.log";
+}
+
+sub _get_error {
+ my @errors = Imager::i_errors();
+ return join(": ", map $_->[0], @errors);
+}
--- /dev/null
+#!perl
+use strict;
+use Imager;
+use Imager::Color::Float;
+use Imager::Fill;
+use Config;
+my $loaded_threads;
+BEGIN {
+ if ($Config{useithreads} && $] > 5.008007) {
+ $loaded_threads =
+ eval {
+ require threads;
+ threads->import;
+ 1;
+ };
+ }
+}
+use Test::More;
+
+$Config{useithreads}
+ or plan skip_all => "can't test Imager's threads support with no threads";
+$] > 5.008007
+ or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
+$loaded_threads
+ or plan skip_all => "couldn't load threads";
+
+$INC{"Devel/Cover.pm"}
+ and plan skip_all => "threads and Devel::Cover don't get along";
+
+# https://rt.cpan.org/Ticket/Display.html?id=65812
+# https://github.com/schwern/test-more/issues/labels/Test-Builder2#issue/100
+$Test::More::VERSION =~ /^2\.00_/
+ and plan skip_all => "threads are hosed in 2.00_06 and presumably all 2.00_*";
+
+plan tests => 13;
+
+my $thread = threads->create(sub { 1; });
+ok($thread->join, "join first thread");
+
+# these are all, or contain, XS allocated objects, if we don't handle
+# CLONE requests, or provide a CLONE_SKIP, we'll probably see a
+# double-free, one from the thread, and the other from the main line
+# of control.
+#
+# So make one of each
+
+my $im = Imager->new(xsize => 10, ysize => 10);
+my $c = Imager::Color->new(0, 0, 0); # make some sort of color
+ok($c, "made the color");
+my $cf = Imager::Color::Float->new(0, 0, 0);
+ok($cf, "made the float color");
+my $hl;
+SKIP:
+{
+ Imager::Internal::Hlines::testing()
+ or skip "no hlines visible to test", 1;
+ $hl = Imager::Internal::Hlines::new(0, 100, 0, 100);
+ ok($hl, "made the hlines");
+}
+my $io = Imager::io_new_bufchain();
+ok($io, "made the io");
+my $tt;
+SKIP:
+{
+ $Imager::formats{tt}
+ or skip("No TT font support", 1);
+ $tt = Imager::Font->new(type => "tt", file => "fontfiles/dodge.ttf");
+ ok($tt, "made the font");
+}
+my $ft2;
+SKIP:
+{
+ $Imager::formats{ft2}
+ or skip "No FT2 support", 1;
+ $ft2 = Imager::Font->new(type => "ft2", file => "fontfiles/dodge.ttf");
+ ok($ft2, "made ft2 font");
+}
+my $fill = Imager::Fill->new(solid => $c);
+ok($fill, "made the fill");
+
+my $t2 = threads->create
+ (
+ sub {
+ ok(!UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
+ "the low level image object should become unblessed");
+ ok(!$im->_valid_image, "image no longer considered valid");
+ is($im->errstr, "images do not cross threads",
+ "check error message");
+ 1;
+ }
+ );
+ok($t2->join, "join second thread");
+#print STDERR $im->{IMG}, "\n";
+ok(UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
+ "but the object should be fine in the main thread");
+
--- /dev/null
+#!perl -w
+use strict;
+
+# avoiding this prologue would be nice, but it seems to be unavoidable,
+# see "It is also important to note ..." in perldoc threads
+use Config;
+my $loaded_threads;
+BEGIN {
+ if ($Config{useithreads} && $] > 5.008007) {
+ $loaded_threads =
+ eval {
+ require threads;
+ threads->import;
+ 1;
+ };
+ }
+}
+use Test::More;
+
+$Config{useithreads}
+ or plan skip_all => "can't test Imager's threads support with no threads";
+$] > 5.008007
+ or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
+$loaded_threads
+ or plan skip_all => "couldn't load threads";
+
+$INC{"Devel/Cover.pm"}
+ and plan skip_all => "threads and Devel::Cover don't get along";
+
+use Imager;
+
+# test that the error contexts are separate under threads
+
+plan tests => 11;
+
+Imager->open_log(log => "testout/t081error.log");
+
+Imager::i_clear_error();
+Imager::i_push_error(0, "main thread a");
+
+my @threads;
+for my $tid (1..5) {
+ my $t1 = threads->create
+ (
+ sub {
+ my $id = shift;
+ Imager::i_push_error(0, "$id: child thread a");
+ sleep(1+rand(4));
+ Imager::i_push_error(1, "$id: child thread b");
+
+ is_deeply([ Imager::i_errors() ],
+ [
+ [ "$id: child thread b", 1 ],
+ [ "$id: child thread a", 0 ],
+ ], "$id: check errors in child");
+ 1;
+ },
+ $tid
+ );
+ push @threads, [ $tid, $t1 ];
+}
+
+Imager::i_push_error(1, "main thread b");
+
+for my $thread (@threads) {
+ my ($id, $t1) = @$thread;
+ ok($t1->join, "join child $id");
+}
+
+Imager::i_push_error(2, "main thread c");
+
+is_deeply([ Imager::i_errors() ],
+ [
+ [ "main thread c", 2 ],
+ [ "main thread b", 1 ],
+ [ "main thread a", 0 ],
+ ], "check errors in parent");
+
--- /dev/null
+#!perl -w
+use strict;
+
+# avoiding this prologue would be nice, but it seems to be unavoidable,
+# see "It is also important to note ..." in perldoc threads
+use Config;
+my $loaded_threads;
+BEGIN {
+ if ($Config{useithreads} && $] > 5.008007) {
+ $loaded_threads =
+ eval {
+ require threads;
+ threads->import;
+ 1;
+ };
+ }
+}
+use Test::More;
+
+$Config{useithreads}
+ or plan skip_all => "can't test Imager's threads support with no threads";
+$] > 5.008007
+ or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
+$loaded_threads
+ or plan skip_all => "couldn't load threads";
+
+$INC{"Devel/Cover.pm"}
+ and plan skip_all => "threads and Devel::Cover don't get along";
+
+use Imager;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t080log1.log")
+ or plan skip_all => "Cannot open log file: " . Imager->errstr;
+
+plan tests => 3;
+
+Imager->log("main thread a\n");
+
+my $t1 = threads->create
+ (
+ sub {
+ Imager->log("child thread a\n");
+ Imager->open_log(log => "testout/t080log2.log")
+ or die "Cannot open second log file: ", Imager->errstr;
+ Imager->log("child thread b\n");
+ sleep(1);
+ Imager->log("child thread c\n");
+ sleep(1);
+ 1;
+ }
+ );
+
+Imager->log("main thread b\n");
+sleep(1);
+Imager->log("main thread c\n");
+ok($t1->join, "join child thread");
+Imager->log("main thread d\n");
+Imager->close_log();
+
+my %log1 = parse_log("testout/t080log1.log");
+my %log2 = parse_log("testout/t080log2.log");
+
+my @log1 =
+ (
+ "main thread a",
+ "main thread b",
+ "child thread a",
+ "main thread c",
+ "main thread d",
+ );
+
+my @log2 =
+ (
+ "child thread b",
+ "child thread c",
+ );
+
+is_deeply(\%log1, { map {; $_ => 1 } @log1 },
+ "check messages in main thread log");
+is_deeply(\%log2, { map {; $_ => 1 } @log2 },
+ "check messages in child thread log");
+
+# grab the messages from the given log
+sub parse_log {
+ my ($filename) = @_;
+
+ open my $fh, "<", $filename
+ or die "Cannot open log file $filename: $!";
+
+ my %lines;
+ while (<$fh>) {
+ chomp;
+ my ($date, $time, $file_line, $level, $message) = split ' ', $_, 5;
+ $lines{$message} = 1;
+ }
+
+ delete $lines{"Imager - log started (level = 1)"};
+ delete $lines{"Imager $Imager::VERSION starting"};
+
+ return %lines;
+}
+
+END {
+ unlink "testout/t080log1.log", "testout/t080log2.log"
+ unless $ENV{IMAGER_KEEP_FILES};
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager;
+use Imager::Test qw(test_image test_image_16 test_image_mono test_image_gray test_image_gray_16 test_image_double test_image_named);
+use Test::More tests => 60;
+
+# test Imager::Test
+
+for my $named (0, 1) {
+ my $named_desc = $named ? " (by name)" : "";
+ {
+ my $im = $named ? test_image_named("basic") : test_image();
+ ok($im, "got basic test image$named_desc");
+ is($im->type, "direct", "check basic image type");
+ is($im->getchannels, 3, "check basic image channels");
+ is($im->bits, 8, "check basic image bits");
+ ok(!$im->is_bilevel, "check basic isn't mono");
+ }
+ {
+ my $im = $named ? test_image_named("basic16") : test_image_16();
+ ok($im, "got 16-bit basic test image$named_desc");
+ is($im->type, "direct", "check 16-bit basic image type");
+ is($im->getchannels, 3, "check 16-bit basic image channels");
+ is($im->bits, 16, "check 16-bit basic image bits");
+ ok(!$im->is_bilevel, "check 16-bit basic isn't mono");
+ }
+
+ {
+ my $im = $named ? test_image_named("basic_double") : test_image_double();
+ ok($im, "got double basic test image$named_desc");
+ is($im->type, "direct", "check double basic image type");
+ is($im->getchannels, 3, "check double basic image channels");
+ is($im->bits, "double", "check double basic image bits");
+ ok(!$im->is_bilevel, "check double basic isn't mono");
+ }
+ {
+ my $im = $named ? test_image_named("gray") : test_image_gray();
+ ok($im, "got gray test image$named_desc");
+ is($im->type, "direct", "check gray image type");
+ is($im->getchannels, 1, "check gray image channels");
+ is($im->bits, 8, "check gray image bits");
+ ok(!$im->is_bilevel, "check gray isn't mono");
+ $im->write(file => "testout/t03gray.pgm");
+ }
+
+ {
+ my $im = $named ? test_image_named("gray16") : test_image_gray_16();
+ ok($im, "got gray test image$named_desc");
+ is($im->type, "direct", "check 16-bit gray image type");
+ is($im->getchannels, 1, "check 16-bit gray image channels");
+ is($im->bits, 16, "check 16-bit gray image bits");
+ ok(!$im->is_bilevel, "check 16-bit isn't mono");
+ $im->write(file => "testout/t03gray16.pgm");
+ }
+
+ {
+ my $im = $named ? test_image_named("mono") : test_image_mono();
+ ok($im, "got mono image$named_desc");
+ is($im->type, "paletted", "check mono image type");
+ is($im->getchannels, 3, "check mono image channels");
+ is($im->bits, 8, "check mono image bits");
+ ok($im->is_bilevel, "check mono is mono");
+ $im->write(file => "testout/t03mono.pbm");
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 7;
+BEGIN { use_ok("Imager", ":all") }
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t05error.log");
+
+# try to read an invalid pnm file
+open FH, "< testimg/junk.ppm"
+ or die "Cannot open testin/junk: $!";
+binmode(FH);
+my $IO = Imager::io_new_fd(fileno(FH));
+my $im = i_readpnm_wiol($IO, -1);
+SKIP:{
+ ok(!$im, "read of junk.ppm should have failed")
+ or skip("read didn't fail!", 5);
+
+ my @errors = Imager::i_errors();
+
+ is(scalar @errors, 1, "got the errors")
+ or skip("no errors to check", 4);
+
+ SKIP:
+ {
+ my $error0 = $errors[0];
+ is(ref $error0, "ARRAY", "entry 0 is an array ref")
+ or skip("entry 0 not an array", 3);
+
+ is(scalar @$error0, 2, "entry 0 has 2 elements")
+ or skip("entry 0 doesn't have enough elements", 2);
+
+ is($error0->[0], "while skipping to height", "check message");
+ is($error0->[1], "0", "error code should be 0");
+ }
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink "testout/t05error.log";
+}
--- /dev/null
+#!perl -w
+use strict;
+use Imager;
+use Test::More tests => 6;
+
+my $log_name = "testout/t95log.log";
+
+my $log_message = "test message 12345";
+
+SKIP: {
+ skip("Logging not build", 3)
+ unless Imager::i_log_enabled();
+ ok(Imager->open_log(log => $log_name), "open log")
+ or diag("Open log: " . Imager->errstr);
+ ok(-f $log_name, "file is there");
+ Imager->log($log_message);
+ Imager->close_log();
+
+ my $data = '';
+ if (open LOG, "< $log_name") {
+ $data = do { local $/; <LOG> };
+ close LOG;
+ }
+ like($data, qr/\Q$log_message/, "check message made it to the log");
+}
+
+SKIP: {
+ skip("Logging built", 3)
+ if Imager::i_log_enabled();
+
+ ok(!Imager->open_log(log => $log_name), "should be no logfile");
+ is(Imager->errstr, "Logging disabled", "check error message");
+ ok(!-f $log_name, "file shouldn't be there");
+}
--- /dev/null
+#!perl -w
+use strict;
+
+# avoiding this prologue would be nice, but it seems to be unavoidable,
+# see "It is also important to note ..." in perldoc threads
+use Config;
+my $loaded_threads;
+BEGIN {
+ if ($Config{useithreads} && $] > 5.008007) {
+ $loaded_threads =
+ eval {
+ require threads;
+ threads->import;
+ 1;
+ };
+ }
+}
+use Test::More;
+
+$Config{useithreads}
+ or plan skip_all => "can't test Imager's threads support with no threads";
+$] > 5.008007
+ or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
+$loaded_threads
+ or plan skip_all => "couldn't load threads";
+
+$INC{"Devel/Cover.pm"}
+ and plan skip_all => "threads and Devel::Cover don't get along";
+
+use Imager;
+
+# test that image file limits are localized to a thread
+
+plan tests => 31;
+
+Imager->open_log(log => "testout/t082limit.log");
+
+ok(Imager->set_file_limits(width => 10, height => 10, bytes => 300),
+ "set limits to 10, 10, 300");
+
+ok(Imager->check_file_limits(width => 10, height => 10),
+ "successful check limits in parent");
+
+ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 2),
+ "failed check limits in parent");
+
+my @threads;
+for my $tid (1..5) {
+ my $t1 = threads->create
+ (
+ sub {
+ my $id = shift;
+ my $dlimit = $tid * 5;
+ my $blimit = $dlimit * $dlimit * 3;
+ ok(Imager->set_file_limits(width => $dlimit, height => $dlimit,
+ bytes => $blimit),
+ "$tid: set limits to $dlimit x $dlimit, $blimit bytes");
+ ok(Imager->check_file_limits(width => $dlimit, height => $dlimit),
+ "$tid: successful check $dlimit x $dlimit");
+ ok(!Imager->check_file_limits(width => $dlimit, height => $dlimit, sample_size => 2),
+ "$tid: failed check $dlimit x $dlimit, ssize 2");
+ is_deeply([ Imager->get_file_limits ], [ $dlimit, $dlimit, $blimit ],
+ "check limits are still $dlimit x $dlimit , $blimit bytes");
+ },
+ $tid
+ );
+ push @threads, [ $tid, $t1 ];
+}
+
+for my $thread (@threads) {
+ my ($id, $t1) = @$thread;
+ ok($t1->join, "join child $id");
+}
+
+ok(Imager->check_file_limits(width => 10, height => 10),
+ "test we still pass");
+ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 2),
+ "test we still fail");
+is_deeply([ Imager->get_file_limits ], [ 10, 10, 300 ],
+ "check original main thread limits still set");
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 23;
+use Imager;
+
+BEGIN { use_ok('Imager::Matrix2d', ':handy') }
+
+my $id = Imager::Matrix2d->identity;
+
+ok(almost_equal($id, [ 1, 0, 0,
+ 0, 1, 0,
+ 0, 0, 1 ]), "identity matrix");
+my $trans = Imager::Matrix2d->translate('x'=>10, 'y'=>-11);
+ok(almost_equal($trans, [ 1, 0, 10,
+ 0, 1, -11,
+ 0, 0, 1 ]), "translate matrix");
+my $trans_x = Imager::Matrix2d->translate(x => 10);
+ok(almost_equal($trans_x, [ 1, 0, 10,
+ 0, 1, 0,
+ 0, 0, 1 ]), "translate just x");
+my $trans_y = Imager::Matrix2d->translate('y' => 11);
+ok(almost_equal($trans_y, [ 1, 0, 0,
+ 0, 1, 11,
+ 0, 0, 1 ]), "translate just y");
+
+my $rotate = Imager::Matrix2d->rotate(degrees=>90);
+ok(almost_equal($rotate, [ 0, -1, 0,
+ 1, 0, 0,
+ 0, 0, 1 ]), "rotate matrix");
+
+my $shear = Imager::Matrix2d->shear('x'=>0.2, 'y'=>0.3);
+ok(almost_equal($shear, [ 1, 0.2, 0,
+ 0.3, 1, 0,
+ 0, 0, 1 ]), "shear matrix");
+
+my $scale = Imager::Matrix2d->scale('x'=>1.2, 'y'=>0.8);
+ok(almost_equal($scale, [ 1.2, 0, 0,
+ 0, 0.8, 0,
+ 0, 0, 1 ]), "scale matrix");
+
+my $custom = Imager::Matrix2d->matrix(1, 0, 0, 0, 1, 0, 0, 0, 1);
+ok(almost_equal($custom, [ 1, 0, 0,
+ 0, 1, 0,
+ 0, 0, 1 ]), "custom matrix");
+
+my $trans_called;
+$rotate = Imager::Matrix2d::Test->rotate(degrees=>90, x=>50);
+ok($trans_called, "translate called on rotate with just x");
+
+$trans_called = 0;
+$rotate = Imager::Matrix2d::Test->rotate(degrees=>90, 'y'=>50);
+ok($trans_called, "translate called on rotate with just y");
+
+ok(!Imager::Matrix2d->matrix(), "bad custom matrix");
+is(Imager->errstr, "9 co-efficients required", "check error");
+
+{
+ my @half = ( 0.5, 0, 0,
+ 0, 0.5, 0,
+ 0, 0, 1 );
+ my @quart = ( 0, 0.25, 0,
+ 1, 0, 0,
+ 0, 0, 1 );
+ my $half_matrix = Imager::Matrix2d->matrix(@half);
+ my $quart_matrix = Imager::Matrix2d->matrix(@quart);
+ my $result = $half_matrix * $quart_matrix;
+ is_deeply($half_matrix * \@quart, $result, "mult by unblessed matrix");
+ is_deeply(\@half * $quart_matrix, $result, "mult with unblessed matrix");
+
+ my $half_three = Imager::Matrix2d->matrix(1.5, 0, 0, 0, 1.5, 0, 0, 0, 3);
+ is_deeply($half_matrix * 3, $half_three, "mult by three");
+ is_deeply(3 * $half_matrix, $half_three, "mult with three");
+
+ {
+ # check error handling - bad ref type
+ my $died =
+ !eval {
+ my $foo = $half_matrix * +{};
+ 1;
+ };
+ ok($died, "mult by hash ref died");
+ like($@, qr/multiply by array ref or number/, "check message");
+ }
+
+ {
+ # check error handling - bad array
+ $@ = '';
+ my $died =
+ !eval {
+ my $foo = $half_matrix * [ 1 .. 8 ];
+ 1;
+ };
+ ok($died, "mult by short array ref died");
+ like($@, qr/9 elements required in array ref/, "check message");
+ }
+
+ {
+ # check error handling - bad value
+ $@ = '';
+ my $died =
+ !eval {
+ my $foo = $half_matrix * "abc";
+ 1;
+ };
+ ok($died, "mult by bad scalar died");
+ like($@, qr/multiply by array ref or number/, "check message");
+ }
+
+}
+
+
+sub almost_equal {
+ my ($m1, $m2) = @_;
+
+ for my $i (0..8) {
+ abs($m1->[$i] - $m2->[$i]) < 0.00001 or return undef;
+ }
+ return 1;
+}
+
+# this is used to ensure translate() is called correctly by rotate
+package Imager::Matrix2d::Test;
+use vars qw(@ISA);
+BEGIN { @ISA = qw(Imager::Matrix2d); }
+
+sub translate {
+ my ($class, %opts) = @_;
+
+ ++$trans_called;
+ return $class->SUPER::translate(%opts);
+}
+
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 6;
+use File::Spec;
+
+{ # RT 37353
+ local @INC = @INC;
+
+ unshift @INC, File::Spec->catdir('blib', 'lib');
+ unshift @INC, File::Spec->catdir('blib', 'arch');
+ require Imager::ExtUtils;
+ my $path = Imager::ExtUtils->base_dir;
+ ok(File::Spec->file_name_is_absolute($path), "check dirs absolute")
+ or print "# $path\n";
+}
+
+{ # includes
+ my $includes = Imager::ExtUtils->includes;
+ ok($includes =~ s/^-I//, "has the -I");
+ ok(-e File::Spec->catfile($includes, "imext.h"), "found a header");
+}
+
+{ # typemap
+ my $typemap = Imager::ExtUtils->typemap;
+ ok($typemap, "got a typemap path");
+ ok(-f $typemap, "it exists");
+ open TYPEMAP, "< $typemap";
+ my $tm_content = do { local $/; <TYPEMAP>; };
+ close TYPEMAP;
+ cmp_ok($tm_content, '=~', "Imager::Color\\s+T_PTROBJ",
+ "it seems to be the right file");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+use Imager;
+
+# this script tests an internal set of functions for Imager, they
+# aren't intended to be used at the perl level.
+# these functions aren't present in all Imager builds
+
+unless (Imager::Internal::Hlines::testing()) {
+ plan skip_all => 'Imager not built to run this test';
+}
+
+plan tests => 15;
+
+my $hline = Imager::Internal::Hlines::new(0, 100, 0, 100);
+my $base_text = 'start_y: 0 limit_y: 100 start_x: 0 limit_x: 100';
+ok($hline, "made hline");
+is($hline->dump, "$base_text\n", "check values");
+$hline->add(5, -5, 7);
+is($hline->dump, <<EOS, "check (-5, 7) added");
+$base_text
+ 5 (1): [0, 2)
+EOS
+$hline->add(5, 8, 4);
+is($hline->dump, <<EOS, "check (8, 4) added");
+$base_text
+ 5 (2): [0, 2) [8, 12)
+EOS
+$hline->add(5, 3, 3);
+is($hline->dump, <<EOS, "check (3, 3) added");
+$base_text
+ 5 (3): [0, 2) [3, 6) [8, 12)
+EOS
+$hline->add(5, 2, 6);
+is($hline->dump, <<EOS, "check (2, 6) added");
+$base_text
+ 5 (1): [0, 12)
+EOS
+# adding out of range should do nothing
+my $current = <<EOS;
+$base_text
+ 5 (1): [0, 12)
+EOS
+$hline->add(6, -5, 5);
+is($hline->dump, $current, "check (6, -5, 5) not added");
+$hline->add(6, 100, 5);
+is($hline->dump, $current, "check (6, 100, 5) not added");
+$hline->add(-1, 5, 2);
+is($hline->dump, $current, "check (-1, 5, 2) not added");
+$hline->add(100, 5, 2);
+is($hline->dump, $current, "check (10, 5, 2) not added");
+
+# overlapped add check
+$hline->add(6, 2, 6);
+$hline->add(6, 3, 4);
+is($hline->dump, <<EOS, "check internal overlap merged");
+$base_text
+ 5 (1): [0, 12)
+ 6 (1): [2, 8)
+EOS
+
+# white box test: try to force reallocation of an entry
+for my $i (0..20) {
+ $hline->add(7, $i*2, 1);
+}
+is($hline->dump, <<EOS, "lots of segments");
+$base_text
+ 5 (1): [0, 12)
+ 6 (1): [2, 8)
+ 7 (21): [0, 1) [2, 3) [4, 5) [6, 7) [8, 9) [10, 11) [12, 13) [14, 15) [16, 17) [18, 19) [20, 21) [22, 23) [24, 25) [26, 27) [28, 29) [30, 31) [32, 33) [34, 35) [36, 37) [38, 39) [40, 41)
+EOS
+# now merge them
+$hline->add(7, 1, 39);
+is($hline->dump, <<EOS, "merge lots of segments");
+$base_text
+ 5 (1): [0, 12)
+ 6 (1): [2, 8)
+ 7 (1): [0, 41)
+EOS
+
+# clean object
+$hline = Imager::Internal::Hlines::new(50, 50, 50, 50);
+$base_text = 'start_y: 50 limit_y: 100 start_x: 50 limit_x: 100';
+
+# left merge
+$hline->add(51, 45, 10);
+$hline->add(51, 55, 4);
+is($hline->dump, <<EOS, "left merge");
+$base_text
+ 51 (1): [50, 59)
+EOS
+
+# right merge
+$hline->add(52, 90, 5);
+$hline->add(52, 87, 5);
+is($hline->dump, <<EOS, "right merge");
+$base_text
+ 51 (1): [50, 59)
+ 52 (1): [87, 95)
+EOS
+
+undef $hline;
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+use ExtUtils::Manifest qw(maniread);
+eval "use Test::Pod 1.00;";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+my $manifest = maniread();
+my @pod = grep /\.(pm|pl|pod|PL)$/, keys %$manifest;
+plan tests => scalar(@pod);
+for my $file (@pod) {
+ pod_file_ok($file, "pod ok in $file");
+}
--- /dev/null
+#!perl -w
+# packaging test - make sure we included the samples in the MANIFEST <sigh>
+use Test::More;
+use ExtUtils::Manifest qw(maniread);
+
+# first build a list of samples from samples/README
+open SAMPLES, "< samples/README"
+ or die "Cannot open samples/README: $!";
+my @sample_files;
+while (<SAMPLES>) {
+ chomp;
+ /^\w[\w.-]+\.\w+$/ and push @sample_files, $_;
+}
+
+close SAMPLES;
+
+plan tests => scalar(@sample_files);
+
+my $manifest = maniread();
+
+for my $filename (@sample_files) {
+ ok(exists($manifest->{"samples/$filename"}),
+ "sample file $filename in manifest");
+}
--- /dev/null
+#!perl -w
+use strict;
+use lib 't';
+use Test::More;
+use ExtUtils::Manifest qw(maniread);
+#sub Pod::Coverage::TRACE_ALL() { 1 }
+eval "use Test::Pod::Coverage 1.08;";
+# 1.08 required for coverage_class support
+plan skip_all => "Test::Pod::Coverage 1.08 required for POD coverage" if $@;
+
+# scan for a list of files to get Imager method documentation from
+my $manifest = maniread();
+my @pods = ( 'Imager.pm', grep /\.pod$/, keys %$manifest );
+
+my @private =
+ (
+ '^io?_',
+ '^DSO_',
+ '^Inline$',
+ '^yatf$',
+ '^malloc_state$',
+ '^init_log$',
+ '^polybezier$', # not ready for public consumption
+ '^border$', # I don't know what it is, expect it to go away
+ );
+my @trustme = ( '^open$', );
+
+plan tests => 20;
+
+{
+ pod_coverage_ok('Imager', { also_private => \@private,
+ pod_from => \@pods,
+ trustme => \@trustme,
+ coverage_class => 'Pod::Coverage::Imager' });
+ pod_coverage_ok('Imager::Font');
+ my @color_private = ( '^i_', '_internal$' );
+ pod_coverage_ok('Imager::Color',
+ { also_private => \@color_private });
+ pod_coverage_ok('Imager::Color::Float',
+ { also_private => \@color_private });
+ pod_coverage_ok('Imager::Color::Table');
+ pod_coverage_ok('Imager::ExtUtils');
+ pod_coverage_ok('Imager::Expr');
+ my $trust_parents = { coverage_class => 'Pod::Coverage::CountParents' };
+ pod_coverage_ok('Imager::Expr::Assem', $trust_parents);
+ pod_coverage_ok('Imager::Fill');
+ pod_coverage_ok('Imager::Font::BBox');
+ pod_coverage_ok('Imager::Font::Wrap');
+ pod_coverage_ok('Imager::Fountain');
+ pod_coverage_ok('Imager::Matrix2d');
+ pod_coverage_ok('Imager::Regops');
+ pod_coverage_ok('Imager::Transform');
+ pod_coverage_ok('Imager::Test');
+ pod_coverage_ok('Imager::IO',
+ {
+ pod_from => "lib/Imager/IO.pod",
+ coverage_class => "Pod::Coverage::Imager",
+ module => "Imager",
+ });
+}
+
+{
+ # check all documented methods/functions are in the method index
+ my $coverage =
+ Pod::Coverage::Imager->new(package => 'Imager',
+ pod_from => \@pods,
+ trustme => \@trustme,
+ also_private => \@private);
+ my %methods = map { $_ => 1 } $coverage->covered;
+ open IMAGER, "< Imager.pm"
+ or die "Cannot open Imager.pm: $!";
+ while (<IMAGER>) {
+ last if /^=head1 METHOD INDEX/;
+ }
+ my @indexed;
+ my @unknown_indexed;
+ while (<IMAGER>) {
+ last if /^=\w/ && !/^=for\b/;
+
+ if (/^(\w+)\(/) {
+ push @indexed, $1;
+ unless (delete $methods{$1}) {
+ push @unknown_indexed, $1;
+ }
+ }
+ }
+
+ unless (is(keys %methods, 0, "all methods in method index")) {
+ diag "the following methods are documented but not in the index:";
+ diag $_ for sort keys %methods;
+ }
+ unless (is(@unknown_indexed, 0, "only methods in method index")) {
+ diag "the following names are in the method index but not documented";
+ diag $_ for sort @unknown_indexed;
+ }
+
+ sub dict_cmp_func;
+ is_deeply(\@indexed, [ sort dict_cmp_func @indexed ],
+ "check method index is alphabetically sorted");
+}
+
+sub dict_cmp_func {
+ (my $tmp_a = lc $a) =~ tr/_//d;
+ (my $tmp_b = lc $b) =~ tr/_//d;
+
+ $tmp_a cmp $tmp_b;
+}
--- /dev/null
+#!perl -w
+# this is intended for various kwalitee tests
+use strict;
+use Test::More;
+use ExtUtils::Manifest qw(maniread);
+
+my $manifest = maniread;
+
+# work up counts first
+
+my @pl_files = grep /\.(p[lm]|PL|perl)$/, keys %$manifest;
+
+plan tests => scalar(@pl_files);
+
+for my $filename (@pl_files) {
+ open PL, "< $filename"
+ or die "Cannot open $filename: $!";
+ my $found_strict;
+ while (<PL>) {
+ if (/^use strict;/) {
+ ++$found_strict;
+ last;
+ }
+ }
+ close PL;
+ ok($found_strict, "file $filename has use strict");
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+plan skip_all => "Only run as part of the dist"
+ unless -f "META.yml";
+eval "use CPAN::Meta 2.110580;";
+plan skip_all => "CPAN::Meta required for testing META.yml"
+ if $@;
+plan skip_all => "Only if automated or author testing"
+ unless $ENV{AUTOMATED_TESTING} || -d "../.git";
+plan tests => 1;
+
+my $meta;
+unless (ok(eval {
+ $meta = CPAN::Meta->load_file("META.yml",
+ { lazy_validation => 0 }) },
+ "loaded META.yml successfully")) {
+ diag($@);
+}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 15;
-
-use_ok('Imager');
-use_ok('Imager::Font');
-use_ok('Imager::Color');
-use_ok('Imager::Color::Float');
-use_ok('Imager::Color::Table');
-use_ok('Imager::Matrix2d');
-use_ok('Imager::ExtUtils');
-use_ok('Imager::Expr');
-use_ok('Imager::Expr::Assem');
-use_ok('Imager::Font::BBox');
-use_ok('Imager::Font::Wrap');
-use_ok('Imager::Fountain');
-use_ok('Imager::Regops');
-use_ok('Imager::Test');
-use_ok('Imager::Transform');
+++ /dev/null
-#!perl -w
-# t/t01introvert.t - tests internals of image formats
-# to make sure we get expected values
-
-use strict;
-use Test::More tests => 466;
-
-BEGIN { use_ok(Imager => qw(:handy :all)) }
-
-use Imager::Test qw(image_bounds_checks is_color3 is_color4 is_fcolor4 color_cmp mask_tests is_fcolor3);
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t01introvert.log");
-
-my $im_g = Imager::ImgRaw::new(100, 101, 1);
-
-my $red = NC(255, 0, 0);
-my $green = NC(0, 255, 0);
-my $blue = NC(0, 0, 255);
-
-use Imager::Color::Float;
-my $f_black = Imager::Color::Float->new(0, 0, 0);
-my $f_red = Imager::Color::Float->new(1.0, 0, 0);
-my $f_green = Imager::Color::Float->new(0, 1.0, 0);
-my $f_blue = Imager::Color::Float->new(0, 0, 1.0);
-
-is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
-ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
-ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
-is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
-is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
-is(Imager::i_img_get_width($im_g), 100, "100 pixels wide");
-is(Imager::i_img_get_height($im_g), 101, "101 pixels high");
-
-my @ginfo = Imager::i_img_info($im_g);
-is($ginfo[0], 100, "1 channel image width");
-is($ginfo[1], 101, "1 channel image height");
-
-undef $im_g; # can we check for release after this somehow?
-
-my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
-
-is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
-is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
-is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
-is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
-
-undef $im_rgb;
-
-my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
-
-ok($im_pal, "make paletted image");
-is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
-is(Imager::i_img_bits($im_pal), 8, "pal img bits");
-is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
-
-my $red_idx = check_add($im_pal, $red, 0);
-my $green_idx = check_add($im_pal, $green, 1);
-my $blue_idx = check_add($im_pal, $blue, 2);
-
-# basic writing of palette indicies
-# fill with red
-is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100,
- "write red 100 times");
-# and blue
-is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
- "write blue 50 times");
-
-# make sure we get it back
-my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
-ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
-ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
-is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50,
- "gpal in scalar context");
-my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
-is(@samp, 300, "gsamp count in list context");
-my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
-is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
-my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
-is(length($samp), 300, "gsamp scalar length");
-is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
-
-# reading indicies as colors
-my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
-ok($c_red, "got the red pixel");
-is_color3($c_red, 255, 0, 0, "and it's red");
-my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
-ok($c_blue, "got the blue pixel");
-is_color3($c_blue, 0, 0, 255, "and it's blue");
-
-# drawing with colors
-ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
-# that was in the palette, should still be paletted
-is(Imager::i_img_type($im_pal), 1, "image still paletted");
-
-my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
-ok($c_green, "got green pixel");
-is_color3($c_green, 0, 255, 0, "and it's green");
-
-is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
-is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
-
-my $black = NC(0, 0, 0);
-# this should convert the image to RGB
-ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
-is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
-
-{
- my %quant =
- (
- colors => [$red, $green, $blue, $black],
- make_colors => 'none',
- );
- my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
- ok($im_pal2, "got an image from quantizing");
- is(@{$quant{colors}}, 4, "quant has the right number of colours");
- is(Imager::i_colorcount($im_pal2), 4, "and so does the image");
- my @colors = Imager::i_getcolors($im_pal2, 0, 4);
- my ($first) = Imager::i_getcolors($im_pal2, 0);
- my @first = $colors[0]->rgba;
- is_color3($first, $first[0], $first[1], $first[2],
- "check first color is first for multiple or single fetch");
- is_color3($colors[0], 255, 0, 0, "still red");
- is_color3($colors[1], 0, 255, 0, "still green");
- is_color3($colors[2], 0, 0, 255, "still blue");
- is_color3($colors[3], 0, 0, 0, "still black");
- my @samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
- my @expect = unpack("C*", "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50);
- my $match_list = is_deeply(\@samples, \@expect, "colors are still correct");
- my $samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
- my $match_scalar = is_deeply([ unpack("C*", $samples) ],
- \@expect, "colors are still correct (scalar)");
- unless ($match_list && $match_scalar) {
- # this has been failing on a particular smoker, provide more
- # diagnostic information
- print STDERR "Pallete:\n";
- print STDERR " $_: ", join(",", $colors[$_]->rgba), "\n" for 0..$#colors;
- print STDERR "Samples (list): ", join(",", @samples), "\n";
- print STDERR "Samples (scalar): ", join(",", unpack("C*", $samples)), "\n";
- print STDERR "Indexes: ", join(",", Imager::i_gpal($im_pal2, 0, 100, 0)), "\n";
- }
-}
-
-# test the OO interfaces
-my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
-ok($impal2, "make paletted via OO")
- or diag(Imager->errstr);
-is($impal2->getchannels, 3, "check channels");
-is($impal2->bits, 8, "check bits");
-is($impal2->type, 'paletted', "check type");
-is($impal2->getwidth, 200, "check width");
-is($impal2->getheight, 201, "check height");
-
-{
- my $red_idx = $impal2->addcolors(colors=>[$red]);
- ok($red_idx, "add red to OO");
- is(0+$red_idx, 0, "and it's expected index for red");
- my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
- ok($blue_idx, "add blue/green via OO");
- is($blue_idx, 1, "and it's expected index for blue");
- my $green_idx = $blue_idx + 1;
- my $c = $impal2->getcolors(start=>$green_idx);
- is_color3($c, 0, 255, 0, "found green where expected");
- my @cols = $impal2->getcolors;
- is(@cols, 3, "got 3 colors");
- my @exp = ( $red, $blue, $green );
- my $good = 1;
- for my $i (0..2) {
- if (color_cmp($cols[$i], $exp[$i])) {
- $good = 0;
- last;
- }
- }
- ok($good, "all colors in palette as expected");
- is($impal2->colorcount, 3, "and colorcount returns 3");
- is($impal2->maxcolors, 256, "maxcolors as expected");
- is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
- ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
- "we can setcolors");
-
- # make an rgb version
- my $imrgb2 = $impal2->to_rgb8()
- or diag($impal2->errstr);
- is($imrgb2->type, 'direct', "converted is direct");
-
- # and back again, specifying the palette
- my @colors = ( $red, $blue, $green );
- my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
- make_colors=>'none',
- translate=>'closest');
- ok($impal3, "got a paletted image from conversion");
- dump_colors(@colors);
- print "# in image\n";
- dump_colors($impal3->getcolors);
- is($impal3->colorcount, 3, "new image has expected color table size");
- is($impal3->type, 'paletted', "and is paletted");
-}
-
-{
- my $im = Imager->new;
- ok($im, "make empty image");
- ok(!$im->to_rgb8, "convert to rgb8");
- is($im->errstr, "to_rgb8: empty input image", "check message");
- is($im->bits, undef, "can't call bits on an empty image");
- is($im->errstr, "bits: empty input image", "check message");
- is($im->type, undef, "can't call type on an empty image");
- is($im->errstr, "type: empty input image", "check message");
- is($im->virtual, undef, "can't call virtual on an empty image");
- is($im->errstr, "virtual: empty input image", "check message");
- is($im->is_bilevel, undef, "can't call virtual on an empty image");
- is($im->errstr, "is_bilevel: empty input image", "check message");
- ok(!$im->getscanline(y => 0), "can't call getscanline on an empty image");
- is($im->errstr, "getscanline: empty input image", "check message");
- ok(!$im->setscanline(y => 0, pixels => [ $red, $blue ]),
- "can't call setscanline on an empty image");
- is($im->errstr, "setscanline: empty input image", "check message");
- ok(!$im->getsamples(y => 0), "can't call getsamples on an empty image");
- is($im->errstr, "getsamples: empty input image", "check message");
- is($im->getwidth, undef, "can't get width of empty image");
- is($im->errstr, "getwidth: empty input image", "check message");
- is($im->getheight, undef, "can't get height of empty image");
- is($im->errstr, "getheight: empty input image", "check message");
- is($im->getchannels, undef, "can't get channels of empty image");
- is($im->errstr, "getchannels: empty input image", "check message");
- is($im->getmask, undef, "can't get mask of empty image");
- is($im->errstr, "getmask: empty input image", "check message");
- is($im->setmask, undef, "can't set mask of empty image");
- is($im->errstr, "setmask: empty input image", "check message");
-}
-
-{ # basic checks, 8-bit direct images
- my $im = Imager->new(xsize => 2, ysize => 3);
- ok($im, 'create 8-bit direct image');
- is($im->bits, 8, '8 bits');
- ok(!$im->virtual, 'not virtual');
- is($im->type, 'direct', 'direct image');
- ok(!$im->is_bilevel, 'not mono');
-}
-
-ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "0 height error message check");
-ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "0 width error message check");
-ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "-ve width error message check");
-ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "-ve height error message check");
-ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "-ve width/height error message check");
-
-ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
- "fail to create a zero channel image");
-cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
- "out of range channel message check");
-ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
- "fail to create a five channel image");
-cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
- "out of range channel message check");
-
-{
- # https://rt.cpan.org/Ticket/Display.html?id=8213
- # check for handling of memory allocation of very large images
- # only test this on 32-bit machines - on a 64-bit machine it may
- # result in trying to allocate 4Gb of memory, which is unfriendly at
- # least and may result in running out of memory, causing a different
- # type of exit
- SKIP:
- {
- use Config;
- skip("don't want to allocate 4Gb", 8) unless $Config{ptrsize} == 4;
-
- my $uint_range = 256 ** $Config{intsize};
- print "# range $uint_range\n";
- my $dim1 = int(sqrt($uint_range))+1;
-
- my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
- is($im_b, undef, "integer overflow check - 1 channel");
-
- $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
- ok($im_b, "but same height ok");
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
-
- # do a similar test with a 3 channel image, so we're sure we catch
- # the same case where the third dimension causes the overflow
- my $dim3 = int(sqrt($uint_range / 3))+1;
-
- $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
- is($im_b, undef, "integer overflow check - 3 channel");
-
- $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
- ok($im_b, "but same height ok");
-
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
- }
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
- my $warning;
- local $SIG{__WARN__} =
- sub {
- $warning = "@_";
- my $printed = $warning;
- $printed =~ s/\n$//;
- $printed =~ s/\n/\n\#/g;
- print "# ",$printed, "\n";
- };
- my $img = Imager->new(xsize=>10, ysize=>10);
- $img->to_rgb8(); # doesn't really matter what the source is
- cmp_ok($warning, '=~', 'void', "correct warning");
- cmp_ok($warning, '=~', 't01introvert\\.t', "correct file");
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=11860
- my $im = Imager->new(xsize=>2, ysize=>2);
- $im->setpixel(x=>0, 'y'=>0, color=>$red);
- $im->setpixel(x=>1, 'y'=>0, color=>$blue);
-
- my @row = Imager::i_glin($im->{IMG}, 0, 2, 0);
- is(@row, 2, "got 2 pixels from i_glin");
- is_color3($row[0], 255, 0, 0, "red first");
- is_color3($row[1], 0, 0, 255, "then blue");
-}
-
-{ # general tag tests
-
- # we don't care much about the image itself
- my $im = Imager::ImgRaw::new(10, 10, 1);
-
- ok(Imager::i_tags_addn($im, 'alpha', 0, 101), "i_tags_addn(...alpha, 0, 101)");
- ok(Imager::i_tags_addn($im, undef, 99, 102), "i_tags_addn(...undef, 99, 102)");
- is(Imager::i_tags_count($im), 2, "should have 2 tags");
- ok(Imager::i_tags_addn($im, undef, 99, 103), "i_tags_addn(...undef, 99, 103)");
- is(Imager::i_tags_count($im), 3, "should have 3 tags, despite the dupe");
- is(Imager::i_tags_find($im, 'alpha', 0), '0 but true', "find alpha");
- is(Imager::i_tags_findn($im, 99, 0), 1, "find 99");
- is(Imager::i_tags_findn($im, 99, 2), 2, "find 99 again");
- is(Imager::i_tags_get($im, 0), 101, "check first");
- is(Imager::i_tags_get($im, 1), 102, "check second");
- is(Imager::i_tags_get($im, 2), 103, "check third");
-
- ok(Imager::i_tags_add($im, 'beta', 0, "hello", 0),
- "add string with string key");
- ok(Imager::i_tags_add($im, 'gamma', 0, "goodbye", 0),
- "add another one");
- ok(Imager::i_tags_add($im, undef, 199, "aloha", 0),
- "add one keyed by number");
- is(Imager::i_tags_find($im, 'beta', 0), 3, "find beta");
- is(Imager::i_tags_find($im, 'gamma', 0), 4, "find gamma");
- is(Imager::i_tags_findn($im, 199, 0), 5, "find 199");
- ok(Imager::i_tags_delete($im, 2), "delete");
- is(Imager::i_tags_find($im, 'beta', 0), 2, 'find beta after deletion');
- ok(Imager::i_tags_delbyname($im, 'beta'), 'delete beta by name');
- is(Imager::i_tags_find($im, 'beta', 0), undef, 'beta not there now');
- is(Imager::i_tags_get_string($im, "gamma"), "goodbye",
- 'i_tags_get_string() on a string');
- is(Imager::i_tags_get_string($im, 99), 102,
- 'i_tags_get_string() on a number entry');
- ok(Imager::i_tags_delbycode($im, 99), 'delete by code');
- is(Imager::i_tags_findn($im, 99, 0), undef, '99 not there now');
- is(Imager::i_tags_count($im), 3, 'final count of 3');
-}
-
-{
- print "# low-level scan line function tests\n";
- my $im = Imager::ImgRaw::new(10, 10, 4);
- Imager::i_ppix($im, 5, 0, $red);
-
- # i_glin/i_glinf
- my @colors = Imager::i_glin($im, 0, 10, 0);
- is_deeply([ (0) x 20, (255, 0, 0, 255), (0) x 16 ],
- [ map $_->rgba, @colors ],
- "i_glin - list context");
- my $colors = Imager::i_glin($im, 0, 10, 0);
- is("00" x 20 . "FF0000FF" . "00" x 16,
- uc unpack("H*", $colors), "i_glin - scalar context");
- my @fcolors = Imager::i_glinf($im, 0, 10, 0);
- is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
- [ map $_->rgba, @fcolors ],
- "i_glinf - list context");
- my $fcolors = Imager::i_glinf($im, 0, 10, 0);
- is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
- [ unpack "d*", $fcolors ],
- "i_glinf - scalar context");
-
- # i_plin/i_plinf
- my @plin_colors = (($black) x 4, $red, $blue, ($black) x 4);
- is(Imager::i_plin($im, 0, 1, @plin_colors),
- 10, "i_plin - pass in a list");
- # make sure we get it back
- is_deeply([ map [ $_->rgba ], @plin_colors ],
- [ map [ $_->rgba ], Imager::i_glin($im, 0, 10, 1) ],
- "check i_plin wrote to the image");
- my @scalar_plin =
- (
- (0,0,0,0) x 4,
- (0, 255, 0, 255),
- (0, 0, 255, 255),
- (0, 0, 0, 0) x 4,
- );
- is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)),
- 10, "i_plin - pass in a scalar");
- is_deeply(\@scalar_plin,
- [ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ],
- "check i_plin scalar wrote to the image");
-
- my @plinf_colors = # Note: only 9 pixels
- (
- ($f_blue) x 4,
- $f_red,
- ($f_black) x 3,
- $f_black
- );
- is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9,
- "i_plinf - list");
- is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ],
- [ map $_->rgba, @plinf_colors ],
- "check colors were written");
- my @scalar_plinf =
- (
- ( 1.0, 1.0, 0, 1.0 ) x 3,
- ( 0, 1.0, 1.0, 1.0 ) x 2,
- ( 0, 0, 0, 0 ),
- ( 1.0, 0, 1.0, 1.0 ),
- );
- is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)),
- 7, "i_plinf - scalar");
- is_deeply(\@scalar_plinf,
- [ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ],
- "check colors were written");
-
- is_deeply([ Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ]) ],
- [ (0, 0) x 5, (255, 255), (0, 0) x 4 ],
- "i_gsamp list context");
- is("0000" x 5 . "FFFF" . "0000" x 4,
- uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ])),
- "i_gsamp scalar context");
- is_deeply([ Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ]) ],
- [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
- (1.0, 1.0, 1.0) ], "i_gsampf - list context");
- is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ])) ],
- [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
- (1.0, 1.0, 1.0) ], "i_gsampf - scalar context");
- print "# end low-level scan-line function tests\n";
-}
-
-my $psamp_outside_error = "Image position outside of image";
-{ # psamp
- print "# psamp\n";
- my $imraw = Imager::ImgRaw::new(10, 20, 3);
- {
- is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
- "i_psamp def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
- "i_psamp def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
- "check color written");
- is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
- "i_psamp channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
- "i_psamp channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 63, 32) x 10 ],
- "check full row");
- is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
- [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
- 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
- is(Imager::i_psamp($imraw, 4, 6, undef, [ 0 .. 18 ], 1), 18,
- "psamp with offset");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
- [ (0) x 12, 1 .. 18 ],
- "check result");
- is(Imager::i_psamp($imraw, 4, 11, undef, [ 0 .. 18 ], 1, 3), 9,
- "psamp with offset and width");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
- [ (0) x 12, 1 .. 9, (0) x 9 ],
- "check result");
- }
- { # errors we catch
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psamp($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- }
- { # test the im_sample_list typemap
- ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], undef); 1 },
- "pass undef as the sample list");
- like($@, qr/data must be a scalar or an arrayref/,
- "check message");
- ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
- "hashref as the sample list");
- like($@, qr/data must be a scalar or an arrayref/,
- "check message");
- ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], []); 1 },
- "empty sample list");
- like($@, qr/i_psamp: no samples provided in data/,
- "check message");
- ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], ""); 1 },
- "empty scalar sample list");
- like($@, qr/i_psamp: no samples provided in data/,
- "check message");
-
- # not the typemap
- is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
- "negative offset");
- is(_get_error(), "offset must be non-negative",
- "check message");
-
- is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
- "too high offset");
- is(_get_error(), "offset greater than number of samples supplied",
- "check message");
- }
- print "# end psamp tests\n";
-}
-
-{ # psampf
- print "# psampf\n";
- my $imraw = Imager::ImgRaw::new(10, 20, 3);
- {
- is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
- "i_psampf def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
- "check color written");
- is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
- "i_psampf channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 64, 32) x 10 ],
- "check full row");
- is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
- [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
- 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
- is(Imager::i_psampf($imraw, 4, 6, undef, [ map $_/254.9, 0 .. 18 ], 1), 18,
- "psampf with offset");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
- [ (0) x 12, 1 .. 18 ],
- "check result");
- is(Imager::i_psampf($imraw, 4, 11, undef, [ map $_/254.9, 0 .. 18 ], 1, 3), 9,
- "psampf with offset and width");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
- [ (0) x 12, 1 .. 9, (0) x 9 ],
- "check result");
- }
- { # errors we catch
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psampf($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- }
- { # test the im_fsample_list typemap
- ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], undef); 1 },
- "pass undef as the sample list");
- like($@, qr/data must be a scalar or an arrayref/,
- "check message");
- ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
- "hashref as the sample list");
- like($@, qr/data must be a scalar or an arrayref/,
- "check message");
- ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], []); 1 },
- "empty sample list");
- like($@, qr/i_psampf: no samples provided in data/,
- "check message");
- ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], ""); 1 },
- "empty scalar sample list");
- like($@, qr/i_psampf: no samples provided in data/,
- "check message");
-
- # not the typemap
- is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
- "negative offset");
- is(_get_error(), "offset must be non-negative",
- "check message");
-
- is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
- "too high offset");
- is(_get_error(), "offset greater than number of samples supplied",
- "check message");
- }
- print "# end psampf tests\n";
-}
-
-{
- print "# OO level scanline function tests\n";
- my $im = Imager->new(xsize=>10, ysize=>10, channels=>4);
- $im->setpixel(color=>$red, 'x'=>5, 'y'=>0);
- ok(!$im->getscanline(), "getscanline() - supply nothing, get nothing");
- is($im->errstr, "missing y parameter", "check message");
- is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0) ],
- [ ([ 0,0,0,0]) x 5, [ 255, 0, 0, 255 ], ([ 0,0,0,0]) x 4 ],
- "getscanline, list context, default x, width");
- is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>3) ],
- [ ([0,0,0,0]) x 2, [ 255, 0, 0, 255 ], ([0,0,0,0]) x 4 ],
- "getscanline, list context, default width");
- is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>4, width=>4) ],
- [ [0,0,0,0], [ 255, 0, 0, 255 ], ([0,0,0,0]) x 2 ],
- "getscanline, list context, no defaults");
- is(uc unpack("H*", $im->getscanline('y'=>0)),
- "00000000" x 5 . "FF0000FF" . "00000000" x 4,
- "getscanline, scalar context, default x, width");
- is_deeply([ map [ $_->rgba ],
- $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
- [ [0,0,0,0], [ 1.0, 0, 0, 1.0 ], ([0,0,0,0]) x 2 ],
- "getscanline float, list context, no defaults");
- is_deeply([ unpack "d*",
- $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
- [ (0,0,0,0), ( 1.0, 0, 0, 1.0 ), (0,0,0,0) x 2 ],
- "getscanline float, scalar context, no defaults");
-
- ok(!$im->getscanline('y'=>0, type=>'invalid'),
- "check invalid type checking");
- like($im->errstr, qr/invalid type parameter/,
- "check message for invalid type");
-
- my @plin_colors = (($black) x 4, $red, $blue, ($green) x 4);
- is($im->setscanline('y'=>1, pixels=>\@plin_colors), 10,
- "setscanline - arrayref, default x");
- is_deeply([ map [ $_->rgba ], @plin_colors ],
- [ map [ $_->rgba ], $im->getscanline('y'=>1) ],
- "check colors were written");
-
- my @plin_colors2 = ( $green, $red, $blue, $red );
- is($im->setscanline('y'=>2, 'x'=>3, pixels=>\@plin_colors2), 4,
- "setscanline - arrayref");
-
- # using map instead of x here due to a bug in some versions of Test::More
- # fixed in the latest Test::More
- is_deeply([ ( map [ 0,0,0,0 ], 1..3), (map [ $_->rgba ], @plin_colors2),
- ( map [ 0,0,0,0 ], 1..3) ],
- [ map [ $_->rgba ], $im->getscanline('y'=>2) ],
- "check write to middle of line");
-
- my $raw_colors = pack "H*", "FF00FFFF"."FF0000FF"."FFFFFFFF";
- is($im->setscanline('y'=>3, 'x'=>2, pixels=>$raw_colors), 3,
- "setscanline - scalar, default raw type")
- or print "# ",$im->errstr,"\n";
- is(uc unpack("H*", $im->getscanline('y'=>3, 'x'=>1, 'width'=>5)),
- "00000000".uc(unpack "H*", $raw_colors)."00000000",
- "check write");
-
- # float colors
- my @fcolors = ( $f_red, $f_blue, $f_black, $f_green );
- is($im->setscanline('y'=>4, 'x'=>3, pixels=>\@fcolors), 4,
- "setscanline - float arrayref");
- is_deeply([ map [ $_->rgba ], @fcolors ],
- [ map [ $_->rgba ], $im->getscanline('y'=>4, 'x'=>3, width=>4, type=>'float') ],
- "check write");
- # packed
- my $packed_fcolors = pack "d*", map $_->rgba, @fcolors;
- is($im->setscanline('y'=>5, 'x'=>4, pixels=>$packed_fcolors, type=>'float'), 4,
- "setscanline - float scalar");
- is_deeply([ map [ $_->rgba ], @fcolors ],
- [ map [ $_->rgba ], $im->getscanline('y'=>5, 'x'=>4, width=>4, type=>'float') ],
- "check write");
-
- # get samples
- is_deeply([ $im->getsamples('y'=>1, channels=>[ 0 ]) ],
- [ map +($_->rgba)[0], @plin_colors ],
- "get channel 0, list context, default x, width");
- is_deeply([ unpack "C*", $im->getsamples('y'=>1, channels=>[0, 2]) ],
- [ map { ($_->rgba)[0, 2] } @plin_colors ],
- "get channel 0, 1, scalar context");
- is_deeply([ $im->getsamples('y'=>4, 'x'=>3, width=>4, type=>'float',
- channels=>[1,3]) ],
- [ map { ($_->rgba)[1,3] } @fcolors ],
- "get channels 1,3, list context, float samples");
- is_deeply([ unpack "d*",
- $im->getsamples('y'=>4, 'x'=>3, width=>4,
- type=>'float', channels=>[3,2,1,0]) ],
- [ map { ($_->rgba)[3,2,1,0] } @fcolors ],
- "get channels 3..0 as scalar, float samples");
-
- print "# end OO level scanline function tests\n";
-}
-
-{ # RT 74882
- # for the non-gsamp_bits case with a target parameter it was
- # treating the target parameter as a hashref
- {
- my $im = Imager->new(xsize => 10, ysize => 10);
- my $c1 = NC(0, 63, 255);
- my $c2 = NC(255, 128, 255);
- is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
- 10, "set some test data")
- or diag "setscanline: ", $im->errstr;
- my @target;
- is($im->getsamples(y => 1, x => 1, target => \@target, width => 3),
- 9, "getsamples to target");
- is_deeply(\@target, [ 255, 128, 255, 0, 63, 255, 255, 128, 255 ],
- "check result");
- }
- {
- my $im = Imager->new(xsize => 10, ysize => 10, bits => "double");
- my $c1 = NCF(0, 0.25, 1.0);
- my $c2 = NCF(1.0, 0.5, 1.0);
- is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
- 10, "set some test data")
- or diag "setscanline: ", $im->errstr;
- my @target;
- is($im->getsamples(y => 1, x => 1, target => \@target, width => 3, type => "float"),
- 9, "getsamples to target");
- is_deeply(\@target, [ 1.0, 0.5, 1.0, 0, 0.25, 1.0, 1.0, 0.5, 1.0 ],
- "check result");
- }
-}
-
-{ # to avoid confusion, i_glin/i_glinf modified to return 0 in unused
- # channels at the perl level
- my $im = Imager->new(xsize => 4, ysize => 4, channels => 2);
- my $fill = Imager::Color->new(128, 255, 0, 0);
- ok($im->box(filled => 1, color => $fill), 'fill it up');
- my $data = $im->getscanline('y' => 0);
- is(unpack("H*", $data), "80ff000080ff000080ff000080ff0000",
- "check we get zeros");
- my @colors = $im->getscanline('y' => 0);
- is_color4($colors[0], 128, 255, 0, 0, "check object interface[0]");
- is_color4($colors[1], 128, 255, 0, 0, "check object interface[1]");
- is_color4($colors[2], 128, 255, 0, 0, "check object interface[2]");
- is_color4($colors[3], 128, 255, 0, 0, "check object interface[3]");
-
- my $dataf = $im->getscanline('y' => 0, type => 'float');
- # the extra pack/unpack is to force double precision rather than long
- # double, otherwise the test fails
- is_deeply([ unpack("d*", $dataf) ],
- [ unpack("d*", pack("d*", ( 128.0 / 255.0, 1.0, 0, 0, ) x 4)) ],
- "check we get zeroes (double)");
- my @fcolors = $im->getscanline('y' => 0, type => 'float');
- is_fcolor4($fcolors[0], 128.0/255.0, 1.0, 0, 0, "check object interface[0]");
- is_fcolor4($fcolors[1], 128.0/255.0, 1.0, 0, 0, "check object interface[1]");
- is_fcolor4($fcolors[2], 128.0/255.0, 1.0, 0, 0, "check object interface[2]");
- is_fcolor4($fcolors[3], 128.0/255.0, 1.0, 0, 0, "check object interface[3]");
-}
-
-{ # check the channel mask function
-
- my $im = Imager->new(xsize => 10, ysize=>10, bits=>8);
-
- mask_tests($im, 0.005);
-}
-
-{ # check bounds checking
- my $im = Imager->new(xsize => 10, ysize => 10);
-
- image_bounds_checks($im);
-}
-
-{ # setsamples() interface to psamp()
- my $im = Imager->new(xsize => 10, ysize => 10);
- is($im->setsamples(y => 1, x => 2, data => [ 1 .. 6 ]), 6,
- "simple put (array), default channels");
- is_deeply([ $im->getsamples(y => 1, x => 0) ],
- [ (0) x 6, 1 .. 6, (0) x 18 ], "check they were stored");
- is($im->setsamples(y => 3, x => 3, data => pack("C*", 2 .. 10 )), 9,
- "simple put (scalar), default channels")
- or diag $im->errstr;
- is_deeply([ $im->getsamples(y => 3, x => 0) ],
- [ (0) x 9, 2 .. 10, (0) x 12 ], "check they were stored");
- is($im->setsamples(y => 4, x => 4, data => [ map $_ / 254.5, 1 .. 6 ], type => 'float'),
- 6, "simple put (float array), default channels");
- is_deeply([ $im->getsamples(y => 4, x => 0) ],
- [ (0) x 12, 1 .. 6, (0) x 12 ], "check they were stored");
-
- is($im->setsamples(y => 5, x => 3, data => pack("d*", map $_ / 254.5, 1 .. 6), type => 'float'),
- 6, "simple put (float scalar), default channels");
- is_deeply([ $im->getsamples(y => 5, x => 0) ],
- [ (0) x 9, 1 .. 6, (0) x 15 ], "check they were stored");
-
- is($im->setsamples(y => 7, x => 3, data => [ 0 .. 18 ], offset => 1), 18,
- "setsamples offset");
- is_deeply([ $im->getsamples(y => 7) ],
- [ (0) x 9, 1 .. 18, (0) x 3 ],
- "check result");
-
- is($im->setsamples(y => 8, x => 3, data => [ map $_ / 254.9, 0 .. 18 ],
- offset => 1, type => 'float'),
- 18, "setsamples offset (float)");
- is_deeply([ $im->getsamples(y => 8) ],
- [ (0) x 9, 1 .. 18, (0) x 3 ],
- "check result");
-
- is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ]) ],
- [], "check out of range result (8bit)");
- is($im->errstr, $psamp_outside_error, "check error message");
-
- is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ], type => "float") ],
- [], "check out of range result (float)");
- is($im->errstr, $psamp_outside_error, "check error message");
-
- is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
- data => [ (0) x 3 ]) ],
- [], "check bad channels (8bit)");
- is($im->errstr, "No channel 3 in this image",
- "check error message");
-
- is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
- data => [ (0) x 3 ], type => "float") ],
- [], "check bad channels (float)");
- is($im->errstr, "No channel 3 in this image",
- "check error message");
-
- is($im->setsamples(y => 5, data => [ (0) x 3 ], type => "bad"),
- undef, "setsamples with bad type");
- is($im->errstr, "setsamples: type parameter invalid",
- "check error message");
- is($im->setsamples(y => 5),
- undef, "setsamples with no data");
- is($im->errstr, "setsamples: data parameter missing",
- "check error message");
-
- is($im->setsamples(y => 5, data => undef),
- undef, "setsamples with undef data");
- is($im->errstr, "setsamples: data parameter not defined",
- "check error message");
-
- my $imempty = Imager->new;
- is($imempty->setsamples(y => 0, data => [ (0) x 3 ]), undef,
- "setsamples to empty image");
- is($imempty->errstr, "setsamples: empty input image",
- "check error message");
-}
-
-{ # getpixel parameters
- my $im = Imager->new(xsize => 10, ysize => 10);
- $im->box(filled => 1, xmax => 4, color => NC(255, 0, 0));
- $im->box(filled => 1, xmin => 5, ymax => 4, color => NC(0, 255, 255));
- $im->box(filled => 1, xmin => 5, ymin => 5, color => NC(255, 0, 255));
- { # error handling
- my $empty = Imager->new;
- ok(!$empty->getpixel(x => 0, y => 0), "getpixel empty image");
- is($empty->errstr, "getpixel: empty input image", "check message");
-
- ok(!$im->getpixel(y => 0), "missing x");
- is($im->errstr, "getpixel: missing x or y parameter", "check message");
-
- $im->_set_error("something different");
- ok(!$im->getpixel(x => 0), "missing y");
- is($im->errstr, "getpixel: missing x or y parameter", "check message");
-
- ok(!$im->getpixel(x => [], y => 0), "empty x array ref");
- is($im->errstr, "getpixel: x is a reference to an empty array",
- "check message");
-
- ok(!$im->getpixel(x => 0, y => []), "empty y array ref");
- is($im->errstr, "getpixel: y is a reference to an empty array",
- "check message");
-
- ok(!$im->getpixel(x => 0, y => 0, type => "bad"), "bad type (scalar path)");
- is($im->errstr, "getpixel: type must be '8bit' or 'float'",
- "check message");
-
- $im->_set_error("something different");
- ok(!$im->getpixel(x => [ 0 ], y => [ 0 ], type => "bad"),
- "bad type (array path)");
- is($im->errstr, "getpixel: type must be '8bit' or 'float'",
- "check message");
- }
-
- # simple calls
- is_color3($im->getpixel(x => 1, y => 0), 255, 0, 0,
- "getpixel(1, 0)");
- is_color3($im->getpixel(x => 8, y => 1), 0, 255, 255,
- "getpixel(8, 1)");
- is_color3($im->getpixel(x => 8, y => 7), 255, 0, 255,
- "getpixel(8, 7)");
-
- {
- # simple arrayrefs
- my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ]);
- is(@colors, 3, "getpixel 2 3 element array refs");
- is_color3($colors[0], 255, 0, 0, "check first color");
- is_color3($colors[1], 255, 0, 255, "check second color");
- is_color3($colors[2], 0, 255, 255, "check third color");
- }
-
- # array and scalar
- {
- my @colors = $im->getpixel(x => 5, y => [ 4, 5, 9 ]);
- is(@colors, 3, "getpixel x scalar, y arrayref of 3");
- is_color3($colors[0], 0, 255, 255, "check first color");
- is_color3($colors[1], 255, 0, 255, "check second color");
- is_color3($colors[2], 255, 0, 255, "check third color");
- }
-
- {
- my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => 2);
- is(@colors, 3, "getpixel y scalar, x arrayref of 3");
- is_color3($colors[0], 255, 0, 0, "check first color");
- is_color3($colors[1], 255, 0, 0, "check second color");
- is_color3($colors[2], 0, 255, 255, "check third color");
- }
-
- { # float
- is_fcolor3($im->getpixel(x => 1, y => 0, type => 'float'),
- 1.0, 0, 0, "getpixel(1,0) float");
- is_fcolor3($im->getpixel(x => 8, y => 1, type => 'float'),
- 0, 1.0, 1.0, "getpixel(8,1) float");
- is_fcolor3($im->getpixel(x => 8, y => 7, type => 'float'),
- 1.0, 0, 1.0, "getpixel(8,7) float");
-
- my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], type => 'float');
- is(@colors, 3, "getpixel 2 3 element array refs (float)");
- is_fcolor3($colors[0], 1, 0, 0, "check first color");
- is_fcolor3($colors[1], 1, 0, 1, "check second color");
- is_fcolor3($colors[2], 0, 1, 1, "check third color");
- }
-
- { # out of bounds
- my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0);
- is(@colors, 4, "should be 4 entries")
- or diag $im->errstr;
- is_color3($colors[0], 255, 0, 0, "first red");
- is($colors[1], undef, "second undef");
- is_color3($colors[2], 0, 255, 255, "third cyan");
- is($colors[3], undef, "fourth undef");
- }
-
- { # out of bounds
- my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0, type => "float");
- is(@colors, 4, "should be 4 entries")
- or diag $im->errstr;
- is_fcolor3($colors[0], 1.0, 0, 0, "first red");
- is($colors[1], undef, "second undef");
- is_fcolor3($colors[2], 0, 1.0, 1.0, "third cyan");
- is($colors[3], undef, "fourth undef");
- }
-}
-
-{ # setpixel
- my $im = Imager->new(xsize => 10, ysize => 10);
- { # errors
- my $empty = Imager->new;
- ok(!$empty->setpixel(x => 0, y => 0, color => $red),
- "setpixel on empty image");
- is($empty->errstr, "setpixel: empty input image", "check message");
-
- ok(!$im->setpixel(y => 0, color => $red), "missing x");
- is($im->errstr, "setpixel: missing x or y parameter", "check message");
-
- $im->_set_error("something different");
- ok(!$im->setpixel(x => 0, color => $red), "missing y");
- is($im->errstr, "setpixel: missing x or y parameter", "check message");
-
- ok(!$im->setpixel(x => [], y => 0, color => $red), "empty x array ref");
- is($im->errstr, "setpixel: x is a reference to an empty array",
- "check message");
-
- ok(!$im->setpixel(x => 0, y => [], color => $red), "empty y array ref");
- is($im->errstr, "setpixel: y is a reference to an empty array",
- "check message");
-
- ok(!$im->setpixel(x => 0, y => 0, color => "not really a color"),
- "color not a color");
- is($im->errstr, "setpixel: No color named not really a color found",
- "check message");
- }
-
- # simple set
- is($im->setpixel(x => 0, y => 0, color => $red), $im,
- "simple setpixel")
- or diag "simple set float: ", $im->errstr;
- is_color3($im->getpixel(x => 0, y => 0), 255, 0, 0, "check stored pixel");
-
- is($im->setpixel(x => 1, y => 2, color => $f_red), $im,
- "simple setpixel (float)")
- or diag "simple set float: ", $im->errstr;
- is_color3($im->getpixel(x => 1, y => 2), 255, 0, 0, "check stored pixel");
-
- is($im->setpixel(x => -1, y => 0, color => $red), undef,
- "simple setpixel outside of image");
- is($im->setpixel(x => 0, y => -1, color => $f_red), undef,
- "simple setpixel (float) outside of image");
-
- # simple arrayrefs
- is($im->setpixel( x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], color => $blue),
- 3, "setpixel with 3 element array refs");
- my @colors = $im->getpixel(x => [ 8, 7, 0 ], y => [ 7, 3, 0 ]);
- is_color3($colors[0], 0, 0, 255, "check first color");
- is_color3($colors[1], 0, 0, 255, "check second color");
- is_color3($colors[2], 0, 0, 255, "check third color");
-
- # array and scalar
- {
- is($im->setpixel(x => 5, y => [ 4, 5, 9 ], color => $green), 3,
- "setpixel with x scalar, y arrayref of 3");
- my @colors = $im->getpixel(x => [ 5, 5, 5 ], y => [ 4, 5, 9 ]);
- is_color3($colors[0], 0, 255, 0, "check first color");
- is_color3($colors[1], 0, 255, 0, "check second color");
- is_color3($colors[2], 0, 255, 0, "check third color");
- }
-
- {
- is($im->setpixel(x => [ 0, 4, 5 ], y => 2, color => $blue), 3,
- "setpixel with y scalar, x arrayref of 3");
- my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => [ 2, 2, 2 ]);
- is_color3($colors[0], 0, 0, 255, "check first color");
- is_color3($colors[1], 0, 0, 255, "check second color");
- is_color3($colors[2], 0, 0, 255, "check third color");
- }
-
- {
- is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $blue), 3,
- "set array with two bad locations")
- or diag "set array bad locations: ", $im->errstr;
- my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
- is_color3($colors[0], 0, 0, 255, "check first color");
- is_color3($colors[1], 0, 0, 255, "check second color");
- is_color3($colors[2], 0, 0, 255, "check third color");
- }
- {
- is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $f_green), 3,
- "set array with two bad locations (float)")
- or diag "set array bad locations (float): ", $im->errstr;
- my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
- is_color3($colors[0], 0, 255, 0, "check first color");
- is_color3($colors[1], 0, 255, 0, "check second color");
- is_color3($colors[2], 0, 255, 0, "check third color");
- }
- { # default color
- is($im->setpixel(x => 0, y => 9), $im, "setpixel() default color")
- or diag "setpixel default color: ", $im->errstr;
- is_color3($im->getpixel(x => 0, y => 9), 255, 255, 255,
- "check color set");
- }
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->addtag(name => "foo", value => 1),
- "can't addtag on an empty image");
- is($empty->errstr, "addtag: empty input image",
- "check error message");
- ok(!$empty->settag(name => "foo", value => 1),
- "can't settag on an empty image");
- is($empty->errstr, "settag: empty input image",
- "check error message");
- ok(!$empty->deltag(name => "foo"), "can't deltag on an empty image");
- is($empty->errstr, "deltag: empty input image",
- "check error message");
- ok(!$empty->tags(name => "foo"), "can't tags on an empty image");
- is($empty->errstr, "tags: empty input image",
- "check error message");
-}
-
-Imager->close_log();
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t01introvert.log";
-}
-
-sub check_add {
- my ($im, $color, $expected) = @_;
- my $index = Imager::i_addcolors($im, $color);
- ok($index, "got index");
- print "# $index\n";
- is(0+$index, $expected, "index matched expected");
- my ($new) = Imager::i_getcolors($im, $index);
- ok($new, "got the color");
- ok(color_cmp($new, $color) == 0, "color matched what was added");
-
- $index;
-}
-
-# sub array_ncmp {
-# my ($a1, $a2) = @_;
-# my $len = @$a1 < @$a2 ? @$a1 : @$a2;
-# for my $i (0..$len-1) {
-# my $diff = $a1->[$i] <=> $a2->[$i]
-# and return $diff;
-# }
-# return @$a1 <=> @$a2;
-# }
-
-sub dump_colors {
- for my $col (@_) {
- print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
- }
-}
-
-sub _get_error {
- my @errors = Imager::i_errors();
- return join(": ", map $_->[0], @errors);
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 244;
-use Imager qw(:all :handy);
-use Imager::Test qw(is_color3 is_fcolor3);
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t020masked.log");
-
-my $base_rgb = Imager::ImgRaw::new(100, 100, 3);
-# put something in there
-my $black = NC(0, 0, 0);
-my $red = NC(255, 0, 0);
-my $green = NC(0, 255, 0);
-my $blue = NC(0, 0, 255);
-my $white = NC(255, 255, 255);
-my $grey = NC(128, 128, 128);
-use Imager::Color::Float;
-my $redf = Imager::Color::Float->new(1, 0, 0);
-my $greenf = Imager::Color::Float->new(0, 1, 0);
-my $bluef = Imager::Color::Float->new(0, 0, 1);
-my $greyf = Imager::Color::Float->new(0.5, 0.5, 0.5);
-my @cols = ($red, $green, $blue);
-for my $y (0..99) {
- Imager::i_plin($base_rgb, 0, $y, ($cols[$y % 3] ) x 100);
-}
-
-# first a simple subset image
-my $s_rgb = Imager::i_img_masked_new($base_rgb, undef, 25, 25, 50, 50);
-
-is(Imager::i_img_getchannels($s_rgb), 3,
- "1 channel image channel count match");
-ok(Imager::i_img_getmask($s_rgb) & 1,
- "1 channel image mask");
-ok(Imager::i_img_virtual($s_rgb),
- "1 channel image thinks it isn't virtual");
-is(Imager::i_img_bits($s_rgb), 8,
- "1 channel image has bits == 8");
-is(Imager::i_img_type($s_rgb), 0, # direct
- "1 channel image is direct");
-
-my @ginfo = i_img_info($s_rgb);
-is($ginfo[0], 50, "check width");
-is($ginfo[1], 50, "check height");
-
-# sample some pixels through the subset
-my $c = Imager::i_get_pixel($s_rgb, 0, 0);
-is_color3($c, 0, 255, 0, "check (0,0)");
-$c = Imager::i_get_pixel($s_rgb, 49, 49);
-# (25+49)%3 = 2
-is_color3($c, 0, 0, 255, "check (49,49)");
-
-# try writing to it
-for my $y (0..49) {
- Imager::i_plin($s_rgb, 0, $y, ($cols[$y % 3]) x 50);
-}
-pass("managed to write to it");
-# and checking the target image
-$c = Imager::i_get_pixel($base_rgb, 25, 25);
-is_color3($c, 255, 0, 0, "check (25,25)");
-$c = Imager::i_get_pixel($base_rgb, 29, 29);
-is_color3($c, 0, 255, 0, "check (29,29)");
-
-undef $s_rgb;
-
-# a basic background
-for my $y (0..99) {
- Imager::i_plin($base_rgb, 0, $y, ($red ) x 100);
-}
-my $mask = Imager::ImgRaw::new(50, 50, 1);
-# some venetian blinds
-for my $y (4..20) {
- Imager::i_plin($mask, 5, $y*2, ($white) x 40);
-}
-# with a strip down the middle
-for my $y (0..49) {
- Imager::i_plin($mask, 20, $y, ($white) x 8);
-}
-my $m_rgb = Imager::i_img_masked_new($base_rgb, $mask, 25, 25, 50, 50);
-ok($m_rgb, "make masked with mask");
-for my $y (0..49) {
- Imager::i_plin($m_rgb, 0, $y, ($green) x 50);
-}
-my @color_tests =
- (
- [ 25+0, 25+0, $red ],
- [ 25+19, 25+0, $red ],
- [ 25+20, 25+0, $green ],
- [ 25+27, 25+0, $green ],
- [ 25+28, 25+0, $red ],
- [ 25+49, 25+0, $red ],
- [ 25+19, 25+7, $red ],
- [ 25+19, 25+8, $green ],
- [ 25+19, 25+9, $red ],
- [ 25+0, 25+8, $red ],
- [ 25+4, 25+8, $red ],
- [ 25+5, 25+8, $green ],
- [ 25+44, 25+8, $green ],
- [ 25+45, 25+8, $red ],
- [ 25+49, 25+49, $red ],
- );
-my $test_num = 15;
-for my $test (@color_tests) {
- my ($x, $y, $testc) = @$test;
- my ($r, $g, $b) = $testc->rgba;
- my $c = Imager::i_get_pixel($base_rgb, $x, $y);
- is_color3($c, $r, $g, $b, "at ($x, $y)");
-}
-
-{
- # tests for the OO versions, fairly simple, since the basic functionality
- # is covered by the low-level interface tests
-
- my $base = Imager->new(xsize=>100, ysize=>100);
- ok($base, "make base OO image");
- $base->box(color=>$blue, filled=>1); # fill it all
- my $mask = Imager->new(xsize=>80, ysize=>80, channels=>1);
- $mask->box(color=>$white, filled=>1, xmin=>5, xmax=>75, ymin=>5, ymax=>75);
- my $m_img = $base->masked(mask=>$mask, left=>5, top=>5);
- ok($m_img, "make masked OO image");
- is($m_img->getwidth, 80, "check width");
- $m_img->box(color=>$green, filled=>1);
- my $c = $m_img->getpixel(x=>0, y=>0);
- is_color3($c, 0, 0, 255, "check (0,0)");
- $c = $m_img->getpixel(x => 5, y => 5);
- is_color3($c, 0, 255, 0, "check (5,5)");
-
- # older versions destroyed the Imager::ImgRaw object manually in
- # Imager::DESTROY rather than letting Imager::ImgRaw::DESTROY
- # destroy the object
- # so we test here by destroying the base and mask objects and trying
- # to draw to the masked wrapper
- # you may need to test with ElectricFence to trigger the problem
- undef $mask;
- undef $base;
- $m_img->box(color=>$blue, filled=>1);
- pass("didn't crash unreffing base or mask for masked image");
-}
-
-# 35.7% cover on maskimg.c up to here
-
-{ # error handling:
- my $base = Imager->new(xsize => 100, ysize => 100);
- ok($base, "make base");
- { # make masked image subset outside of the base image
- my $masked = $base->masked(left => 100);
- ok (!$masked, "fail to make empty masked");
- is($base->errstr, "subset outside of target image", "check message");
- }
-}
-
-{ # size limiting
- my $base = Imager->new(xsize => 10, ysize => 10);
- ok($base, "make base for size limit tests");
- {
- my $masked = $base->masked(left => 5, right => 15);
- ok($masked, "make masked");
- is($masked->getwidth, 5, "check width truncated");
- }
- {
- my $masked = $base->masked(top => 5, bottom => 15);
- ok($masked, "make masked");
- is($masked->getheight, 5, "check height truncated");
- }
-}
-# 36.7% up to here
-
-$mask = Imager->new(xsize => 80, ysize => 80, channels => 1);
-$mask->box(filled => 1, color => $white, xmax => 39, ymax => 39);
-$mask->box(fill => { hatch => "check1x1" }, ymin => 40, xmax => 39);
-
-{
- my $base = Imager->new(xsize => 100, ysize => 100, bits => "double");
- ok($base, "base for single pixel tests");
- is($base->type, "direct", "check type");
- my $masked = $base->masked(mask => $mask, left => 1, top => 2);
- my $limited = $base->masked(left => 1, top => 2);
-
- is($masked->type, "direct", "check masked is same type as base");
- is($limited->type, "direct", "check limited is same type as base");
-
- {
- # single pixel writes, masked
- {
- ok($masked->setpixel(x => 1, y => 3, color => $green),
- "set (1,3) in masked (2, 5) in based");
- my $c = $base->getpixel(x => 2, y => 5);
- is_color3($c, 0, 255, 0, "check it wrote through");
- ok($masked->setpixel(x => 45, y => 2, color => $red),
- "set (45,2) in masked (46,4) in base (no mask)");
- $c = $base->getpixel(x => 46, y => 4);
- is_color3($c, 0, 0, 0, "shouldn't have written through");
- }
- {
- ok($masked->setpixel(x => 2, y => 3, color => $redf),
- "write float red to (2,3) base(3,5)");
- my $c = $base->getpixel(x => 3, y => 5);
- is_color3($c, 255, 0, 0, "check it wrote through");
- ok($masked->setpixel(x => 45, y => 3, color => $greenf),
- "set float (45,3) in masked (46,5) in base (no mask)");
- $c = $base->getpixel(x => 46, y => 5);
- is_color3($c, 0, 0, 0, "check it didn't write");
- }
- {
- # write out of range should fail
- ok(!$masked->setpixel(x => 80, y => 0, color => $green),
- "write 8-bit color out of range");
- ok(!$masked->setpixel(x => 0, y => 80, color => $greenf),
- "write float color out of range");
- }
- }
-
- # 46.9
-
- {
- print "# plin coverage\n";
- {
- $base->box(filled => 1, color => $black);
- # plin masked
- # simple path
- is($masked->setscanline(x => 76, y => 1, pixels => [ ($red, $green) x 3 ]),
- 4, "try to write 6 pixels, but only write 4");
- is_deeply([ $base->getsamples(x => 77, y => 3, width => 4) ],
- [ ( 0 ) x 12 ],
- "check not written through");
- # !simple path
- is($masked->setscanline(x => 4, y => 2, pixels => [ ($red, $green, $blue, $grey) x (72/4) ]),
- 72, "write many pixels (masked)");
- is_deeply([ $base->getsamples(x => 5, y => 4, width => 72) ],
- [ ( (255, 0, 0), (0, 255, 0), (0, 0, 255), (128, 128, 128)) x 9,
- ( 0, 0, 0 ) x 36 ],
- "check written through to base");
-
- # simple path, due to number of transitions
- is($masked->setscanline(x => 0, y => 40, pixels => [ ($red, $green, $blue, $grey) x 5 ]),
- 20, "try to write 20 pixels, with alternating write through");
- is_deeply([ $base->getsamples(x => 1, y => 42, width => 20) ],
- [ ( (0, 0, 0), (0,255,0), (0,0,0), (128,128,128) ) x 5 ],
- "check correct pixels written through");
- }
-
- {
- $base->box(filled => 1, color => $black);
- # plin, non-masked path
- is($limited->setscanline(x => 4, y => 2, pixels => [ ($red, $green, $blue, $grey) x (72/4) ]),
- 72, "write many pixels (limited)");
- is_deeply([ $base->getsamples(x => 5, y => 4, width => 72) ],
- [ ( (255, 0, 0), (0, 255, 0), (0, 0, 255), (128, 128, 128)) x 18 ],
- "check written through to based");
- }
-
- {
- # draw outside fails
- is($masked->setscanline(x => 80, y => 2, pixels => [ $red, $green ]),
- 0, "check writing no pixels");
- }
- }
-
- {
- print "# plinf coverage\n";
- {
- $base->box(filled => 1, color => $black);
- # plinf masked
- # simple path
- is($masked->setscanline(x => 76, y => 1, pixels => [ ($redf, $greenf) x 3 ]),
- 4, "try to write 6 pixels, but only write 4");
- is_deeply([ $base->getsamples(x => 77, y => 3, width => 4, type => "float") ],
- [ ( 0 ) x 12 ],
- "check not written through");
- # !simple path
- is($masked->setscanline(x => 4, y => 2, pixels => [ ($redf, $greenf, $bluef, $greyf) x (72/4) ]),
- 72, "write many pixels (masked)");
- is_deeply([ $base->getsamples(x => 5, y => 4, width => 72, type => "float") ],
- [ ( (1, 0, 0), (0, 1, 0), (0, 0, 1), (0.5, 0.5, 0.5)) x 9,
- ( 0, 0, 0 ) x 36 ],
- "check written through to base");
-
- # simple path, due to number of transitions
- is($masked->setscanline(x => 0, y => 40, pixels => [ ($redf, $greenf, $bluef, $greyf) x 5 ]),
- 20, "try to write 20 pixels, with alternating write through");
- is_deeply([ $base->getsamples(x => 1, y => 42, width => 20, type => "float") ],
- [ ( (0, 0, 0), (0,1,0), (0,0,0), (0.5,0.5,0.5) ) x 5 ],
- "check correct pixels written through");
- }
-
- {
- $base->box(filled => 1, color => $black);
- # plinf, non-masked path
- is($limited->setscanline(x => 4, y => 2, pixels => [ ($redf, $greenf, $bluef, $greyf) x (72/4) ]),
- 72, "write many pixels (limited)");
- is_deeply([ $base->getsamples(x => 5, y => 4, width => 72, type => "float") ],
- [ ( (1, 0, 0), (0, 1, 0), (0, 0, 1), (0.5, 0.5, 0.5)) x 18 ],
- "check written through to based");
- }
-
- {
- # draw outside fails
- is($masked->setscanline(x => 80, y => 2, pixels => [ $redf, $greenf ]),
- 0, "check writing no pixels");
- }
- }
- # 71.4%
- {
- {
- print "# gpix\n";
- # gpix
- $base->box(filled => 1, color => $black);
- ok($base->setpixel(x => 4, y => 10, color => $red),
- "set base(4,10) to red");
- is_fcolor3($masked->getpixel(x => 3, y => 8),
- 255, 0, 0, "check pixel written");
-
- # out of range
- is($masked->getpixel(x => -1, y => 1),
- undef, "check failure to left");
- is($masked->getpixel(x => 0, y => -1),
- undef, "check failure to top");
- is($masked->getpixel(x => 80, y => 1),
- undef, "check failure to right");
- is($masked->getpixel(x => 0, y => 80),
- undef, "check failure to bottom");
- }
- {
- print "# gpixf\n";
- # gpixf
- $base->box(filled => 1, color => $black);
- ok($base->setpixel(x => 4, y => 10, color => $redf),
- "set base(4,10) to red");
- is_fcolor3($masked->getpixel(x => 3, y => 8, type => "float"),
- 1.0, 0, 0, 0, "check pixel written");
-
- # out of range
- is($masked->getpixel(x => -1, y => 1, type => "float"),
- undef, "check failure to left");
- is($masked->getpixel(x => 0, y => -1, type => "float"),
- undef, "check failure to top");
- is($masked->getpixel(x => 80, y => 1, type => "float"),
- undef, "check failure to right");
- is($masked->getpixel(x => 0, y => 80, type => "float"),
- undef, "check failure to bottom");
- }
- }
- # 74.5
- {
- {
- print "# glin\n";
- $base->box(filled => 1, color => $black);
- is($base->setscanline(x => 31, y => 3,
- pixels => [ ( $red, $green) x 10 ]),
- 20, "write 20 pixels to base image");
- my @colors = $masked->
- getscanline(x => 30, y => 1, width => 20);
- is(@colors, 20, "check we got right number of colors");
- is_color3($colors[0], 255, 0, 0, "check first pixel");
- is_color3($colors[19], 0, 255, 0, "check last pixel");
-
- @colors = $masked->getscanline(x => 76, y => 2, width => 10);
- is(@colors, 4, "read line from right edge");
- is_color3($colors[0], 0, 0, 0, "check pixel");
-
- is_deeply([ $masked->getscanline(x => -1, y => 0, width => 1) ],
- [], "fail read left of image");
- is_deeply([ $masked->getscanline(x => 0, y => -1, width => 1) ],
- [], "fail read top of image");
- is_deeply([$masked->getscanline(x => 80, y => 0, width => 1)],
- [], "fail read right of image");
- is_deeply([$masked->getscanline(x => 0, y => 80, width => 1)],
- [], "fail read bottom of image");
- }
- {
- print "# glinf\n";
- $base->box(filled => 1, color => $black);
- is($base->setscanline(x => 31, y => 3,
- pixels => [ ( $redf, $greenf) x 10 ]),
- 20, "write 20 pixels to base image");
- my @colors = $masked->
- getscanline(x => 30, y => 1, width => 20, type => "float");
- is(@colors, 20, "check we got right number of colors");
- is_fcolor3($colors[0], 1.0, 0, 0, 0, "check first pixel");
- is_fcolor3($colors[19], 0, 1.0, 0, 0, "check last pixel");
-
- @colors = $masked->
- getscanline(x => 76, y => 2, width => 10, type => "float");
- is(@colors, 4, "read line from right edge");
- is_fcolor3($colors[0], 0, 0, 0, 0, "check pixel");
-
- is_deeply([ $masked->getscanline(x => -1, y => 0, width => 1, type => "float") ],
- [], "fail read left of image");
- is_deeply([ $masked->getscanline(x => 0, y => -1, width => 1, type => "float") ],
- [], "fail read top of image");
- is_deeply([$masked->getscanline(x => 80, y => 0, width => 1, type => "float")],
- [], "fail read right of image");
- is_deeply([$masked->getscanline(x => 0, y => 80, width => 1, type => "float")],
- [], "fail read bottom of image");
- }
- }
- # 81.6%
- {
- {
- print "# gsamp\n";
- $base->box(filled => 1, color => $black);
- is($base->setscanline(x => 31, y => 3,
- pixels => [ ( $red, $green) x 10 ]),
- 20, "write 20 pixels to base image");
- my @samps = $masked->
- getsamples(x => 30, y => 1, width => 20);
- is(@samps, 60, "check we got right number of samples");
- is_deeply(\@samps,
- [ (255, 0, 0, 0, 255, 0) x 10 ],
- "check it");
-
- @samps = $masked->
- getsamples(x => 76, y => 2, width => 10);
- is(@samps, 12, "read line from right edge");
- is_deeply(\@samps, [ (0, 0, 0) x 4], "check result");
-
- is_deeply([ $masked->getsamples(x => -1, y => 0, width => 1) ],
- [], "fail read left of image");
- is_deeply([ $masked->getsamples(x => 0, y => -1, width => 1) ],
- [], "fail read top of image");
- is_deeply([$masked->getsamples(x => 80, y => 0, width => 1)],
- [], "fail read right of image");
- is_deeply([$masked->getsamples(x => 0, y => 80, width => 1)],
- [], "fail read bottom of image");
- }
- {
- print "# gsampf\n";
- $base->box(filled => 1, color => $black);
- is($base->setscanline(x => 31, y => 3,
- pixels => [ ( $redf, $greenf) x 10 ]),
- 20, "write 20 pixels to base image");
- my @samps = $masked->
- getsamples(x => 30, y => 1, width => 20, type => "float");
- is(@samps, 60, "check we got right number of samples");
- is_deeply(\@samps,
- [ (1.0, 0, 0, 0, 1.0, 0) x 10 ],
- "check it");
-
- @samps = $masked->
- getsamples(x => 76, y => 2, width => 10, type => "float");
- is(@samps, 12, "read line from right edge");
- is_deeply(\@samps, [ (0, 0, 0) x 4], "check result");
-
- is_deeply([ $masked->getsamples(x => -1, y => 0, width => 1, type => "float") ],
- [], "fail read left of image");
- is_deeply([ $masked->getsamples(x => 0, y => -1, width => 1, type => "float") ],
- [], "fail read top of image");
- is_deeply([$masked->getsamples(x => 80, y => 0, width => 1, type => "float")],
- [], "fail read right of image");
- is_deeply([$masked->getsamples(x => 0, y => 80, width => 1, type => "float")],
- [], "fail read bottom of image");
- }
- }
- # 86.2%
-}
-
-{
- my $base = Imager->new(xsize => 100, ysize => 100, type => "paletted");
- ok($base, "make paletted base");
- is($base->type, "paletted", "check we got paletted");
- is($base->addcolors(colors => [ $black, $red, $green, $blue ]),
- "0 but true",
- "add some colors to base");
- my $masked = $base->masked(mask => $mask, left => 1, top => 2);
- my $limited = $base->masked(left => 1, top => 2);
-
- is($masked->type, "paletted", "check masked is same type as base");
- is($limited->type, "paletted", "check limited is same type as base");
-
- {
- # make sure addcolors forwarded
- is($masked->addcolors(colors => [ $grey ]), 4,
- "test addcolors forwarded");
- my @colors = $masked->getcolors();
- is(@colors, 5, "check getcolors forwarded");
- is_color3($colors[1], 255, 0, 0, "check color from palette");
- }
-
- my ($blacki, $redi, $greeni, $bluei, $greyi) = 0 .. 4;
-
- { # gpal
- print "# gpal\n";
- $base->box(filled => 1, color => $black);
- is($base->setscanline(x => 0, y => 5, type => "index",
- pixels => [ ( $redi, $greeni, $bluei, $greyi) x 25 ]),
- 100, "write some pixels to base");
- my @indexes = $masked->getscanline(y => 3, type => "index", width => "81");
- is(@indexes, 80, "got 80 indexes");
- is_deeply(\@indexes,
- [ ( $greeni, $bluei, $greyi, $redi) x 20 ],
- "check values");
-
- is_deeply([ $masked->getscanline(x => -1, y => 3, type => "index") ],
- [], "fail read left of image");
- }
- # 89.8%
-
- { # ppal, unmasked
- print "# ppal\n";
- $base->box(filled => 1, color => $black);
- is($limited->setscanline(x => 1, y => 1, type => "index",
- pixels => [ ( $redi, $greeni, $bluei) x 3 ]),
- 9, "ppal limited");
- is_deeply([ $base->getscanline(x => 2, y => 3, type => "index",
- width => 9) ],
- [ ( $redi, $greeni, $bluei) x 3 ],
- "check set in base");
- }
- { # ppal, masked
- $base->box(filled => 1, color => $black);
- is($masked->setscanline(x => 1, y => 2, type => "index",
- pixels => [ ( $redi, $greeni, $bluei, $greyi) x 12 ]),
- 48, "ppal masked");
- is_deeply([ $base->getscanline(x => 0, y => 4, type => "index") ],
- [ 0, 0,
- ( $redi, $greeni, $bluei, $greyi ) x 9,
- $redi, $greeni, $bluei, ( 0 ) x 59 ],
- "check written");
- }
- {
- # ppal, errors
- is($masked->setscanline(x => -1, y => 0, type => "index",
- pixels => [ $redi, $bluei ]),
- 0, "fail to write ppal");
-
- is($masked->setscanline(x => 78, y => 0, type => "index",
- pixels => [ $redi, $bluei, $greeni, $greyi ]),
- 2, "write over right side");
- }
-}
-
-my $full_mask = Imager->new(xsize => 10, ysize => 10, channels => 1);
-$full_mask->box(filled => 1, color => NC(255, 0, 0));
-
-# no mask and mask with full coverage should behave the same
-my $psamp_outside_error = "Image position outside of image";
-for my $masked (0, 1){ # psamp
- print "# psamp masked: $masked\n";
- my $imback = Imager::ImgRaw::new(20, 20, 3);
- my $mask;
- if ($masked) {
- $mask = $full_mask->{IMG};
- }
- my $imraw = Imager::i_img_masked_new($imback, $mask, 3, 4, 10, 10);
- {
- is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
- "i_psamp def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
- "i_psamp def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
- "check color written");
- is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
- "i_psamp channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
- "i_psamp channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 63, 32) x 10 ],
- "check full row");
- is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
- [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
- 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- }
- print "# end psamp tests\n";
-}
-
-for my $masked (0, 1) { # psampf
- print "# psampf\n";
- my $imback = Imager::ImgRaw::new(20, 20, 3);
- my $mask;
- if ($masked) {
- $mask = $full_mask->{IMG};
- }
- my $imraw = Imager::i_img_masked_new($imback, $mask, 3, 4, 10, 10);
- {
- is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
- "i_psampf def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
- "check color written");
- is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
- "i_psampf channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 64, 32) x 10 ],
- "check full row");
- is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
- [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
- 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- }
- print "# end psampf tests\n";
-}
-
-{
- my $sub_mask = $full_mask->copy;
- $sub_mask->box(filled => 1, color => NC(0,0,0), xmin => 4, xmax => 6);
- my $base = Imager::ImgRaw::new(20, 20, 3);
- my $masked = Imager::i_img_masked_new($base, $sub_mask->{IMG}, 3, 4, 10, 10);
-
- is(Imager::i_psamp($masked, 0, 2, undef, [ ( 0, 127, 255) x 10 ]), 30,
- "psamp() to masked image");
- is_deeply([ Imager::i_gsamp($base, 0, 20, 6, undef) ],
- [ ( 0, 0, 0 ) x 3, # left of mask
- ( 0, 127, 255 ) x 4, # masked area
- ( 0, 0, 0 ) x 3, # unmasked area
- ( 0, 127, 255 ) x 3, # masked area
- ( 0, 0, 0 ) x 7 ], # right of mask
- "check values written");
- is(Imager::i_psampf($masked, 0, 2, undef, [ ( 0, 0.5, 1.0) x 10 ]), 30,
- "psampf() to masked image");
- is_deeply([ Imager::i_gsamp($base, 0, 20, 6, undef) ],
- [ ( 0, 0, 0 ) x 3, # left of mask
- ( 0, 128, 255 ) x 4, # masked area
- ( 0, 0, 0 ) x 3, # unmasked area
- ( 0, 128, 255 ) x 3, # masked area
- ( 0, 0, 0 ) x 7 ], # right of mask
- "check values written");
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->masked, "fail to make a masked image from an empty");
- is($empty->errstr, "masked: empty input image",
- "check error message");
-}
-
-Imager->close_log();
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t020masked.log";
-}
-
-sub _get_error {
- my @errors = Imager::i_errors();
- return join(": ", map $_->[0], @errors);
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 155;
-
-BEGIN { use_ok(Imager=>qw(:all :handy)) }
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t021sixteen.log");
-
-use Imager::Color::Float;
-use Imager::Test qw(test_image is_image image_bounds_checks test_colorf_gpix
- test_colorf_glin mask_tests is_color3);
-
-my $im_g = Imager::i_img_16_new(100, 101, 1);
-
-is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
-ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
-ok(!Imager::i_img_virtual($im_g), "shouldn't be marked virtual");
-is(Imager::i_img_bits($im_g), 16, "1 channel image has bits == 16");
-is(Imager::i_img_type($im_g), 0, "1 channel image isn't direct");
-
-my @ginfo = i_img_info($im_g);
-is($ginfo[0], 100, "1 channel image width");
-is($ginfo[1], 101, "1 channel image height");
-
-undef $im_g;
-
-my $im_rgb = Imager::i_img_16_new(100, 101, 3);
-
-is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
-ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image mask");
-is(Imager::i_img_bits($im_rgb), 16, "3 channel image bits");
-is(Imager::i_img_type($im_rgb), 0, "3 channel image type");
-
-my $redf = NCF(1, 0, 0);
-my $greenf = NCF(0, 1, 0);
-my $bluef = NCF(0, 0, 1);
-
-# fill with red
-for my $y (0..101) {
- Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
-}
-pass("fill with red");
-# basic sanity
-test_colorf_gpix($im_rgb, 0, 0, $redf, 0, "top-left");
-test_colorf_gpix($im_rgb, 99, 0, $redf, 0, "top-right");
-test_colorf_gpix($im_rgb, 0, 100, $redf, 0, "bottom left");
-test_colorf_gpix($im_rgb, 99, 100, $redf, 0, "bottom right");
-test_colorf_glin($im_rgb, 0, 0, [ ($redf) x 100 ], "first line");
-test_colorf_glin($im_rgb, 0, 100, [ ($redf) x 100 ], "last line");
-
-Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
-test_colorf_glin($im_rgb, 0, 1,
- [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
- "added some green in the middle");
-{
- my @samples;
- is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0 .. 2 ]), 12,
- "i_gsamp_bits all channels - count")
- or print "# ", Imager->_error_as_msg(), "\n";
- is_deeply(\@samples, [ 65535, 0, 0, 65535, 0, 0,
- 0, 65535, 0, 0, 65535, 0 ],
- "check samples retrieved");
- @samples = ();
- is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0, 2 ]), 8,
- "i_gsamp_bits some channels - count")
- or print "# ", Imager->_error_as_msg(), "\n";
- is_deeply(\@samples, [ 65535, 0, 65535, 0,
- 0, 0, 0, 0 ],
- "check samples retrieved");
- # fail gsamp
- is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0, 3 ]), undef,
- "i_gsamp_bits fail bad channel");
- is(Imager->_error_as_msg(), 'No channel 3 in this image', 'check message');
-
- is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 17, \@samples, 0, [ 0, 2 ]), 8,
- "i_gsamp_bits succeed high bits");
- is($samples[0], 131071, "check correct with high bits");
-
- # write some samples back
- my @wr_samples =
- (
- 0, 0, 65535,
- 65535, 0, 0,
- 0, 65535, 0,
- 65535, 65535, 0
- );
- is(Imager::i_psamp_bits($im_rgb, 18, 2, 16, [ 0 .. 2 ], \@wr_samples),
- 12, "write 16-bit samples")
- or print "# ", Imager->_error_as_msg(), "\n";
- @samples = ();
- is(Imager::i_gsamp_bits($im_rgb, 18, 22, 2, 16, \@samples, 0, [ 0 .. 2 ]), 12,
- "read them back")
- or print "# ", Imager->_error_as_msg(), "\n";
- is_deeply(\@samples, \@wr_samples, "check they match");
- my $c = Imager::i_get_pixel($im_rgb, 18, 2);
- is_color3($c, 0, 0, 255, "check it write to the right places");
-}
-
-# basic OO tests
-my $oo16img = Imager->new(xsize=>200, ysize=>201, bits=>16);
-ok($oo16img, "make a 16-bit oo image");
-is($oo16img->bits, 16, "test bits");
-isnt($oo16img->is_bilevel, "should not be considered mono");
-# make sure of error handling
-ok(!Imager->new(xsize=>0, ysize=>1, bits=>16),
- "fail to create a 0 pixel wide image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-
-ok(!Imager->new(xsize=>1, ysize=>0, bits=>16),
- "fail to create a 0 pixel high image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-
-ok(!Imager->new(xsize=>-1, ysize=>1, bits=>16),
- "fail to create a negative width image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-
-ok(!Imager->new(xsize=>1, ysize=>-1, bits=>16),
- "fail to create a negative height image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-
-ok(!Imager->new(xsize=>-1, ysize=>-1, bits=>16),
- "fail to create a negative width/height image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-
-ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>0),
- "fail to create a zero channel image");
-cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
- "and correct error message");
-ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>5),
- "fail to create a five channel image");
-cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
- "and correct error message");
-
-{
- # https://rt.cpan.org/Ticket/Display.html?id=8213
- # check for handling of memory allocation of very large images
- # only test this on 32-bit machines - on a 64-bit machine it may
- # result in trying to allocate 4Gb of memory, which is unfriendly at
- # least and may result in running out of memory, causing a different
- # type of exit
- SKIP: {
- use Config;
- $Config{ptrsize} == 4
- or skip("don't want to allocate 4Gb", 10);
- my $uint_range = 256 ** $Config{intsize};
- print "# range $uint_range\n";
- my $dim1 = int(sqrt($uint_range/2))+1;
-
- my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>16);
- is($im_b, undef, "integer overflow check - 1 channel");
-
- $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>16);
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>16);
- ok($im_b, "but same height ok");
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
-
- # do a similar test with a 3 channel image, so we're sure we catch
- # the same case where the third dimension causes the overflow
- my $dim3 = int(sqrt($uint_range / 3 / 2))+1;
-
- $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>16);
- is($im_b, undef, "integer overflow check - 3 channel");
-
- $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, bits=>16);
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, bits=>16);
- ok($im_b, "but same height ok");
-
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
-
- # check we can allocate a scanline, unlike double images the scanline
- # in the image itself is smaller than a line of i_fcolor
- # divide by 2 to get to int range, by 2 for 2 bytes/pixel, by 3 to
- # fit the image allocation in, but for the floats to overflow
- my $dim4 = $uint_range / 2 / 2 / 3;
- my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>1, bits=>16);
- is($im_o, undef, "integer overflow check - scanline");
- cmp_ok(Imager->errstr, '=~',
- qr/integer overflow calculating scanline allocation/,
- "check error message");
- }
-}
-
-{ # check the channel mask function
-
- my $im = Imager->new(xsize => 10, ysize=>10, bits=>16);
-
- mask_tests($im, 1.0/65535);
-}
-
-{ # convert to rgb16
- my $im = test_image();
- my $im16 = $im->to_rgb16;
- print "# check conversion to 16 bit\n";
- is($im16->bits, 16, "check bits");
- is_image($im, $im16, "check image data matches");
-}
-
-{ # empty image handling
- my $im = Imager->new;
- ok($im, "make empty image");
- ok(!$im->to_rgb16, "convert empty image to 16-bit");
- is($im->errstr, "to_rgb16: empty input image", "check message");
-}
-
-{ # bounds checks
- my $im = Imager->new(xsize => 10, ysize => 10, bits => 16);
- image_bounds_checks($im);
-}
-
-{
- my $im = Imager->new(xsize => 10, ysize => 10, bits => 16, channels => 3);
- my @wr_samples = map int(rand 65536), 1..30;
- is($im->setsamples('y' => 1, data => \@wr_samples, type => '16bit'),
- 30, "write 16-bit to OO image")
- or print "# ", $im->errstr, "\n";
- my @samples;
- is($im->getsamples(y => 1, target => \@samples, type => '16bit'),
- 30, "read 16-bit from OO image")
- or print "# ", $im->errstr, "\n";
- is_deeply(\@wr_samples, \@samples, "check it matches");
-}
-
-my $psamp_outside_error = "Image position outside of image";
-{ # psamp
- print "# psamp\n";
- my $imraw = Imager::i_img_16_new(10, 10, 3);
- {
- is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
- "i_psamp def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
- "i_psamp def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
- "check color written");
- is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
- "i_psamp channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
- "i_psamp channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 63, 32) x 10 ],
- "check full row");
- is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
- [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
- 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- }
- print "# end psamp tests\n";
-}
-
-{ # psampf
- print "# psampf\n";
- my $imraw = Imager::i_img_16_new(10, 10, 3);
- {
- is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
- "i_psampf def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 127, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
- "check color written");
- is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
- "i_psampf channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 127, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (127, 64, 32) x 10 ],
- "check full row");
- is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
- [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
- 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error,
- "check error message");
- }
- print "# end psampf tests\n";
-}
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t021sixteen.log";
-}
-
-sub _get_error {
- my @errors = Imager::i_errors();
- return join(": ", map $_->[0], @errors);
-}
-
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 136;
-BEGIN { use_ok(Imager => qw(:all :handy)) }
-
-use Imager::Test qw(test_image is_image is_color3);
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t022double.log");
-
-use Imager::Test qw(image_bounds_checks test_colorf_gpix test_colorf_glin mask_tests);
-
-use Imager::Color::Float;
-
-my $im_g = Imager::i_img_double_new(100, 101, 1);
-
-ok(Imager::i_img_getchannels($im_g) == 1,
- "1 channel image channel count mismatch");
-ok(Imager::i_img_getmask($im_g) & 1, "1 channel image bad mask");
-ok(Imager::i_img_virtual($im_g) == 0,
- "1 channel image thinks it is virtual");
-my $double_bits = length(pack("d", 1)) * 8;
-print "# $double_bits double bits\n";
-ok(Imager::i_img_bits($im_g) == $double_bits,
- "1 channel image has bits != $double_bits");
-ok(Imager::i_img_type($im_g) == 0, "1 channel image isn't direct");
-
-my @ginfo = i_img_info($im_g);
-ok($ginfo[0] == 100, "1 channel image width incorrect");
-ok($ginfo[1] == 101, "1 channel image height incorrect");
-
-undef $im_g;
-
-my $im_rgb = Imager::i_img_double_new(100, 101, 3);
-
-ok(Imager::i_img_getchannels($im_rgb) == 3,
- "3 channel image channel count mismatch");
-ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image bad mask");
-ok(Imager::i_img_bits($im_rgb) == $double_bits,
- "3 channel image has bits != $double_bits");
-ok(Imager::i_img_type($im_rgb) == 0, "3 channel image isn't direct");
-
-my $redf = NCF(1, 0, 0);
-my $greenf = NCF(0, 1, 0);
-my $bluef = NCF(0, 0, 1);
-
-# fill with red
-for my $y (0..101) {
- Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
-}
-
-# basic sanity
-test_colorf_gpix($im_rgb, 0, 0, $redf);
-test_colorf_gpix($im_rgb, 99, 0, $redf);
-test_colorf_gpix($im_rgb, 0, 100, $redf);
-test_colorf_gpix($im_rgb, 99, 100, $redf);
-test_colorf_glin($im_rgb, 0, 0, [ ($redf) x 100 ], 'sanity glin @0');
-test_colorf_glin($im_rgb, 0, 100, [ ($redf) x 100 ], 'sanity glin @100');
-
-Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
-test_colorf_glin($im_rgb, 0, 1,
- [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
- 'check after write');
-
-# basic OO tests
-my $ooimg = Imager->new(xsize=>200, ysize=>201, bits=>'double');
-ok($ooimg, "couldn't make double image");
-is($ooimg->bits, 'double', "oo didn't give double image");
-ok(!$ooimg->is_bilevel, 'not monochrome');
-
-# check that the image is copied correctly
-my $oocopy = $ooimg->copy;
-is($oocopy->bits, 'double', "oo copy didn't give double image");
-
-ok(!Imager->new(xsize=>0, ysize=>1, bits=>'double'),
- "fail making 0 width image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct message");
-ok(!Imager->new(xsize=>1, ysize=>0, bits=>'double'),
- "fail making 0 height image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct message");
-ok(!Imager->new(xsize=>-1, ysize=>1, bits=>'double'),
- "fail making -ve width image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct message");
-ok(!Imager->new(xsize=>1, ysize=>-1, bits=>'double'),
- "fail making -ve height image");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct message");
-ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>0),
- "fail making 0 channel image");
-cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
- "and correct message");
-ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>5),
- "fail making 5 channel image");
-cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
- "and correct message");
-
-{
- # https://rt.cpan.org/Ticket/Display.html?id=8213
- # check for handling of memory allocation of very large images
- # only test this on 32-bit machines - on a 64-bit machine it may
- # result in trying to allocate 4Gb of memory, which is unfriendly at
- # least and may result in running out of memory, causing a different
- # type of exit
- use Config;
- SKIP:
- {
- $Config{ptrsize} == 4
- or skip "don't want to allocate 4Gb", 8;
- my $uint_range = 256 ** $Config{intsize};
- my $dbl_size = $Config{doublesize} || 8;
- my $dim1 = int(sqrt($uint_range/$dbl_size))+1;
-
- my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>'double');
- is($im_b, undef, "integer overflow check - 1 channel");
-
- $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>'double');
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>'double');
- ok($im_b, "but same height ok");
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
-
- # do a similar test with a 3 channel image, so we're sure we catch
- # the same case where the third dimension causes the overflow
- my $dim3 = int(sqrt($uint_range / 3 / $dbl_size))+1;
-
- $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>'double');
- is($im_b, undef, "integer overflow check - 3 channel");
-
- $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, bits=>'double');
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, bits=>'double');
- ok($im_b, "but same height ok");
-
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
- }
-}
-
-{ # check the channel mask function
-
- my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
-
- mask_tests($im);
-}
-
-{ # bounds checking
- my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
- image_bounds_checks($im);
-}
-
-
-{ # convert to rgb double
- my $im = test_image();
- my $imdb = $im->to_rgb_double;
- print "# check conversion to double\n";
- is($imdb->bits, "double", "check bits");
- is_image($im, $imdb, "check image data matches");
-}
-
-{ # empty image handling
- my $im = Imager->new;
- ok($im, "make empty image");
- ok(!$im->to_rgb_double, "convert empty image to double");
- is($im->errstr, "to_rgb_double: empty input image", "check message");
-}
-
-my $psamp_outside_error = "Image position outside of image";
-{ # psamp
- print "# psamp\n";
- my $imraw = Imager::i_img_double_new(10, 10, 3);
- {
- is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
- "i_psamp def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
- "i_psamp def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
- "check color written");
- is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
- "i_psamp channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
- "i_psamp channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 63, 32) x 10 ],
- "check full row");
- is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
- [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
- 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- }
- print "# end psamp tests\n";
-}
-
-{ # psampf
- print "# psampf\n";
- my $imraw = Imager::i_img_double_new(10, 10, 3);
- {
- is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
- "i_psampf def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
- "check color written");
- is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
- "i_psampf channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 64, 32) x 10 ],
- "check full row");
- is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
- [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
- 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error, "check error message");
- is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error, "check error message");
- }
- print "# end psampf tests\n";
-}
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t022double.log";
-}
-
-sub _get_error {
- my @errors = Imager::i_errors();
- return join(": ", map $_->[0], @errors);
-}
+++ /dev/null
-#!perl -w
-# some of this is tested in t01introvert.t too
-use strict;
-use Test::More tests => 226;
-BEGIN { use_ok("Imager", ':handy'); }
-
-use Imager::Test qw(image_bounds_checks test_image is_color3 isnt_image is_color4 is_fcolor3);
-
-Imager->open_log(log => "testout/t023palette.log");
-
-sub isbin($$$);
-
-my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
-
-ok($img, "paletted image created");
-
-is($img->type, 'paletted', "got a paletted image");
-
-my $black = Imager::Color->new(0,0,0);
-my $red = Imager::Color->new(255,0,0);
-my $green = Imager::Color->new(0,255,0);
-my $blue = Imager::Color->new(0,0,255);
-
-my $white = Imager::Color->new(255,255,255);
-
-# add some color
-my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
-
-print "# blacki $blacki\n";
-ok(defined $blacki && $blacki == 0, "we got the first color");
-
-is($img->colorcount(), 4, "should have 4 colors");
-is($img->maxcolors, 256, "maxcolors always 256");
-
-my ($redi, $greeni, $bluei) = 1..3;
-
-my @all = $img->getcolors;
-ok(@all == 4, "all colors is 4");
-coloreq($all[0], $black, "first black");
-coloreq($all[1], $red, "then red");
-coloreq($all[2], $green, "then green");
-coloreq($all[3], $blue, "and finally blue");
-
-# keep this as an assignment, checking for scalar context
-# we don't want the last color, otherwise if the behaviour changes to
-# get all up to the last (count defaulting to size-index) we'd get a
-# false positive
-my $one_color = $img->getcolors(start=>$redi);
-ok($one_color->isa('Imager::Color'), "check scalar context");
-coloreq($one_color, $red, "and that it's what we want");
-
-# make sure we can find colors
-ok(!defined($img->findcolor(color=>$white)),
- "shouldn't be able to find white");
-ok($img->findcolor(color=>$black) == $blacki, "find black");
-ok($img->findcolor(color=>$red) == $redi, "find red");
-ok($img->findcolor(color=>$green) == $greeni, "find green");
-ok($img->findcolor(color=>$blue) == $bluei, "find blue");
-
-# various failure tests for setcolors
-ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
- "expect failure: low index");
-ok(!defined($img->setcolors(start=>1, colors=>[])),
- "expect failure: no colors");
-ok(!defined($img->setcolors(start=>5, colors=>[$white])),
- "expect failure: high index");
-
-# set the green index to white
-ok($img->setcolors(start => $greeni, colors => [$white]),
- "set a color");
-# and check it
-coloreq(scalar($img->getcolors(start=>$greeni)), $white,
- "make sure it was set");
-ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
-ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
-
-# write a few colors
-ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
- "save multiple");
-coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
-coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
-
-# put it back
-$img->setcolors(start=>$red, colors=>[$red, $green]);
-
-# draw on the image, make sure it stays paletted when it should
-ok($img->box(color=>$red, filled=>1), "fill with red");
-is($img->type, 'paletted', "paletted after fill");
-ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
- xmax=>40, ymax=>40), "green box");
-is($img->type, 'paletted', 'still paletted after box');
-# an AA line will almost certainly convert the image to RGB, don't use
-# an AA line here
-ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
- "draw a line");
-is($img->type, 'paletted', 'still paletted after line');
-
-# draw with white - should convert to direct
-ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
- xmax=>30, ymax=>30), "white box");
-is($img->type, 'direct', "now it should be direct");
-
-# various attempted to make a paletted image from our now direct image
-my $palimg = $img->to_paletted;
-ok($palimg, "we got an image");
-# they should be the same pixel for pixel
-ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
-
-# strange case: no color picking, and no colors
-# this was causing a segmentation fault
-$palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
-ok(!defined $palimg, "to paletted with an empty palette is an error");
-print "# ",$img->errstr,"\n";
-ok(scalar($img->errstr =~ /no colors available for translation/),
- "and got the correct msg");
-
-ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
- "fail on -ve height");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
- "fail on -ve width");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
- "fail on -ve width/height");
-cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
- "and correct error message");
-
-ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
- "fail on 0 channels");
-cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
- "and correct error message");
-ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
- "fail on 5 channels");
-cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
- "and correct error message");
-
-{
- # https://rt.cpan.org/Ticket/Display.html?id=8213
- # check for handling of memory allocation of very large images
- # only test this on 32-bit machines - on a 64-bit machine it may
- # result in trying to allocate 4Gb of memory, which is unfriendly at
- # least and may result in running out of memory, causing a different
- # type of exit
- use Config;
- SKIP:
- {
- skip("don't want to allocate 4Gb", 10)
- unless $Config{ptrsize} == 4;
-
- my $uint_range = 256 ** $Config{intsize};
- my $dim1 = int(sqrt($uint_range))+1;
-
- my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
- is($im_b, undef, "integer overflow check - 1 channel");
-
- $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
- ok($im_b, "but same height ok");
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
-
- # do a similar test with a 3 channel image, so we're sure we catch
- # the same case where the third dimension causes the overflow
- # for paletted images the third dimension can't cause an overflow
- # but make sure we didn't anything too dumb in the checks
- my $dim3 = $dim1;
-
- $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
- is($im_b, undef, "integer overflow check - 3 channel");
-
- $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
- ok($im_b, "but same width ok");
- $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
- ok($im_b, "but same height ok");
-
- cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
- "check the error message");
-
- # test the scanline allocation check
- # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
- # doesn't integer overflow, but the scanline of i_color (4/pixel) does
- my $dim4 = $uint_range / 3;
- my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
- is($im_o, undef, "integer overflow check - scanline size");
- cmp_ok(Imager->errstr, '=~',
- qr/integer overflow calculating scanline allocation/,
- "check error message");
- }
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
- my $warning;
- local $SIG{__WARN__} =
- sub {
- $warning = "@_";
- my $printed = $warning;
- $printed =~ s/\n$//;
- $printed =~ s/\n/\n\#/g;
- print "# ",$printed, "\n";
- };
- my $img = Imager->new(xsize=>10, ysize=>10);
- $img->to_paletted();
- cmp_ok($warning, '=~', 'void', "correct warning");
- cmp_ok($warning, '=~', 't023palette\\.t', "correct file");
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=12676
- # setcolors() has a fencepost error
- my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
-
- is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
- "add test colors");
- ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
- ok(!$img->setcolors(start=>2, colors=>[ $black ]),
- "set after the last color");
-}
-
-{ # https://rt.cpan.org/Ticket/Display.html?id=20056
- # added named color support to addcolor/setcolor
- my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
- is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
- "add colors as strings instead of objects");
- my @colors = $img->getcolors;
- iscolor($colors[0], $black, "check first color");
- iscolor($colors[1], $red, "check second color");
- ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
- "setcolors as strings instead of objects");
- @colors = $img->getcolors;
- iscolor($colors[0], $green, "check first color");
- iscolor($colors[1], $blue, "check second color");
-
- # make sure we handle bad colors correctly
- is($img->colorcount, 2, "start from a known state");
- is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
- "fail to add unknown color");
- is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
- is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
- "fail to set to unknown color");
- is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
-}
-
-{ # https://rt.cpan.org/Ticket/Display.html?id=20338
- # OO interface to i_glin/i_plin
- my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
- is($im->addcolors(colors => [ "#000", "#F00", "#0F0", "#00F" ]), "0 but true",
- "add some test colors")
- or print "# ", $im->errstr, "\n";
- # set a pixel to check
- $im->setpixel(x => 1, 'y' => 0, color => "#0F0");
- is_deeply([ $im->getscanline('y' => 0, type=>'index') ],
- [ 0, 2, (0) x 8 ], "getscanline index in list context");
- isbin($im->getscanline('y' => 0, type=>'index'),
- "\x00\x02" . "\x00" x 8,
- "getscanline index in scalar context");
- is($im->setscanline('y' => 0, pixels => [ 1, 2, 0, 3 ], type => 'index'),
- 4, "setscanline with list");
- is($im->setscanline('y' => 0, x => 4, pixels => pack("C*", 3, 2, 1, 0, 3),
- type => 'index'),
- 5, "setscanline with pv");
- is_deeply([ $im->getscanline(type => 'index', 'y' => 0) ],
- [ 1, 2, 0, 3, 3, 2, 1, 0, 3, 0 ],
- "check values set");
- eval { # should croak on OOR index
- $im->setscanline('y' => 1, pixels => [ 255 ], type=>'index');
- };
- ok($@, "croak on setscanline() to invalid index");
- eval { # same again with pv
- $im->setscanline('y' => 1, pixels => "\xFF", type => 'index');
- };
- ok($@, "croak on setscanline() with pv to invalid index");
-}
-
-{
- print "# make_colors => mono\n";
- # test mono make_colors
- my $imrgb = Imager->new(xsize => 10, ysize => 10);
- $imrgb->setpixel(x => 0, 'y' => 0, color => '#FFF');
- $imrgb->setpixel(x => 1, 'y' => 0, color => '#FF0');
- $imrgb->setpixel(x => 2, 'y' => 0, color => '#000');
- my $mono = $imrgb->to_paletted(make_colors => 'mono',
- translate => 'closest');
- is($mono->type, 'paletted', "check we get right image type");
- is($mono->colorcount, 2, "only 2 colors");
- my ($is_mono, $ziw) = $mono->is_bilevel;
- ok($is_mono, "check monochrome check true");
- is($ziw, 0, "check ziw false");
- my @colors = $mono->getcolors;
- iscolor($colors[0], $black, "check first entry");
- iscolor($colors[1], $white, "check second entry");
- my @pixels = $mono->getscanline(x => 0, 'y' => 0, width => 3, type=>'index');
- is($pixels[0], 1, "check white pixel");
- is($pixels[1], 1, "check yellow pixel");
- is($pixels[2], 0, "check black pixel");
-}
-
-{ # check for the various mono images we accept
- my $mono_8_bw_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
- type => 'paletted');
- ok($mono_8_bw_3->addcolors(colors => [ qw/000000 FFFFFF/ ]),
- "mono8bw3 - add colors");
- ok($mono_8_bw_3->is_bilevel, "it's mono");
- is(($mono_8_bw_3->is_bilevel)[1], 0, 'zero not white');
-
- my $mono_8_wb_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
- type => 'paletted');
- ok($mono_8_wb_3->addcolors(colors => [ qw/FFFFFF 000000/ ]),
- "mono8wb3 - add colors");
- ok($mono_8_wb_3->is_bilevel, "it's mono");
- is(($mono_8_wb_3->is_bilevel)[1], 1, 'zero is white');
-
- my $mono_8_bw_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
- type => 'paletted');
- ok($mono_8_bw_1->addcolors(colors => [ qw/000000 FFFFFF/ ]),
- "mono8bw - add colors");
- ok($mono_8_bw_1->is_bilevel, "it's mono");
- is(($mono_8_bw_1->is_bilevel)[1], 0, 'zero not white');
-
- my $mono_8_wb_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
- type => 'paletted');
- ok($mono_8_wb_1->addcolors(colors => [ qw/FFFFFF 000000/ ]),
- "mono8wb - add colors");
- ok($mono_8_wb_1->is_bilevel, "it's mono");
- is(($mono_8_wb_1->is_bilevel)[1], 1, 'zero is white');
-}
-
-{ # check bounds checking
- my $im = Imager->new(xsize => 10, ysize => 10, type=>'paletted');
- ok($im->addcolors(colors => [ $black ]), "add color of pixel bounds check writes");
-
- image_bounds_checks($im);
-}
-
-{ # test colors array returns colors
- my $data;
- my $im = test_image();
- my @colors;
- my $imp = $im->to_paletted(colors => \@colors,
- make_colors => 'webmap',
- translate => 'closest');
- ok($imp, "made paletted");
- is(@colors, 216, "should be 216 colors in the webmap");
- is_color3($colors[0], 0, 0, 0, "first should be 000000");
- is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
- is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
-}
-
-{ # RT 68508
- my $im = Imager->new(xsize => 10, ysize => 10);
- $im->box(filled => 1, color => Imager::Color->new(255, 0, 0));
- my $palim = $im->to_paletted(make_colors => "mono", translate => "errdiff");
- ok($palim, "convert to mono with error diffusion");
- my $blank = Imager->new(xsize => 10, ysize => 10);
- isnt_image($palim, $blank, "make sure paletted isn't all black");
-}
-
-{ # check validation of palette entries
- my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
- $im->addcolors(colors => [ $black, $red ]);
- {
- my $no_croak = eval {
- $im->setscanline(y => 0, type => 'index', pixels => [ 0, 1 ]);
- 1;
- };
- ok($no_croak, "valid values don't croak");
- }
- {
- my $no_croak = eval {
- $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 0, 1));
- 1;
- };
- ok($no_croak, "valid values don't croak (packed)");
- }
- {
- my $no_croak = eval {
- $im->setscanline(y => 0, type => 'index', pixels => [ 2, 255 ]);
- 1;
- };
- ok(!$no_croak, "invalid values do croak");
- }
- {
- my $no_croak = eval {
- $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 2, 255));
- 1;
- };
- ok(!$no_croak, "invalid values do croak (packed)");
- }
-}
-
-{
- my $im = Imager->new(xsize => 1, ysize => 1);
- my $im_bad = Imager->new;
- {
- my @map = Imager->make_palette({});
- ok(!@map, "make_palette should fail with no images");
- is(Imager->errstr, "make_palette: supply at least one image",
- "check error message");
- }
- {
- my @map = Imager->make_palette({}, $im, $im_bad, $im);
- ok(!@map, "make_palette should fail with an empty image");
- is(Imager->errstr, "make_palette: image 2 is empty",
- "check error message");
- }
- {
- my @map = Imager->make_palette({ make_colors => "mono" }, $im);
- is(@map, 2, "mono should make 2 color palette")
- or skip("unexpected color count", 2);
- is_color4($map[0], 0, 0, 0, 255, "check map[0]");
- is_color4($map[1], 255, 255, 255, 255, "check map[1]");
- }
- {
- my @map = Imager->make_palette({ make_colors => "gray4" }, $im);
- is(@map, 4, "gray4 should make 4 color palette")
- or skip("unexpected color count", 4);
- is_color4($map[0], 0, 0, 0, 255, "check map[0]");
- is_color4($map[1], 85, 85, 85, 255, "check map[1]");
- is_color4($map[2], 170, 170, 170, 255, "check map[2]");
- is_color4($map[3], 255, 255, 255, 255, "check map[3]");
- }
- {
- my @map = Imager->make_palette({ make_colors => "gray16" }, $im);
- is(@map, 16, "gray16 should make 16 color palette")
- or skip("unexpected color count", 4);
- is_color4($map[0], 0, 0, 0, 255, "check map[0]");
- is_color4($map[1], 17, 17, 17, 255, "check map[1]");
- is_color4($map[2], 34, 34, 34, 255, "check map[2]");
- is_color4($map[15], 255, 255, 255, 255, "check map[15]");
- }
- {
- my @map = Imager->make_palette({ make_colors => "gray" }, $im);
- is(@map, 256, "gray16 should make 256 color palette")
- or skip("unexpected color count", 4);
- is_color4($map[0], 0, 0, 0, 255, "check map[0]");
- is_color4($map[1], 1, 1, 1, 255, "check map[1]");
- is_color4($map[33], 33, 33, 33, 255, "check map[2]");
- is_color4($map[255], 255, 255, 255, 255, "check map[15]");
- }
-}
-
-my $psamp_outside_error = "Image position outside of image";
-{ # psamp
- print "# psamp\n";
- my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
- my @colors =
- (
- NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
- NC(64, 0, 192), NC(255, 128, 0), NC(64, 32, 0),
- NC(128, 63, 32), NC(255, 128, 32), NC(64, 32, 16),
- );
- is(Imager::i_addcolors($imraw, @colors), "0 but true",
- "add colors needed for testing");
- {
- is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
- "i_psamp def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
- "i_psamp def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
- "check color written");
- is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
- "i_psamp channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
- "i_psamp channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 63, 32) x 10 ],
- "check full row");
- is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
- [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
- 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
- undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error, "check message");
- is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error, "check message");
- is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error, "check message");
- is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error, "check message");
- }
- ok(Imager::i_img_type($imraw), "still paletted");
- print "# end psamp tests\n";
-}
-
-{ # psampf
- print "# psampf\n";
- my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
- my @colors =
- (
- NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
- NC(64, 0, 191), NC(255, 128, 0), NC(64, 32, 0),
- NC(128, 64, 32), NC(255, 128, 32), NC(64, 32, 16),
- );
- is(Imager::i_addcolors($imraw, @colors), "0 but true",
- "add colors needed for testing");
- {
- is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
- "i_psampf def channels, 3 samples");
- is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
- "check color written");
- Imager::i_img_setmask($imraw, 5);
- is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf def channels, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
- "check color written");
- is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
- "i_psampf channels listed, 3 samples, masked");
- is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
- "check color written");
- Imager::i_img_setmask($imraw, ~0);
- is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
- "i_psampf channels [0, 1], 4 samples");
- is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
- "check first color written");
- is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
- "check second color written");
- is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
- "write a full row");
- is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
- [ (128, 64, 32) x 10 ],
- "check full row");
- is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
- [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
- 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
- }
- { # errors we catch
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
- is(_get_error(), "No channel 3 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
- undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
- is(_get_error(), "No channel -1 in this image",
- "check error message");
- is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
- "negative y");
- is(_get_error(), $psamp_outside_error, "check message");
- is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
- "y overflow");
- is(_get_error(), $psamp_outside_error, "check message");
- is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
- "negative x");
- is(_get_error(), $psamp_outside_error, "check message");
- is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
- "x overflow");
- is(_get_error(), $psamp_outside_error, "check message");
- }
- ok(Imager::i_img_type($imraw), "still paletted");
- print "# end psampf tests\n";
-}
-
-{ # 75258 - gpixf() broken for paletted images
- my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
- ok($im, "make a test image");
- my @colors = ( $black, $red, $green, $blue );
- is($im->addcolors(colors => \@colors), "0 but true",
- "add some colors");
- $im->setpixel(x => 0, y => 0, color => $red);
- $im->setpixel(x => 1, y => 0, color => $green);
- $im->setpixel(x => 2, y => 0, color => $blue);
- is_fcolor3($im->getpixel(x => 0, y => 0, type => "float"),
- 1.0, 0, 0, "get a pixel in float form, make sure it's red");
- is_fcolor3($im->getpixel(x => 1, y => 0, type => "float"),
- 0, 1.0, 0, "get a pixel in float form, make sure it's green");
- is_fcolor3($im->getpixel(x => 2, y => 0, type => "float"),
- 0, 0, 1.0, "get a pixel in float form, make sure it's blue");
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->to_paletted, "can't convert an empty image");
- is($empty->errstr, "to_paletted: empty input image",
- "check error message");
-
- is($empty->addcolors(colors => [ $black ]), -1,
- "can't addcolors() to an empty image");
- is($empty->errstr, "addcolors: empty input image",
- "check error message");
-
- ok(!$empty->setcolors(colors => [ $black ]),
- "can't setcolors() to an empty image");
- is($empty->errstr, "setcolors: empty input image",
- "check error message");
-
- ok(!$empty->getcolors(),
- "can't getcolors() from an empty image");
- is($empty->errstr, "getcolors: empty input image",
- "check error message");
-
- is($empty->colorcount, -1, "can't colorcount() an empty image");
- is($empty->errstr, "colorcount: empty input image",
- "check error message");
-
- is($empty->maxcolors, -1, "can't maxcolors() an empty image");
- is($empty->errstr, "maxcolors: empty input image",
- "check error message");
-
- is($empty->findcolor(color => $blue), undef,
- "can't findcolor an empty image");
- is($empty->errstr, "findcolor: empty input image",
- "check error message");
-}
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t023palette.log"
-}
-
-sub iscolor {
- my ($c1, $c2, $msg) = @_;
-
- my $builder = Test::Builder->new;
- my @c1 = $c1->rgba;
- my @c2 = $c2->rgba;
- if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
- $msg)) {
- $builder->diag(<<DIAG);
- got color: [ @c1 ]
- expected color: [ @c2 ]
-DIAG
- }
-}
-
-sub isbin ($$$) {
- my ($got, $expected, $msg) = @_;
-
- my $builder = Test::Builder->new;
- if (!$builder->ok($got eq $expected, $msg)) {
- (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
- (my $exp_dec = $expected) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
- $builder->diag(<<DIAG);
- got: "$got_dec"
- expected: "$exp_dec"
-DIAG
- }
-}
-
-sub coloreq {
- my ($left, $right, $comment) = @_;
-
- my ($rl, $gl, $bl, $al) = $left->rgba;
- my ($rr, $gr, $br, $ar) = $right->rgba;
-
- print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
- ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
- $comment);
-}
-
-sub _get_error {
- my @errors = Imager::i_errors();
- return join(": ", map $_->[0], @errors);
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager;
-use Imager::Test qw(test_image test_image_16 test_image_mono test_image_gray test_image_gray_16 test_image_double test_image_named);
-use Test::More tests => 60;
-
-# test Imager::Test
-
-for my $named (0, 1) {
- my $named_desc = $named ? " (by name)" : "";
- {
- my $im = $named ? test_image_named("basic") : test_image();
- ok($im, "got basic test image$named_desc");
- is($im->type, "direct", "check basic image type");
- is($im->getchannels, 3, "check basic image channels");
- is($im->bits, 8, "check basic image bits");
- ok(!$im->is_bilevel, "check basic isn't mono");
- }
- {
- my $im = $named ? test_image_named("basic16") : test_image_16();
- ok($im, "got 16-bit basic test image$named_desc");
- is($im->type, "direct", "check 16-bit basic image type");
- is($im->getchannels, 3, "check 16-bit basic image channels");
- is($im->bits, 16, "check 16-bit basic image bits");
- ok(!$im->is_bilevel, "check 16-bit basic isn't mono");
- }
-
- {
- my $im = $named ? test_image_named("basic_double") : test_image_double();
- ok($im, "got double basic test image$named_desc");
- is($im->type, "direct", "check double basic image type");
- is($im->getchannels, 3, "check double basic image channels");
- is($im->bits, "double", "check double basic image bits");
- ok(!$im->is_bilevel, "check double basic isn't mono");
- }
- {
- my $im = $named ? test_image_named("gray") : test_image_gray();
- ok($im, "got gray test image$named_desc");
- is($im->type, "direct", "check gray image type");
- is($im->getchannels, 1, "check gray image channels");
- is($im->bits, 8, "check gray image bits");
- ok(!$im->is_bilevel, "check gray isn't mono");
- $im->write(file => "testout/t03gray.pgm");
- }
-
- {
- my $im = $named ? test_image_named("gray16") : test_image_gray_16();
- ok($im, "got gray test image$named_desc");
- is($im->type, "direct", "check 16-bit gray image type");
- is($im->getchannels, 1, "check 16-bit gray image channels");
- is($im->bits, 16, "check 16-bit gray image bits");
- ok(!$im->is_bilevel, "check 16-bit isn't mono");
- $im->write(file => "testout/t03gray16.pgm");
- }
-
- {
- my $im = $named ? test_image_named("mono") : test_image_mono();
- ok($im, "got mono image$named_desc");
- is($im->type, "paletted", "check mono image type");
- is($im->getchannels, 3, "check mono image channels");
- is($im->bits, 8, "check mono image bits");
- ok($im->is_bilevel, "check mono is mono");
- $im->write(file => "testout/t03mono.pbm");
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 7;
-BEGIN { use_ok("Imager", ":all") }
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t05error.log");
-
-# try to read an invalid pnm file
-open FH, "< testimg/junk.ppm"
- or die "Cannot open testin/junk: $!";
-binmode(FH);
-my $IO = Imager::io_new_fd(fileno(FH));
-my $im = i_readpnm_wiol($IO, -1);
-SKIP:{
- ok(!$im, "read of junk.ppm should have failed")
- or skip("read didn't fail!", 5);
-
- my @errors = Imager::i_errors();
-
- is(scalar @errors, 1, "got the errors")
- or skip("no errors to check", 4);
-
- SKIP:
- {
- my $error0 = $errors[0];
- is(ref $error0, "ARRAY", "entry 0 is an array ref")
- or skip("entry 0 not an array", 3);
-
- is(scalar @$error0, 2, "entry 0 has 2 elements")
- or skip("entry 0 doesn't have enough elements", 2);
-
- is($error0->[0], "while skipping to height", "check message");
- is($error0->[1], "0", "error code should be 0");
- }
-}
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t05error.log";
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 274;
-use Imager::Test qw(is_image);
-# for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
-use IO::Seekable;
-use Config;
-
-BEGIN { use_ok(Imager => ':all') };
-
--d "testout" or mkdir "testout";
-
-$| = 1;
-
-Imager->open_log(log => "testout/t07iolayer.log");
-
-undef($/);
-# start by testing io buffer
-
-my $data="P2\n2 2\n255\n 255 0\n0 255\n";
-my $IO = Imager::io_new_buffer($data);
-my $im = Imager::i_readpnm_wiol($IO, -1);
-
-ok($im, "read from data io");
-
-open(FH, ">testout/t07.ppm") or die $!;
-binmode(FH);
-my $fd = fileno(FH);
-my $IO2 = Imager::io_new_fd( $fd );
-Imager::i_writeppm_wiol($im, $IO2);
-close(FH);
-undef($im);
-
-open(FH, "<testimg/penguin-base.ppm");
-binmode(FH);
-$data = <FH>;
-close(FH);
-my $IO3 = Imager::IO->new_buffer($data);
-#undef($data);
-$im = Imager::i_readpnm_wiol($IO3, -1);
-
-ok($im, "read from buffer, for compare");
-undef $IO3;
-
-open(FH, "<testimg/penguin-base.ppm") or die $!;
-binmode(FH);
-$fd = fileno(FH);
-my $IO4 = Imager::IO->new_fd( $fd );
-my $im2 = Imager::i_readpnm_wiol($IO4, -1);
-close(FH);
-undef($IO4);
-
-ok($im2, "read from file, for compare");
-
-is(i_img_diff($im, $im2), 0, "compare images");
-undef($im2);
-
-my $IO5 = Imager::io_new_bufchain();
-Imager::i_writeppm_wiol($im, $IO5);
-my $data2 = Imager::io_slurp($IO5);
-undef($IO5);
-
-ok($data2, "check we got data from bufchain");
-
-my $IO6 = Imager::io_new_buffer($data2);
-my $im3 = Imager::i_readpnm_wiol($IO6, -1);
-
-is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
-
-my $work = $data;
-my $pos = 0;
-sub io_reader {
- my ($size, $maxread) = @_;
- my $out = substr($work, $pos, $maxread);
- $pos += length $out;
- $out;
-}
-sub io_reader2 {
- my ($size, $maxread) = @_;
- my $out = substr($work, $pos, $maxread);
- $pos += length $out;
- $out;
-}
-my $IO7 = Imager::IO->new_cb(undef, \&io_reader, undef, undef);
-ok($IO7, "making readcb object");
-my $im4 = Imager::i_readpnm_wiol($IO7, -1);
-ok($im4, "read from cb");
-ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
-
-$pos = 0;
-$IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
-ok($IO7, "making short readcb object");
-my $im5 = Imager::i_readpnm_wiol($IO7, -1);
-ok($im4, "read from cb2");
-is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
-
-sub io_writer {
- my ($what) = @_;
- substr($work, $pos, $pos+length $what) = $what;
- $pos += length $what;
-
- 1;
-}
-
-my $did_close;
-sub io_close {
- ++$did_close;
-}
-
-my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
-ok($IO8, "making writecb object");
-$pos = 0;
-$work = '';
-ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
-# I originally compared this to $data, but that doesn't include the
-# Imager header
-is($work, $data2, "write image match");
-ok($did_close, "did close");
-
-# with a short buffer, no closer
-my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
-ok($IO9, "making short writecb object");
-$pos = 0;
-$work = '';
-ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
-is($work, $data2, "short write image match");
-
-{
- my $buf_data = "Test data";
- my $io9 = Imager::io_new_buffer($buf_data);
- is(ref $io9, "Imager::IO", "check class");
- my $work;
- is($io9->raw_read($work, 4), 4, "read 4 from buffer object");
- is($work, "Test", "check data read");
- is($io9->raw_read($work, 5), 5, "read the rest");
- is($work, " data", "check data read");
- is($io9->raw_seek(5, SEEK_SET), 5, "seek");
- is($io9->raw_read($work, 5), 4, "short read");
- is($work, "data", "check data read");
- is($io9->raw_seek(-1, SEEK_CUR), 8, "seek relative");
- is($io9->raw_seek(-5, SEEK_END), 4, "seek relative to end");
- is($io9->raw_seek(-10, SEEK_CUR), -1, "seek failure");
- undef $io9;
-}
-{
- my $io = Imager::IO->new_bufchain();
- is(ref $io, "Imager::IO", "check class");
- is($io->raw_write("testdata"), 8, "check write");
- is($io->raw_seek(-8, SEEK_CUR), 0, "seek relative");
- my $work;
- is($io->raw_read($work, 8), 8, "check read");
- is($work, "testdata", "check data read");
- is($io->raw_seek(-3, SEEK_END), 5, "seek end relative");
- is($io->raw_read($work, 5), 3, "short read");
- is($work, "ata", "check read data");
- is($io->raw_seek(4, SEEK_SET), 4, "absolute seek to write some");
- is($io->raw_write("testdata"), 8, "write");
- is($io->raw_seek(0, SEEK_CUR), 12, "check size");
- $io->raw_close();
-
- # grab the data
- my $data = Imager::io_slurp($io);
- is($data, "testtestdata", "check we have the right data");
-}
-
-{ # callback failure checks
- my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
- # scalar context
- my $buffer;
- my $read_result = $fail_io->raw_read($buffer, 10);
- is($read_result, undef, "read failure undef in scalar context");
- my @read_result = $fail_io->raw_read($buffer, 10);
- is(@read_result, 0, "empty list in list context");
- $read_result = $fail_io->raw_read2(10);
- is($read_result, undef, "raw_read2 failure (scalar)");
- @read_result = $fail_io->raw_read2(10);
- is(@read_result, 0, "raw_read2 failure (list)");
-
- my $write_result = $fail_io->raw_write("test");
- is($write_result, -1, "failed write");
-
- my $seek_result = $fail_io->raw_seek(-1, SEEK_SET);
- is($seek_result, -1, "failed seek");
-}
-
-{ # callback success checks
- my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
- # scalar context
- my $buffer;
- my $read_result = $good_io->raw_read($buffer, 10);
- is($read_result, 8, "read success (scalar)");
- is($buffer, "testdata", "check data");
- my @read_result = $good_io->raw_read($buffer, 10);
- is_deeply(\@read_result, [ 8 ], "read success (list)");
- is($buffer, "testdata", "check data");
- $read_result = $good_io->raw_read2(10);
- is($read_result, "testdata", "read2 success (scalar)");
- @read_result = $good_io->raw_read2(10);
- is_deeply(\@read_result, [ "testdata" ], "read2 success (list)");
-}
-
-{ # end of file
- my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
- my $buffer;
- my $read_result = $eof_io->raw_read($buffer, 10);
- is($read_result, 0, "read eof (scalar)");
- is($buffer, '', "check data");
- my @read_result = $eof_io->raw_read($buffer, 10);
- is_deeply(\@read_result, [ 0 ], "read eof (list)");
- is($buffer, '', "check data");
-}
-
-{ # no callbacks
- my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
- is($none_io->raw_write("test"), -1, "write with no writecb should fail");
- my $buffer;
- is($none_io->raw_read($buffer, 10), undef, "read with no readcb should fail");
- is($none_io->raw_seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
-}
-
-SKIP:
-{ # make sure we croak when trying to write a string with characters over 0xff
- # the write callback shouldn't get called
- skip("no native UTF8 support in this version of perl", 2)
- unless $] >= 5.006;
- my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
- my $data = chr(0x100);
- is(ord $data, 0x100, "make sure we got what we expected");
- my $result =
- eval {
- $io->raw_write($data);
- 1;
- };
- ok(!$result, "should have croaked")
- and print "# $@\n";
-}
-
-{ # 0.52 left some debug code in a path that wasn't tested, make sure
- # that path is tested
- # http://rt.cpan.org/Ticket/Display.html?id=20705
- my $io = Imager::io_new_cb
- (
- sub {
- print "# write $_[0]\n";
- 1
- },
- sub {
- print "# read $_[0], $_[1]\n";
- "x" x $_[1]
- },
- sub { print "# seek\n"; 0 },
- sub { print "# close\n"; 1 });
- my $buffer;
- is($io->raw_read($buffer, 10), 10, "read 10");
- is($buffer, "xxxxxxxxxx", "read value");
- ok($io->raw_write("foo"), "write");
- is($io->raw_close, 0, "close");
-}
-
-SKIP:
-{ # fd_seek write failure
- -c "/dev/full"
- or skip("No /dev/full", 3);
- open my $fh, "> /dev/full"
- or skip("Can't open /dev/full: $!", 3);
- my $io = Imager::io_new_fd(fileno($fh));
- ok($io, "make fd io for /dev/full");
- Imager::i_clear_error();
- is($io->raw_write("test"), -1, "fail to write");
- my $msg = Imager->_error_as_msg;
- like($msg, qr/^write\(\) failure: /, "check error message");
- print "# $msg\n";
-
- # /dev/full succeeds on seek on Linux
-
- undef $io;
-}
-
-SKIP:
-{ # fd_seek seek failure
- my $seekfail = "testout/t07seekfail.dat";
- open my $fh, "> $seekfail"
- or skip("Can't open $seekfail: $!", 3);
- my $io = Imager::io_new_fd(fileno($fh));
- ok($io, "make fd io for $seekfail");
-
- Imager::i_clear_error();
- is($io->raw_seek(-1, SEEK_SET), -1, "shouldn't be able to seek to -1");
- my $msg = Imager->_error_as_msg;
- like($msg, qr/^lseek\(\) failure: /, "check error message");
- print "# $msg\n";
-
- undef $io;
- close $fh;
- unlink $seekfail;
-}
-
-SKIP:
-{ # fd_seek read failure
- open my $fh, "> testout/t07writeonly.txt"
- or skip("Can't open testout/t07writeonly.txt: $!", 3);
- my $io = Imager::io_new_fd(fileno($fh));
- ok($io, "make fd io for write-only");
-
- Imager::i_clear_error();
- my $buf;
- is($io->raw_read($buf, 10), undef,
- "file open for write shouldn't be readable");
- my $msg = Imager->_error_as_msg;
- like($msg, qr/^read\(\) failure: /, "check error message");
- print "# $msg\n";
-
- undef $io;
-}
-
-SKIP:
-{ # fd_seek eof
- open my $fh, "> testout/t07readeof.txt"
- or skip("Can't open testout/t07readeof.txt: $!", 5);
- binmode $fh;
- print $fh "test";
- close $fh;
- open my $fhr, "< testout/t07readeof.txt",
- or skip("Can't open testout/t07readeof.txt: $!", 5);
- my $io = Imager::io_new_fd(fileno($fhr));
- ok($io, "make fd io for read eof");
-
- Imager::i_clear_error();
- my $buf;
- is($io->raw_read($buf, 10), 4,
- "10 byte read on 4 byte file should return 4");
- my $msg = Imager->_error_as_msg;
- is($msg, "", "should be no error message")
- or print STDERR "# read(4) message is: $msg\n";
-
- Imager::i_clear_error();
- $buf = '';
- is($io->raw_read($buf, 10), 0,
- "10 byte read at end of 4 byte file should return 0 (eof)");
-
- $msg = Imager->_error_as_msg;
- is($msg, "", "should be no error message")
- or print STDERR "# read(4), eof message is: $msg\n";
-
- undef $io;
-}
-
-{ # buffered I/O
- my $data="P2\n2 2\n255\n 255 0\n0 255\n";
- my $io = Imager::io_new_buffer($data);
-
- my $c = $io->getc();
-
- is($c, ord "P", "getc");
- my $peekc = $io->peekc();
-
- is($peekc, ord "2", "peekc");
-
- my $peekn = $io->peekn(2);
- is($peekn, "2\n", "peekn");
-
- $c = $io->getc();
- is($c, ord "2", "getc after peekc/peekn");
-
- is($io->seek(0, SEEK_SET), "0", "seek");
- is($io->getc, ord "P", "check we got back to the start");
-}
-
-{ # test closecb result is propagated
- my $success_cb = sub { 1 };
- my $failure_cb = sub { 0 };
-
- {
- my $io = Imager::io_new_cb(undef, $success_cb, undef, $success_cb);
- is($io->close(), 0, "test successful close");
- }
- {
- my $io = Imager::io_new_cb(undef, $success_cb, undef, $failure_cb);
- is($io->close(), -1, "test failed close");
- }
-}
-
-{ # buffered coverage/function tests
- # some data to play with
- my $base = pack "C*", map rand(26) + ord("a"), 0 .. 20_001;
-
- { # buffered accessors
- my $io = Imager::io_new_buffer($base);
- ok($io->set_buffered(0), "set unbuffered");
- ok(!$io->is_buffered, "verify unbuffered");
- ok($io->set_buffered(1), "set buffered");
- ok($io->is_buffered, "verify buffered");
- }
-
- { # initial i_io_read(), buffered
- my $pos = 0;
- my $ops = "";
- my $work = $base;
- my $read = sub {
- my ($size) = @_;
-
- my $req_size = $size;
-
- if ($pos + $size > length $work) {
- $size = length($work) - $pos;
- }
-
- my $result = substr($work, $pos, $size);
- $pos += $size;
- $ops .= "R$req_size>$size;";
-
- print "# read $req_size>$size\n";
-
- return $result;
- };
- my $write = sub {
- my ($data) = @_;
-
- substr($work, $pos, length($data), $data);
-
- return 1;
- };
- {
- my $io = Imager::io_new_cb(undef, $read, undef, undef);
- my $buf;
- is($io->read($buf, 1000), 1000, "read initial 1000");
- is($buf, substr($base, 0, 1000), "check data read");
- is($ops, "R8192>8192;", "check read op happened to buffer size");
-
- undef $buf;
- is($io->read($buf, 1001), 1001, "read another 1001");
- is($buf, substr($base, 1000, 1001), "check data read");
- is($ops, "R8192>8192;", "should be no further reads");
-
- undef $buf;
- is($io->read($buf, 40_000), length($base) - 2001,
- "read the rest in one chunk");
- is($buf, substr($base, 2001), "check the data read");
- my $buffer_left = 8192 - 2001;
- my $after_buffer = length($base) - 8192;
- is($ops, "R8192>8192;R".(40_000 - $buffer_left).">$after_buffer;R21999>0;",
- "check we tried to read the remainder");
- }
- {
- # read after write errors
- my $io = Imager::io_new_cb($write, $read, undef, undef);
- is($io->write("test"), 4, "write 4 bytes, io in write mode");
- is($io->read2(10), undef, "read should fail");
- is($io->peekn(10), undef, "peekn should fail");
- is($io->getc(), -1, "getc should fail");
- is($io->peekc(), -1, "peekc should fail");
- }
- }
-
- {
- my $io = Imager::io_new_buffer($base);
- print "# buffer fill check\n";
- ok($io, "make memory io");
- my $buf;
- is($io->read($buf, 4096), 4096, "read 4k");
- is($buf, substr($base, 0, 4096), "check data is correct");
-
- # peek a bit
- undef $buf;
- is($io->peekn(5120), substr($base, 4096, 5120),
- "peekn() 5120, which should exceed the buffer, and only read the left overs");
- }
-
- { # initial peekn
- my $io = Imager::io_new_buffer($base);
- is($io->peekn(10), substr($base, 0, 10),
- "make sure initial peekn() is sane");
- is($io->read2(10), substr($base, 0, 10),
- "and that reading 10 gets the expected data");
- }
-
- { # oversize peekn
- my $io = Imager::io_new_buffer($base);
- is($io->peekn(10_000), substr($base, 0, 8192),
- "peekn() larger than buffer should return buffer-size bytes");
- }
-
- { # small peekn then large peekn with a small I/O back end
- # this might happen when reading from a socket
- my $work = $base;
- my $pos = 0;
- my $ops = '';
- my $reader = sub {
- my ($size) = @_;
-
- my $req_size = $size;
- # do small reads, to trigger a possible bug
- if ($size > 10) {
- $size = 10;
- }
-
- if ($pos + $size > length $work) {
- $size = length($work) - $pos;
- }
-
- my $result = substr($work, $pos, $size);
- $pos += $size;
- $ops .= "R$req_size>$size;";
-
- print "# read $req_size>$size\n";
-
- return $result;
- };
- my $io = Imager::io_new_cb(undef, $reader, undef, undef);
- ok($io, "small reader io");
- is($io->peekn(25), substr($base, 0, 25), "peek 25");
- is($ops, "R8192>10;R8182>10;R8172>10;",
- "check we got the raw calls expected");
- is($io->peekn(65), substr($base, 0, 65), "peek 65");
- is($ops, "R8192>10;R8182>10;R8172>10;R8162>10;R8152>10;R8142>10;R8132>10;",
- "check we got the raw calls expected");
- }
- for my $buffered (1, 0) { # peekn followed by errors
- my $buffered_desc = $buffered ? "buffered" : "unbuffered";
- my $read = 0;
- my $base = "abcdef";
- my $pos = 0;
- my $reader = sub {
- my $size = shift;
- my $req_size = $size;
- if ($pos + $size > length $base) {
- $size = length($base) - $pos;
- }
- # error instead of eof
- if ($size == 0) {
- print "# read $req_size>error\n";
- return;
- }
- my $result = substr($base, $pos, $size);
- $pos += $size;
-
- print "# read $req_size>$size\n";
-
- return $result;
- };
- my $io = Imager::io_new_cb(undef, $reader, undef, undef);
- ok($io, "make $buffered_desc cb with error after 6 bytes");
- is($io->peekn(5), "abcde",
- "peekn until just before error ($buffered_desc)");
- is($io->peekn(6), "abcdef", "peekn until error ($buffered_desc)");
- is($io->peekn(7), "abcdef", "peekn past error ($buffered_desc)");
- ok(!$io->error,
- "should be no error indicator, since data buffered ($buffered_desc)");
- ok(!$io->eof,
- "should be no eof indicator, since data buffered ($buffered_desc)");
-
- # consume it
- is($io->read2(6), "abcdef", "consume the buffer ($buffered_desc)");
- is($io->peekn(10), undef,
- "peekn should get an error indicator ($buffered_desc)");
- ok($io->error, "should be an error state ($buffered_desc)");
- ok(!$io->eof, "but not eof ($buffered_desc)");
- }
- { # peekn on an empty file
- my $io = Imager::io_new_buffer("");
- is($io->peekn(10), "", "peekn on empty source");
- ok($io->eof, "should be in eof state");
- ok(!$io->error, "but not error");
- }
- { # peekn on error source
- my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
- is($io->peekn(10), undef, "peekn on empty source");
- ok($io->error, "should be in error state");
- ok(!$io->eof, "but not eof");
- }
- { # peekn on short source
- my $io = Imager::io_new_buffer("abcdef");
- is($io->peekn(4), "abcd", "peekn 4 on 6 byte source");
- is($io->peekn(10), "abcdef", "followed by peekn 10 on 6 byte source");
- is($io->peekn(10), "abcdef", "and again, now eof is set");
- }
- { # peekn(0)
- Imager::i_clear_error();
- my $io = Imager::io_new_buffer("abcdef");
- is($io->peekn(0), undef, "peekn 0 on 6 byte source");
- my $msg = Imager->_error_as_msg;
- is($msg, "peekn size must be positive");
- }
- { # getc through a whole file (buffered)
- my $io = Imager::io_new_buffer($base);
- my $out = '';
- while ((my $c = $io->getc()) != -1) {
- $out .= chr($c);
- }
- is($out, $base, "getc should return the file byte by byte (buffered)");
- is($io->getc, -1, "another getc after eof should fail too");
- ok($io->eof, "should be marked eof");
- ok(!$io->error, "shouldn't be marked in error");
- }
- { # getc through a whole file (unbuffered)
- my $io = Imager::io_new_buffer($base);
- $io->set_buffered(0);
- my $out = '';
- while ((my $c = $io->getc()) != -1) {
- $out .= chr($c);
- }
- is($out, $base, "getc should return the file byte by byte (unbuffered)");
- is($io->getc, -1, "another getc after eof should fail too");
- ok($io->eof, "should be marked eof");
- ok(!$io->error, "shouldn't be marked in error");
- }
- { # buffered getc with an error
- my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
- is($io->getc, -1, "buffered getc error");
- ok($io->error, "io marked in error");
- ok(!$io->eof, "but not eof");
- }
- { # unbuffered getc with an error
- my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
- $io->set_buffered(0);
- is($io->getc, -1, "unbuffered getc error");
- ok($io->error, "io marked in error");
- ok(!$io->eof, "but not eof");
- }
- { # initial peekc - buffered
- my $io = Imager::io_new_buffer($base);
- my $c = $io->peekc;
- is($c, ord($base), "buffered peekc matches");
- is($io->peekc, $c, "duplicate peekc matchess");
- }
- { # initial peekc - unbuffered
- my $io = Imager::io_new_buffer($base);
- $io->set_buffered(0);
- my $c = $io->peekc;
- is($c, ord($base), "unbuffered peekc matches");
- is($io->peekc, $c, "duplicate peekc matchess");
- }
- { # initial peekc eof - buffered
- my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
- my $c = $io->peekc;
- is($c, -1, "buffered eof peekc is -1");
- is($io->peekc, $c, "duplicate matches");
- ok($io->eof, "io marked eof");
- ok(!$io->error, "but not error");
- }
- { # initial peekc eof - unbuffered
- my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
- $io->set_buffered(0);
- my $c = $io->peekc;
- is($c, -1, "buffered eof peekc is -1");
- is($io->peekc, $c, "duplicate matches");
- ok($io->eof, "io marked eof");
- ok(!$io->error, "but not error");
- }
- { # initial peekc error - buffered
- my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
- my $c = $io->peekc;
- is($c, -1, "buffered error peekc is -1");
- is($io->peekc, $c, "duplicate matches");
- ok($io->error, "io marked error");
- ok(!$io->eof, "but not eof");
- }
- { # initial peekc error - unbuffered
- my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
- $io->set_buffered(0);
- my $c = $io->peekc;
- is($c, -1, "unbuffered error peekc is -1");
- is($io->peekc, $c, "duplicate matches");
- ok($io->error, "io marked error");
- ok(!$io->eof, "but not eof");
- }
- { # initial putc
- my $io = Imager::io_new_bufchain();
- is($io->putc(ord "A"), ord "A", "initial putc buffered");
- is($io->close, 0, "close it");
- is(Imager::io_slurp($io), "A", "check it was written");
- }
- { # initial putc - unbuffered
- my $io = Imager::io_new_bufchain();
- $io->set_buffered(0);
- is($io->putc(ord "A"), ord "A", "initial putc unbuffered");
- is($io->close, 0, "close it");
- is(Imager::io_slurp($io), "A", "check it was written");
- }
- { # putc unbuffered with error
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- $io->set_buffered(0);
- is($io->putc(ord "A"), -1, "initial putc unbuffered error");
- ok($io->error, "io in error");
- is($io->putc(ord "B"), -1, "still in error");
- }
- { # writes while in read state
- my $io = Imager::io_new_cb(sub { 1 }, sub { return "AA" }, undef, undef);
- is($io->getc, ord "A", "read to setup read buffer");
- is($io->putc(ord "B"), -1, "putc should fail");
- is($io->write("test"), -1, "write should fail");
- }
- { # buffered putc error handling
- # tests the check for error state in the buffered putc code
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- $io->putc(ord "A");
- ok(!$io->flush, "flush should fail");
- ok($io->error, "should be in error state");
- is($io->putc(ord "B"), -1, "check for error");
- }
- { # buffered putc flush error handling
- # test handling of flush failure and of the error state resulting
- # from that
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- my $i = 0;
- while (++$i < 100_000 && $io->putc(ord "A") == ord "A") {
- # until we have to flush and fail doing do
- }
- is($i, 8193, "should have failed on 8193rd byte");
- ok($io->error, "should be in error state");
- is($io->putc(ord "B"), -1, "next putc should fail");
- }
- { # buffered write flush error handling
- # test handling of flush failure and of the error state resulting
- # from that
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- my $i = 0;
- while (++$i < 100_000 && $io->write("A") == 1) {
- # until we have to flush and fail doing do
- }
- is($i, 8193, "should have failed on 8193rd byte");
- ok($io->error, "should be in error state");
- is($io->write("B"), -1, "next write should fail");
- }
- { # buffered read error
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- is($io->read2(10), undef, "initial read returning error");
- ok($io->error, "should be in error state");
- }
- { # unbuffered read error
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- $io->set_buffered(0);
- is($io->read2(10), undef, "initial read returning error");
- ok($io->error, "should be in error state");
- }
- { # unbuffered write error
- my $count = 0;
- my $io = Imager::io_new_cb(sub { return $count++; }, undef, undef, undef);
- $io->set_buffered(0);
- is($io->write("A"), -1, "unbuffered write failure");
- ok($io->error, "should be in error state");
- is($io->write("BC"), -1, "should still fail");
- }
- { # buffered write + large write
- my $io = Imager::io_new_bufchain();
- is($io->write(substr($base, 0, 4096)), 4096,
- "should be buffered");
- is($io->write(substr($base, 4096)), length($base) - 4096,
- "large write, should fill buffer and fall back to direct write");
- is($io->close, 0, "close it");
- is(Imager::io_slurp($io), $base, "make sure the data is correct");
- }
- { # initial large write with failure
- # tests error handling for the case where we bypass the buffer
- # when the write is too large to fit
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- ok($io->flush, "flush with nothing buffered should succeed");
- is($io->write($base), -1, "large write failure");
- ok($io->error, "should be in error state");
- is($io->close, -1, "should fail to close");
- }
- { # write that causes a flush then fills the buffer a bit
- my $io = Imager::io_new_bufchain();
- is($io->write(substr($base, 0, 6000)), 6000, "fill the buffer a bit");
- is($io->write(substr($base, 6000, 4000)), 4000,
- "cause it to flush and then fill some more");
- is($io->write(substr($base, 10000)), length($base)-10000,
- "write out the rest of our test data");
- is($io->close, 0, "close the stream");
- is(Imager::io_slurp($io), $base, "make sure the data is right");
- }
- { # failure on flush on close
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- is($io->putc(ord "A"), ord "A", "something in the buffer");
- ok(!$io->error, "should be no error yet");
- is($io->close, -1, "close should failure due to flush error");
- }
- { # seek failure
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- is($io->seek(0, SEEK_SET), -1, "seek failure");
- }
- { # read a little and seek
- my $io = Imager::io_new_buffer($base);
- is($io->getc, ord $base, "read one");
- is($io->getc, ord substr($base, 1, 1), "read another");
- is($io->seek(-1, SEEK_CUR), 1, "seek relative back to origin+1");
- is($io->getc, ord substr($base, 1, 1), "read another again");
- }
- { # seek with failing flush
- my $io = Imager::io_new_cb(undef, undef, undef, undef);
- is($io->putc(ord "A"), ord "A", "write one");
- ok(!$io->error, "not in error mode (yet)");
- is($io->seek(0, SEEK_SET), -1, "seek failure due to flush");
- ok($io->error, "in error mode");
- }
- { # gets()
- my $data = "test1\ntest2\ntest3";
- my $io = Imager::io_new_buffer($data);
- is($io->gets(6), "test1\n", "gets(6)");
- is($io->gets(5), "test2", "gets(5) (short for the line)");
- is($io->gets(10), "\n", "gets(10) the rest of the line (the newline)");
- is($io->gets(), "test3", "gets(default) unterminated line");
- }
- { # more gets()
- my $data = "test1\ntest2\ntest3";
- my $io = Imager::io_new_buffer($data);
- is($io->gets(6, ord("1")), "test1", "gets(6) (line terminator 1)");
- is($io->gets(6, ord("2")), "\ntest2", "gets(6) (line terminator 2)");
- is($io->gets(6, ord("3")), "\ntest3", "gets(6) (line terminator 3)");
- is($io->getc, -1, "should be eof");
- }
-}
-
-{ # based on discussion on IRC, user was attempting to write a TIFF
- # image file with only a write callback, but TIFF requires seek and
- # read callbacks when writing.
- # https://rt.cpan.org/Ticket/Display.html?id=76782
- my $cb = Imager::io_new_cb(undef, undef, undef, undef);
- {
- Imager::i_clear_error();
- my $data;
- is($cb->read($data, 10), undef, "default read callback should fail");
- is(Imager->_error_as_msg(), "read callback called but no readcb supplied",
- "check error message");
- }
- {
- Imager::i_clear_error();
- is($cb->raw_write("abc"), -1, "default write callback should fail");
- is(Imager->_error_as_msg(), "write callback called but no writecb supplied",
- "check error message");
- }
- {
- Imager::i_clear_error();
- is($cb->seek(0, 0), -1, "default seek callback should fail");
- is(Imager->_error_as_msg(), "seek callback called but no seekcb supplied",
- "check error message");
- }
-}
-
-SKIP:
-{
- $Config{useperlio}
- or skip "PerlIO::scalar requires perlio", 13;
-
- my $foo;
- open my $fh, "+<", \$foo;
- my $io = Imager::IO->_new_perlio($fh);
- ok($io, "perlio: make a I/O object for a perl scalar fh");
- is($io->write("test"), 4, "perlio: check we can write");
- is($io->seek(2, SEEK_SET), 2, "perlio: check we can seek");
- is($io->write("more"), 4, "perlio: write some more");
- is($io->seek(0, SEEK_SET), 0, "perlio: seek back to start");
- my $data;
- is($io->read($data, 10), 6, "perlio: read everything back");
- is($data, "temore", "perlio: check we read back what we wrote");
- is($io->close, 0, "perlio: close it");
- is($foo, "temore", "perlio: check it got to the scalar properly");
-
- my $io2 = Imager::IO->new_fh($fh);
- ok($io2, "new_fh() can make an I/O layer object from a scalar fh");
- close $fh;
-
- my $im = Imager->new(xsize => 10, ysize => 10);
- $foo = "";
- open my $fh2, ">", \$foo;
- ok($im->write(fh => $fh2, type => "pnm"), "can write image to scalar fh")
- or print "# ", $im->errstr, "\n";
-
- close $fh2;
- open my $fh3, "<", \$foo;
- my $im2 = Imager->new(fh => $fh3);
- ok($im2, "read image from a scalar fh");
- is_image($im, $im2, "check they match");
-}
-
-{
- tie *FOO, "IO::Tied";
- my $io = Imager::IO->new_fh(\*FOO);
- ok($io, "tied: make a I/O object for a tied fh");
- is($io->write("test"), 4, "tied: check we can write");
- is($io->seek(2, SEEK_SET), 2, "tied: check we can seek");
- is($io->write("more"), 4, "tied: write some more");
- is($io->seek(0, SEEK_SET), 0, "tied: seek back to start");
- my $data;
- is($io->read($data, 10), 6, "tied: read everything back");
- is($data, "temore", "tied: check we read back what we wrote");
- is($io->close, 0, "tied: close it");
- is(tied(*FOO)->[0], "temore", "tied: check it got to the output properly");
-}
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t07.ppm", "testout/t07iolayer.log";
-}
-
-sub eof_read {
- my ($max_len) = @_;
-
- return '';
-}
-
-sub good_read {
- my ($max_len) = @_;
-
- my $data = "testdata";
- length $data <= $max_len or substr($data, $max_len) = '';
-
- print "# good_read ($max_len) => $data\n";
-
- return $data;
-}
-
-sub fail_write {
- return;
-}
-
-sub fail_read {
- return;
-}
-
-sub fail_seek {
- return -1;
-}
-
-package IO::Tied;
-use base 'Tie::Handle';
-use IO::Seekable;
-
-sub TIEHANDLE {
- return bless [ "", 0 ];
-}
-
-sub PRINT {
- for my $entry (@_[1 .. $#_]) {
- substr($_[0][0], $_[0][1], length $entry, $entry);
- $_[0][1] += length $entry;
- }
-
- return 1;
-}
-
-sub SEEK {
- my ($self, $offset, $whence) = @_;
-
- my $newpos;
- if ($whence == SEEK_SET) {
- $newpos = $offset;
- }
- elsif ($whence == SEEK_CUR) {
- $newpos = $self->[1] + $offset;
- }
- elsif ($whence == SEEK_END) {
- $newpos = length($self->[0]) + $newpos;
- }
- else {
- return -1;
- }
-
- if ($newpos < 0) {
- return 0;
- }
-
- $self->[1] = $newpos;
-
- return 1;
-}
-
-sub TELL {
- return $_[0][1];
-}
-
-sub READ {
- my $self = shift;
- my $outlen = $_[1];
- my $offset = @_ > 2 ? $_[2] : 0;
- if ($self->[1] + $outlen > length $self->[0]) {
- $outlen = length($self->[0]) - $self->[1];
- $outlen <= 0
- and return "";
- }
- defined $_[0] or $_[0] = "";
- substr($_[0], $offset, $outlen) = substr($self->[0], $self->[1], $outlen);
- $self->[1] += $outlen;
-
- return $outlen;
-}
+++ /dev/null
-#!perl -w
-use strict;
-
-# avoiding this prologue would be nice, but it seems to be unavoidable,
-# see "It is also important to note ..." in perldoc threads
-use Config;
-my $loaded_threads;
-BEGIN {
- if ($Config{useithreads} && $] > 5.008007) {
- $loaded_threads =
- eval {
- require threads;
- threads->import;
- 1;
- };
- }
-}
-use Test::More;
-
-$Config{useithreads}
- or plan skip_all => "can't test Imager's threads support with no threads";
-$] > 5.008007
- or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
-$loaded_threads
- or plan skip_all => "couldn't load threads";
-
-$INC{"Devel/Cover.pm"}
- and plan skip_all => "threads and Devel::Cover don't get along";
-
-use Imager;
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t080log1.log")
- or plan skip_all => "Cannot open log file: " . Imager->errstr;
-
-plan tests => 3;
-
-Imager->log("main thread a\n");
-
-my $t1 = threads->create
- (
- sub {
- Imager->log("child thread a\n");
- Imager->open_log(log => "testout/t080log2.log")
- or die "Cannot open second log file: ", Imager->errstr;
- Imager->log("child thread b\n");
- sleep(1);
- Imager->log("child thread c\n");
- sleep(1);
- 1;
- }
- );
-
-Imager->log("main thread b\n");
-sleep(1);
-Imager->log("main thread c\n");
-ok($t1->join, "join child thread");
-Imager->log("main thread d\n");
-Imager->close_log();
-
-my %log1 = parse_log("testout/t080log1.log");
-my %log2 = parse_log("testout/t080log2.log");
-
-my @log1 =
- (
- "main thread a",
- "main thread b",
- "child thread a",
- "main thread c",
- "main thread d",
- );
-
-my @log2 =
- (
- "child thread b",
- "child thread c",
- );
-
-is_deeply(\%log1, { map {; $_ => 1 } @log1 },
- "check messages in main thread log");
-is_deeply(\%log2, { map {; $_ => 1 } @log2 },
- "check messages in child thread log");
-
-# grab the messages from the given log
-sub parse_log {
- my ($filename) = @_;
-
- open my $fh, "<", $filename
- or die "Cannot open log file $filename: $!";
-
- my %lines;
- while (<$fh>) {
- chomp;
- my ($date, $time, $file_line, $level, $message) = split ' ', $_, 5;
- $lines{$message} = 1;
- }
-
- delete $lines{"Imager - log started (level = 1)"};
- delete $lines{"Imager $Imager::VERSION starting"};
-
- return %lines;
-}
-
-END {
- unlink "testout/t080log1.log", "testout/t080log2.log"
- unless $ENV{IMAGER_KEEP_FILES};
-}
+++ /dev/null
-#!perl -w
-use strict;
-
-# avoiding this prologue would be nice, but it seems to be unavoidable,
-# see "It is also important to note ..." in perldoc threads
-use Config;
-my $loaded_threads;
-BEGIN {
- if ($Config{useithreads} && $] > 5.008007) {
- $loaded_threads =
- eval {
- require threads;
- threads->import;
- 1;
- };
- }
-}
-use Test::More;
-
-$Config{useithreads}
- or plan skip_all => "can't test Imager's threads support with no threads";
-$] > 5.008007
- or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
-$loaded_threads
- or plan skip_all => "couldn't load threads";
-
-$INC{"Devel/Cover.pm"}
- and plan skip_all => "threads and Devel::Cover don't get along";
-
-use Imager;
-
-# test that the error contexts are separate under threads
-
-plan tests => 11;
-
-Imager->open_log(log => "testout/t081error.log");
-
-Imager::i_clear_error();
-Imager::i_push_error(0, "main thread a");
-
-my @threads;
-for my $tid (1..5) {
- my $t1 = threads->create
- (
- sub {
- my $id = shift;
- Imager::i_push_error(0, "$id: child thread a");
- sleep(1+rand(4));
- Imager::i_push_error(1, "$id: child thread b");
-
- is_deeply([ Imager::i_errors() ],
- [
- [ "$id: child thread b", 1 ],
- [ "$id: child thread a", 0 ],
- ], "$id: check errors in child");
- 1;
- },
- $tid
- );
- push @threads, [ $tid, $t1 ];
-}
-
-Imager::i_push_error(1, "main thread b");
-
-for my $thread (@threads) {
- my ($id, $t1) = @$thread;
- ok($t1->join, "join child $id");
-}
-
-Imager::i_push_error(2, "main thread c");
-
-is_deeply([ Imager::i_errors() ],
- [
- [ "main thread c", 2 ],
- [ "main thread b", 1 ],
- [ "main thread a", 0 ],
- ], "check errors in parent");
-
+++ /dev/null
-#!perl -w
-use strict;
-
-# avoiding this prologue would be nice, but it seems to be unavoidable,
-# see "It is also important to note ..." in perldoc threads
-use Config;
-my $loaded_threads;
-BEGIN {
- if ($Config{useithreads} && $] > 5.008007) {
- $loaded_threads =
- eval {
- require threads;
- threads->import;
- 1;
- };
- }
-}
-use Test::More;
-
-$Config{useithreads}
- or plan skip_all => "can't test Imager's threads support with no threads";
-$] > 5.008007
- or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
-$loaded_threads
- or plan skip_all => "couldn't load threads";
-
-$INC{"Devel/Cover.pm"}
- and plan skip_all => "threads and Devel::Cover don't get along";
-
-use Imager;
-
-# test that image file limits are localized to a thread
-
-plan tests => 31;
-
-Imager->open_log(log => "testout/t082limit.log");
-
-ok(Imager->set_file_limits(width => 10, height => 10, bytes => 300),
- "set limits to 10, 10, 300");
-
-ok(Imager->check_file_limits(width => 10, height => 10),
- "successful check limits in parent");
-
-ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 2),
- "failed check limits in parent");
-
-my @threads;
-for my $tid (1..5) {
- my $t1 = threads->create
- (
- sub {
- my $id = shift;
- my $dlimit = $tid * 5;
- my $blimit = $dlimit * $dlimit * 3;
- ok(Imager->set_file_limits(width => $dlimit, height => $dlimit,
- bytes => $blimit),
- "$tid: set limits to $dlimit x $dlimit, $blimit bytes");
- ok(Imager->check_file_limits(width => $dlimit, height => $dlimit),
- "$tid: successful check $dlimit x $dlimit");
- ok(!Imager->check_file_limits(width => $dlimit, height => $dlimit, sample_size => 2),
- "$tid: failed check $dlimit x $dlimit, ssize 2");
- is_deeply([ Imager->get_file_limits ], [ $dlimit, $dlimit, $blimit ],
- "check limits are still $dlimit x $dlimit , $blimit bytes");
- },
- $tid
- );
- push @threads, [ $tid, $t1 ];
-}
-
-for my $thread (@threads) {
- my ($id, $t1) = @$thread;
- ok($t1->join, "join child $id");
-}
-
-ok(Imager->check_file_limits(width => 10, height => 10),
- "test we still pass");
-ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 2),
- "test we still fail");
-is_deeply([ Imager->get_file_limits ], [ 10, 10, 300 ],
- "check original main thread limits still set");
+++ /dev/null
-#!perl -w
-
-# This file is for testing file functionality that is independent of
-# the file format
-
-use strict;
-use Test::More tests => 89;
-use Imager;
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t1000files.log");
-
-SKIP:
-{
- # Test that i_test_format_probe() doesn't pollute stdout
-
- # Initally I tried to write this test using open to redirect files,
- # but there was a buffering problem that made it so the data wasn't
- # being written to the output file. This external perl call avoids
- # that problem
-
- my $test_script = 'testout/t1000files_probe.pl';
-
- # build a temp test script to use
- ok(open(SCRIPT, "> $test_script"), "open test script")
- or skip("no test script $test_script: $!", 2);
- print SCRIPT <<'PERL';
-#!perl
-use Imager;
-use strict;
-my $file = shift or die "No file supplied";
-open FH, "< $file" or die "Cannot open file: $!";
-binmode FH;
-my $io = Imager::io_new_fd(fileno(FH));
-Imager::i_test_format_probe($io, -1);
-PERL
- close SCRIPT;
- my $perl = $^X;
- $perl = qq/"$perl"/ if $perl =~ / /;
-
- print "# script: $test_script\n";
- my $cmd = "$perl -Mblib $test_script t/t1000files.t";
- print "# command: $cmd\n";
-
- my $out = `$cmd`;
- is($?, 0, "command successful");
- is($out, '', "output should be empty");
-}
-
-# test the file limit functions
-# by default the limits are zero (unlimited)
-print "# image file limits\n";
-is_deeply([ Imager->get_file_limits() ], [0, 0, 0x40000000 ],
- "check defaults");
-ok(Imager->set_file_limits(width=>100), "set only width");
-is_deeply([ Imager->get_file_limits() ], [100, 0, 0x40000000 ],
- "check width set");
-ok(Imager->set_file_limits(height=>150, bytes=>10000),
- "set height and bytes");
-is_deeply([ Imager->get_file_limits() ], [ 100, 150, 10000 ],
- "check all values now set");
-ok(Imager->check_file_limits(width => 100, height => 30),
- "check 100 x 30 (def channels, sample_size) ok")
- or diag(Imager->errstr);
-ok(Imager->check_file_limits(width => 100, height => 100, channels => 1),
- "check 100 x 100 x 1 (def sample_size) ok")
- or diag(Imager->errstr);
-ok(Imager->check_file_limits(width => 100, height => 100, channels => 1),
- "check 100 x 100 x 1 (def sample_size) ok")
- or diag(Imager->errstr);
-ok(!Imager->check_file_limits(width => 100, height => 100, channels => 1, sample_size => "float"),
- "check 100 x 100 x 1 x float should fail");
-ok(!Imager->check_file_limits(width => 100, height => 100, channels => 0),
- "0 channels should fail");
-is(Imager->errstr, "file size limit - channels 0 out of range",
- "check error message");
-ok(!Imager->check_file_limits(width => 0, height => 100),
- "0 width should fail");
-is(Imager->errstr, "file size limit - image width of 0 is not positive",
- "check error message");
-ok(!Imager->check_file_limits(width => 100, height => 0),
- "0 height should fail");
-is(Imager->errstr, "file size limit - image height of 0 is not positive",
- "check error message");
-ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 0),
- "0 sample_size should fail");
-is(Imager->errstr, "file size limit - sample_size 0 out of range",
- "check error message");
-ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 1000),
- "1000 sample_size should fail");
-is(Imager->errstr, "file size limit - sample_size 1000 out of range",
- "check error message");
-ok(Imager->set_file_limits(reset=>1, height => 99),
- "set height and reset");
-is_deeply([ Imager->get_file_limits() ], [ 0, 99, 0x40000000 ],
- "check only height is set");
-ok(Imager->set_file_limits(reset=>1),
- "just reset");
-is_deeply([ Imager->get_file_limits() ], [ 0, 0, 0x40000000 ],
- "check all are reset");
-
-# bad parameters
-is_deeply([ Imager->check_file_limits() ], [],
- "missing size paramaters");
-is(Imager->errstr, "check_file_limits: width must be defined",
- "check message");
-is_deeply([ Imager->check_file_limits(width => 100.5) ], [],
- "non-integer parameter");
-is(Imager->errstr, "check_file_limits: width must be a positive integer",
- "check message");
-
-# test error handling for loading file handers
-{
- # first, no module at all
- {
- my $data = "abc";
- ok(!Imager->new(data => $data, filetype => "unknown"),
- "try to read an unknown file type");
- like(Imager->errstr, qr(^format 'unknown' not supported - formats .* - Can't locate Imager/File/UNKNOWN.pm or Imager/File/UNKNOWNReader.pm$),
- "check error message");
- }
- {
- my $data;
- my $im = Imager->new(xsize => 10, ysize => 10);
- ok(!$im->write(data => \$data, type => "unknown"),
- "try to write an unknown file type");
- like($im->errstr, qr(^format 'unknown' not supported - formats .* - Can't locate Imager/File/UNKNOWN.pm or Imager/File/UNKNOWNWriter.pm$),
- "check error message");
- }
- push @INC, "t/t1000lib";
- {
- my $data = "abc";
- ok(!Imager->new(data => $data, filetype => "bad"),
- "try to read an bad (other load failure) file type");
- like(Imager->errstr, qr(^format 'bad' not supported - formats .* available for reading - This module fails to load loading Imager/File/BAD.pm$),
- "check error message");
- }
- {
- my $data;
- my $im = Imager->new(xsize => 10, ysize => 10);
- ok(!$im->write(data => \$data, type => "bad"),
- "try to write an bad file type");
- like($im->errstr, qr(^format 'bad' not supported - formats .* available for writing - This module fails to load loading Imager/File/BAD.pm$),
- "check error message");
- }
-}
-
-{ # test empty image handling for write()/write_multi()
- my $empty = Imager->new;
- my $data;
- ok(!$empty->write(data => \$data, type => "pnm"),
- "fail to write an empty image");
- is($empty->errstr, "write: empty input image", "check error message");
- my $good = Imager->new(xsize => 1, ysize => 1);
- ok(!Imager->write_multi({ data => \$data, type => "pnm" }, $good, $empty),
- "fail to write_multi an empty image");
- is(Imager->errstr, "write_multi: empty input image (image 2)");
-}
-
-# check file type probe
-probe_ok("49492A41", undef, "not quite tiff");
-probe_ok("4D4D0041", undef, "not quite tiff");
-probe_ok("49492A00", "tiff", "tiff intel");
-probe_ok("4D4D002A", "tiff", "tiff motorola");
-probe_ok("474946383961", "gif", "gif 89");
-probe_ok("474946383761", "gif", "gif 87");
-probe_ok(<<TGA, "tga", "TGA");
-00 00 0A 00 00 00 00 00 00 00 00 00 96 00 96 00
-18 20 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
-00 00 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
-00 00 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
-TGA
-
-probe_ok(<<TGA, "tga", "TGA 32-bit");
-00 00 0A 00 00 00 00 00 00 00 00 00 0A 00 0A 00
-20 08 84 00 00 00 00 84 FF FF FF FF 84 00 00 00
-00 84 FF FF FF FF 84 00 00 00 00 84 FF FF FF FF
-TGA
-
-probe_ok(<<ICO, "ico", "Windows Icon");
-00 00 01 00 02 00 20 20 10 00 00 00 00 00 E8 02
-00 00 26 00 00 00 20 20 00 00 00 00 00 00 A8 08
-00 00 0E 03 00 00 28 00 00 00 20 00 00 00 40 00
-ICO
-
-probe_ok(<<ICO, "cur", "Windows Cursor");
-00 00 02 00 02 00 20 20 10 00 00 00 00 00 E8 02
-00 00 26 00 00 00 20 20 00 00 00 00 00 00 A8 08
-00 00 0E 03 00 00 28 00 00 00 20 00 00 00 40 00
-ICO
-
-probe_ok(<<SGI, "sgi", "SGI RGB");
-01 DA 01 01 00 03 00 96 00 96 00 03 00 00 00 00
-00 00 00 FF 00 00 00 00 6E 6F 20 6E 61 6D 65 00
-00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
-SGI
-
-probe_ok(<<ILBM, "ilbm", "ILBM");
-46 4F 52 4D 00 00 60 7A 49 4C 42 4D 42 4D 48 44
-00 00 00 14 00 96 00 96 00 00 00 00 18 00 01 80
-00 00 0A 0A 00 96 00 96 42 4F 44 59 00 00 60 51
-ILBM
-
-probe_ok(<<XPM, "xpm", "XPM");
-2F 2A 20 58 50 4D 20 2A 2F 0A 73 74 61 74 69 63
-20 63 68 61 72 20 2A 6E 6F 6E 61 6D 65 5B 5D 20
-3D 20 7B 0A 2F 2A 20 77 69 64 74 68 20 68 65 69
-XPM
-
-probe_ok(<<PCX, "pcx", 'PCX');
-0A 05 01 08 00 00 00 00 95 00 95 00 96 00 96 00
-00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
-00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
-PCX
-
-probe_ok(<<FITS, "fits", "FITS");
-53 49 4D 50 4C 45 20 20 3D 20 20 20 20 20 20 20
-20 20 20 20 20 20 20 20 20 20 20 20 20 54 20 20
-20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
-FITS
-
-probe_ok(<<PSD, "psd", "Photoshop");
-38 42 50 53 00 01 00 00 00 00 00 00 00 06 00 00
-00 3C 00 00 00 96 00 08 00 03 00 00 00 00 00 00
-0B E6 38 42 49 4D 03 ED 00 00 00 00 00 10 00 90
-PSD
-
-probe_ok(<<EPS, "eps", "Encapsulated Postscript");
-25 21 50 53 2D 41 64 6F 62 65 2D 32 2E 30 20 45
-50 53 46 2D 32 2E 30 0A 25 25 43 72 65 61 74 6F
-72 3A 20 70 6E 6D 74 6F 70 73 0A 25 25 54 69 74
-EPS
-
-probe_ok(<<UTAH, "utah", "Utah RLE");
-52 CC 00 00 00 00 0A 00 0A 00 0A 03 08 00 08 00
-2F 00 48 49 53 54 4F 52 59 3D 70 6E 6D 74 6F 72
-6C 65 20 6F 6E 20 54 68 75 20 4D 61 79 20 31 31
-20 31 36 3A 33 35 3A 34 33 20 32 30 30 36 0A 09
-UTAH
-
-probe_ok(<<XWD, "xwd", "X Window Dump");
-00 00 00 69 00 00 00 07 00 00 00 02 00 00 00 18
-00 00 01 E4 00 00 01 3C 00 00 00 00 00 00 00 00
-00 00 00 20 00 00 00 00 00 00 00 20 00 00 00 20
-00 00 07 90 00 00 00 04 00 FF 00 00 00 00 FF 00
-XWD
-
-probe_ok(<<GZIP, "gzip", "gzip compressed");
-1F 8B 08 08 C2 81 BD 44 02 03 49 6D 61 67 65 72
-2D 30 2E 35 31 5F 30 33 2E 74 61 72 00 EC 5B 09
-40 53 C7 BA 9E 24 AC 01 D9 44 04 44 08 8B B2 8A
-C9 C9 42 92 56 41 50 20 A0 02 41 41 01 17 48 80
-GZIP
-
-probe_ok(<<BZIP2, "bzip2", "bzip2 compressed");
-42 5A 68 39 31 41 59 26 53 59 0F D8 8C 09 00 03
-28 FF FF FF FF FB 7F FB 77 FF EF BF 6B 7F BE FF
-FF DF EE C8 0F FF F3 FF FF FF FC FF FB B1 FF FB
-F4 07 DF D0 03 B8 03 60 31 82 05 2A 6A 06 83 20
-BZIP2
-
-probe_ok(<<WEBP, "webp", "Google WEBP");
-52 49 46 46 2C 99 00 00 57 45 42 50 56 50 38 20
-20 99 00 00 70 7A 02 9D 01 2A E0 01 80 02 00 87
-08 85 85 88 85 84 88 88 83 AF E2 F7 64 1F 98 55
-1B 6A 70 F5 8A 45 09 95 0C 09 7E 25 D9 2E 46 44
-07 84 FB 01 FD 2C 8A 2F 97 CC ED DB 50 0F 11 3B
-WEBP
-
-probe_ok(<<JPEG2K, "jp2", "JPEG 2000");
-00 00 00 0C 6A 50 20 20 0D 0A 87 0A 00 00 00 14
-66 74 79 70 6A 70 32 20 00 00 00 00 6A 70 32 20
-00 00 00 2D 6A 70 32 68 00 00 00 16 69 68 64 72
-00 00 02 80 00 00 01 E0 00 03 07 07 00 00 00 00
-00 0F 63 6F 6C 72 01 00 00 00 00 00 10 00 00 00
-00 6A 70 32 63 FF 4F FF 51 00 2F 00 00 00 00 01
-JPEG2K
-
-{ # RT 72475
- # check error messages from read/read_multi
- my $data = "nothing useful";
- my @mult_data = Imager->read_multi(data => $data);
- is(@mult_data, 0, "read_multi with non-image input data should fail");
- is(Imager->errstr,
- "type parameter missing and it couldn't be determined from the file contents",
- "check the error message");
-
- my @mult_file = Imager->read_multi(file => "t/t1000files.t");
- is(@mult_file, 0, "read_multi with non-image filename should fail");
- is(Imager->errstr,
- "type parameter missing and it couldn't be determined from the file contents or file name",
- "check the error message");
-
- my $im = Imager->new;
- ok(!$im->read(data => $data), "read from non-image data should fail");
- is($im->errstr,
- "type parameter missing and it couldn't be determined from the file contents",
- "check the error message");
-
- ok(!$im->read(file => "t/t1000files.t"),
- "read from non-image file should fail");
- is($im->errstr,
- "type parameter missing and it couldn't be determined from the file contents or file name",
- "check the error message");
-}
-
-{
- # test def_guess_type
- my @tests =
- (
- pnm => "pnm",
- GIF => "gif",
- tif => "tiff",
- TIFF => "tiff",
- JPG => "jpeg",
- rle => "utah",
- bmp => "bmp",
- dib => "bmp",
- rgb => "sgi",
- BW => "sgi",
- TGA => "tga",
- CUR => "cur",
- ico => "ico",
- ILBM => "ilbm",
- pcx => "pcx",
- psd => "psd",
- );
-
- while (my ($ext, $expect) = splice(@tests, 0, 2)) {
- my $filename = "foo.$ext";
- is(Imager::def_guess_type($filename), $expect,
- "type for $filename should be $expect");
- }
-}
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t1000files.log";
-}
-
-sub probe_ok {
- my ($packed, $exp_type, $name) = @_;
-
- my $builder = Test::Builder->new;
- $packed =~ tr/ \r\n//d; # remove whitespace used for layout
- my $data = pack("H*", $packed);
-
- my $io = Imager::io_new_buffer($data);
- my $result = Imager::i_test_format_probe($io, -1);
-
- return $builder->is_eq($result, $exp_type, $name)
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-use Imager qw(:all);
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t101jpeg.log");
-
-$Imager::formats{"jpeg"}
- and plan skip_all => "have jpeg support - this tests the lack of it";
-
-plan tests => 6;
-
-my $im = Imager->new;
-ok(!$im->read(file=>"testimg/base.jpg"), "should fail to read jpeg");
-cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
-$im = Imager->new(xsize=>2, ysize=>2);
-ok(!$im->write(file=>"testout/nojpeg.jpg"), "should fail to write jpeg");
-cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
-ok(!grep($_ eq 'jpeg', Imager->read_types), "check jpeg not in read types");
-ok(!grep($_ eq 'jpeg', Imager->write_types), "check jpeg not in write types");
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t101jpeg.log";
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager qw(:all);
-use Test::More;
-
-$Imager::formats{"png"}
- and plan skip_all => "png available, and this tests the lack of it";
-
-plan tests => 6;
-
-my $im = Imager->new;
-ok(!$im->read(file=>"testimg/test.png"), "should fail to read png");
-cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
-$im = Imager->new(xsize=>2, ysize=>2);
-ok(!$im->write(file=>"testout/nopng.png"), "should fail to write png");
-cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
-ok(!grep($_ eq 'png', Imager->read_types), "check png not in read types");
-ok(!grep($_ eq 'png', Imager->write_types), "check png not in write types");
-
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 53;
-use Imager qw(:all);
-use Imager::Test qw/is_color3 is_color4 test_image test_image_mono/;
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t103raw.log");
-
-$| = 1;
-
-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 $img=Imager::ImgRaw::new(150,150,3);
-my $cmpimg=Imager::ImgRaw::new(150,150,3);
-
-i_box_filled($img,70,25,130,125,$green);
-i_box_filled($img,20,25,80,125,$blue);
-i_arc($img,75,75,30,0,361,$red);
-i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
-
-my $timg = Imager::ImgRaw::new(20, 20, 4);
-my $trans = i_color_new(255, 0, 0, 127);
-i_box_filled($timg, 0, 0, 20, 20, $green);
-i_box_filled($timg, 2, 2, 18, 18, $trans);
-
-open(FH,">testout/t103.raw") || die "Cannot open testout/t103.raw for writing\n";
-binmode(FH);
-my $IO = Imager::io_new_fd( fileno(FH) );
-ok(i_writeraw_wiol($img, $IO), "write raw low") or
- print "# Cannot write testout/t103.raw\n";
-close(FH);
-
-open(FH,"testout/t103.raw") || die "Cannot open testout/t103.raw\n";
-binmode(FH);
-$IO = Imager::io_new_fd( fileno(FH) );
-$cmpimg = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
-ok($cmpimg, "read raw low")
- or print "# Cannot read testout/t103.raw\n";
-close(FH);
-
-print "# raw average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
-
-# I could have kept the raw images for these tests in binary files in
-# testimg/, but I think keeping them as hex encoded data in here makes
-# it simpler to add more if necessary
-# Later we may change this to read from a scalar instead
-save_data('testout/t103_base.raw');
-save_data('testout/t103_3to4.raw');
-save_data('testout/t103_line_int.raw');
-save_data('testout/t103_img_int.raw');
-
-# load the base image
-open FH, "testout/t103_base.raw"
- or die "Cannot open testout/t103_base.raw: $!";
-binmode FH;
-$IO = Imager::io_new_fd( fileno(FH) );
-
-my $baseimg = i_readraw_wiol( $IO, 4, 4, 3, 3, 0);
-ok($baseimg, "read base raw image")
- or die "Cannot read base raw image";
-close FH;
-
-# the actual read tests
-# each read_test() call does 2 tests:
-# - check if the read succeeds
-# - check if it matches $baseimg
-read_test('testout/t103_3to4.raw', 4, 4, 4, 3, 0, $baseimg);
-read_test('testout/t103_line_int.raw', 4, 4, 3, 3, 1, $baseimg);
-# intrl==2 is documented in raw.c but doesn't seem to be implemented
-#read_test('testout/t103_img_int.raw', 4, 4, 3, 3, 2, $baseimg, 7);
-
-# paletted images
-SKIP:
-{
- my $palim = Imager::i_img_pal_new(20, 20, 3, 256);
- ok($palim, "make paletted image")
- or skip("couldn't make paletted image", 2);
- my $redindex = Imager::i_addcolors($palim, $red);
- my $blueindex = Imager::i_addcolors($palim, $blue);
- for my $y (0..9) {
- Imager::i_ppal($palim, 0, $y, ($redindex) x 20);
- }
- for my $y (10..19) {
- Imager::i_ppal($palim, 0, $y, ($blueindex) x 20);
- }
- open FH, "> testout/t103_pal.raw"
- or die "Cannot create testout/t103_pal.raw: $!";
- binmode FH;
- $IO = Imager::io_new_fd(fileno(FH));
- ok(i_writeraw_wiol($palim, $IO), "write low paletted");
- close FH;
-
- open FH, "testout/t103_pal.raw"
- or die "Cannot open testout/t103_pal.raw: $!";
- binmode FH;
- my $data = do { local $/; <FH> };
- is($data, "\x0" x 200 . "\x1" x 200, "compare paletted data written");
- close FH;
-}
-
-# 16-bit image
-# we don't have 16-bit reads yet
-SKIP:
-{
- my $img16 = Imager::i_img_16_new(150, 150, 3);
- ok($img16, "make 16-bit/sample image")
- or skip("couldn't make 16 bit/sample image", 1);
- i_box_filled($img16,70,25,130,125,$green);
- i_box_filled($img16,20,25,80,125,$blue);
- i_arc($img16,75,75,30,0,361,$red);
- i_conv($img16,[0.1, 0.2, 0.4, 0.2, 0.1]);
-
- open FH, "> testout/t103_16.raw"
- or die "Cannot create testout/t103_16.raw: $!";
- binmode FH;
- $IO = Imager::io_new_fd(fileno(FH));
- ok(i_writeraw_wiol($img16, $IO), "write low 16 bit image");
- close FH;
-}
-
-# try a simple virtual image
-SKIP:
-{
- my $maskimg = Imager::i_img_masked_new($img, undef, 0, 0, 150, 150);
- ok($maskimg, "make masked image")
- or skip("couldn't make masked image", 3);
-
- open FH, "> testout/t103_virt.raw"
- or die "Cannot create testout/t103_virt.raw: $!";
- binmode FH;
- $IO = Imager::io_new_fd(fileno(FH));
- ok(i_writeraw_wiol($maskimg, $IO), "write virtual raw");
- close FH;
-
- open FH, "testout/t103_virt.raw"
- or die "Cannot open testout/t103_virt.raw: $!";
- binmode FH;
- $IO = Imager::io_new_fd(fileno(FH));
- my $cmpimgmask = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
- ok($cmpimgmask, "read result of masked write");
- my $diff = i_img_diff($maskimg, $cmpimgmask);
- print "# difference for virtual image $diff\n";
- is($diff, 0, "compare masked to read");
-
- # check that i_format is set correctly
- my $index = Imager::i_tags_find($cmpimgmask, 'i_format', 0);
- if ($index) {
- my $value = Imager::i_tags_get($cmpimgmask, $index);
- is($value, 'raw', "check i_format value");
- }
- else {
- fail("couldn't find i_format tag");
- }
-}
-
-{ # error handling checks
- # should get an error writing to a open for read file
- # make a empty file
- open RAW, "> testout/t103_empty.raw"
- or die "Cannot create testout/t103_empty.raw: $!";
- close RAW;
- open RAW, "< testout/t103_empty.raw"
- or die "Cannot open testout/t103_empty.raw: $!";
- my $im = Imager->new(xsize => 50, ysize=>50);
- ok(!$im->write(fh => \*RAW, type => 'raw', buffered => 0),
- "write to open for read handle");
- cmp_ok($im->errstr, '=~', '^Could not write to file: write\(\) failure',
- "check error message");
- close RAW;
-
- # should get an error reading an empty file
- ok(!$im->read(file => 'testout/t103_empty.raw', xsize => 50, ysize=>50, type=>'raw', interleave => 1),
- 'read an empty file');
- is($im->errstr, 'premature end of file', "check message");
- SKIP:
- {
- # see 862083f7e40bc2a9e3b94aedce56c1336e7bdb25 in perl5 git
- $] >= 5.010
- or skip "5.8.x and earlier don't treat a read on a WRONLY file as an error", 2;
- open RAW, "> testout/t103_empty.raw"
- or die "Cannot create testout/t103_empty.raw: $!";
- ok(!$im->read(fh => \*RAW, , xsize => 50, ysize=>50, type=>'raw', interleave => 1),
- 'read a file open for write');
- cmp_ok($im->errstr, '=~', '^error reading file: read\(\) failure', "check message");
- }
-}
-
-
-{
- ok(grep($_ eq 'raw', Imager->read_types), "check raw in read types");
- ok(grep($_ eq 'raw', Imager->write_types), "check raw in write types");
-}
-
-
-{ # OO no interleave warning
- my $im = Imager->new;
- my $msg;
- local $SIG{__WARN__} = sub { $msg = "@_" };
- ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4,
- type => "raw"),
- "read without interleave parameter")
- or print "# ", $im->errstr, "\n";
- ok($msg, "should have warned");
- like($msg, qr/interleave/, "check warning is ok");
- # check we got the right value
- is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
- "check the image was read correctly");
-
- # check no warning if either is supplied
- $im = Imager->new;
- undef $msg;
- ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", interleave => 0),
- "read with interleave 0");
- is($msg, undef, "no warning");
- is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
- "check read non-interleave");
-
- $im = Imager->new;
- undef $msg;
- ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 0),
- "read with raw_interleave 0");
- is($msg, undef, "no warning");
- is_color3($im->getpixel(x => 1, y => 0), 0x01, 0x12, 0x23,
- "check read non-interleave");
-
- # make sure set to 1 is sane
- $im = Imager->new;
- undef $msg;
- ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 1),
- "read with raw_interleave 1");
- is($msg, undef, "no warning");
- is_color3($im->getpixel(x => 2, y => 0), 0x02, 0x13, 0x24,
- "check read interleave = 1");
-}
-
-{ # invalid interleave error handling
- my $im = Imager->new;
- ok(!$im->read(file => "testout/t103_base.raw", raw_interleave => 2, type => "raw", xsize => 4, ysize => 4),
- "invalid interleave");
- is($im->errstr, "raw_interleave must be 0 or 1", "check message");
-}
-
-{ # store/data channel behaviour
- my $im = Imager->new;
- ok($im->read(file => "testout/t103_3to4.raw", xsize => 4, ysize => 4,
- raw_datachannels => 4, raw_interleave => 0, type => "raw"),
- "read 4 channel file as 3 channels")
- or print "# ", $im->errstr, "\n";
- is_color3($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34,
- "check read correctly");
-}
-
-{ # should fail to read with storechannels > 4
- my $im = Imager->new;
- ok(!$im->read(file => "testout/t103_line_int.raw", type => "raw",
- raw_interleave => 1, xsize => 4, ysize => 4,
- raw_storechannels => 5),
- "read with large storechannels");
- is($im->errstr, "raw_storechannels must be between 1 and 4",
- "check error message");
-}
-
-{ # should zero spare channels if storechannels > datachannels
- my $im = Imager->new;
- ok($im->read(file => "testout/t103_base.raw", type => "raw",
- raw_interleave => 0, xsize => 4, ysize => 4,
- raw_storechannels => 4),
- "read with storechannels > datachannels");
- is($im->getchannels, 4, "should have 4 channels");
- is_color4($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34, 0x00,
- "check last channel zeroed");
-}
-
-{
- my @ims = ( basic => test_image(), mono => test_image_mono() );
- push @ims, masked => test_image()->masked();
-
- my $fail_close = sub {
- Imager::i_push_error(0, "synthetic close failure");
- return 0;
- };
-
- while (my ($type, $im) = splice(@ims, 0, 2)) {
- my $io = Imager::io_new_cb(sub { 1 }, undef, undef, $fail_close);
- ok(!$im->write(io => $io, type => "raw"),
- "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/t103raw.log";
- unlink(qw(testout/t103_base.raw testout/t103_3to4.raw
- testout/t103_line_int.raw testout/t103_img_int.raw))
-}
-
-sub read_test {
- my ($in, $xsize, $ysize, $data, $store, $intrl, $base) = @_;
- open FH, $in or die "Cannot open $in: $!";
- binmode FH;
- my $IO = Imager::io_new_fd( fileno(FH) );
-
- my $img = i_readraw_wiol($IO, $xsize, $ysize, $data, $store, $intrl);
- SKIP:
- {
- ok($img, "read_test $in read")
- or skip("couldn't read $in", 1);
- is(i_img_diff($img, $baseimg), 0, "read_test $in compare");
- }
-}
-
-sub save_data {
- my $outname = shift;
- my $data = load_data();
- open FH, "> $outname" or die "Cannot create $outname: $!";
- binmode FH;
- print FH $data;
- close FH;
-}
-
-sub load_data {
- my $hex = '';
- while (<DATA>) {
- next if /^#/;
- last if /^EOF/;
- chomp;
- $hex .= $_;
- }
- $hex =~ tr/ //d;
- my $result = pack("H*", $hex);
- #print unpack("H*", $result),"\n";
- return $result;
-}
-
-# FIXME: may need tests for 1,2,4 channel images
-
-__DATA__
-# we keep some packed raw images here
-# we decode this in the code, ignoring lines starting with #, a subfile
-# ends with EOF, data is HEX encoded (spaces ignored)
-
-# basic 3 channel version of the image
-001122 011223 021324 031425
-102132 112233 122334 132435
-203142 213243 223344 233445
-304152 314253 324354 334455
-EOF
-
-# test image for reading a 4 channel image into a 3 channel image
-# 4 x 4 pixels
-00112233 01122334 02132435 03142536
-10213243 11223344 12233445 13243546
-20314253 21324354 22334455 23344556
-30415263 31425364 32435465 33445566
-EOF
-
-# test image for line based interlacing
-# 4 x 4 pixels
-# first line
-00 01 02 03
-11 12 13 14
-22 23 24 25
-
-# second line
-10 11 12 13
-21 22 23 24
-32 33 34 35
-
-# third line
-20 21 22 23
-31 32 33 34
-42 43 44 45
-
-# fourth line
-30 31 32 33
-41 42 43 44
-52 53 54 55
-
-EOF
-
-# test image for image based interlacing
-# first channel
-00 01 02 03
-10 11 12 13
-20 21 22 23
-30 31 32 33
-
-# second channel
-11 12 13 14
-21 22 23 24
-31 32 33 34
-41 42 43 44
-
-# third channel
-22 23 24 25
-32 33 34 35
-42 43 44 45
-52 53 54 55
-
-EOF
+++ /dev/null
-#!perl -w
-use Imager ':all';
-use Test::More tests => 205;
-use strict;
-use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image test_image_named);
-
-$| = 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";
-close($fh);
-
-$IO = Imager::io_new_bufchain();
-ok(i_writeppm_wiol($img, $IO), "write to bufchain")
- or die "Cannot write to bufchain";
-my $data = Imager::io_slurp($IO);
-
-$fh = openimage("testout/t104.ppm");
-$IO = Imager::io_new_fd( fileno($fh) );
-my $cmpimg = i_readpnm_wiol($IO,-1);
-ok($cmpimg, "read image we wrote")
- or die "Cannot read testout/t104.ppm\n";
-close($fh);
-
-is(i_img_diff($img, $cmpimg), 0, "compare written and read images");
-
-my $rdata = slurp("testout/t104.ppm");
-is($data, $rdata, "check data read from file and bufchain data");
-
-# build a grayscale image
-my $gimg = Imager::ImgRaw::new(150, 150, 1);
-my $gray = i_color_new(128, 0, 0, 255);
-my $dgray = i_color_new(64, 0, 0, 255);
-my $white = i_color_new(255, 0, 0, 255);
-i_box_filled($gimg, 20, 20, 130, 130, $gray);
-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));
-ok(i_writeppm_wiol($gimg, $IO), "write grayscale");
-close FH;
-
-open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
-binmode FH;
-$IO = Imager::io_new_fd(fileno(FH));
-my $gcmpimg = i_readpnm_wiol($IO, -1);
-ok($gcmpimg, "read grayscale");
-is(i_img_diff($gimg, $gcmpimg), 0,
- "compare written and read greyscale images");
-
-my $ooim = Imager->new;
-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_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 0), 255);
-check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 1), 0);
-is($ooim->type, 'paletted', "check pbm read as paletted");
-is($ooim->tags(name=>'pnm_type'), 1, "check pnm_type tag");
-
-{
- # https://rt.cpan.org/Ticket/Display.html?id=7465
- # the pnm reader ignores the maxval that it reads from the pnm file
- my $maxval = Imager->new;
- ok($maxval->read(file=>"testimg/maxval.ppm"),
- "read testimg/maxval.ppm");
-
- # this image contains three pixels, with each sample from 0 to 63
- # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
-
- # check basic parameters
- is($maxval->getchannels, 3, "channel count");
- is($maxval->getwidth, 3, "width");
- is($maxval->getheight, 1, "height");
-
- # check the pixels
- ok(my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
- is_color3($white, 255, 255, 255, "white pixel");
- is_color3($grey, 130, 130, 130, "grey pixel");
- is_color3($green, 125, 125, 0, "green pixel");
- is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
-
- # and do the same for ASCII images
- my $maxval_asc = Imager->new;
- ok($maxval_asc->read(file=>"testimg/maxval_asc.ppm"),
- "read testimg/maxval_asc.ppm");
-
- # this image contains three pixels, with each sample from 0 to 63
- # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
-
- # check basic parameters
- is($maxval_asc->getchannels, 3, "channel count");
- is($maxval_asc->getwidth, 3, "width");
- is($maxval_asc->getheight, 1, "height");
-
- is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
-
- # check the pixels
- ok(my ($white_asc, $grey_asc, $green_asc) = $maxval_asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
- is_color3($white_asc, 255, 255, 255, "white asc pixel");
- is_color3($grey_asc, 130, 130, 130, "grey asc pixel");
- is_color3($green_asc, 125, 125, 0, "green asc pixel");
-}
-
-{ # previously we didn't validate maxval at all, make sure it's
- # validated now
- my $maxval0 = Imager->new;
- ok(!$maxval0->read(file=>'testimg/maxval_0.ppm'),
- "should fail to read maxval 0 image");
- print "# ", $maxval0->errstr, "\n";
- like($maxval0->errstr, qr/maxval is zero - invalid pnm file/,
- "error expected from reading maxval_0.ppm");
-
- my $maxval65536 = Imager->new;
- ok(!$maxval65536->read(file=>'testimg/maxval_65536.ppm'),
- "should fail reading maxval 65536 image");
- print "# ",$maxval65536->errstr, "\n";
- like($maxval65536->errstr, qr/maxval of 65536 is over 65535 - invalid pnm file/,
- "error expected from reading maxval_65536.ppm");
-
- # maxval of 256 is valid, and handled as of 0.56
- my $maxval256 = Imager->new;
- ok($maxval256->read(file=>'testimg/maxval_256.ppm'),
- "should succeed reading maxval 256 image");
- is_color3($maxval256->getpixel(x => 0, 'y' => 0),
- 0, 0, 0, "check black in maxval_256");
- is_color3($maxval256->getpixel(x => 0, 'y' => 1),
- 255, 255, 255, "check white in maxval_256");
- is($maxval256->bits, 16, "check bits/sample on maxval 256");
-
- # make sure we handle maxval > 255 for ascii
- my $maxval4095asc = Imager->new;
- ok($maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'),
- "read maxval_4095_asc.ppm");
- is($maxval4095asc->getchannels, 3, "channels");
- is($maxval4095asc->getwidth, 3, "width");
- is($maxval4095asc->getheight, 1, "height");
- is($maxval4095asc->bits, 16, "check bits/sample on maxval 4095");
-
- ok(my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
- is_color3($white, 255, 255, 255, "white 4095 pixel");
- is_color3($grey, 128, 128, 128, "grey 4095 pixel");
- is_color3($green, 127, 127, 0, "green 4095 pixel");
-}
-
-{ # check i_format is set when reading a pnm file
- # doesn't really matter which file.
- my $maxval = Imager->new;
- ok($maxval->read(file=>"testimg/maxval.ppm"),
- "read test file");
- my ($type) = $maxval->tags(name=>'i_format');
- is($type, 'pnm', "check i_format");
-}
-
-{ # check file limits are checked
- my $limit_file = "testout/t104.ppm";
- ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
- my $im = Imager->new;
- ok(!$im->read(file=>$limit_file),
- "should fail read due to size limits");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/image width/, "check message");
-
- ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
- ok(!$im->read(file=>$limit_file),
- "should fail read due to size limits");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/image height/, "check message");
-
- ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside width limit");
- ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside height limit");
-
- # 150 x 150 x 3 channel image uses 67500 bytes
- ok(Imager->set_file_limits(reset=>1, bytes=>67499),
- "set bytes limit 67499");
- ok(!$im->read(file=>$limit_file),
- "should fail - too many bytes");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/storage size/, "check error message");
- ok(Imager->set_file_limits(reset=>1, bytes=>67500),
- "set bytes limit 67500");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside bytes limit");
- Imager->set_file_limits(reset=>1);
-}
-
-{
- # check we correctly sync with the data stream
- my $im = Imager->new;
- ok($im->read(file => 'testimg/pgm.pgm', type => 'pnm'),
- "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;
- 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'),
- "fail to read short bin ppm");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/short_bin16.ppm', type=>'pnm'),
- "fail to read short bin ppm (maxval 65535)");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/short_bin.pgm', type=>'pnm'),
- "fail to read short bin pgm");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/short_bin16.pgm', type=>'pnm'),
- "fail to read short bin pgm (maxval 65535)");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/short_bin.pbm', type => 'pnm'),
- "fail to read a short bin pbm");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/short_asc.ppm', type => 'pnm'),
- "fail to read a short asc ppm");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/short_asc.pgm', type => 'pnm'),
- "fail to read a short asc pgm");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/short_asc.pbm', type => 'pnm'),
- "fail to read a short asc pbm");
- cmp_ok($im->errstr, '=~', 'short read - file truncated',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/bad_asc.ppm', type => 'pnm'),
- "fail to read a bad asc ppm");
- cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/bad_asc.pgm', type => 'pnm'),
- "fail to read a bad asc pgm");
- cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok(!$im->read(file => 'testimg/bad_asc.pbm', type => 'pnm'),
- "fail to read a bad asc pbm");
- cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm',
- "check error message");
-}
-
-{
- my $im = Imager->new;
- ok($im->read(file => 'testimg/short_bin.ppm', type => 'pnm',
- 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_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");
- is($im->bits, 16, "check correct bits");
-}
-
-{
- my $im = Imager->new;
- ok($im->read(file => 'testimg/short_bin.pgm', type => 'pnm',
- 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_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_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_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_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_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_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_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_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, 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");
-
- # check it
- my $imread = Imager->new;
- ok($imread->read(file => 'testout/t104_mono.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");
-}
-
-{
- 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");
-}
-
-{
- print "# 16-bit output\n";
- my $data;
- my $im = test_image_16();
-
- # without tag, it should do 8-bit output
- ok($im->write(data => \$data, type => 'pnm'),
- "write 16-bit image as 8-bit/sample ppm");
- my $im8 = Imager->new;
- ok($im8->read(data => $data), "read it back");
- is($im8->tags(name => 'pnm_maxval'), 255, "check maxval");
- is_image($im, $im8, "check image matches");
-
- # try 16-bit output
- $im->settag(name => 'pnm_write_wide_data', value => 1);
- $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);
- open(FH, $fname) or die "Cannot open $fname: $!\n";
- binmode(FH);
- return *FH;
-}
-
-sub slurp {
- my $fh = openimage(shift);
- local $/;
- my $data = <$fh>;
- close($fh);
- return $data;
-}
-
-sub check_gray {
- my ($c, $gray) = @_;
-
- my ($g) = $c->rgba;
- is($g, $gray, "compare gray");
-}
-
+++ /dev/null
-#!perl -w
-use strict;
-$|=1;
-use Test::More;
-use Imager qw(:all);
-
-$Imager::formats{"gif"}
- and plan skip_all => "gif support available and this tests the lack of it";
-
-plan tests => 12;
-
-my $im = Imager->new;
-ok(!$im->read(file=>"GIF/testimg/scale.gif"), "should fail to read gif");
-cmp_ok($im->errstr, '=~', "format 'gif' not supported",
- "check no gif message");
-ok(!Imager->read_multi(file=>"GIF/testimg/scale.gif"),
- "should fail to read multi gif");
-cmp_ok($im->errstr, '=~', "format 'gif' not supported",
- "check no gif message");
-
-$im = Imager->new(xsize=>2, ysize=>2);
-
-ok(!$im->write(file=>"testout/nogif.gif"), "should fail to write gif");
-ok(!-e "testout/nogif.gif", "shouldn't create the file");
-cmp_ok($im->errstr, '=~', "format 'gif' not supported",
- "check no gif message");
-
-ok(!Imager->write_multi({file => "testout/nogif.gif"}, $im, $im),
- "should fail to write multi gif");
-ok(!-e "testout/nogif.gif", "shouldn't create the file");
-cmp_ok($im->errstr, '=~', "format 'gif' not supported",
- "check no gif message");
-
-ok(!grep($_ eq 'gif', Imager->read_types), "check gif not in read types");
-ok(!grep($_ eq 'gif', Imager->write_types), "check gif not in write types");
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-use Imager qw(:all);
-
-$Imager::formats{"tiff"}
- and plan skip_all => "tiff support available - this tests the lack of it";
-
-plan tests => 12;
-
-my $im = Imager->new;
-
-ok(!$im->read(file=>"TIFF/testimg/comp4.tif"), "should fail to read tif");
-cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
- "check no tiff message");
-
-ok(!$im->read_multi(file => "TIFF/testimg/comp4.tif"),
- "should fail to read multi tiff");
-cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
- "check no tiff message");
-
-$im = Imager->new(xsize=>2, ysize=>2);
-
-ok(!$im->write(file=>"testout/notiff.tif"), "should fail to write tiff");
-cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
- "check no tiff message");
-ok(!-e "testout/notiff.tif", "file shouldn't be created");
-
-ok(!Imager->write_multi({file=>"testout/notiff.tif"}, $im, $im),
- "should fail to write multi tiff");
-cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
- "check no tiff message");
-ok(!-e "testout/notiff.tif", "file shouldn't be created");
-
-ok(!grep($_ eq 'tiff', Imager->read_types), "check tiff not in read types");
-ok(!grep($_ eq 'tiff', Imager->write_types), "check tiff not in write types");
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 215;
-use Imager qw(:all);
-use Imager::Test qw(test_image_raw is_image is_color3 test_image);
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t107bmp.log");
-
-my @files;
-my $debug_writes = 0;
-
-my $base_diff = 0;
-# if you change this make sure you generate new compressed versions
-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 $img = test_image_raw();
-
-Imager::i_tags_add($img, 'i_xres', 0, '300', 0);
-Imager::i_tags_add($img, 'i_yres', 0, undef, 300);
-write_test($img, "testout/t107_24bit.bmp");
-push @files, "t107_24bit.bmp";
-# 'webmap' is noticably faster than the default
-my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
- translate=>'errdiff'});
-write_test($im8, "testout/t107_8bit.bmp");
-push @files, "t107_8bit.bmp";
-# use a fixed palette so we get reproducible results for the compressed
-# version
-my @pal16 = map { NC($_) }
- qw(605844 966600 0148b2 00f800 bf0a33 5e009e
- 2ead1b 0000f8 004b01 fd0000 0e1695 000002);
-my $im4 = Imager::i_img_to_pal($img, { colors=>\@pal16, make_colors=>'none' });
-write_test($im4, "testout/t107_4bit.bmp");
-push @files, "t107_4bit.bmp";
-my $im1 = Imager::i_img_to_pal($img, { colors=>[ NC(0, 0, 0), NC(176, 160, 144) ],
- make_colors=>'none', translate=>'errdiff' });
-write_test($im1, "testout/t107_1bit.bmp");
-push @files, "t107_1bit.bmp";
-my $bi_rgb = 0;
-my $bi_rle8 = 1;
-my $bi_rle4 = 2;
-my $bi_bitfields = 3;
-read_test("testout/t107_24bit.bmp", $img,
- bmp_compression=>0, bmp_bit_count => 24);
-read_test("testout/t107_8bit.bmp", $im8,
- bmp_compression=>0, bmp_bit_count => 8);
-read_test("testout/t107_4bit.bmp", $im4,
- bmp_compression=>0, bmp_bit_count => 4);
-read_test("testout/t107_1bit.bmp", $im1, bmp_compression=>0,
- bmp_bit_count=>1);
-# the following might have slight differences
-$base_diff = i_img_diff($img, $im8) * 2;
-print "# base difference $base_diff\n";
-read_test("testimg/comp4.bmp", $im4,
- bmp_compression=>$bi_rle4, bmp_bit_count => 4);
-read_test("testimg/comp8.bmp", $im8,
- bmp_compression=>$bi_rle8, bmp_bit_count => 8);
-
-my $imoo = Imager->new;
-# read via OO
-ok($imoo->read(file=>'testout/t107_24bit.bmp'), "read via OO")
- or print "# ",$imoo->errstr,"\n";
-
-ok($imoo->write(file=>'testout/t107_oo.bmp'), "write via OO")
- or print "# ",$imoo->errstr,"\n";
-push @files, "t107_oo.bmp";
-
-# various invalid format tests
-# we have so many different test images to try to detect all the possible
-# failure paths in the code, adding these did detect real problems
-print "# catch various types of invalid bmp files\n";
-my @tests =
- (
- # entries in each array ref are:
- # - basename of an invalid BMP file
- # - error message that should be produced
- # - description of what is being tested
- # - possible flag to indicate testing only on 32-bit machines
- [ 'badplanes.bmp', 'not a BMP file', "invalid planes value" ],
- [ 'badbits.bmp', 'unknown bit count for BMP file (5)',
- 'should fail to read invalid bits' ],
-
- # 1-bit/pixel BMPs
- [ 'badused1.bmp', 'out of range colors used (3)',
- 'out of range palette size (1-bit)' ],
- [ 'badcomp1.bmp', 'unknown 1-bit BMP compression (1)',
- 'invalid compression value (1-bit)' ],
- [ 'bad1wid0.bmp', 'file size limit - image width of 0 is not positive',
- 'width 0 (1-bit)' ],
- [ 'bad4oflow.bmp',
- 'file size limit - integer overflow calculating storage',
- 'overflow integers on 32-bit machines (1-bit)', '32bitonly' ],
- [ 'short1.bmp', 'failed reading 1-bit bmp data',
- 'short 1-bit' ],
-
- # 4-bit/pixel BMPs
- [ 'badused4a.bmp', 'out of range colors used (272)',
- 'should fail to read invalid pal size (272) (4-bit)' ],
- [ 'badused4b.bmp', 'out of range colors used (17)',
- 'should fail to read invalid pal size (17) (4-bit)' ],
- [ 'badcomp4.bmp', 'unknown 4-bit BMP compression (1)',
- 'invalid compression value (4-bit)' ],
- [ 'short4.bmp', 'failed reading 4-bit bmp data',
- 'short uncompressed 4-bit' ],
- [ 'short4rle.bmp', 'missing data during decompression',
- 'short compressed 4-bit' ],
- [ 'bad4wid0.bmp', 'file size limit - image width of 0 is not positive',
- 'width 0 (4-bit)' ],
- [ 'bad4widbig.bmp', 'file size limit - image width of -2147483628 is not positive',
- 'width big (4-bit)' ],
- [ 'bad4oflow.bmp', 'file size limit - integer overflow calculating storage',
- 'overflow integers on 32-bit machines (4-bit)', '32bitonly' ],
-
- # 8-bit/pixel BMPs
- [ 'bad8useda.bmp', 'out of range colors used (257)',
- 'should fail to read invalid pal size (8-bit)' ],
- [ 'bad8comp.bmp', 'unknown 8-bit BMP compression (2)',
- 'invalid compression value (8-bit)' ],
- [ 'short8.bmp', 'failed reading 8-bit bmp data',
- 'short uncompressed 8-bit' ],
- [ 'short8rle.bmp', 'missing data during decompression',
- 'short compressed 8-bit' ],
- [ 'bad8wid0.bmp', 'file size limit - image width of 0 is not positive',
- 'width 0 (8-bit)' ],
- [ 'bad8oflow.bmp', 'file size limit - integer overflow calculating storage',
- 'overflow integers on 32-bit machines (8-bit)', '32bitonly' ],
-
- # 24-bit/pixel BMPs
- [ 'short24.bmp', 'failed reading image data',
- 'short 24-bit' ],
- [ 'bad24wid0.bmp', 'file size limit - image width of 0 is not positive',
- 'width 0 (24-bit)' ],
- [ 'bad24oflow.bmp', 'file size limit - integer overflow calculating storage',
- 'overflow integers on 32-bit machines (24-bit)', '32bitonly' ],
- [ 'bad24comp.bmp', 'unknown 24-bit BMP compression (4)',
- 'bad compression (24-bit)' ],
- );
-use Config;
-my $ptrsize = $Config{ptrsize};
-for my $test (@tests) {
- my ($file, $error, $comment, $bit32only) = @$test;
- SKIP:
- {
- skip("only tested on 32-bit machines", 2)
- if $bit32only && $ptrsize != 4;
- ok(!$imoo->read(file=>"testimg/$file"), $comment);
- print "# ", $imoo->errstr, "\n";
- is($imoo->errstr, $error, "check error message");
- }
-}
-
-# previously we didn't seek to the offbits position before reading
-# the image data, check we handle it correctly
-# in each case the first is an original image with a given number of
-# bits and the second is the same file with data inserted before the
-# image bits and the offset modified to suit
-my @comp =
- (
- [ 'winrgb2.bmp', 'winrgb2off.bmp', 1 ],
- [ 'winrgb4.bmp', 'winrgb4off.bmp', 4 ],
- [ 'winrgb8.bmp', 'winrgb8off.bmp', 8 ],
- [ 'winrgb24.bmp', 'winrgb24off.bmp', 24 ],
- );
-
-for my $comp (@comp) {
- my ($base_file, $off_file, $bits) = @$comp;
-
- my $base_im = Imager->new;
- my $got_base =
- ok($base_im->read(file=>"testimg/$base_file"),
- "read original")
- or print "# ",$base_im->errstr,"\n";
- my $off_im = Imager->new;
- my $got_off =
- ok($off_im->read(file=>"testimg/$off_file"),
- "read offset file")
- or print "# ",$off_im->errstr,"\n";
- SKIP:
- {
- skip("missed one file", 1)
- unless $got_base && $got_off;
- is(i_img_diff($base_im->{IMG}, $off_im->{IMG}), 0,
- "compare base and offset image ($bits bits)");
- }
-}
-
-{ # check file limits are checked
- my $limit_file = "testout/t107_24bit.bmp";
- ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
- my $im = Imager->new;
- ok(!$im->read(file=>$limit_file),
- "should fail read due to size limits");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/image width/, "check message");
-
- ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
- ok(!$im->read(file=>$limit_file),
- "should fail read due to size limits");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/image height/, "check message");
-
- ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside width limit");
- ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside height limit");
-
- # 150 x 150 x 3 channel image uses 67500 bytes
- ok(Imager->set_file_limits(reset=>1, bytes=>67499),
- "set bytes limit 67499");
- ok(!$im->read(file=>$limit_file),
- "should fail - too many bytes");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/storage size/, "check error message");
- ok(Imager->set_file_limits(reset=>1, bytes=>67500),
- "set bytes limit 67500");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside bytes limit");
- Imager->set_file_limits(reset=>1);
-}
-
-{ # various short read failure tests, each entry has:
- # source filename, size, expected error
- # these have been selected based on code coverage, to check each
- # failure path is checked, where practical
- my @tests =
- (
- [
- "file truncated inside header",
- "winrgb2.bmp",
- 20, "file too short to be a BMP file"
- ],
- [
- "1-bit, truncated inside palette",
- "winrgb2.bmp",
- 56, "reading BMP palette"
- ],
- [
- "1-bit, truncated in offset region",
- "winrgb2off.bmp", 64, "failed skipping to image data offset"
- ],
- [
- "1-bit, truncated in image data",
- "winrgb2.bmp", 96, "failed reading 1-bit bmp data"
- ],
- [
- "4-bit, truncated inside palette",
- "winrgb4.bmp",
- 56, "reading BMP palette"
- ],
- [
- "4-bit, truncated in offset region",
- "winrgb4off.bmp", 120, "failed skipping to image data offset",
- ],
- [
- "4-bit, truncate in image data",
- "winrgb4.bmp", 120, "failed reading 4-bit bmp data"
- ],
- [
- "4-bit RLE, truncate in uncompressed data",
- "comp4.bmp", 0x229, "missing data during decompression"
- ],
- [
- "8-bit, truncated in palette",
- "winrgb8.bmp", 1060, "reading BMP palette"
- ],
- [
- "8-bit, truncated in offset region",
- "winrgb8off.bmp", 1080, "failed skipping to image data offset"
- ],
- [
- "8-bit, truncated in image data",
- "winrgb8.bmp", 1080, "failed reading 8-bit bmp data"
- ],
- [
- "8-bit RLE, truncate in uncompressed data",
- "comp8.bmp", 0x68C, "missing data during decompression"
- ],
- [
- "24-bit, truncate in offset region",
- "winrgb24off.bmp", 56, "failed skipping to image data offset",
- ],
- [
- "24-bit, truncate in image data",
- "winrgb24.bmp", 100, "failed reading image data",
- ],
- );
-
- my $test_index = 0;
- for my $test (@tests) {
- my ($desc, $srcfile, $size, $error) = @$test;
- my $im = Imager->new;
- open IMDATA, "< testimg/$srcfile"
- or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
- binmode IMDATA;
- my $data;
- read(IMDATA, $data, $size) == $size
- or die "$test_index - $desc: Could not read $size data from $srcfile";
- close IMDATA;
- ok(!$im->read(data => $data, type =>'bmp'),
- "$test_index - $desc: Should fail to read");
- is($im->errstr, $error, "$test_index - $desc: check message");
- ++$test_index;
- }
-}
-
-{ # various short read success tests, each entry has:
- # source filename, size, expected tags
- print "# allow_incomplete tests\n";
- my @tests =
- (
- [
- "1-bit",
- "winrgb2.bmp", 96,
- {
- bmp_compression_name => 'BI_RGB',
- bmp_compression => 0,
- bmp_used_colors => 2,
- i_lines_read => 8,
- },
- ],
- [
- "4-bit",
- "winrgb4.bmp", 250,
- {
- bmp_compression_name => 'BI_RGB',
- bmp_compression => 0,
- bmp_used_colors => 16,
- i_lines_read => 11,
- },
- ],
- [
- "4-bit RLE - uncompressed seq",
- "comp4.bmp", 0x229,
- {
- bmp_compression_name => 'BI_RLE4',
- bmp_compression => 2,
- bmp_used_colors => 16,
- i_lines_read => 44,
- },
- ],
- [
- "4-bit RLE - start seq",
- "comp4.bmp", 0x97,
- {
- bmp_compression_name => 'BI_RLE4',
- bmp_compression => 2,
- bmp_used_colors => 16,
- i_lines_read => 8,
- },
- ],
- [
- "8-bit",
- "winrgb8.bmp", 1250,
- {
- bmp_compression_name => 'BI_RGB',
- bmp_compression => 0,
- bmp_used_colors => 256,
- i_lines_read => 8,
- },
- ],
- [
- "8-bit RLE - uncompressed seq",
- "comp8.bmp", 0x68C,
- {
- bmp_compression_name => 'BI_RLE8',
- bmp_compression => 1,
- bmp_used_colors => 256,
- i_lines_read => 27,
- },
- ],
- [
- "8-bit RLE - initial seq",
- "comp8.bmp", 0x487,
- {
- bmp_compression_name => 'BI_RLE8',
- bmp_compression => 1,
- bmp_used_colors => 256,
- i_lines_read => 20,
- },
- ],
- [
- "24-bit",
- "winrgb24.bmp", 800,
- {
- bmp_compression_name => 'BI_RGB',
- bmp_compression => 0,
- bmp_used_colors => 0,
- i_lines_read => 12,
- },
- ],
- );
-
- my $test_index = 0;
- for my $test (@tests) {
- my ($desc, $srcfile, $size, $tags) = @$test;
- my $im = Imager->new;
- open IMDATA, "< testimg/$srcfile"
- or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
- binmode IMDATA;
- my $data;
- read(IMDATA, $data, $size) == $size
- or die "$test_index - $desc: Could not read $size data from $srcfile";
- close IMDATA;
- ok($im->read(data => $data, type =>'bmp', allow_incomplete => 1),
- "$test_index - $desc: Should read successfully");
- # check standard tags are set
- is($im->tags(name => 'i_format'), 'bmp',
- "$test_index - $desc: i_format set");
- is($im->tags(name => 'i_incomplete'), 1,
- "$test_index - $desc: i_incomplete set");
- my %check_tags;
- for my $key (keys %$tags) {
- $check_tags{$key} = $im->tags(name => $key);
- }
- is_deeply(\%check_tags, $tags, "$test_index - $desc: check tags");
- ++$test_index;
- }
-}
-
-{ # check handling of reading images with negative height
- # each entry is:
- # source file, description
- print "# check handling of negative height values\n";
- my @tests =
- (
- [ "winrgb2.bmp", "1-bit, uncompressed" ],
- [ "winrgb4.bmp", "4-bit, uncompressed" ],
- [ "winrgb8.bmp", "8-bit, uncompressed" ],
- [ "winrgb24.bmp", "24-bit, uncompressed" ],
- [ "comp4.bmp", "4-bit, RLE" ],
- [ "comp8.bmp", "8-bit, RLE" ],
- );
- my $test_index = 0;
- for my $test (@tests) {
- my ($file, $desc) = @$test;
- open IMDATA, "< testimg/$file"
- or die "$test_index - Cannot open $file: $!";
- binmode IMDATA;
- my $data = do { local $/; <IMDATA> };
- close IMDATA;
- my $im_orig = Imager->new;
- $im_orig->read(data => $data)
- or die "Cannot load original $file: ", $im_orig->errstr;
-
- # now negate the height
- my $orig_height = unpack("V", substr($data, 0x16, 4));
- my $neg_height = 0xFFFFFFFF & ~($orig_height - 1);
- substr($data, 0x16, 4) = pack("V", $neg_height);
-
- # and read the modified image
- my $im = Imager->new;
- ok($im->read(data => $data),
- "$test_index - $desc: read negated height image")
- or print "# ", $im->errstr, "\n";
-
- # flip orig to match what we should get
- $im_orig->flip(dir => 'v');
-
- # check it out
- is_image($im, $im_orig, "$test_index - $desc: check image");
-
- ++$test_index;
- }
-}
-
-{ print "# patched data read failure tests\n";
- # like the "various invalid format" tests, these generate fail
- # images from other images included with Imager without providing a
- # full bmp source, saving on dist size and focusing on the changes needed
- # to cause the failure
- # each entry is: source file, patches, expected error, description
-
- my @tests =
- (
- # low image data offsets
- [
- "winrgb2.bmp",
- { 10 => "3d 00 00 00" },
- "image data offset too small (61)",
- "1-bit, small image offset"
- ],
- [
- "winrgb4.bmp",
- { 10 => "75 00 00 00" },
- "image data offset too small (117)",
- "4-bit, small image offset"
- ],
- [
- "winrgb8.bmp",
- { 10 => "35 04 00 00" },
- "image data offset too small (1077)",
- "8-bit, small image offset"
- ],
- [
- "winrgb24.bmp",
- { 10 => "35 00 00 00" },
- "image data offset too small (53)",
- "24-bit, small image offset"
- ],
- # compression issues
- [
- "comp8.bmp",
- { 0x436 => "97" },
- "invalid data during decompression",
- "8bit, RLE run beyond edge of image"
- ],
- [
- # caused glibc malloc or valgrind to complain
- "comp8.bmp",
- { 0x436 => "94 00 00 03" },
- "invalid data during decompression",
- "8bit, literal run beyond edge of image"
- ],
- [
- "comp4.bmp",
- { 0x76 => "FF bb FF BB" },
- "invalid data during decompression",
- "4bit - RLE run beyond edge of image"
- ],
- [
- "comp4.bmp",
- { 0x76 => "94 bb 00 FF" },
- "invalid data during decompression",
- "4bit - literal run beyond edge of image"
- ],
- );
- my $test_index = 0;
- for my $test (@tests) {
- my ($filename, $patches, $error, $desc) = @$test;
-
- my $data = load_patched_file("testimg/$filename", $patches);
- my $im = Imager->new;
- ok(!$im->read(data => $data, type=>'bmp'),
- "$test_index - $desc:should fail to read");
- is($im->errstr, $error, "$test_index - $desc:check message");
- ++$test_index;
- }
-}
-
-{ # various write failure tests
- # each entry is:
- # source, limit, expected error, description
- my @tests =
- (
- [
- "winrgb2.bmp", 1,
- "cannot write bmp header: limit reached",
- "1-bit, writing header"
- ],
- [
- "winrgb4.bmp", 1,
- "cannot write bmp header: limit reached",
- "4-bit, writing header"
- ],
- [
- "winrgb8.bmp", 1,
- "cannot write bmp header: limit reached",
- "8-bit, writing header"
- ],
- [
- "winrgb24.bmp", 1,
- "cannot write bmp header: limit reached",
- "24-bit, writing header"
- ],
- [
- "winrgb2.bmp", 0x38,
- "cannot write palette entry: limit reached",
- "1-bit, writing palette"
- ],
- [
- "winrgb4.bmp", 0x38,
- "cannot write palette entry: limit reached",
- "4-bit, writing palette"
- ],
- [
- "winrgb8.bmp", 0x38,
- "cannot write palette entry: limit reached",
- "8-bit, writing palette"
- ],
- [
- "winrgb2.bmp", 0x40,
- "writing 1 bit/pixel packed data: limit reached",
- "1-bit, writing image data"
- ],
- [
- "winrgb4.bmp", 0x80,
- "writing 4 bit/pixel packed data: limit reached",
- "4-bit, writing image data"
- ],
- [
- "winrgb8.bmp", 0x440,
- "writing 8 bit/pixel packed data: limit reached",
- "8-bit, writing image data"
- ],
- [
- "winrgb24.bmp", 0x39,
- "writing image data: limit reached",
- "24-bit, writing image data"
- ],
- );
- print "# write failure tests\n";
- my $test_index = 0;
- for my $test (@tests) {
- my ($file, $limit, $error, $desc) = @$test;
-
- my $im = Imager->new;
- $im->read(file => "testimg/$file")
- or die "Cannot read $file: ", $im->errstr;
-
- my $io = Imager::io_new_cb(limited_write($limit), undef, undef, undef, 1);
- $io->set_buffered(0);
- print "# writing with limit of $limit\n";
- ok(!$im->write(type => 'bmp', io => $io),
- "$test_index - $desc: write should fail");
- is($im->errstr, $error, "$test_index - $desc: check error message");
-
- ++$test_index;
- }
-}
-
-{
- ok(grep($_ eq 'bmp', Imager->read_types), "check bmp in read types");
- ok(grep($_ eq 'bmp', Imager->write_types), "check bmp in write types");
-}
-
-{
- # RT #30075
- # give 4/2 channel images a background color when saving to BMP
- 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);
- ok($im->write(file=>"testout/t107_alpha.bmp", type=>'bmp'),
- "should succeed writing 4 channel image");
- push @files, "t107_alpha.bmp";
- my $imread = Imager->new;
- ok($imread->read(file => 'testout/t107_alpha.bmp'), "read it back");
- 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 => 'bmp', i_background => '#FF0000'),
- "write with red background");
- ok($imread->read(data => $data, type => 'bmp'),
- "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");
-}
-
-{ # RT 41406
- my $data;
- my $im = test_image();
- ok($im->write(data => \$data, type => 'bmp'), "write using OO");
- my $size = unpack("V", substr($data, 34, 4));
- is($size, 67800, "check data size");
-}
-
-{ # check close failures are handled correctly
- my $im = test_image();
- my $fail_close = sub {
- Imager::i_push_error(0, "synthetic close failure");
- return 0;
- };
- ok(!$im->write(type => "bmp", callback => sub { 1 },
- closecb => $fail_close),
- "check failing close fails");
- like($im->errstr, qr/synthetic close failure/,
- "check error message");
-}
-
-Imager->close_log;
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink map "testout/$_", @files;
- unlink "testout/t107bmp.log";
-}
-
-sub write_test {
- my ($im, $filename) = @_;
- local *FH;
-
- if (open FH, "> $filename") {
- binmode FH;
- my $IO = Imager::io_new_fd(fileno(FH));
- unless (ok(Imager::i_writebmp_wiol($im, $IO), $filename)) {
- print "# ",Imager->_error_as_msg(),"\n";
- }
- undef $IO;
- close FH;
- }
- else {
- fail("could not open $filename: $!");
- }
-}
-
-sub read_test {
- my ($filename, $im, %tags) = @_;
- local *FH;
-
- print "# read_test: $filename\n";
-
- $tags{i_format} = "bmp";
-
- if (open FH, "< $filename") {
- binmode FH;
- my $IO = Imager::io_new_fd(fileno(FH));
- my $im_read = Imager::i_readbmp_wiol($IO);
- if ($im_read) {
- my $diff = i_img_diff($im, $im_read);
- if ($diff > $base_diff) {
- fail("image mismatch reading $filename");
- }
- else {
- my $tags_ok = 1;
- for my $tag (keys %tags) {
- if (my $index = Imager::i_tags_find($im_read, $tag, 0)) {
- my ($name, $value) = Imager::i_tags_get($im_read, $index);
- my $exp_value = $tags{$tag};
- print "# tag $name = '$value' - expect '$exp_value'\n";
- if ($exp_value =~ /\d/) {
- if ($value != $tags{$tag}) {
- print "# tag $tag value mismatch $tags{$tag} != $value\n";
- $tags_ok = 0;
- }
- }
- else {
- if ($value ne $tags{$tag}) {
- print "# tag $tag value mismatch $tags{$tag} != $value\n";
- $tags_ok = 0;
- }
- }
- }
- }
- ok($tags_ok, "reading $filename");
- # for my $i (0 .. Imager::i_tags_count($im_read)-1) {
- # my ($name, $value) = Imager::i_tags_get($im_read, $i);
- # print "# tag '$name' => '$value'\n";
- #}
- }
- }
- else {
- fail("could not read $filename: ".Imager->_error_as_msg());
- }
- undef $IO;
- close FH;
- }
- else {
- fail("could not open $filename: $!");
- }
-}
-
-sub limited_write {
- my ($limit) = @_;
-
- return
- sub {
- my ($data) = @_;
- $limit -= length $data;
- if ($limit >= 0) {
- print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
- return 1;
- }
- else {
- print "# write of ", length $data, " bytes failed\n";
- Imager::i_push_error(0, "limit reached");
- return;
- }
- };
-}
-
-sub load_patched_file {
- my ($filename, $patches) = @_;
-
- open IMDATA, "< $filename"
- or die "Cannot open $filename: $!";
- binmode IMDATA;
- my $data = do { local $/; <IMDATA> };
- for my $offset (keys %$patches) {
- (my $hdata = $patches->{$offset}) =~ tr/ //d;
- my $pdata = pack("H*", $hdata);
- substr($data, $offset, length $pdata) = $pdata;
- }
-
- return $data;
-}
+++ /dev/null
-#!perl -w
-use Imager qw(:all);
-use strict;
-use Test::More tests=>68;
-use Imager::Test qw(is_color4 is_image test_image);
-
--d "testout" or mkdir "testout";
-
-init_log("testout/t108tga.log",1);
-
-my $img = create_test_image();
-my $base_diff = 0;
-
-write_test($img, "testout/t108_24bit.tga", 0, 0, "");
-write_test($img, "testout/t108_24bit_rle.tga", 0, 1, "");
-write_test($img, "testout/t108_15bit.tga", 1, 1, "");
-write_test($img, "testout/t108_15bit_rle.tga", 1, 1, "");
-
-# 'webmap' is noticably faster than the default
-my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
- translate=>'errdiff'});
-
-write_test($im8, "testout/t108_8bit.tga", 0, 0, "");
-write_test($im8, "testout/t108_8bit_rle.tga", 0, 1, "");
-write_test($im8, "testout/t108_8_15bit.tga", 1, 0, "");
-write_test($im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
-
-
-# use a fixed palette so we get reproducible results for the compressed
-# version
-
-my @bit4 = map { NC($_) }
- qw(605844 966600 0148b2 00f800 bf0a33 5e009e
- 2ead1b 0000f8 004b01 fd0000 0e1695 000002);
-
-my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
-
-my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
- make_colors=>'none' });
-
-my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
- make_colors=>'none',
- translate=>'errdiff' });
-
-write_test($im4, "testout/t108_4bit.tga", 0, 1, "");
-write_test($im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
-
-read_test("testout/t108_24bit.tga", $img);
-read_test("testout/t108_8bit.tga", $im8);
-read_test("testout/t108_4bit.tga", $im4);
-read_test("testout/t108_1bit.tga", $im1);
-
-# the following might have slight differences
-
-$base_diff = i_img_diff($img, $im8) * 2;
-
-print "# base difference $base_diff\n";
-
-my $imoo = Imager->new;
-ok($imoo->read(file=>'testout/t108_24bit.tga'),
- "OO read image")
- or print "# ",$imoo->errstr,"\n";
-
-ok($imoo->write(file=>'testout/t108_oo.tga'),
- "OO write image")
- or print "# ",$imoo->errstr,"\n";
-
-my ($type) = $imoo->tags(name=>'i_format');
-is($type, 'tga', "check i_format tag");
-
-# in 0.44 and earlier, reading an image with an idstring of 128 or more
-# bytes would result in an allocation error, if the platform char type
-# was signed
-$imoo = Imager->new;
-ok($imoo->read(file=>'testimg/longid.tga'), "read long id image");
-my ($id) = $imoo->tags(name=>'tga_idstring');
-is($id, "X" x 128, "check tga_idstring tag");
-my ($bitspp) = $imoo->tags(name=>'tga_bitspp');
-is($bitspp, 24, "check tga_bitspp tag");
-my ($compressed) = $imoo->tags(name=>'compressed');
-is($compressed, 1, "check compressed tag");
-
-{ # check file limits are checked
- my $limit_file = "testout/t108_24bit.tga";
- ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
- my $im = Imager->new;
- ok(!$im->read(file=>$limit_file),
- "should fail read due to size limits");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/image width/, "check message");
-
- ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
- ok(!$im->read(file=>$limit_file),
- "should fail read due to size limits");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/image height/, "check message");
-
- ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside width limit");
- ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside height limit");
-
- # 150 x 150 x 3 channel image uses 67500 bytes
- ok(Imager->set_file_limits(reset=>1, bytes=>67499),
- "set bytes limit 67499");
- ok(!$im->read(file=>$limit_file),
- "should fail - too many bytes");
- print "# ",$im->errstr,"\n";
- like($im->errstr, qr/storage size/, "check error message");
- ok(Imager->set_file_limits(reset=>1, bytes=>67500),
- "set bytes limit 67500");
- ok($im->read(file=>$limit_file),
- "should succeed - just inside bytes limit");
- Imager->set_file_limits(reset=>1);
-}
-
-{ # Issue # 18397
- # the issue is for 4 channel images to jpeg, but 2 channel images have
- # a similar problem on tga
- my $im = Imager->new(xsize=>100, ysize=>100, channels => 2);
- my $data;
- ok(!$im->write(data => \$data, type=>'tga'),
- "check failure of writing a 2 channel image");
- is($im->errstr, "Cannot store 2 channel image in targa format",
- "check the error message");
-}
-
-{
- ok(grep($_ eq 'tga', Imager->read_types), "check tga in read types");
- ok(grep($_ eq 'tga', Imager->write_types), "check tga in write types");
-}
-
-{ # Issue #32926
- # a sample image was read as all transparent
- # it had bitsperpixel = 16 and atribute channel set to 1, so it
- # should have an alpha channel.
- # So we'll do what the gimp does and treat a zero value as opaque.
-
- my $im = Imager->new;
- ok($im->read(file => 'testimg/alpha16.tga'),
- "read 16-bit/pixel alpha image");
- my $c1 = $im->getpixel('x' => 0, 'y' => 0);
- is_color4($c1, 0, 0, 0, 0, "check transparent pixel");
- my $c2 = $im->getpixel('x' => 19, 'y' => 0);
- is_color4($c2, 255, 0, 0, 255, "check opaque pixel");
-
- # since this has an effect on writing too, write,it, read it, check it
- my $data;
- ok($im->write(data => \$data, type => 'tga', wierdpack => 1),
- "write 16-bit/pixel w/alpha");
- my $im2 = Imager->new;
- ok($im2->read(data => $data), "read it back");
- is_image($im, $im2, "check they match");
-}
-
-{ # prior to the types re-work we treated the tga xsize/ysize as
- # signed short, which is wrong
- SKIP:
- {
- my $im = Imager->new(xsize => 40960, ysize => 1);
- my $data;
- ok($im->write(data => \$data, type => "tga"),
- "write a wide (but not too wide) image out");
- my $im2 = Imager->new(data => $data);
- ok($im2, "read it back in")
- or skip("Couldn't read the wide image", 2);
- is($im2->getwidth, 40960, "make sure the width survived the trip");
- is($im2->getheight, 1, "make sure the height survived the trip");
- }
-
- SKIP:
- {
- my $im = Imager->new(xsize => 1, ysize => 40960);
- my $data;
- ok($im->write(data => \$data, type => "tga"),
- "write a tall (but not too tall) image out");
- my $im2 = Imager->new(data => $data);
- ok($im2, "read it back in")
- or skip("Couldn't read the tall image", 2);
- is($im2->getwidth, 1, "make sure the width survived the trip");
- is($im2->getheight, 40960, "make sure the height survived the trip");
- }
-}
-
-{
- # TGA files are limited to 0xFFFF x 0xFFFF pixels
- my $max_dim = 0xFFFF;
- {
- my $im = Imager->new(xsize => 1+$max_dim, ysize => 1);
- my $data = '';
- ok(!$im->write(data => \$data, type => "tga"),
- "fail to write too wide an image");
- is($im->errstr, "image too large for TGA",
- "check error message");
- }
- SKIP:
- {
- my $im = Imager->new(xsize => $max_dim, ysize => 1);
- $im->box(fill => { hatch => "check4x4" });
- my $data = '';
- ok($im->write(data => \$data, type => "tga"),
- "write image at width limit")
- or print "# ", $im->errstr, "\n";
- my $im2 = Imager->new(data => $data, ftype => "tga");
- ok($im2, "read it ok")
- or skip("cannot load the wide image", 1);
- is($im->getwidth, $max_dim, "check width");
- is($im->getheight, 1, "check height");
- }
- {
- my $im = Imager->new(xsize => 1, ysize => 1+$max_dim);
- my $data = '';
- ok(!$im->write(data => \$data, type => "tga"),
- "fail to write too tall an image");
- is($im->errstr, "image too large for TGA",
- "check error message");
- }
- SKIP:
- {
- my $im = Imager->new(xsize => 1, ysize => $max_dim);
- $im->box(fill => { hatch => "check2x2" });
- my $data = '';
- ok($im->write(data => \$data, type => "tga"),
- "write image at width limit");
- my $im2 = Imager->new(data => $data, ftype => "tga");
- ok($im2, "read it ok")
- or skip("cannot load the wide image", 1);
- is($im->getwidth, 1, "check width");
- is($im->getheight, $max_dim, "check height");
- }
-}
-
-{ # check close failures are handled correctly
- my $im = test_image();
- my $fail_close = sub {
- Imager::i_push_error(0, "synthetic close failure");
- return 0;
- };
- ok(!$im->write(type => "tga", callback => sub { 1 },
- closecb => $fail_close),
- "check failing close fails");
- like($im->errstr, qr/synthetic close failure/,
- "check error message");
-}
-
-sub write_test {
- my ($im, $filename, $wierdpack, $compress, $idstring) = @_;
- local *FH;
-
- if (open FH, "> $filename") {
- binmode FH;
- my $IO = Imager::io_new_fd(fileno(FH));
- ok(Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring),
- "write $filename")
- or print "# ",Imager->_error_as_msg(),"\n";
- undef $IO;
- close FH;
- } else {
- fail("write $filename: open failed: $!");
- }
-}
-
-
-sub read_test {
- my ($filename, $im, %tags) = @_;
- local *FH;
-
- if (open FH, "< $filename") {
- binmode FH;
- my $IO = Imager::io_new_fd(fileno(FH));
- my $im_read = Imager::i_readtga_wiol($IO,-1);
- if ($im_read) {
- my $diff = i_img_diff($im, $im_read);
- cmp_ok($diff, '<=', $base_diff,
- "check read image vs original");
- } else {
- fail("read $filename ".Imager->_error_as_msg());
- }
- undef $IO;
- close FH;
- } else {
- fail("read $filename, open failure: $!");
- }
-}
-
-sub create_test_image {
-
- 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 $img = Imager::ImgRaw::new(150,150,3);
-
- i_box_filled($img, 70, 25, 130, 125, $green);
- i_box_filled($img, 20, 25, 80, 125, $blue);
- i_arc($img, 75, 75, 30, 0, 361, $red);
- i_conv($img, [0.1, 0.2, 0.4, 0.2, 0.1]);
-
- return $img;
-}
+++ /dev/null
-#!perl -w
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-use Test::More tests => 70;
-
-use Imager;
-use Imager::Test qw(is_fcolor4);
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t15color.log");
-
-my $c1 = Imager::Color->new(100, 150, 200, 250);
-ok(test_col($c1, 100, 150, 200, 250), 'simple 4-arg');
-my $c2 = Imager::Color->new(100, 150, 200);
-ok(test_col($c2, 100, 150, 200, 255), 'simple 3-arg');
-my $c3 = Imager::Color->new("#6496C8");
-ok(test_col($c3, 100, 150, 200, 255), 'web color');
-# crashes in Imager-0.38pre8 and earlier
-my @foo;
-for (1..1000) {
- push(@foo, Imager::Color->new("#FFFFFF"));
-}
-my $fail;
-for (@foo) {
- Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
- Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
- test_col($_, 128, 128, 128, 128) or ++$fail;
-}
-ok(!$fail, 'consitency check');
-
-# test the new OO methods
-color_ok('r g b',, 100, 150, 200, 255, Imager::Color->new(r=>100, g=>150, b=>200));
-color_ok('red green blue', 101, 151, 201, 255,
- Imager::Color->new(red=>101, green=>151, blue=>201));
-color_ok('grey', 102, 255, 255, 255, Imager::Color->new(grey=>102));
-color_ok('gray', 103, 255, 255, 255, Imager::Color->new(gray=>103));
-SKIP:
-{
- skip "no X rgb.txt found", 1
- unless grep -r, Imager::Color::_test_x_palettes();
- color_ok('xname', 0, 0, 255, 255, Imager::Color->new(xname=>'blue'));
-}
-color_ok('gimp', 255, 250, 250, 255,
- Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal'));
-color_ok('h s v', 255, 255, 255, 255, Imager::Color->new(h=>0, 's'=>0, 'v'=>1.0));
-color_ok('h s v again', 255, 0, 0, 255, Imager::Color->new(h=>0, 's'=>1, v=>1));
-color_ok('web 6 digit', 128, 129, 130, 255, Imager::Color->new(web=>'#808182'));
-color_ok('web 3 digit', 0x11, 0x22, 0x33, 255, Imager::Color->new(web=>'#123'));
-color_ok('rgb arrayref', 255, 150, 121, 255, Imager::Color->new(rgb=>[ 255, 150, 121 ]));
-color_ok('rgba arrayref', 255, 150, 121, 128,
- Imager::Color->new(rgba=>[ 255, 150, 121, 128 ]));
-color_ok('hsv arrayref', 255, 0, 0, 255, Imager::Color->new(hsv=>[ 0, 1, 1 ]));
-color_ok('channel0-3', 129, 130, 131, 134,
- Imager::Color->new(channel0=>129, channel1=>130, channel2=>131,
- channel3=>134));
-color_ok('c0-3', 129, 130, 131, 134,
- Imager::Color->new(c0=>129, c1=>130, c2=>131, c3=>134));
-color_ok('channels arrayref', 200, 201, 203, 204,
- Imager::Color->new(channels=>[ 200, 201, 203, 204 ]));
-color_ok('name', 255, 250, 250, 255,
- Imager::Color->new(name=>'snow', palette=>'testimg/test_gimp_pal'));
-
-# test the internal HSV <=> RGB conversions
-# these values were generated using the GIMP
-# all but hue is 0..360, saturation and value from 0 to 1
-# rgb from 0 to 255
-my @hsv_vs_rgb =
- (
- { hsv => [ 0, 0.2, 0.1 ], rgb=> [ 25, 20, 20 ] },
- { hsv => [ 0, 0.5, 1.0 ], rgb => [ 255, 127, 127 ] },
- { hsv => [ 100, 0.5, 1.0 ], rgb => [ 170, 255, 127 ] },
- { hsv => [ 100, 1.0, 1.0 ], rgb=> [ 85, 255, 0 ] },
- { hsv => [ 335, 0.5, 0.5 ], rgb=> [127, 63, 90 ] },
- );
-
-use Imager::Color::Float;
-my $test_num = 23;
-my $index = 0;
-for my $entry (@hsv_vs_rgb) {
- print "# color index $index\n";
- my $hsv = $entry->{hsv};
- my $rgb = $entry->{rgb};
- my $fhsvo = Imager::Color::Float->new($hsv->[0]/360.0, $hsv->[1], $hsv->[2]);
- my $fc = Imager::Color::Float::i_hsv_to_rgb($fhsvo);
- fcolor_close_enough("i_hsv_to_rgbf $index", $rgb->[0]/255, $rgb->[1]/255,
- $rgb->[2]/255, $fc);
- my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
- fcolor_close_enough("i_rgbf_to_hsv $index", $hsv->[0]/360.0, $hsv->[1], $hsv->[2],
- $fc2);
-
- my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255,
- $hsv->[2] * 255);
- my $c = Imager::Color::i_hsv_to_rgb($hsvo);
- color_close_enough("i_hsv_to_rgb $index", @$rgb, $c);
- my $c2 = Imager::Color::i_rgb_to_hsv($c);
- color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255,
- $hsv->[2] * 255, $c2);
- ++$index;
-}
-
-# check the built-ins table
-color_ok('builtin black', 0, 0, 0, 255,
- Imager::Color->new(builtin=>'black'));
-
-{
- my $c1 = Imager::Color->new(255, 255, 255, 0);
- my $c2 = Imager::Color->new(255, 255, 255, 255);
- ok(!$c1->equals(other=>$c2), "not equal no ignore alpha");
- ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)),
- "equal with ignore alpha");
- ok($c1->equals(other=>$c1), "equal to itself");
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=13143
- # Imager::Color->new(color_name) warning if HOME environment variable not set
- local $ENV{HOME};
- my @warnings;
- local $SIG{__WARN__} = sub { push @warnings, "@_" };
-
- # presumably no-one will name a color like this.
- my $c1 = Imager::Color->new(gimp=>"ABCDEFGHIJKLMNOP");
- is(@warnings, 0, "Should be no warnings")
- or do { print "# $_" for @warnings };
-}
-
-{
- # float color from hex triple
- my $f3white = Imager::Color::Float->new("#FFFFFF");
- is_fcolor4($f3white, 1.0, 1.0, 1.0, 1.0, "check color #FFFFFF");
- my $f3black = Imager::Color::Float->new("#000000");
- is_fcolor4($f3black, 0, 0, 0, 1.0, "check color #000000");
- my $f3grey = Imager::Color::Float->new("#808080");
- is_fcolor4($f3grey, 0x80/0xff, 0x80/0xff, 0x80/0xff, 1.0, "check color #808080");
-
- my $f4white = Imager::Color::Float->new("#FFFFFF80");
- is_fcolor4($f4white, 1.0, 1.0, 1.0, 0x80/0xff, "check color #FFFFFF80");
-}
-
-{
- # fail to make a color
- ok(!Imager::Color::Float->new("-unknown-"), "try to make float color -unknown-");
-}
-
-{
- # set after creation
- my $c = Imager::Color::Float->new(0, 0, 0);
- is_fcolor4($c, 0, 0, 0, 1.0, "check simple init of float color");
- ok($c->set(1.0, 0.5, 0.25, 1.0), "set() the color");
- is_fcolor4($c, 1.0, 0.5, 0.25, 1.0, "check after set");
-
- ok(!$c->set("-unknown-"), "set to unknown");
-}
-
-{
- # test ->hsv
- my $c = Imager::Color->new(255, 0, 0);
- my($h,$s,$v) = $c->hsv;
- is($h,0,'red hue');
- is($s,1,'red saturation');
- is($v,1,'red value');
-
- $c = Imager::Color->new(0, 255, 0);
- ($h,$s,$v) = $c->hsv;
- is($h,120,'green hue');
- is($s,1,'green saturation');
- is($v,1,'green value');
-
- $c = Imager::Color->new(0, 0, 255);
- ($h,$s,$v) = $c->hsv;
- is($h,240,'blue hue');
- is($s,1,'blue saturation');
- is($v,1,'blue value');
-
- $c = Imager::Color->new(255, 255, 255);
- ($h,$s,$v) = $c->hsv;
- is($h,0,'white hue');
- is($s,0,'white saturation');
- is($v,1,'white value');
-
- $c = Imager::Color->new(0, 0, 0);
- ($h,$s,$v) = $c->hsv;
- is($h,0,'black hue');
- is($s,0,'black saturation');
- is($v,0,'black value');
-}
-
-sub test_col {
- my ($c, $r, $g, $b, $a) = @_;
- unless ($c) {
- print "# $Imager::ERRSTR\n";
- return 0;
- }
- my ($cr, $cg, $cb, $ca) = $c->rgba;
- return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
-}
-
-sub color_close_enough {
- my ($name, $r, $g, $b, $c) = @_;
-
- my ($cr, $cg, $cb) = $c->rgba;
- ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5,
- "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
-}
-
-sub color_close_enough_hsv {
- my ($name, $h, $s, $v, $c) = @_;
-
- my ($ch, $cs, $cv) = $c->rgba;
- if ($ch < 5 && $h > 250) {
- $ch += 255;
- }
- elsif ($ch > 250 && $h < 5) {
- $h += 255;
- }
- ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5,
- "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)");
-}
-
-sub fcolor_close_enough {
- my ($name, $r, $g, $b, $c) = @_;
-
- my ($cr, $cg, $cb) = $c->rgba;
- ok(abs($cr-$r) <= 0.01 && abs($cg-$g) <= 0.01 && abs($cb-$b) <= 0.01,
- "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
-}
-
-sub color_ok {
- my ($name, $r, $g, $b, $a, $c) = @_;
-
- unless (ok(test_col($c, $r, $g, $b, $a), $name)) {
- print "# ($r,$g,$b,$a) != (".join(",", $c ? $c->rgba: ()).")\n";
- }
-}
-
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 23;
-use Imager;
-
-BEGIN { use_ok('Imager::Matrix2d', ':handy') }
-
-my $id = Imager::Matrix2d->identity;
-
-ok(almost_equal($id, [ 1, 0, 0,
- 0, 1, 0,
- 0, 0, 1 ]), "identity matrix");
-my $trans = Imager::Matrix2d->translate('x'=>10, 'y'=>-11);
-ok(almost_equal($trans, [ 1, 0, 10,
- 0, 1, -11,
- 0, 0, 1 ]), "translate matrix");
-my $trans_x = Imager::Matrix2d->translate(x => 10);
-ok(almost_equal($trans_x, [ 1, 0, 10,
- 0, 1, 0,
- 0, 0, 1 ]), "translate just x");
-my $trans_y = Imager::Matrix2d->translate('y' => 11);
-ok(almost_equal($trans_y, [ 1, 0, 0,
- 0, 1, 11,
- 0, 0, 1 ]), "translate just y");
-
-my $rotate = Imager::Matrix2d->rotate(degrees=>90);
-ok(almost_equal($rotate, [ 0, -1, 0,
- 1, 0, 0,
- 0, 0, 1 ]), "rotate matrix");
-
-my $shear = Imager::Matrix2d->shear('x'=>0.2, 'y'=>0.3);
-ok(almost_equal($shear, [ 1, 0.2, 0,
- 0.3, 1, 0,
- 0, 0, 1 ]), "shear matrix");
-
-my $scale = Imager::Matrix2d->scale('x'=>1.2, 'y'=>0.8);
-ok(almost_equal($scale, [ 1.2, 0, 0,
- 0, 0.8, 0,
- 0, 0, 1 ]), "scale matrix");
-
-my $custom = Imager::Matrix2d->matrix(1, 0, 0, 0, 1, 0, 0, 0, 1);
-ok(almost_equal($custom, [ 1, 0, 0,
- 0, 1, 0,
- 0, 0, 1 ]), "custom matrix");
-
-my $trans_called;
-$rotate = Imager::Matrix2d::Test->rotate(degrees=>90, x=>50);
-ok($trans_called, "translate called on rotate with just x");
-
-$trans_called = 0;
-$rotate = Imager::Matrix2d::Test->rotate(degrees=>90, 'y'=>50);
-ok($trans_called, "translate called on rotate with just y");
-
-ok(!Imager::Matrix2d->matrix(), "bad custom matrix");
-is(Imager->errstr, "9 co-efficients required", "check error");
-
-{
- my @half = ( 0.5, 0, 0,
- 0, 0.5, 0,
- 0, 0, 1 );
- my @quart = ( 0, 0.25, 0,
- 1, 0, 0,
- 0, 0, 1 );
- my $half_matrix = Imager::Matrix2d->matrix(@half);
- my $quart_matrix = Imager::Matrix2d->matrix(@quart);
- my $result = $half_matrix * $quart_matrix;
- is_deeply($half_matrix * \@quart, $result, "mult by unblessed matrix");
- is_deeply(\@half * $quart_matrix, $result, "mult with unblessed matrix");
-
- my $half_three = Imager::Matrix2d->matrix(1.5, 0, 0, 0, 1.5, 0, 0, 0, 3);
- is_deeply($half_matrix * 3, $half_three, "mult by three");
- is_deeply(3 * $half_matrix, $half_three, "mult with three");
-
- {
- # check error handling - bad ref type
- my $died =
- !eval {
- my $foo = $half_matrix * +{};
- 1;
- };
- ok($died, "mult by hash ref died");
- like($@, qr/multiply by array ref or number/, "check message");
- }
-
- {
- # check error handling - bad array
- $@ = '';
- my $died =
- !eval {
- my $foo = $half_matrix * [ 1 .. 8 ];
- 1;
- };
- ok($died, "mult by short array ref died");
- like($@, qr/9 elements required in array ref/, "check message");
- }
-
- {
- # check error handling - bad value
- $@ = '';
- my $died =
- !eval {
- my $foo = $half_matrix * "abc";
- 1;
- };
- ok($died, "mult by bad scalar died");
- like($@, qr/multiply by array ref or number/, "check message");
- }
-
-}
-
-
-sub almost_equal {
- my ($m1, $m2) = @_;
-
- for my $i (0..8) {
- abs($m1->[$i] - $m2->[$i]) < 0.00001 or return undef;
- }
- return 1;
-}
-
-# this is used to ensure translate() is called correctly by rotate
-package Imager::Matrix2d::Test;
-use vars qw(@ISA);
-BEGIN { @ISA = qw(Imager::Matrix2d); }
-
-sub translate {
- my ($class, %opts) = @_;
-
- ++$trans_called;
- return $class->SUPER::translate(%opts);
-}
-
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 165;
-
-use Imager ':handy';
-use Imager::Fill;
-use Imager::Color::Float;
-use Imager::Test qw(is_image is_color4 is_fcolor4 is_color3);
-use Config;
-
--d "testout" or mkdir "testout";
-
-Imager::init_log("testout/t20fill.log", 1);
-
-my $blue = NC(0,0,255);
-my $red = NC(255, 0, 0);
-my $redf = Imager::Color::Float->new(1, 0, 0);
-my $bluef = Imager::Color::Float->new(0, 0, 1);
-my $rsolid = Imager::i_new_fill_solid($blue, 0);
-ok($rsolid, "building solid fill");
-my $raw1 = Imager::ImgRaw::new(100, 100, 3);
-# use the normal filled box
-Imager::i_box_filled($raw1, 0, 0, 99, 99, $blue);
-my $raw2 = Imager::ImgRaw::new(100, 100, 3);
-Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid);
-ok(1, "drawing with solid fill");
-my $diff = Imager::i_img_diff($raw1, $raw2);
-ok($diff == 0, "solid fill doesn't match");
-Imager::i_box_filled($raw1, 0, 0, 99, 99, $red);
-my $rsolid2 = Imager::i_new_fill_solidf($redf, 0);
-ok($rsolid2, "creating float solid fill");
-Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rsolid2);
-$diff = Imager::i_img_diff($raw1, $raw2);
-ok($diff == 0, "float solid fill doesn't match");
-
-# ok solid still works, let's try a hatch
-# hash1 is a 2x2 checkerboard
-my $rhatcha = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 0, 0);
-my $rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 2, 0);
-ok($rhatcha && $rhatchb, "can't build hatched fill");
-
-# the offset should make these match
-Imager::i_box_cfill($raw1, 0, 0, 99, 99, $rhatcha);
-Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
-ok(1, "filling with hatch");
-$diff = Imager::i_img_diff($raw1, $raw2);
-ok($diff == 0, "hatch images different");
-$rhatchb = Imager::i_new_fill_hatch($blue, $red, 0, 1, undef, 4, 6);
-Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
-$diff = Imager::i_img_diff($raw1, $raw2);
-ok($diff == 0, "hatch images different");
-
-# I guess I was tired when I originally did this - make sure it keeps
-# acting the way it's meant to
-# I had originally expected these to match with the red and blue swapped
-$rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 2, 2);
-Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
-$diff = Imager::i_img_diff($raw1, $raw2);
-ok($diff == 0, "hatch images different");
-
-# this shouldn't match
-$rhatchb = Imager::i_new_fill_hatch($red, $blue, 0, 1, undef, 1, 1);
-Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rhatchb);
-$diff = Imager::i_img_diff($raw1, $raw2);
-ok($diff, "hatch images the same!");
-
-# custom hatch
-# the inverse of the 2x2 checkerboard
-my $hatch = pack("C8", 0x33, 0x33, 0xCC, 0xCC, 0x33, 0x33, 0xCC, 0xCC);
-my $rcustom = Imager::i_new_fill_hatch($blue, $red, 0, 0, $hatch, 0, 0);
-Imager::i_box_cfill($raw2, 0, 0, 99, 99, $rcustom);
-$diff = Imager::i_img_diff($raw1, $raw2);
-ok(!$diff, "custom hatch mismatch");
-
-{
- # basic test of floating color hatch fills
- # this will exercise the code that the gcc shipped with OS X 10.4
- # forgets to generate
- # the float version is called iff we're working with a non-8-bit image
- # i_new_fill_hatchf() makes the same object as i_new_fill_hatch() but
- # we test the other construction code path here
- my $fraw1 = Imager::i_img_double_new(100, 100, 3);
- my $fhatch1 = Imager::i_new_fill_hatchf($redf, $bluef, 0, 1, undef, 0, 0);
- ok($fraw1, "making double image 1");
- ok($fhatch1, "making float hatch 1");
- Imager::i_box_cfill($fraw1, 0, 0, 99, 99, $fhatch1);
- my $fraw2 = Imager::i_img_double_new(100, 100, 3);
- my $fhatch2 = Imager::i_new_fill_hatchf($bluef, $redf, 0, 1, undef, 0, 2);
- ok($fraw2, "making double image 2");
- ok($fhatch2, "making float hatch 2");
- Imager::i_box_cfill($fraw2, 0, 0, 99, 99, $fhatch2);
-
- $diff = Imager::i_img_diff($fraw1, $fraw2);
- ok(!$diff, "float custom hatch mismatch");
- save($fraw1, "testout/t20hatchf1.ppm");
- save($fraw2, "testout/t20hatchf2.ppm");
-}
-
-# test the oo interface
-my $im1 = Imager->new(xsize=>100, ysize=>100);
-my $im2 = Imager->new(xsize=>100, ysize=>100);
-
-my $solid = Imager::Fill->new(solid=>'#FF0000');
-ok($solid, "creating oo solid fill");
-ok($solid->{fill}, "bad oo solid fill");
-$im1->box(fill=>$solid);
-$im2->box(filled=>1, color=>$red);
-$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
-ok(!$diff, "oo solid fill");
-
-my $hatcha = Imager::Fill->new(hatch=>'check2x2');
-my $hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2);
-$im1->box(fill=>$hatcha);
-$im2->box(fill=>$hatchb);
-# should be different
-$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
-ok($diff, "offset checks the same!");
-$hatchb = Imager::Fill->new(hatch=>'check2x2', dx=>2, dy=>2);
-$im2->box(fill=>$hatchb);
-$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
-ok(!$diff, "offset into similar check should be the same");
-
-# test dymanic build of fill
-$im2->box(fill=>{hatch=>'check2x2', dx=>2, fg=>NC(255,255,255),
- bg=>NC(0,0,0)});
-$diff = Imager::i_img_diff($im1->{IMG}, $im2->{IMG});
-ok(!$diff, "offset and flipped should be the same");
-
-# a simple demo
-my $im = Imager->new(xsize=>200, ysize=>200);
-
-$im->box(xmin=>10, ymin=>10, xmax=>190, ymax=>190,
- fill=>{ hatch=>'check4x4',
- fg=>NC(128, 0, 0),
- bg=>NC(128, 64, 0) })
- or print "# ",$im->errstr,"\n";
-$im->arc(r=>80, d1=>45, d2=>75,
- fill=>{ hatch=>'stipple2',
- combine=>1,
- fg=>[ 0, 0, 0, 255 ],
- bg=>{ rgba=>[255,255,255,160] } })
- or print "# ",$im->errstr,"\n";
-$im->arc(r=>80, d1=>75, d2=>135,
- fill=>{ fountain=>'radial', xa=>100, ya=>100, xb=>20, yb=>100 })
- or print "# ",$im->errstr,"\n";
-$im->write(file=>'testout/t20_sample.ppm');
-
-# flood fill tests
-my $rffimg = Imager::ImgRaw::new(100, 100, 3);
-# build a H
-Imager::i_box_filled($rffimg, 10, 10, 20, 90, $blue);
-Imager::i_box_filled($rffimg, 80, 10, 90, 90, $blue);
-Imager::i_box_filled($rffimg, 20, 45, 80, 55, $blue);
-my $black = Imager::Color->new(0, 0, 0);
-Imager::i_flood_fill($rffimg, 15, 15, $red);
-my $rffcmp = Imager::ImgRaw::new(100, 100, 3);
-# build a H
-Imager::i_box_filled($rffcmp, 10, 10, 20, 90, $red);
-Imager::i_box_filled($rffcmp, 80, 10, 90, 90, $red);
-Imager::i_box_filled($rffcmp, 20, 45, 80, 55, $red);
-$diff = Imager::i_img_diff($rffimg, $rffcmp);
-ok(!$diff, "flood fill difference");
-
-my $ffim = Imager->new(xsize=>100, ysize=>100);
-my $yellow = Imager::Color->new(255, 255, 0);
-$ffim->box(xmin=>10, ymin=>10, xmax=>20, ymax=>90, color=>$blue, filled=>1);
-$ffim->box(xmin=>20, ymin=>45, xmax=>80, ymax=>55, color=>$blue, filled=>1);
-$ffim->box(xmin=>80, ymin=>10, xmax=>90, ymax=>90, color=>$blue, filled=>1);
-ok($ffim->flood_fill('x'=>50, 'y'=>50, color=>$red), "flood fill");
-$diff = Imager::i_img_diff($rffcmp, $ffim->{IMG});
-ok(!$diff, "oo flood fill difference");
-$ffim->flood_fill('x'=>50, 'y'=>50,
- fill=> {
- hatch => 'check2x2',
- fg => '0000FF',
- });
-# fill=>{
-# fountain=>'radial',
-# xa=>50, ya=>50,
-# xb=>10, yb=>10,
-# });
-$ffim->write(file=>'testout/t20_ooflood.ppm');
-
-my $copy = $ffim->copy;
-ok($ffim->flood_fill('x' => 50, 'y' => 50,
- color => $red, border => '000000'),
- "border solid flood fill");
-is(Imager::i_img_diff($ffim->{IMG}, $rffcmp), 0, "compare");
-ok($ffim->flood_fill('x' => 50, 'y' => 50,
- fill => { hatch => 'check2x2', fg => '0000FF', },
- border => '000000'),
- "border cfill fill");
-is(Imager::i_img_diff($ffim->{IMG}, $copy->{IMG}), 0,
- "compare");
-
-# test combining modes
-my $fill = NC(192, 128, 128, 128);
-my $target = NC(64, 32, 64);
-my $trans_target = NC(64, 32, 64, 128);
-my %comb_tests =
- (
- none=>
- {
- opaque => $fill,
- trans => $fill,
- },
- normal=>
- {
- opaque => NC(128, 80, 96),
- trans => NC(150, 96, 107, 191),
- },
- multiply =>
- {
- opaque => NC(56, 24, 48),
- trans => NC(101, 58, 74, 192),
- },
- dissolve =>
- {
- opaque => [ $target, NC(192, 128, 128, 255) ],
- trans => [ $trans_target, NC(192, 128, 128, 255) ],
- },
- add =>
- {
- opaque => NC(159, 96, 128),
- trans => NC(128, 80, 96, 255),
- },
- subtract =>
- {
- opaque => NC(0, 0, 0),
- trans => NC(0, 0, 0, 255),
- },
- diff =>
- {
- opaque => NC(96, 64, 64),
- trans => NC(127, 85, 85, 192),
- },
- lighten =>
- {
- opaque => NC(128, 80, 96),
- trans => NC(149, 95, 106, 192),
- },
- darken =>
- {
- opaque => $target,
- trans => NC(106, 63, 85, 192),
- },
- # the following results are based on the results of the tests and
- # are suspect for that reason (and were broken at one point <sigh>)
- # but trying to work them out manually just makes my head hurt - TC
- hue =>
- {
- opaque => NC(64, 32, 47),
- trans => NC(64, 32, 42, 128),
- },
- saturation =>
- {
- opaque => NC(63, 37, 64),
- trans => NC(64, 39, 64, 128),
- },
- value =>
- {
- opaque => NC(127, 64, 128),
- trans => NC(149, 75, 150, 128),
- },
- color =>
- {
- opaque => NC(64, 37, 52),
- trans => NC(64, 39, 50, 128),
- },
- );
-
-for my $comb (Imager::Fill->combines) {
- my $test = $comb_tests{$comb};
- my $fillobj = Imager::Fill->new(solid=>$fill, combine=>$comb);
-
- for my $bits (qw(8 double)) {
- {
- my $targim = Imager->new(xsize=>4, ysize=>4, bits => $bits);
- $targim->box(filled=>1, color=>$target);
- $targim->box(fill=>$fillobj);
- my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
- my $allowed = $test->{opaque};
- $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
- ok(scalar grep(color_close($_, $c), @$allowed),
- "opaque '$comb' $bits bits")
- or print "# got:",join(",", $c->rgba)," allowed: ",
- join("|", map { join(",", $_->rgba) } @$allowed),"\n";
- }
-
- {
- # make sure the alpha path in the combine function produces the same
- # or at least as sane a result as the non-alpha path
- my $targim = Imager->new(xsize=>4, ysize=>4, channels => 4, bits => $bits);
- $targim->box(filled=>1, color=>$target);
- $targim->box(fill=>$fillobj);
- my $c = Imager::i_get_pixel($targim->{IMG}, 1, 1);
- my $allowed = $test->{opaque};
- $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
- ok(scalar grep(color_close4($_, $c), @$allowed),
- "opaque '$comb' 4-channel $bits bits")
- or print "# got:",join(",", $c->rgba)," allowed: ",
- join("|", map { join(",", $_->rgba) } @$allowed),"\n";
- }
-
- {
- my $transim = Imager->new(xsize => 4, ysize => 4, channels => 4, bits => $bits);
- $transim->box(filled=>1, color=>$trans_target);
- $transim->box(fill => $fillobj);
- my $c = $transim->getpixel(x => 1, 'y' => 1);
- my $allowed = $test->{trans};
- $allowed =~ /ARRAY/ or $allowed = [ $allowed ];
- ok(scalar grep(color_close4($_, $c), @$allowed),
- "translucent '$comb' $bits bits")
- or print "# got:",join(",", $c->rgba)," allowed: ",
- join("|", map { join(",", $_->rgba) } @$allowed),"\n";
- }
- }
-}
-
-ok($ffim->arc(r=>45, color=>$blue, aa=>1), "aa circle");
-$ffim->write(file=>"testout/t20_aacircle.ppm");
-
-# image based fills
-my $green = NC(0, 255, 0);
-my $fillim = Imager->new(xsize=>40, ysize=>40, channels=>4);
-$fillim->box(filled=>1, xmin=>5, ymin=>5, xmax=>35, ymax=>35,
- color=>NC(0, 0, 255, 128));
-$fillim->arc(filled=>1, r=>10, color=>$green, aa=>1);
-my $ooim = Imager->new(xsize=>150, ysize=>150);
-$ooim->box(filled=>1, color=>$green, xmin=>70, ymin=>25, xmax=>130, ymax=>125);
-$ooim->box(filled=>1, color=>$blue, xmin=>20, ymin=>25, xmax=>80, ymax=>125);
-$ooim->arc(r=>30, color=>$red, aa=>1);
-
-my $oocopy = $ooim->copy();
-ok($oocopy->arc(fill=>{image=>$fillim,
- combine=>'normal',
- xoff=>5}, r=>40),
- "image based fill");
-$oocopy->write(file=>'testout/t20_image.ppm');
-
-# a more complex version
-use Imager::Matrix2d ':handy';
-$oocopy = $ooim->copy;
-ok($oocopy->arc(fill=>{
- image=>$fillim,
- combine=>'normal',
- matrix=>m2d_rotate(degrees=>30),
- xoff=>5
- }, r=>40),
- "transformed image based fill");
-$oocopy->write(file=>'testout/t20_image_xform.ppm');
-
-ok(!$oocopy->arc(fill=>{ hatch=>"not really a hatch" }, r=>20),
- "error handling of automatic fill conversion");
-ok($oocopy->errstr =~ /Unknown hatch type/,
- "error message for automatic fill conversion");
-
-# previous box fills to float images, or using the fountain fill
-# got into a loop here
-
-SKIP:
-{
- skip("can't test without alarm()", 1) unless $Config{d_alarm};
- local $SIG{ALRM} = sub { die; };
-
- eval {
- alarm(2);
- ok($ooim->box(xmin=>20, ymin=>20, xmax=>80, ymax=>40,
- fill=>{ fountain=>'linear', xa=>20, ya=>20, xb=>80,
- yb=>20 }), "linear box fill");
- alarm 0;
- };
- $@ and ok(0, "linear box fill $@");
-}
-
-# test that passing in a non-array ref returns an error
-{
- my $fill = Imager::Fill->new(fountain=>'linear',
- xa => 20, ya=>20, xb=>20, yb=>40,
- segments=>"invalid");
- ok(!$fill, "passing invalid segments produces an error");
- cmp_ok(Imager->errstr, '=~', 'array reference',
- "check the error message");
-}
-
-# test that colors in segments are converted
-{
- my @segs =
- (
- [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
- );
- my $fill = Imager::Fill->new(fountain=>'linear',
- xa => 0, ya=>20, xb=>49, yb=>20,
- segments=>\@segs);
- ok($fill, "check that color names are converted")
- or print "# ",Imager->errstr,"\n";
- my $im = Imager->new(xsize=>50, ysize=>50);
- $im->box(fill=>$fill);
- my $left = $im->getpixel('x'=>0, 'y'=>20);
- ok(color_close($left, Imager::Color->new(0,0,0)),
- "check black converted correctly");
- my $right = $im->getpixel('x'=>49, 'y'=>20);
- ok(color_close($right, Imager::Color->new(255,255,255)),
- "check white converted correctly");
-
- # check that invalid colors handled correctly
-
- my @segs2 =
- (
- [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
- );
- my $fill2 = Imager::Fill->new(fountain=>'linear',
- xa => 0, ya=>20, xb=>49, yb=>20,
- segments=>\@segs2);
- ok(!$fill2, "check handling of invalid color names");
- cmp_ok(Imager->errstr, '=~', 'No color named', "check error message");
-}
-
-{ # RT #35278
- # hatch fills on a grey scale image don't adapt colors
- for my $bits (8, 'double') {
- my $im_g = Imager->new(xsize => 10, ysize => 10, channels => 1, bits => $bits);
- $im_g->box(filled => 1, color => 'FFFFFF');
- my $fill = Imager::Fill->new
- (
- combine => 'normal',
- hatch => 'weave',
- fg => '000000',
- bg => 'FFFFFF'
- );
- $im_g->box(fill => $fill);
- my $im_c = Imager->new(xsize => 10, ysize => 10, channels => 3, bits => $bits);
- $im_c->box(filled => 1, color => 'FFFFFF');
- $im_c->box(fill => $fill);
- my $im_cg = $im_g->convert(preset => 'rgb');
- is_image($im_c, $im_cg, "check hatch is the same between color and greyscale (bits $bits)");
-
- # check the same for image fills
- my $grey_fill = Imager::Fill->new
- (
- image => $im_g,
- combine => 'normal'
- );
- my $im_cfg = Imager->new(xsize => 20, ysize => 20, bits => $bits);
- $im_cfg->box(filled => 1, color => '808080');
- $im_cfg->box(fill => $grey_fill);
- my $rgb_fill = Imager::Fill->new
- (
- image => $im_cg,
- combine => 'normal'
- );
- my $im_cfc = Imager->new(xsize => 20, ysize => 20, bits => $bits);
- $im_cfc->box(filled => 1, color => '808080');
- $im_cfc->box(fill => $rgb_fill);
- is_image($im_cfg, $im_cfc, "check filling from grey image matches filling from rgb (bits = $bits)");
-
- my $im_gfg = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
- $im_gfg->box(filled => 1, color => '808080');
- $im_gfg->box(fill => $grey_fill);
- my $im_gfg_c = $im_gfg->convert(preset => 'rgb');
- is_image($im_gfg_c, $im_cfg, "check grey filled with grey against base (bits = $bits)");
-
- my $im_gfc = Imager->new(xsize => 20, ysize => 20, channels => 1, bits => $bits);
- $im_gfc->box(filled => 1, color => '808080');
- $im_gfc->box(fill => $rgb_fill);
- my $im_gfc_c = $im_gfc->convert(preset => 'rgb');
- is_image($im_gfc_c, $im_cfg, "check grey filled with color against base (bits = $bits)");
- }
-}
-
-{ # alpha modifying fills
- { # 8-bit/sample
- my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4);
- $base_img->setscanline
- (
- x => 0,
- y => 0,
- pixels =>
- [
- map Imager::Color->new($_),
- qw/FF000020 00FF0080 00008040 FFFF00FF/,
- ],
- );
- $base_img->setscanline
- (
- x => 0,
- y => 1,
- pixels =>
- [
- map Imager::Color->new($_),
- qw/FFFF00FF FF000000 00FF0080 00008040/
- ]
- );
- my $base_fill = Imager::Fill->new
- (
- image => $base_img,
- combine => "normal",
- );
- ok($base_fill, "make the base image fill");
- my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
- or print "# ", Imager->errstr, "\n";
- ok($fill50, "make 50% alpha translation fill");
-
- { # 4 channel image
- my $out = Imager->new(xsize => 10, ysize => 10, channels => 4);
- $out->box(fill => $fill50);
- is_color4($out->getpixel(x => 0, y => 0),
- 255, 0, 0, 16, "check alpha output");
- is_color4($out->getpixel(x => 2, y => 1),
- 0, 255, 0, 64, "check alpha output");
- $out->box(filled => 1, color => "000000");
- is_color4($out->getpixel(x => 0, y => 0),
- 0, 0, 0, 255, "check after clear");
- $out->box(fill => $fill50);
- is_color4($out->getpixel(x => 4, y => 2),
- 16, 0, 0, 255, "check drawn against background");
- is_color4($out->getpixel(x => 6, y => 3),
- 0, 64, 0, 255, "check drawn against background");
- }
- { # 3 channel image
- my $out = Imager->new(xsize => 10, ysize => 10, channels => 3);
- $out->box(fill => $fill50);
- is_color3($out->getpixel(x => 0, y => 0),
- 16, 0, 0, "check alpha output");
- is_color3($out->getpixel(x => 2, y => 1),
- 0, 64, 0, "check alpha output");
- is_color3($out->getpixel(x => 0, y => 1),
- 128, 128, 0, "check alpha output");
- }
- }
- { # double/sample
- use Imager::Color::Float;
- my $base_img = Imager->new(xsize => 4, ysize => 2, channels => 4, bits => "double");
- $base_img->setscanline
- (
- x => 0,
- y => 0,
- pixels =>
- [
- map Imager::Color::Float->new(@$_),
- [ 1, 0, 0, 0.125 ],
- [ 0, 1, 0, 0.5 ],
- [ 0, 0, 0.5, 0.25 ],
- [ 1, 1, 0, 1 ],
- ],
- );
- $base_img->setscanline
- (
- x => 0,
- y => 1,
- pixels =>
- [
- map Imager::Color::Float->new(@$_),
- [ 1, 1, 0, 1 ],
- [ 1, 0, 0, 0 ],
- [ 0, 1, 0, 0.5 ],
- [ 0, 0, 0.5, 0.25 ],
- ]
- );
- my $base_fill = Imager::Fill->new
- (
- image => $base_img,
- combine => "normal",
- );
- ok($base_fill, "make the base image fill");
- my $fill50 = Imager::Fill->new(type => "opacity", opacity => 0.5, other => $base_fill)
- or print "# ", Imager->errstr, "\n";
- ok($fill50, "make 50% alpha translation fill");
- my $out = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => "double");
- $out->box(fill => $fill50);
- is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
- 1, 0, 0, 0.0625, "check alpha output at 0,0");
- is_fcolor4($out->getpixel(x => 2, y => 1, type => "float"),
- 0, 1, 0, 0.25, "check alpha output at 2,1");
- $out->box(filled => 1, color => "000000");
- is_fcolor4($out->getpixel(x => 0, y => 0, type => "float"),
- 0, 0, 0, 1, "check after clear");
- $out->box(fill => $fill50);
- is_fcolor4($out->getpixel(x => 4, y => 2, type => "float"),
- 0.0625, 0, 0, 1, "check drawn against background at 4,2");
- is_fcolor4($out->getpixel(x => 6, y => 3, type => "float"),
- 0, 0.25, 0, 1, "check drawn against background at 6,3");
- }
- ok(!Imager::Fill->new(type => "opacity"),
- "should fail to make an opacity fill with no other fill object");
- is(Imager->errstr, "'other' parameter required to create opacity fill",
- "check error message");
- ok(!Imager::Fill->new(type => "opacity", other => "xx"),
- "should fail to make an opacity fill with a bad other parameter");
- is(Imager->errstr, "'other' parameter must be an Imager::Fill object to create an opacity fill",
- "check error message");
-
- # check auto conversion of hashes
- ok(Imager::Fill->new(type => "opacity", other => { solid => "FF0000" }),
- "check we auto-create fills")
- or print "# ", Imager->errstr, "\n";
-
- {
- # fill with combine none was modifying the wrong channel for a
- # no-alpha target image
- my $fill = Imager::Fill->new(solid => "#FFF", combine => "none");
- my $fill2 = Imager::Fill->new
- (
- type => "opacity",
- opacity => 0.5,
- other => $fill
- );
- my $im = Imager->new(xsize => 1, ysize => 1);
- ok($im->box(fill => $fill2), "fill with replacement opacity fill");
- is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
- "check for correct colour");
- }
-
- {
- require Imager::Fountain;
- my $fount = Imager::Fountain->new;
- $fount->add(c1 => "FFFFFF"); # simple white to black
- # base fill is a fountain
- my $base_fill = Imager::Fill->new
- (
- fountain => "linear",
- segments => $fount,
- xa => 0,
- ya => 0,
- xb => 100,
- yb => 100,
- );
- ok($base_fill, "made fountain fill base");
- my $op_fill = Imager::Fill->new
- (
- type => "opacity",
- other => $base_fill,
- opacity => 0.5,
- );
- ok($op_fill, "made opacity fountain fill");
- my $im = Imager->new(xsize => 100, ysize => 100);
- ok($im->box(fill => $op_fill), "draw with it");
- }
-}
-
-{ # RT 71309
- my $fount = Imager::Fountain->simple(colors => [ '#804041', '#804041' ],
- positions => [ 0, 1 ]);
- my $im = Imager->new(xsize => 40, ysize => 40);
- $im->box(filled => 1, color => '#804040');
- my $fill = Imager::Fill->new
- (
- combine => 0,
- fountain => "linear",
- segments => $fount,
- xa => 0, ya => 0,
- xb => 40, yb => 40,
- );
- $im->polygon(fill => $fill,
- points =>
- [
- [ 0, 0 ],
- [ 40, 20 ],
- [ 20, 40 ],
- ]
- );
- # the bug magnified the differences between the source and destination
- # color, blending between the background and fill colors here only allows
- # for those 2 colors in the result.
- # with the bug extra colors appeared along the edge of the polygon.
- is($im->getcolorcount, 2, "only original and fill color");
-}
-
-SKIP:
-{
- # the wrong image dimension was used for adjusting vs yoff,
- # producing uncovered parts of the output image
- my $tx = Imager->new(xsize => 30, ysize => 20);
- ok($tx, "create texture image")
- or diag "create texture image", Imager->errstr;
- $tx or skip "no texture image", 7;
- ok($tx->box(filled => 1, color => "ff0000"), "fill texture image")
- or diag "fill texture image", $tx->errstr;
- my $cmp = Imager->new(xsize => 100, ysize => 100);
- ok($cmp, "create comparison image")
- or diag "create comparison image: ", Imager->errstr;
- $cmp or skip "no comparison image", 5;
- ok($cmp->box(filled => 1, color => "FF0000"), "fill compare image")
- or diag "fill compare image: ", $cmp->errstr;
- my $im = Imager->new(xsize => 100, ysize => 100);
- ok($im, "make test image")
- or diag "make test image: ", Imager->errstr;
- $im or skip "no test image", 3;
- my $fill = Imager::Fill->new(image => $tx, yoff => 10);
- ok($fill, "make xoff=10 image fill")
- or diag "make fill: ", Imager->errstr;
- $fill or skip "no fill", 2;
- ok($im->box(fill => $fill), "fill test image")
- or diag "fill test image: ", $im->errstr;
- is_image($im, $cmp, "check test image");
-}
-
-sub color_close {
- my ($c1, $c2) = @_;
-
- my @c1 = $c1->rgba;
- my @c2 = $c2->rgba;
-
- for my $i (0..2) {
- if (abs($c1[$i]-$c2[$i]) > 2) {
- return 0;
- }
- }
- return 1;
-}
-
-sub color_close4 {
- my ($c1, $c2) = @_;
-
- my @c1 = $c1->rgba;
- my @c2 = $c2->rgba;
-
- for my $i (0..3) {
- if (abs($c1[$i]-$c2[$i]) > 2) {
- return 0;
- }
- }
- return 1;
-}
-
-# for use during testing
-sub save {
- my ($im, $name) = @_;
-
- open FH, "> $name" or die "Cannot create $name: $!";
- binmode FH;
- my $io = Imager::io_new_fd(fileno(FH));
- Imager::i_writeppm_wiol($im, $io) or die "Cannot save to $name";
- undef $io;
- close FH;
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 256;
-use Imager ':all';
-use Imager::Test qw(is_color3 is_image);
-use constant PI => 3.14159265358979;
-
--d "testout" or mkdir "testout";
-
-init_log("testout/t21draw.log",1);
-
-my $redobj = NC(255, 0, 0);
-my $red = 'FF0000';
-my $greenobj = NC(0, 255, 0);
-my $green = [ 0, 255, 0 ];
-my $blueobj = NC(0, 0, 255);
-my $blue = { hue=>240, saturation=>1, value=>1 };
-my $white = '#FFFFFF';
-
-{
- my $img = Imager->new(xsize=>100, ysize=>500);
-
- ok($img->box(color=>$blueobj, xmin=>10, ymin=>10, xmax=>48, ymax=>18),
- "box with color obj");
- ok($img->box(color=>$blue, xmin=>10, ymin=>20, xmax=>48, ymax=>28),
- "box with color");
- ok($img->box(color=>$redobj, xmin=>10, ymin=>30, xmax=>28, ymax=>48, filled=>1),
- "filled box with color obj");
- ok($img->box(color=>$red, xmin=>30, ymin=>30, xmax=>48, ymax=>48, filled=>1),
- "filled box with color");
-
- ok($img->arc('x'=>75, 'y'=>25, r=>24, color=>$redobj),
- "filled arc with colorobj");
-
- ok($img->arc('x'=>75, 'y'=>25, r=>20, color=>$green),
- "filled arc with colorobj");
- ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$white, d1=>325, d2=>225),
- "filled arc with color");
-
- ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$blue, d1=>225, d2=>325),
- "filled arc with color");
- ok($img->arc('x'=>75, 'y'=>25, r=>15, color=>$green, aa=>1),
- "filled arc with color");
-
- ok($img->line(color=>$blueobj, x1=>5, y1=>55, x2=>35, y2=>95),
- "line with colorobj");
-
- # FIXME - neither the start nor end-point is set for a non-aa line
- my $c = Imager::i_get_pixel($img->{IMG}, 5, 55);
- ok(color_cmp($c, $blueobj) == 0, "# TODO start point not set");
-
- ok($img->line(color=>$red, x1=>10, y1=>55, x2=>40, y2=>95, aa=>1),
- "aa line with color");
- ok($img->line(color=>$green, x1=>15, y1=>55, x2=>45, y2=>95, antialias=>1),
- "antialias line with color");
-
- ok($img->polyline(points=>[ [ 55, 55 ], [ 90, 60 ], [ 95, 95] ],
- color=>$redobj),
- "polyline points with color obj");
- ok($img->polyline('x'=>[ 55, 85, 90 ], 'y'=>[60, 65, 95], color=>$green, aa=>1),
- "polyline xy with color aa");
- ok($img->polyline('x'=>[ 55, 80, 85 ], 'y'=>[65, 70, 95], color=>$green,
- antialias=>1),
- "polyline xy with color antialias");
-
- ok($img->setpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], color=>$red),
- "set array of pixels");
- ok($img->setpixel('x'=>39, 'y'=>55, color=>$green),
- "set single pixel");
- use Imager::Color::Float;
- my $flred = Imager::Color::Float->new(1, 0, 0, 0);
- my $flgreen = Imager::Color::Float->new(0, 1, 0, 0);
- ok($img->setpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59], color=>$flred),
- "set array of float pixels");
- ok($img->setpixel('x'=>45, 'y'=>55, color=>$flgreen),
- "set single float pixel");
- my @gp = $img->getpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59]);
- ok(grep($_->isa('Imager::Color'), @gp) == 3, "check getpixel result type");
- ok(grep(color_cmp($_, NC(255, 0, 0)) == 0, @gp) == 3,
- "check getpixel result colors");
- my $gp = $img->getpixel('x'=>45, 'y'=>55);
- ok($gp->isa('Imager::Color'), "check scalar getpixel type");
- ok(color_cmp($gp, NC(0, 255, 0)) == 0, "check scalar getpixel color");
- @gp = $img->getpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], type=>'float');
- ok(grep($_->isa('Imager::Color::Float'), @gp) == 3,
- "check getpixel float result type");
- ok(grep(color_cmp($_, $flred) == 0, @gp) == 3,
- "check getpixel float result type");
- $gp = $img->getpixel('x'=>39, 'y'=>55, type=>'float');
- ok($gp->isa('Imager::Color::Float'), "check scalar float getpixel type");
- ok(color_cmp($gp, $flgreen) == 0, "check scalar float getpixel color");
-
- # more complete arc tests
- ok($img->arc(x=>25, 'y'=>125, r=>20, d1=>315, d2=>45, color=>$greenobj),
- "color arc through angle 0");
- # use diff combine here to make sure double writing is noticable
- ok($img->arc(x=>75, 'y'=>125, r=>20, d1=>315, d2=>45,
- fill => { solid=>$blueobj, combine => 'diff' }),
- "fill arc through angle 0");
- ok($img->arc(x=>25, 'y'=>175, r=>20, d1=>315, d2=>225, color=>$redobj),
- "concave color arc");
- angle_marker($img, 25, 175, 23, 315, 225);
- ok($img->arc(x=>75, 'y'=>175, r=>20, d1=>315, d2=>225,
- fill => { solid=>$greenobj, combine=>'diff' }),
- "concave fill arc");
- angle_marker($img, 75, 175, 23, 315, 225);
- ok($img->arc(x=>25, y=>225, r=>20, d1=>135, d2=>45, color=>$redobj),
- "another concave color arc");
- angle_marker($img, 25, 225, 23, 45, 135);
- ok($img->arc(x=>75, y=>225, r=>20, d1=>135, d2=>45,
- fill => { solid=>$blueobj, combine=>'diff' }),
- "another concave fillarc");
- angle_marker($img, 75, 225, 23, 45, 135);
- ok($img->arc(x=>25, y=>275, r=>20, d1=>135, d2=>45, color=>$redobj, aa=>1),
- "concave color arc aa");
- ok($img->arc(x=>75, y=>275, r=>20, d1=>135, d2=>45,
- fill => { solid=>$blueobj, combine=>'diff' }, aa=>1),
- "concave fill arc aa");
-
- ok($img->circle(x=>25, y=>325, r=>20, color=>$redobj),
- "color circle no aa");
- ok($img->circle(x=>75, y=>325, r=>20, color=>$redobj, aa=>1),
- "color circle aa");
- ok($img->circle(x=>25, 'y'=>375, r=>20,
- fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
- "fill circle no aa");
- ok($img->circle(x=>75, 'y'=>375, r=>20, aa=>1,
- fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
- "fill circle aa");
-
- ok($img->arc(x=>50, y=>450, r=>45, d1=>135, d2=>45,
- fill => { solid=>$blueobj, combine=>'diff' }),
- "another concave fillarc");
- angle_marker($img, 50, 450, 47, 45, 135);
-
- ok($img->write(file=>'testout/t21draw.ppm'),
- "saving output");
-}
-
-{
- my $im = Imager->new(xsize => 400, ysize => 400);
- ok($im->arc(x => 200, y => 202, r => 10, filled => 0),
- "draw circle outline");
- is_color3($im->getpixel(x => 200, y => 202), 0, 0, 0,
- "check center not filled");
- ok($im->arc(x => 198, y => 200, r => 13, filled => 0, color => "#f88"),
- "draw circle outline");
- is_color3($im->getpixel(x => 198, y => 200), 0, 0, 0,
- "check center not filled");
- ok($im->arc(x => 200, y => 200, r => 24, filled => 0, color => "#0ff"),
- "draw circle outline");
- my $r = 40;
- while ($r < 180) {
- ok($im->arc(x => 200, y => 200, r => $r, filled => 0, color => "#ff0"),
- "draw circle outline r $r");
- $r += 15;
- }
- ok($im->write(file => "testout/t21circout.ppm"),
- "save arc outline");
-}
-
-{
- my $im = Imager->new(xsize => 400, ysize => 400);
- {
- my $lc = Imager::Color->new(32, 32, 32);
- my $an = 0;
- while ($an < 360) {
- my $an_r = $an * PI / 180;
- my $ca = cos($an_r);
- my $sa = sin($an_r);
- $im->line(aa => 1, color => $lc,
- x1 => 198 + 5 * $ca, y1 => 202 + 5 * $sa,
- x2 => 198 + 190 * $ca, y2 => 202 + 190 * $sa);
- $an += 5;
- }
- }
- my $d1 = 0;
- my $r = 20;
- while ($d1 < 350) {
- ok($im->arc(x => 198, y => 202, r => $r, d1 => $d1, d2 => $d1+300, filled => 0),
- "draw arc outline r$r d1$d1 len 300");
- ok($im->arc(x => 198, y => 202, r => $r+3, d1 => $d1, d2 => $d1+40, filled => 0, color => '#FFFF00'),
- "draw arc outline r$r d1$d1 len 40");
- $d1 += 15;
- $r += 6;
- }
- is_color3($im->getpixel(x => 198, y => 202), 0, 0, 0,
- "check center not filled");
- ok($im->write(file => "testout/t21arcout.ppm"),
- "save arc outline");
-}
-
-{
- my $im = Imager->new(xsize => 400, ysize => 400);
- ok($im->arc(x => 197, y => 201, r => 10, filled => 0, aa => 1, color => 'white'),
- "draw circle outline");
- is_color3($im->getpixel(x => 197, y => 201), 0, 0, 0,
- "check center not filled");
- ok($im->arc(x => 197, y => 205, r => 13, filled => 0, color => "#f88", aa => 1),
- "draw circle outline");
- is_color3($im->getpixel(x => 197, y => 205), 0, 0, 0,
- "check center not filled");
- ok($im->arc(x => 190, y => 215, r => 24, filled => 0, color => [0,0, 255, 128], aa => 1),
- "draw circle outline");
- my $r = 40;
- while ($r < 190) {
- ok($im->arc(x => 197, y => 201, r => $r, filled => 0, aa => 1, color => '#ff0'), "draw aa circle rad $r");
- $r += 7;
- }
- ok($im->write(file => "testout/t21aacircout.ppm"),
- "save arc outline");
-}
-
-{
- my $im = Imager->new(xsize => 400, ysize => 400);
- {
- my $lc = Imager::Color->new(32, 32, 32);
- my $an = 0;
- while ($an < 360) {
- my $an_r = $an * PI / 180;
- my $ca = cos($an_r);
- my $sa = sin($an_r);
- $im->line(aa => 1, color => $lc,
- x1 => 198 + 5 * $ca, y1 => 202 + 5 * $sa,
- x2 => 198 + 190 * $ca, y2 => 202 + 190 * $sa);
- $an += 5;
- }
- }
- my $d1 = 0;
- my $r = 20;
- while ($d1 < 350) {
- ok($im->arc(x => 198, y => 202, r => $r, d1 => $d1, d2 => $d1+300, filled => 0, aa => 1),
- "draw aa arc outline r$r d1$d1 len 300");
- ok($im->arc(x => 198, y => 202, r => $r+3, d1 => $d1, d2 => $d1+40, filled => 0, color => '#FFFF00', aa => 1),
- "draw aa arc outline r$r d1$d1 len 40");
- $d1 += 15;
- $r += 6;
- }
- is_color3($im->getpixel(x => 198, y => 202), 0, 0, 0,
- "check center not filled");
- ok($im->write(file => "testout/t21aaarcout.ppm"),
- "save arc outline");
-}
-
-{
- my $im = Imager->new(xsize => 400, ysize => 400);
-
- my $an = 0;
- my $step = 15;
- while ($an <= 360-$step) {
- my $cx = int(200 + 20 * cos(($an+$step/2) * PI / 180));
- my $cy = int(200 + 20 * sin(($an+$step/2) * PI / 180));
-
- ok($im->arc(x => $cx, y => $cy, aa => 1, color => "#fff",
- d1 => $an, d2 => $an+$step, filled => 0, r => 170),
- "angle starting from $an");
- ok($im->arc(x => $cx+0.5, y => $cy+0.5, aa => 1, color => "#ff0",
- d1 => $an, d2 => $an+$step, r => 168),
- "filled angle starting from $an");
-
- $an += $step;
- }
- ok($im->write(file => "testout/t21aaarcs.ppm"),
- "save arc outline");
-}
-
-{
- # we document that drawing from d1 to d2 where d2 > d1 will draw an
- # arc going through 360 degrees, test that
- my $im = Imager->new(xsize => 200, ysize => 200);
- ok($im->arc(x => 100, y => 100, aa => 0, filled => 0, color => '#fff',
- d1 => 270, d2 => 90, r => 90), "draw non-aa arc through 0");
- ok($im->arc(x => 100, y => 100, aa => 1, filled => 0, color => '#fff',
- d1 => 270, d2 => 90, r => 80), "draw aa arc through 0");
- ok($im->write(file => "testout/t21arc0.ppm"),
- "save arc through 0");
-}
-
-{
- # test drawing color defaults
- {
- my $im = Imager->new(xsize => 10, ysize => 10);
- ok($im->box(), "default outline the image"); # should outline the image
- is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
- "check outline default color TL");
- is_color3($im->getpixel(x => 9, y => 5), 255, 255, 255,
- "check outline default color MR");
- }
-
- {
- my $im = Imager->new(xsize => 10, ysize => 10);
- ok($im->box(filled => 1), "default fill the image"); # should fill the image
- is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
- "check fill default color TL");
- is_color3($im->getpixel(x => 5, y => 5), 255, 255, 255,
- "check fill default color MM");
- }
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->box(), "can't draw box to empty image");
- is($empty->errstr, "box: empty input image", "check error message");
- ok(!$empty->arc(), "can't draw arc to empty image");
- is($empty->errstr, "arc: empty input image", "check error message");
- ok(!$empty->line(x1 => 0, y1 => 0, x2 => 10, y2 => 0),
- "can't draw line to empty image");
- is($empty->errstr, "line: empty input image", "check error message");
- ok(!$empty->polyline(points => [ [ 0, 0 ], [ 10, 0 ] ]),
- "can't draw polyline to empty image");
- is($empty->errstr, "polyline: empty input image", "check error message");
- ok(!$empty->polygon(points => [ [ 0, 0 ], [ 10, 0 ], [ 0, 10 ] ]),
- "can't draw polygon to empty image");
- is($empty->errstr, "polygon: empty input image", "check error message");
- ok(!$empty->flood_fill(x => 0, y => 0), "can't flood fill to empty image");
- is($empty->errstr, "flood_fill: empty input image", "check error message");
-}
-
-
-malloc_state();
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t21draw.ppm";
- unlink "testout/t21circout.ppm";
- unlink "testout/t21aacircout.ppm";
- unlink "testout/t21arcout.ppm";
- unlink "testout/t21aaarcout.ppm";
- unlink "testout/t21aaarcs.ppm";
- unlink "testout/t21arc0.ppm";
-}
-
-sub color_cmp {
- my ($l, $r) = @_;
- my @l = $l->rgba;
- my @r = $r->rgba;
- # print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
- return $l[0] <=> $r[0]
- || $l[1] <=> $r[1]
- || $l[2] <=> $r[2];
-}
-
-sub angle_marker {
- my ($img, $x, $y, $radius, @angles) = @_;
-
- for my $angle (@angles) {
- my $x1 = int($x + $radius * cos($angle * PI / 180) + 0.5);
- my $y1 = int($y + $radius * sin($angle * PI / 180) + 0.5);
- my $x2 = int($x + (5+$radius) * cos($angle * PI / 180) + 0.5);
- my $y2 = int($y + (5+$radius) * sin($angle * PI / 180) + 0.5);
-
- $img->line(x1=>$x1, y1=>$y1, x2=>$x2, y2=>$y2, color=>'#FFF');
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 15;
-use Imager;
-use Imager::Test qw(is_image);
-
--d "testout" or mkdir "testout";
-
-{ # flood_fill wouldn't fill to the right if the area was just a
- # single scan-line
- my $im = Imager->new(xsize => 5, ysize => 3);
- ok($im, "make flood_fill test image");
- ok($im->line(x1 => 0, y1 => 1, x2 => 4, y2 => 1, color => "white"),
- "create fill area");
- ok($im->flood_fill(x => 3, y => 1, color => "blue"),
- "fill it");
- my $cmp = Imager->new(xsize => 5, ysize => 3);
- ok($cmp, "make test image");
- ok($cmp->line(x1 => 0, y1 => 1, x2 => 4, y2 => 1, color => "blue"),
- "synthezied filled area");
- is_image($im, $cmp, "flood_fill filled horizontal line");
-}
-
-SKIP:
-{ # flood_fill won't fill entire line below if line above is shorter
- my $im = Imager->new(file => "testimg/filltest.ppm");
- ok($im, "Load test image")
- or skip("Couldn't load test image: " . Imager->errstr, 3);
-
- # fill from first bad place
- my $fill1 = $im->copy;
- ok($fill1->flood_fill(x => 8, y => 2, color => "#000000"),
- "fill from a top most spot");
- my $cmp = Imager->new(xsize => $im->getwidth, ysize => $im->getheight);
- is_image($fill1, $cmp, "check it filled the lot");
- ok($fill1->write(file => "testout/t22fill1.ppm"), "save");
-
- # second bad place
- my $fill2 = $im->copy;
- ok($fill2->flood_fill(x => 17, y => 3, color => "#000000"),
- "fill from not quite top most spot");
- is_image($fill2, $cmp, "check it filled the lot");
- ok($fill2->write(file => "testout/t22fill2.ppm"), "save");
-}
-
-{ # verticals
- my $im = vimage("FFFFFF");
- my $cmp = vimage("FF0000");
-
- ok($im->flood_fill(x => 4, y=> 8, color => "FF0000"),
- "fill at bottom of vertical well");
- is_image($im, $cmp, "check the result");
-}
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t22fill1.ppm";
- unlink "testout/t22fill2.ppm";
-}
-
-# make a vertical test image
-sub vimage {
- my $c = shift;
-
- my $im = Imager->new(xsize => 10, ysize => 10);
- $im->line(x1 => 1, y1 => 1, x2 => 8, y2 => 1, color => $c);
- $im->line(x1 => 4, y1 => 2, x2 => 4, y2 => 8, color => $c);
-
- return $im;
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager;
-use Test::More tests => 14;
-
-unshift @INC, "t";
-
-ok(Imager::Font->register(type => "test",
- class=>"GoodTestFont",
- files => "\\.ppm\$"),
- "register a test font");
-
-ok(Imager::Font->register(type => "bad",
- class => "BadTestFont",
- files => "\\.ppm\$"),
- "register a bad test font");
-
-ok(!Imager::Font->register(), "no register parameters");
-like(Imager->errstr, qr/No type parameter/, "check message");
-
-ok(!Imager::Font->register(type => "bad1"), "no class parameter");
-like(Imager->errstr, qr/No class parameter/, "check message");
-
-ok(!Imager::Font->register(type => "bad2", class => "BadFont", files => "**"),
- "bad files parameter");
-is(Imager->errstr, "files isn't a valid regexp", "check message");
-
-Imager::Font->priorities("bad", "test");
-
-# RT #62855
-# previously we'd select the first file matched font driver, even if
-# it wasn't available, then crash loading it.
-
-SKIP:
-{
- my $good;
- ok(eval {
- $good = Imager::Font->new(file => "testimg/penguin-base.ppm");
- }, "load good font avoiding RT 62855")
- or skip("Failed to load", 1);
- ok($good->isa("GoodTestFont"), "and it's the right type");
-}
-
-
-use Imager::Font::Test;
-
-# check string() and align_string() handle an empty image
-{
- my $font = Imager::Font::Test->new;
- my $empty = Imager->new;
- ok(!$empty->string(text => "foo", x => 0, y => 10, size => 10, font => $font),
- "can't draw text on an empty image");
- is($empty->errstr, "string: empty input image",
- "check error message");
- ok(!$empty->align_string(text => "foo", x => 0, y => 10, size => 10, font => $font),
- "can't draw text on an empty image");
- is($empty->errstr, "align_string: empty input image",
- "check error message");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 97;
-
-$|=1;
-
-BEGIN { use_ok(Imager => ':all') }
-use Imager::Test qw(diff_text_with_nul is_color3 is_image);
-
--d "testout" or mkdir "testout";
-
-init_log("testout/t35ttfont.log",2);
-
-SKIP:
-{
- skip("freetype 1.x unavailable or disabled", 96)
- unless $Imager::formats{"tt"};
- print "# has tt\n";
-
- my $deffont = './fontfiles/dodge.ttf';
- my $fontname=$ENV{'TTFONTTEST'} || $deffont;
-
- if (!ok(-f $fontname, "check test font file exists")) {
- print "# cannot find fontfile for truetype test $fontname\n";
- skip('Cannot load test font', 89);
- }
-
- #i_init_fonts();
- # i_tt_set_aa(1);
-
- my $bgcolor = i_color_new(255,0,0,0);
- my $overlay = Imager::ImgRaw::new(320,140,3);
- i_box_filled($overlay, 0, 0, 319, 139, i_color_new(128, 128, 128));
-
- my $ttraw = Imager::i_tt_new($fontname);
- ok($ttraw, "create font");
-
- my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',0);
- is(@bbox, 8, "bounding box");
- print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n";
-
- ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XM CLH',6,1,0), "cp output");
- ok(i_tt_cp($ttraw,$overlay,5,120,1,50.0,'XM CLH',6,0,0), "cp output (non AA)");
- i_line($overlay,0,50,100,50,$bgcolor,1);
-
- open(FH,">testout/t35ttfont.ppm") || die "cannot open testout/t35ttfont.ppm\n";
- binmode(FH);
- my $IO = Imager::io_new_fd( fileno(FH) );
- ok(i_writeppm_wiol($overlay, $IO), "save t35ttfont.ppm");
- close(FH);
-
- $bgcolor=i_color_set($bgcolor,200,200,200,0);
- my $backgr=Imager::ImgRaw::new(500,300,3);
-
- # i_tt_set_aa(2);
-
- ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'te st',5,1,0),
- "normal output");
- ok(i_tt_text($ttraw,$backgr,100,200,$bgcolor,50.0,'te st',5,0,0),
- "normal output (non AA)");
-
- my $ugly = Imager::i_tt_new("./fontfiles/ImUgly.ttf");
- ok($ugly, "create ugly font");
- # older versions were dropping the bottom of g and the right of a
- ok(i_tt_text($ugly, $backgr,100, 80, $bgcolor, 14, 'g%g', 3, 1, 0),
- "draw g%g");
- ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 6, 1, 0),
- "draw delta");
- i_line($backgr,0,20,499,20,i_color_new(0,127,0,0),1);
- ok(i_tt_text($ttraw, $backgr, 20, 20, $bgcolor, 14, 'abcdefghijklmnopqrstuvwxyz{|}', 29, 1, 0), "alphabet");
- ok(i_tt_text($ttraw, $backgr, 20, 50, $bgcolor, 14, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 26, 1, 0), "ALPHABET");
-
- # UTF8 tests
- # for perl < 5.6 we can hand-encode text
- # the following is "A\x{2010}A"
- #
- my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
- my $alttext = "A-A";
-
- my @utf8box = i_tt_bbox($ttraw, 50.0, $text, 1);
- is(@utf8box, 8, "utf8 bbox element count");
- my @base = i_tt_bbox($ttraw, 50.0, $alttext, 0);
- is(@base, 8, "alt bbox element count");
- my $maxdiff = $fontname eq $deffont ? 0 : $base[2] / 3;
- print "# (@utf8box vs @base)\n";
- ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
- "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)");
-
- # hand-encoded UTF8 drawing
- ok(i_tt_text($ttraw, $backgr, 200, 80, $bgcolor, 14, $text, length($text), 1, 1), "draw hand-encoded UTF8");
-
- ok(i_tt_cp($ttraw, $backgr, 250, 80, 1, 14, $text, length($text), 1, 1),
- "cp hand-encoded UTF8");
-
- # ok, try native perl UTF8 if available
- SKIP:
- {
- skip("perl too old to test native UTF8 support", 5) unless $] >= 5.006;
-
- my $text;
- # we need to do this in eval to prevent compile time errors in older
- # versions
- eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
- #$text = "A".chr(0x2010)."A"; # this one works too
- ok(i_tt_text($ttraw, $backgr, 300, 80, $bgcolor, 14, $text, 0, 1, 0),
- "draw UTF8");
- ok(i_tt_cp($ttraw, $backgr, 350, 80, 0, 14, $text, 0, 1, 0),
- "cp UTF8");
- @utf8box = i_tt_bbox($ttraw, 50.0, $text, 0);
- is(@utf8box, 8, "native utf8 bbox element count");
- ok(abs($utf8box[2] - $base[2]) <= $maxdiff,
- "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)");
- eval q{$text = "A\x{0905}\x{0906}\x{0103}A"}; # Devanagari
- ok(i_tt_text($ugly, $backgr, 100, 160, $bgcolor, 36, $text, 0, 1, 0),
- "more complex output");
- }
-
- open(FH,">testout/t35ttfont2.ppm") || die "cannot open testout/t35ttfont.ppm\n";
- binmode(FH);
- $IO = Imager::io_new_fd( fileno(FH) );
- ok(i_writeppm_wiol($backgr, $IO), "save t35ttfont2.ppm");
- close(FH);
-
- my $exists_font = "fontfiles/ExistenceTest.ttf";
- my $hcfont = Imager::Font->new(file=>$exists_font, type=>'tt');
- SKIP:
- {
- ok($hcfont, "loading existence test font")
- or skip("could not load test font", 20);
-
- # list interface
- my @exists = $hcfont->has_chars(string=>'!A');
- ok(@exists == 2, "check return count");
- ok($exists[0], "we have an exclamation mark");
- ok(!$exists[1], "we have no exclamation mark");
-
- # scalar interface
- my $exists = $hcfont->has_chars(string=>'!A');
- ok(length($exists) == 2, "check return length");
- ok(ord(substr($exists, 0, 1)), "we have an exclamation mark");
- ok(!ord(substr($exists, 1, 1)), "we have no upper-case A");
-
- my $face_name = Imager::i_tt_face_name($hcfont->{id});
- print "# face $face_name\n";
- is($face_name, 'ExistenceTest', "face name (function)");
- $face_name = $hcfont->face_name;
- is($face_name, 'ExistenceTest', "face name (OO)");
-
- # FT 1.x cheats and gives names even if the font doesn't have them
- my @glyph_names = $hcfont->glyph_names(string=>"!J/");
- is($glyph_names[0], 'exclam', "check exclam name OO");
- ok(!defined($glyph_names[1]), "check for no J name OO");
- is($glyph_names[2], 'slash', "check slash name OO");
-
- print "# ** name table of the test font **\n";
- Imager::i_tt_dump_names($hcfont->{id});
-
- # the test font is known to have a shorter advance width for that char
- my @bbox = $hcfont->bounding_box(string=>"/", size=>100);
- is(@bbox, 8, "should be 8 entries");
- isnt($bbox[6], $bbox[2], "different advance width from pos width");
- print "# @bbox\n";
- my $bbox = $hcfont->bounding_box(string=>"/", size=>100);
- isnt($bbox->pos_width, $bbox->advance_width, "OO check");
-
- cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
-
- cmp_ok($bbox->display_width, '>', $bbox->advance_width,
- "check display width (roughly)");
-
- # check with a char that fits inside the box
- $bbox = $hcfont->bounding_box(string=>"!", size=>100);
- print "# @$bbox\n";
- print "# pos width ", $bbox->pos_width, "\n";
- is($bbox->pos_width, $bbox->advance_width,
- "check backwards compatibility");
- cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
- cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
- cmp_ok($bbox->display_width, '<', $bbox->advance_width,
- "display smaller than advance");
- }
- undef $hcfont;
-
- my $name_font = "fontfiles/NameTest.ttf";
- $hcfont = Imager::Font->new(file=>$name_font, type=>'tt');
- SKIP:
- {
- ok($hcfont, "loading name font")
- or skip("could not load name font $name_font", 3);
- # make sure a missing string parameter is handled correctly
- eval {
- $hcfont->glyph_names();
- };
- is($@, "", "correct error handling");
- cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
-
- my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
- my @names = $hcfont->glyph_names(string=>$text, utf8=>1);
- is($names[0], "hyphentwo", "check utf8 glyph name");
- }
-
- undef $hcfont;
-
- SKIP:
- { print "# alignment tests\n";
- my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
- ok($font, "loaded deffont OO")
- or skip("could not load font:".Imager->errstr, 4);
- my $im = Imager->new(xsize=>140, ysize=>150);
- my %common =
- (
- font=>$font,
- size=>40,
- aa=>1,
- );
- $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
- $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
- $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
- for my $args ([ x=>5, text=>"A", color=>"white" ],
- [ x=>40, text=>"y", color=>"white" ],
- [ x=>75, text=>"A", channel=>1 ],
- [ x=>110, text=>"y", channel=>1 ]) {
- ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
- ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
- ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
- }
- ok($im->write(file=>'testout/t35align.ppm'), "save align image");
- }
-
- { # Ticket #14804 Imager::Font->new() doesn't report error details
- # when using freetype 1
- # make sure we're using C locale for messages
- use POSIX qw(setlocale LC_ALL);
- setlocale(LC_ALL, "C");
-
- my $font = Imager::Font->new(file=>'t/t35ttfont.t', type=>'tt');
- ok(!$font, "font creation should have failed for invalid file");
- cmp_ok(Imager->errstr, 'eq', 'Invalid file format.',
- "test error message");
-
- setlocale(LC_ALL, "");
- }
-
- { # check errstr set correctly
- my $font = Imager::Font->new(file=>$fontname, type=>'tt',
- size => undef);
- ok($font, "made size error test font");
- my $im = Imager->new(xsize=>100, ysize=>100);
- ok($im, "made size error test image");
- ok(!$im->string(font=>$font, x=>10, 'y'=>50, string=>"Hello"),
- "drawing should fail with no size");
- is($im->errstr, "No font size provided", "check error message");
-
- # try no string
- ok(!$im->string(font=>$font, x=>10, 'y'=>50, size=>15),
- "drawing should fail with no string");
- is($im->errstr, "missing required parameter 'string'",
- "check error message");
- }
-
- { # introduced in 0.46 - outputting just space crashes
- my $im = Imager->new(xsize=>100, ysize=>100);
- my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', size=>14);
- ok($im->string(font=>$font, x=> 5, 'y' => 50, string=>' '),
- "outputting just a space was crashing");
- }
-
- { # string output cut off at NUL ('\0')
- # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
- my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
- ok($font, "loaded imugly");
-
- diff_text_with_nul("a\\0b vs a", "a\0b", "a",
- font => $font, color => '#FFFFFF');
- diff_text_with_nul("a\\0b vs a", "a\0b", "a",
- font => $font, channel => 1);
-
- # UTF8 encoded \x{2010}
- my $dash = pack("C*", 0xE2, 0x80, 0x90);
- diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
- font => $font, color => '#FFFFFF', utf8 => 1);
- diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash,
- font => $font, channel => 1, utf8 => 1);
- }
-
- SKIP:
- { # RT 11972
- # when rendering to a transparent image the coverage should be
- # expressed in terms of the alpha channel rather than the color
- my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt');
- ok($font, "loaded fontfiles/ImUgly.ttf")
- or skip("Could not load test font: ".Imager->errstr, 4);
- my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
- ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
- x => 0, y => 15, font => $font),
- "draw to transparent image");
- #$im->write(file => "foo.png");
- my $im_noalpha = $im->convert(preset => 'noalpha');
- my $im_pal = $im->to_paletted(make_colors => 'mediancut');
- my @colors = $im_pal->getcolors;
- is(@colors, 2, "should be only 2 colors");
- @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
- is_color3($colors[0], 0, 0, 0, "check we got black");
- is_color3($colors[1], 255, 0, 0, "and red");
- }
-
- SKIP:
- { # RT 71564
- my $noalpha = Imager::Color->new(255, 255, 255, 0);
- my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt',
- color => $noalpha);
- ok($font, "loaded fontfiles/ImUgly.ttf")
- or skip("Could not load test font: ".Imager->errstr, 4);
- {
- my $im = Imager->new(xsize => 40, ysize => 20);
- my $copy = $im->copy;
- ok($im->string(string => "AB", size => 20, aa => 1,
- x => 0, y => 15, font => $font),
- "draw with transparent color, aa");
- is_image($im, $copy, "should draw nothing");
- }
- {
- my $im = Imager->new(xsize => 40, ysize => 20);
- my $copy = $im->copy;
- ok($im->string(string => "AB", size => 20, aa => 0,
- x => 0, y => 15, font => $font),
- "draw with transparent color, non-aa");
- local $TODO = "RT 73359 - non-AA text isn't normal mode rendered";
- is_image($im, $copy, "should draw nothing");
- }
- }
-
- ok(1, "end of code");
-}
+++ /dev/null
-#!/usr/bin/perl -w
-use strict;
-
-#use lib qw(blib/lib blib/arch);
-
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-use Test::More tests => 16;
-
-BEGIN { use_ok('Imager') };
-
-BEGIN {
- require Imager::Test;
- Imager::Test->import(qw(isnt_image));
-}
-
--d "testout" or mkdir "testout";
-
-Imager->open_log(log => "testout/t36oofont.log");
-
-my $fontname_tt=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
-
-my $green=Imager::Color->new(92,205,92,128);
-die $Imager::ERRSTR unless $green;
-my $red=Imager::Color->new(205, 92, 92, 255);
-die $Imager::ERRSTR unless $red;
-
-SKIP:
-{
- $Imager::formats{"tt"} && -f $fontname_tt
- or skip("FT1.x missing or disabled", 14);
-
- my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
-
- my $font=Imager::Font->new(file=>$fontname_tt,size=>25)
- or die $img->{ERRSTR};
-
- ok(1, "create TT font object");
-
- ok($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
- "draw text");
-
- $img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
-
- my $text="LLySja";
- my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
-
- is(@bbox, 8, "bbox list size");
-
- $img->box(box=>\@bbox, color=>$green);
-
- $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
- ok($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1),
- "draw hand-encoded UTF8 text");
-
- SKIP:
- {
- $] >= 5.006
- or skip("perl too old for native utf8", 1);
- eval q{$text = "A\x{2010}A"};
- ok($img->string(font=>$font, text=>$text, 'x'=>200, 'y'=>50),
- "draw native UTF8 text");
- }
-
- ok($img->write(file=>"testout/t36oofont2.ppm", type=>'pnm'),
- "write t36oofont2.ppm")
- or print "# ", $img->errstr,"\n";
-
- ok($font->utf8, "make sure utf8 method returns true");
-
- my $has_chars = $font->has_chars(string=>"\x01A");
- is($has_chars, "\x00\x01", "has_chars scalar");
- my @has_chars = $font->has_chars(string=>"\x01A");
- ok(!$has_chars[0], "has_chars list 0");
- ok($has_chars[1], "has_chars list 1");
-
- { # RT 71469
- my $font1 = Imager::Font->new(file => $fontname_tt, type => "tt");
- my $font2 = Imager::Font::Truetype->new(file => $fontname_tt);
-
- for my $font ($font1, $font2) {
- print "# ", join(",", $font->{color}->rgba), "\n";
-
- my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);
-
- ok($im->string(text => "T", font => $font, y => 15),
- "draw with default color")
- or print "# ", $im->errstr, "\n";
- my $work = Imager->new(xsize => 20, ysize => 20);
- my $cmp = $work->copy;
- $work->rubthrough(src => $im);
- isnt_image($work, $cmp, "make sure something was drawn");
- }
- }
-}
-
-ok(1, "end");
+++ /dev/null
-#!perl -w
-use strict;
-use Imager::Test qw(std_font_tests std_font_test_count);
-use Imager::Font;
-use Test::More;
-
-$Imager::formats{tt}
- or plan skip_all => "No tt available";
-
-Imager->open_log(log => "testout/t37std.log");
-
-plan tests => std_font_test_count();
-
-my $font = Imager::Font->new(file => "fontfiles/dodge.ttf",
- type => "tt");
-my $name_font =
- Imager::Font->new(file => "fontfiles/ImUgly.ttf",
- type => "tt");
-
-SKIP:
-{
- $font
- or skip "Cannot load font", std_font_test_count();
- std_font_tests
- ({
- font => $font,
- has_chars => [ 1, 1, 1 ],
- glyph_name_font => $name_font,
- glyph_names => [ qw(A uni2010 A) ],
- });
-}
-
-Imager->close_log;
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 232;
-
-BEGIN { use_ok(Imager=>':all') }
-use Imager::Test qw(is_image is_color4 is_image_similar);
-
--d "testout" or mkdir "testout";
-
-Imager::init('log'=>'testout/t40scale.log');
-my $img=Imager->new();
-
-ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'),
- "load test image") or print "# ",$img->errstr,"\n";
-
-my $scaleimg=$img->scale(scalefactor=>0.25)
- or print "# ",$img->errstr,"\n";
-ok($scaleimg, "scale it (good mode)");
-
-ok($scaleimg->write(file=>'testout/t40scale1.ppm',type=>'pnm'),
- "save scaled image") or print "# ",$img->errstr,"\n";
-
-$scaleimg=$img->scale(scalefactor=>0.25,qtype=>'preview');
-ok($scaleimg, "scale it (preview)") or print "# ",$img->errstr,"\n";
-
-ok($scaleimg->write(file=>'testout/t40scale2.ppm',type=>'pnm'),
- "write preview scaled image") or print "# ",$img->errstr,"\n";
-
-$scaleimg = $img->scale(scalefactor => 0.25, qtype => 'mixing');
-ok($scaleimg, "scale it (mixing)") or print "# ", $img->errstr, "\n";
-ok($scaleimg->write(file=>'testout/t40scale3.ppm', type=>'pnm'),
- "write mixing scaled image") or print "# ", $img->errstr, "\n";
-
-{ # double image scaling with mixing, since it has code to handle it
- my $dimg = Imager->new(xsize => $img->getwidth, ysize => $img->getheight,
- channels => $img->getchannels,
- bits => 'double');
- ok($dimg, "create double/sample image");
- $dimg->paste(src => $img);
- $scaleimg = $dimg->scale(scalefactor => 0.25, qtype => 'mixing');
- ok($scaleimg, "scale it (mixing, double)");
- ok($scaleimg->write(file => 'testout/t40mixdbl.ppm', type => 'pnm'),
- "write double/mixing scaled image");
- is($scaleimg->bits, 'double', "got the right image type as output");
-
- # hscale only, mixing
- $scaleimg = $dimg->scale(xscalefactor => 0.33, yscalefactor => 1.0,
- qtype => 'mixing');
- ok($scaleimg, "scale it (hscale, mixing, double)");
- is($scaleimg->getheight, $dimg->getheight, "same height");
- ok($scaleimg->write(file => 'testout/t40hscdmix.ppm', type => 'pnm'),
- "save it");
-
- # vscale only, mixing
- $scaleimg = $dimg->scale(xscalefactor => 1.0, yscalefactor => 0.33,
- qtype => 'mixing');
- ok($scaleimg, "scale it (vscale, mixing, double)");
- is($scaleimg->getwidth, $dimg->getwidth, "same width");
- ok($scaleimg->write(file => 'testout/t40vscdmix.ppm', type => 'pnm'),
- "save it");
-}
-
-{
- # check for a warning when scale() is called in void context
- my $warning;
- local $SIG{__WARN__} =
- sub {
- $warning = "@_";
- my $printed = $warning;
- $printed =~ s/\n$//;
- $printed =~ s/\n/\n\#/g;
- print "# ",$printed, "\n";
- };
- $img->scale(scalefactor=>0.25);
- cmp_ok($warning, '=~', qr/void/, "check warning");
- cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
- $warning = '';
- $img->scaleX(scalefactor=>0.25);
- cmp_ok($warning, '=~', qr/void/, "check warning");
- cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
- $warning = '';
- $img->scaleY(scalefactor=>0.25);
- cmp_ok($warning, '=~', qr/void/, "check warning");
- cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
-}
-{ # https://rt.cpan.org/Ticket/Display.html?id=7467
- # segfault in Imager 0.43
- # make sure scale() doesn't let us make an image zero pixels high or wide
- # it does this by making the given axis as least 1 pixel high
- my $out = $img->scale(scalefactor=>0.00001);
- is($out->getwidth, 1, "min scale width");
- is($out->getheight, 1, "min scale height");
-
- $out = $img->scale(scalefactor=>0.00001, qtype => 'preview');
- is($out->getwidth, 1, "min scale width (preview)");
- is($out->getheight, 1, "min scale height (preview)");
-
- $out = $img->scale(scalefactor=>0.00001, qtype => 'mixing');
- is($out->getwidth, 1, "min scale width (mixing)");
- is($out->getheight, 1, "min scale height (mixing)");
-}
-
-{ # error handling - NULL image
- my $im = Imager->new;
- ok(!$im->scale(scalefactor => 0.5), "try to scale empty image");
- is($im->errstr, "scale: empty input image", "check error message");
-
- # scaleX/scaleY
- ok(!$im->scaleX(scalefactor => 0.5), "try to scaleX empty image");
- is($im->errstr, "scaleX: empty input image", "check error message");
- ok(!$im->scaleY(scalefactor => 0.5), "try to scaleY empty image");
- is($im->errstr, "scaleY: empty input image", "check error message");
-}
-
-{ # invalid qtype value
- my $im = Imager->new(xsize => 100, ysize => 100);
- ok(!$im->scale(scalefactor => 0.5, qtype=>'unknown'), "unknown qtype");
- is($im->errstr, "invalid value for qtype parameter", "check error message");
-
- # invalid type value
- ok(!$im->scale(xpixels => 10, ypixels=>50, type=>"unknown"), "unknown type");
- is($im->errstr, "invalid value for type parameter", "check error message");
-}
-
-SKIP:
-{ # Image::Math::Constrain support
- eval "require Image::Math::Constrain;";
- $@ and skip "optional module Image::Math::Constrain not installed", 3;
- my $constrain = Image::Math::Constrain->new(20, 100);
- my $im = Imager->new(xsize => 160, ysize => 96);
- my $result = $im->scale(constrain => $constrain);
- ok($result, "successful scale with Image::Math::Constrain");
- is($result->getwidth, 20, "check result width");
- is($result->getheight, 12, "check result height");
-}
-
-{ # scale size checks
- my $im = Imager->new(xsize => 160, ysize => 96); # some random size
-
- scale_test($im, 'scale', 80, 48, "48 x 48 def type",
- xpixels => 48, ypixels => 48);
- scale_test($im, 'scale', 80, 48, "48 x 48 max type",
- xpixels => 48, ypixels => 48, type => 'max');
- scale_test($im, 'scale', 80, 48, "80 x 80 min type",
- xpixels => 80, ypixels => 80, type => 'min');
- scale_test($im, 'scale', 80, 48, "no scale parameters (default to 0.5 scalefactor)");
- scale_test($im, 'scale', 120, 72, "0.75 scalefactor",
- scalefactor => 0.75);
- scale_test($im, 'scale', 80, 48, "80 width",
- xpixels => 80);
- scale_test($im, 'scale', 120, 72, "72 height",
- ypixels => 72);
-
- # new scaling parameters in 0.54
- scale_test($im, 'scale', 80, 48, "xscale 0.5",
- xscalefactor => 0.5);
- scale_test($im, 'scale', 80, 48, "yscale 0.5",
- yscalefactor => 0.5);
- scale_test($im, 'scale', 40, 48, "xscale 0.25 yscale 0.5",
- xscalefactor => 0.25, yscalefactor => 0.5);
- scale_test($im, 'scale', 160, 48, "xscale 1.0 yscale 0.5",
- xscalefactor => 1.0, yscalefactor => 0.5);
- scale_test($im, 'scale', 160, 48, "xpixels 160 ypixels 48 type nonprop",
- xpixels => 160, ypixels => 48, type => 'nonprop');
- scale_test($im, 'scale', 160, 96, "xpixels 160 ypixels 96",
- xpixels => 160, ypixels => 96);
- scale_test($im, 'scale', 80, 96, "xpixels 80 ypixels 96 type nonprop",
- xpixels => 80, ypixels => 96, type => 'nonprop');
-
- # scaleX
- scale_test($im, 'scaleX', 80, 96, "defaults");
- scale_test($im, 'scaleX', 40, 96, "0.25 scalefactor",
- scalefactor => 0.25);
- scale_test($im, 'scaleX', 120, 96, "pixels 120",
- pixels => 120);
-
- # scaleY
- scale_test($im, 'scaleY', 160, 48, "defaults");
- scale_test($im, 'scaleY', 160, 192, "2.0 scalefactor",
- scalefactor => 2.0);
- scale_test($im, 'scaleY', 160, 144, "pixels 144",
- pixels => 144);
-}
-
-{ # check proper alpha handling for mixing
- my $im = Imager->new(xsize => 40, ysize => 40, channels => 4);
- $im->box(filled => 1, color => 'C0C0C0');
- my $rot = $im->rotate(degrees => -4)
- or die;
- $rot = $rot->to_rgb16;
- my $sc = $rot->scale(qtype => 'mixing', xpixels => 40);
- my $out = Imager->new(xsize => $sc->getwidth, ysize => $sc->getheight);
- $out->box(filled => 1, color => 'C0C0C0');
- my $cmp = $out->copy;
- $out->rubthrough(src => $sc);
- is_image($out, $cmp, "check we get the right image after scaling (mixing)");
-
- # we now set alpha=0 pixels to zero on scaling
- is_color4($sc->getpixel('x' => 39, 'y' => 39), 0, 0, 0, 0,
- "check we set alpha=0 pixels to zero on scaling");
-}
-
-{ # check proper alpha handling for default scaling
- my $im = Imager->new(xsize => 40, ysize => 40, channels => 4);
- $im->box(filled => 1, color => 'C0C0C0');
- my $rot = $im->rotate(degrees => -4)
- or die;
- my $sc = $rot->scale(qtype => "normal", xpixels => 40);
- my $out = Imager->new(xsize => $sc->getwidth, ysize => $sc->getheight);
- $out->box(filled => 1, color => 'C0C0C0');
- my $cmp = $out->copy;
- $out->rubthrough(src => $sc);
- is_image_similar($out, $cmp, 100, "check we get the right image after scaling (normal)");
-
- # we now set alpha=0 pixels to zero on scaling
- is_color4($sc->getpixel('x' => 39, 'y' => 39), 0, 0, 0, 0,
- "check we set alpha=0 pixels to zero on scaling");
-}
-
-{ # scale_calculate
- my $im = Imager->new(xsize => 100, ysize => 120);
- is_deeply([ $im->scale_calculate(scalefactor => 0.5) ],
- [ 0.5, 0.5, 50, 60 ],
- "simple scale_calculate");
- is_deeply([ Imager->scale_calculate(scalefactor => 0.5) ],
- [], "failed scale_calculate");
- is_deeply([ Imager->scale_calculate(width => 120, height => 150,
- xpixels => 240) ],
- [ 2.0, 2.0, 240, 300 ],
- "class method scale_factor");
-}
-
-{ # passing a reference for scaling parameters should fail
- # RT #35172
- my $im = Imager->new(xsize => 100, ysize => 100);
- ok(!$im->scale(xpixels => {}), "can't use a reference as a size");
- cmp_ok($im->errstr, '=~', "xpixels parameter cannot be a reference",
- "check error message");
-}
-
-sub scale_test {
- my ($in, $method, $exp_width, $exp_height, $note, @parms) = @_;
-
- print "# $note: @parms\n";
- for my $qtype (qw(normal preview mixing)) {
- SKIP:
- {
- my $scaled = $in->$method(@parms, qtype => $qtype);
- ok($scaled, "$method $note qtype $qtype")
- or skip("failed to scale", 2);
- is($scaled->getwidth, $exp_width, "check width");
- is($scaled->getheight, $exp_height, "check height");
- }
- }
-}
+++ /dev/null
-#!perl -w
-######################### We start with some black magic to print on failure.
-
-# this used to do the check for the load of Imager, but I want to be able
-# to count tests, which means I need to load Imager first
-# since many of the early tests already do this, we don't really need to
-
-use strict;
-use Imager;
-use IO::Seekable;
-
-my $buggy_giflib_file = "buggy_giflib.txt";
-
--d "testout" or mkdir "testout";
-
-Imager::init("log"=>"testout/t50basicoo.log");
-
-# single image/file types
-my @types = qw( jpeg png raw pnm gif tiff bmp tga );
-
-# multiple image/file formats
-my @mtypes = qw(tiff gif);
-
-my %hsh=%Imager::formats;
-
-my $test_num = 0;
-my $count;
-for my $type (@types) {
- $count += 31 if $hsh{$type};
-}
-for my $type (@mtypes) {
- $count += 7 if $hsh{$type};
-}
-
-print "1..$count\n";
-
-print "# avaliable formats:\n";
-for(keys %hsh) { print "# $_\n"; }
-
-#print Dumper(\%hsh);
-
-my $img = Imager->new();
-
-my %files;
-@files{@types} = ({ file => "JPEG/testimg/209_yonge.jpg" },
- { file => "testimg/test.png" },
- { file => "testimg/test.raw", xsize=>150, ysize=>150, type=>'raw', interleave => 0},
- { file => "testimg/penguin-base.ppm" },
- { file => "GIF/testimg/expected.gif" },
- { file => "TIFF/testimg/comp8.tif" },
- { file => "testimg/winrgb24.bmp" },
- { file => "testimg/test.tga" }, );
-my %writeopts =
- (
- gif=> { make_colors=>'webmap', translate=>'closest', gifquant=>'gen',
- gif_delay=>20 },
- );
-
-for my $type (@types) {
- next unless $hsh{$type};
- print "# type $type\n";
- my %opts = %{$files{$type}};
- my @a = map { "$_=>${opts{$_}}" } keys %opts;
- print "#opening Format: $type, options: @a\n";
- ok($img->read( %opts ), "reading from file", $img);
- #or die "failed: ",$img->errstr,"\n";
-
- my %mopts = %opts;
- delete $mopts{file};
-
- # read from a file handle
- my $fh = IO::File->new($opts{file}, "r");
- if (ok($fh, "opening $opts{file}")) {
- binmode $fh;
- my $fhimg = Imager->new;
- if (ok($fhimg->read(fh=>$fh, %mopts), "read from fh")) {
- ok($fh->seek(0, SEEK_SET), "seek after read");
- if (ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "read from fh")) {
- ok(Imager::i_img_diff($img->{IMG}, $fhimg->{IMG}) == 0,
- "image comparison after fh read");
- }
- else {
- skip("no image to compare");
- }
- ok($fh->seek(0, SEEK_SET), "seek after read");
- }
-
- # read from a fd
- my $fdimg = Imager->new;
- if (ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")) {
- ok(Imager::i_img_diff($img->{IMG}, $fdimg->{IMG}) == 0,
- "image comparistion after fd read");
- }
- else {
- skip("no image to compare");
- }
- ok($fh->seek(0, SEEK_SET), "seek after fd read");
- ok($fh->close, "close fh after reads");
- }
- else {
- skip("couldn't open the damn file: $!", 7);
- }
-
- # read from a memory buffer
- open DATA, "< $opts{file}"
- or die "Cannot open $opts{file}: $!";
- binmode DATA;
- my $data = do { local $/; <DATA> };
- close DATA;
- my $bimg = Imager->new;
-
- if (ok($bimg->read(data=>$data, %mopts, type=>$type), "read from buffer",
- $img)) {
- ok(Imager::i_img_diff($img->{IMG}, $bimg->{IMG}) == 0,
- "comparing buffer read image");
- }
- else {
- skip("nothing to compare");
- }
-
- # read from callbacks, both with minimum and maximum reads
- my $buf = $data;
- my $seekpos = 0;
- my $reader_min =
- sub {
- my ($size, $maxread) = @_;
- my $out = substr($buf, $seekpos, $size);
- $seekpos += length $out;
- $out;
- };
- my $reader_max =
- sub {
- my ($size, $maxread) = @_;
- my $out = substr($buf, $seekpos, $maxread);
- $seekpos += length $out;
- $out;
- };
- my $seeker =
- sub {
- my ($offset, $whence) = @_;
- #print "io_seeker($offset, $whence)\n";
- if ($whence == SEEK_SET) {
- $seekpos = $offset;
- }
- elsif ($whence == SEEK_CUR) {
- $seekpos += $offset;
- }
- else { # SEEK_END
- $seekpos = length($buf) + $offset;
- }
- #print "-> $seekpos\n";
- $seekpos;
- };
- my $cbimg = Imager->new;
- ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts),
- "read from callback min", $cbimg);
- ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
- "comparing mincb image");
- $seekpos = 0;
- ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts),
- "read from callback max", $cbimg);
- ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
- "comparing maxcb image");
-}
-
-for my $type (@types) {
- next unless $hsh{$type};
-
- print "# write tests for $type\n";
- # test writes
- next unless $hsh{$type};
- my $file = "testout/t50out.$type";
- my $wimg = Imager->new;
- # if this doesn't work, we're so screwed up anyway
-
- ok($wimg->read(file=>"testimg/penguin-base.ppm"),
- "cannot read base file", $wimg);
-
- # first to a file
- print "# writing $type to a file\n";
- my %extraopts;
- %extraopts = %{$writeopts{$type}} if $writeopts{$type};
- ok($wimg->write(file=>$file, %extraopts),
- "writing $type to a file $file", $wimg);
-
- print "# writing $type to a FH\n";
- # to a FH
- my $fh = IO::File->new($file, "w+")
- or die "Could not create $file: $!";
- binmode $fh;
- ok($wimg->write(fh=>$fh, %extraopts, type=>$type),
- "writing $type to a FH", $wimg);
- ok($fh->seek(0, SEEK_END) > 0,
- "seek after writing $type to a FH");
- ok(print($fh "SUFFIX\n"),
- "write to FH after writing $type");
- ok($fh->close, "closing FH after writing $type");
-
- if (ok(open(DATA, "< $file"), "opening data source")) {
- binmode DATA;
- my $data = do { local $/; <DATA> };
- close DATA;
-
- # writing to a buffer
- print "# writing $type to a buffer\n";
- my $buf = '';
- ok($wimg->write(data=>\$buf, %extraopts, type=>$type),
- "writing $type to a buffer", $wimg);
- $buf .= "SUFFIX\n";
- open DATA, "> testout/t50_buf.$type"
- or die "Cannot create $type buffer file: $!";
- binmode DATA;
- print DATA $buf;
- close DATA;
- ok($data eq $buf, "comparing file data to buffer");
-
- $buf = '';
- my $seekpos = 0;
- my $did_close;
- my $writer =
- sub {
- my ($what) = @_;
- if ($seekpos > length $buf) {
- $buf .= "\0" x ($seekpos - length $buf);
- }
- substr($buf, $seekpos, length $what) = $what;
- $seekpos += length $what;
- $did_close = 0; # the close must be last
- 1;
- };
- my $reader_min =
- sub {
- my ($size, $maxread) = @_;
- my $out = substr($buf, $seekpos, $size);
- $seekpos += length $out;
- $out;
- };
- my $reader_max =
- sub {
- my ($size, $maxread) = @_;
- my $out = substr($buf, $seekpos, $maxread);
- $seekpos += length $out;
- $out;
- };
- use IO::Seekable;
- my $seeker =
- sub {
- my ($offset, $whence) = @_;
- #print "io_seeker($offset, $whence)\n";
- if ($whence == SEEK_SET) {
- $seekpos = $offset;
- }
- elsif ($whence == SEEK_CUR) {
- $seekpos += $offset;
- }
- else { # SEEK_END
- $seekpos = length($buf) + $offset;
- }
- #print "-> $seekpos\n";
- $seekpos;
- };
-
- my $closer = sub { ++$did_close; };
-
- print "# writing $type via callbacks (mb=1)\n";
- ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer,
- readcb=>$reader_min,
- %extraopts, type=>$type, maxbuffer=>1),
- "writing $type to callback (mb=1)", $wimg);
-
- ok($did_close, "checking closecb called");
- $buf .= "SUFFIX\n";
- ok($data eq $buf, "comparing callback output to file data");
- print "# writing $type via callbacks (no mb)\n";
- $buf = '';
- $did_close = 0;
- $seekpos = 0;
- # we don't use the closecb here - used to make sure we don't get
- # a warning/error on an attempt to call an undef close sub
- ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min,
- %extraopts, type=>$type),
- "writing $type to callback (no mb)", $wimg);
- $buf .= "SUFFIX\n";
- ok($data eq $buf, "comparing callback output to file data");
- }
- else {
- skip("couldn't open data source", 7);
- }
-}
-
-my $img2 = $img->crop(width=>50, height=>50);
-$img2 -> write(file=> 'testout/t50.ppm', type=>'pnm');
-
-undef($img);
-
-# multi image/file tests
-print "# multi-image write tests\n";
-for my $type (@mtypes) {
- next unless $hsh{$type};
- print "# $type\n";
-
- my $file = "testout/t50out.$type";
- my $wimg = Imager->new;
-
- # if this doesn't work, we're so screwed up anyway
- ok($wimg->read(file=>"testout/t50out.$type"),
- "reading base file", $wimg);
-
- ok(my $wimg2 = $wimg->copy, "copying base image", $wimg);
- ok($wimg2->flip(dir=>'h'), "flipping base image", $wimg2);
-
- my @out = ($wimg, $wimg2);
- my %extraopts;
- %extraopts = %{$writeopts{$type}} if $writeopts{$type};
- ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts },
- @out),
- "writing multiple to a file", "Imager");
-
- # make sure we get the same back
- my @images = Imager->read_multi(file=>"testout/t50_multi.$type");
- if (ok(@images == @out, "checking read image count")) {
- for my $i (0 .. $#out) {
- my $diff = Imager::i_img_diff($out[$i]{IMG}, $images[$i]{IMG});
- print "# diff $diff\n";
- ok($diff == 0, "comparing image $i");
- }
- }
- else {
- skip("wrong number of images read", 2);
- }
-}
-
-
-Imager::malloc_state();
-
-#print "ok 2\n";
-
-sub ok {
- my ($ok, $msg, $img, $why, $skipcount) = @_;
-
- ++$test_num;
- if ($ok) {
- print "ok $test_num # $msg\n";
- Imager::i_log_entry("ok $test_num # $msg\n", 0);
- }
- else {
- my $err;
- $err = $img->errstr if $img;
- # VMS (if we ever support it) wants the whole line in one print
- my $line = "not ok $test_num # line ".(caller)[2].": $msg";
- $line .= ": $err" if $err;
- print $line, "\n";
- Imager::i_log_entry($line."\n", 0);
- }
- skip($why, $skipcount) if defined $why;
- $ok;
-}
-
-sub skip {
- my ($why, $skipcount) = @_;
-
- $skipcount ||= 1;
- for (1.. $skipcount) {
- ++$test_num;
- print "ok $test_num # skipped $why\n";
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-use Imager;
-
-eval "use Affix::Infix2Postfix; 1;"
- or plan skip_all => "No Affix::Infix2Postfix";
-
-plan tests => 8;
-
-#$Imager::DEBUG=1;
-
--d "testout" or mkdir "testout";
-
-Imager->open_log('log'=>'testout/t55trans.log');
-
-my $img=Imager->new();
-
-SKIP:
-{
- ok($img, "make image object")
- or skip("can't make image object", 5);
-
- ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'),
- "read sample image")
- or skip("couldn't load test image", 4);
-
- SKIP:
- {
- my $nimg=$img->transform(xexpr=>'x',yexpr=>'y+10*sin((x+y)/10)');
- ok($nimg, "do transformation")
- or skip ( "warning ".$img->errstr, 1 );
-
- # xopcodes=>[qw( x y Add)],yopcodes=>[qw( x y Sub)],parm=>[]
-
- ok($nimg->write(type=>'pnm',file=>'testout/t55.ppm'), "save to file");
- }
-
- SKIP:
- {
- my $nimg=$img->transform(xexpr=>'x+0.1*y+5*sin(y/10.0+1.57)',
- yexpr=>'y+10*sin((x+y-0.785)/10)');
- ok($nimg, "more complex transform")
- or skip("couldn't make image", 1);
-
- ok($nimg->write(type=>'pnm',file=>'testout/t55b.ppm'), "save to file");
- }
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->transform(xexpr => "x", yexpr => "y"),
- "fail to transform an empty image");
- is($empty->errstr, "transform: empty input image",
- "check error message");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 6;
-BEGIN { use_ok('Imager::Expr') }
-
-SKIP:
-{
- my $expr = Imager::Expr->new({rpnexpr=><<EXPR, variables=>[ qw(x y) ], constants=>{one=>1, two=>2}});
-x two * # see if comments work
-y one +
-getp1
-EXPR
- ok($expr, "compile postfix")
- or print "# ", Imager::Expr->error, "\n";
- $expr
- or skip("Could not compile", 4);
-
- # perform some basic validation on the code
- my $code = $expr->dumpcode();
- my @code = split /\n/, $code;
- ok($code[-1] =~ /:\s+ret/, "ret at the end");
- ok(grep(/:\s+mult.*x/, @code), "found mult");
- ok(grep(/:\s+add.*y/, @code), "found add");
- ok(grep(/:\s+getp1/, @code), "found getp1");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 7;
-
-BEGIN { use_ok('Imager::Expr') }
-
-# only test this if Parse::RecDescent was loaded successfully
-SKIP:
-{
- Imager::Expr->type_registered('expr')
- or skip("Imager::Expr::Infix not available", 6);
-
- my $opts = {expr=>'z=0.8;return hsv(x/w*360,y/h,z)', variables=>[ qw(x y) ], constants=>{h=>100,w=>100}};
- my $expr = Imager::Expr->new($opts);
- ok($expr, "make infix expression")
- or skip("Could not make infix expression", 5);
- my $code = $expr->dumpcode();
- my @code = split /\n/,$code;
- #print $code;
- ok($code[-1] =~ /:\s+ret/, "final op a ret");
- ok(grep(/:\s+mult.*360/, @code), "mult by 360 found");
- # strength reduction converts these to mults
- #print grep(/:\s+div.*x/, @code) ? "ok 5\n" : "not ok 5\n";
- #print grep(/:\s+div.*y/, @code) ? "ok 6\n" : "not ok 6\n";
- ok(grep(/:\s+mult.*x/, @code), "mult by x found");
- ok(grep(/:\s+mult.*y/, @code), "mult by y found");
- ok(grep(/:\s+hsv.*0\.8/, @code), "hsv op found");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 40;
-BEGIN { use_ok('Imager'); }
-use Imager::Test qw(is_color3);
-
--d "testout" or mkdir "testout";
-
-Imager::init('log'=>'testout/t58trans2.log');
-
-my $im1 = Imager->new();
-$im1->open(file=>'testimg/penguin-base.ppm', type=>'pnm')
- || die "Cannot read image";
-my $im2 = Imager->new();
-$im2->open(file=>'testimg/scale.ppm',type=>'pnm')
- || die "Cannot read testimg/scale.ppm";
-
-# error handling
-my $opts = { rpnexpr=>'x x 10 / sin 10 * y + get1' };
-my $im3 = Imager::transform2($opts);
-ok(!$im3, "returned an image on error");
-ok(defined($Imager::ERRSTR), "No error message on failure");
-
-# image synthesis
-my $im4 = Imager::transform2({
- width=>300, height=>300,
- rpnexpr=>'x y cx cy distance !d y cy - x cx - atan2 !a @d 10 / @a + 3.1416 2 * % !a2 @a2 cy * 3.1416 / 1 @a2 sin 1 + 2 / hsv'});
-ok($im4, "synthesis failed");
-
-if ($im4) {
- $im4->write(type=>'pnm', file=>'testout/t56a.ppm')
- || die "Cannot write testout/t56a.ppm";
-}
-
-# image distortion
-my $im5 = Imager::transform2({
- rpnexpr=>'x x 10 / sin 10 * y + getp1'
-}, $im1);
-ok($im5, "image distortion");
-if ($im5) {
- $im5->write(type=>'pnm', file=>'testout/t56b.ppm')
- || die "Cannot write testout/t56b.ppm";
-}
-
-# image combination
-$opts = {
-rpnexpr=>'x h / !rat x w2 % y h2 % getp2 !pat x y getp1 @rat * @pat 1 @rat - * +'
-};
-my $im6 = Imager::transform2($opts,$im1,$im2);
-ok($im6, "image combination");
-if ($im6) {
- $im6->write(type=>'pnm', file=>'testout/t56c.ppm')
- || die "Cannot write testout/t56c.ppm";
-}
-
-# alpha
-$opts =
- {
- rpnexpr => '0 0 255 x y + w h + 2 - / 255 * rgba',
- channels => 4,
- width => 50,
- height => 50,
- };
-my $im8 = Imager::transform2($opts);
-ok($im8, "alpha output");
-my $c = $im8->getpixel(x=>0, 'y'=>0);
-is(($c->rgba)[3], 0, "zero alpha");
-$c = $im8->getpixel(x=>49, 'y'=>49);
-is(($c->rgba)[3], 255, "max alpha");
-
-$opts = { rpnexpr => 'x 1 + log 50 * y 1 + log 50 * getp1' };
-my $im9 = Imager::transform2($opts, $im1);
-ok($im9, "log function");
-if ($im9) {
- $im9->write(type=>'pnm', file=>'testout/t56-9.ppm');
-}
-
-# op tests
-sub op_test($$$$$$);
-print "# op tests\n";
-op_test('7F0000', <<EOS, 0, 127, 0, 'value hsv getp1');
-120 1.0
-0 0 getp1 value
-hsv
-EOS
-op_test("7F0000", <<EOS, 255, 0, 0, 'hue');
-0 0 getp1 hue
-1.0 1.0 hsv
-EOS
-op_test("7F0000", <<EOS, 0, 255, 0, 'sat');
-120 0 0 getp1 sat 1.0 hsv
-EOS
-op_test("4060A0", <<'EOS', 128, 128, 128, "add mult sub rgb red green blue");
-0 0 getp1 !p @p red 2 * @p green 32 + @p blue 32 - rgb
-EOS
-op_test('806040', <<'EOS', 64, 64, 64, "div uminus");
-0 0 getp1 !p @p red 2 / @p green 32 uminus add @p blue rgb
-EOS
-op_test('40087f', <<'EOS', 8, 64, 31, 'pow mod');
-0 0 getp1 !p @p red 0.5 pow @p green 2 pow @p blue 32 mod rgb
-EOS
-op_test('202122', '0 0 getp1 4 *', 128, 132, 136, 'multp');
-op_test('404040', '0 0 getp1 1 2 3 rgb +', 65, 66, 67, 'addp');
-op_test('414243', '0 0 getp1 3 2 1 rgb -', 62, 64, 66, 'subp');
-op_test('808040', <<'EOS', 64, 64, 8, 'sin cos pi sqrt');
-0 0 getp1 !p pi 6 / sin @p red * 0.1 + pi 3 / cos @p green * 0.1 +
-@p blue sqrt rgb
-EOS
-op_test('008080', <<'EOS', 0, 0, 0, 'atan2');
-0 0 0 0 getp1 !p @p red 128 / @p green 128 / atan2 hsv
-EOS
-op_test('000000', <<'EOS', 150, 150, 150, 'distance');
-0 100 120 10 distance !d @d @d @d rgb
-EOS
-op_test('000000', <<'EOS', 100, 100, 100, 'int');
-50.75 int 2 * !i @i @i @i rgb
-EOS
-op_test('000100', <<'EOS', 128, 0, 0, 'if');
-0 0 getp1 !p @p red 0 128 if @p green 0 128 if 0 rgb
-EOS
-op_test('FF0000', <<'EOS', 0, 255, 0, 'ifp');
-0 0 0 getp1 0 255 0 rgb ifp
-EOS
-op_test('000000', <<'EOS', 1, 0, 1, 'le lt gt');
-0 1 le 1 0 lt 1 0 gt rgb
-EOS
-op_test('000000', <<'EOS', 0, 1, 0, 'ge eq ne');
-0 1 ge 0 0 eq 0 0 ne rgb
-EOS
-op_test('000000', <<'EOS', 0, 1, 1, 'and or not');
-1 0 and 1 0 or 0 not rgb
-EOS
-op_test('000000', <<'EOS', 255, 0, 255, 'abs');
--255 abs 0 abs 255 abs rgb
-EOS
-op_test('000000', <<'EOS', 50, 82, 0, 'exp log');
-1 exp log 50 * 0.5 + 0.5 exp 50 * 0 rgb
-EOS
-op_test('800000', <<'EOS', 128, 0, 0, 'det');
-1 0 0 1 det 128 * 1 1 1 1 det 128 * 0 rgb
-EOS
-op_test('FF80C0', <<'EOS', 127, 0, 0, 'sat');
-0 0 getp1 sat 255 * 0.01 + 0 0 rgb
-EOS
-
-
-{
- my $empty = Imager->new;
- my $good = Imager->new(xsize => 1, ysize => 1);
- ok(!Imager::transform2({ rpnexpr => "x y getp1" }, $good, $empty),
- "can't transform an empty image");
- is(Imager->errstr, "transform2: empty input image (input image 2)",
- "check error message");
-}
-
-use Imager::Transform;
-
-# some simple tests
-print "# Imager::Transform\n";
-my @funcs = Imager::Transform->list;
-ok(@funcs, "funcs");
-
-my $tran = Imager::Transform->new($funcs[0]);
-ok($tran, "got tranform");
-ok($tran->describe() eq Imager::Transform->describe($funcs[0]),
- "description");
-# look for a function that takes inputs (at least one does)
-my @needsinputs = grep Imager::Transform->new($_)->inputs, @funcs;
-# make sure they're
-my @inputs = Imager::Transform->new($needsinputs[0])->inputs;
-ok($inputs[0]{desc}, "input description");
-# at some point I might want to test the actual transformations
-
-# check lower level error handling
-my $im7 = Imager::transform2({rpnexpr=>'x y getp2', width=>100, height=>100});
-ok(!$im7, "expected failure on accessing invalid image");
-print "# ", Imager->errstr, "\n";
-ok(Imager->errstr =~ /not enough images/, "didn't get expected error");
-
-sub op_test ($$$$$$) {
- my ($in_color, $code, $r, $g, $b, $comment) = @_;
-
- my $im = Imager->new(xsize => 1, ysize => 1);
- $im->setpixel(x => 0, y => 0, color => $in_color);
- SKIP:
- {
- my $out = Imager::transform2({ rpnexpr => $code }, $im);
- unless ($out) {
- fail("$comment: could not compile $code - ".Imager->errstr);
- return;
- }
- my $found = $out->getpixel(x => 0, y => 0);
- is_color3($found, $r, $g, $b, $comment);
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 6;
-
-BEGIN { use_ok('Imager::Expr::Assem') }
-
-SKIP:
-{
- my $expr = Imager::Expr->new
- ({assem=><<EOS,
- var count:n ; var p:p
- count = 0
- p = getp1 x y
-loop:
-# this is just a delay
- count = add count 1
- var temp:n
- temp = lt count totalcount
- jumpnz temp loop
- ret p
-EOS
- variables=>[qw(x y)],
- constants=>{totalcount=>5}
- });
- ok($expr, "compile simple assembler")
- or do {
- print "# ", Imager::Expr->error, "\n";
- skip("didn't compile", 4);
- };
- my $code = $expr->dumpcode();
- my @code = split /\n/, $code;
- ok($code[-1] =~ /:\s+ret/, "last op is a ret");
- ok($code[0] =~ /:\s+set/, "first op is a set");
- ok($code[1] =~ /:\s+getp1/, "next is a getp1");
- ok($code[3] =~ /:\s+lt/, "found comparison");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager qw(:handy);
-use Test::More tests => 122;
-
--d "testout" or mkdir "testout";
-
-Imager::init_log("testout/t61filters.log", 1);
-use Imager::Test qw(is_image_similar test_image is_image is_color4 is_fcolor4);
-# meant for testing the filters themselves
-
-my $imbase = test_image();
-
-my $im_other = Imager->new(xsize=>150, ysize=>150);
-$im_other->box(xmin=>30, ymin=>60, xmax=>120, ymax=>90, filled=>1);
-
-test($imbase, {type=>'autolevels'}, 'testout/t61_autolev.ppm');
-
-test($imbase, {type=>'contrast', intensity=>0.5},
- 'testout/t61_contrast.ppm');
-
-# this one's kind of cool
-test($imbase, {type=>'conv', coef=>[ 0.3, 1, 0.3, ], },
- 'testout/t61_conv_blur.ppm');
-
-{
- my $work = $imbase->copy;
- ok(!Imager::i_conv($work->{IMG}, []), "conv should fail with empty array");
- ok(!$work->filter(type => 'conv', coef => []),
- "check the conv OO intergave too");
- is($work->errstr, "there must be at least one coefficient",
- "check conv error message");
-}
-
-{
- my $work8 = $imbase->copy;
- ok(!$work8->filter(type => "conv", coef => "ABC"),
- "coef not an array");
-}
-{
- my $work8 = $imbase->copy;
- ok(!$work8->filter(type => "conv", coef => [ -1, 2, -1 ]),
- "should fail if sum of coef is 0");
- is($work8->errstr, "sum of coefficients is zero", "check message");
-}
-
-{
- my $work8 = $imbase->copy;
- my $work16 = $imbase->to_rgb16;
- my $coef = [ -0.2, 1, -0.2 ];
- ok($work8->filter(type => "conv", coef => $coef),
- "filter 8 bit image");
- ok($work16->filter(type => "conv", , coef => $coef),
- "filter 16 bit image");
- is_image_similar($work8, $work16, 80000, "8 and 16 bit conv match");
-}
-
-{
- my $gauss = test($imbase, {type=>'gaussian', stddev=>5 },
- 'testout/t61_gaussian.ppm');
-
- my $imbase16 = $imbase->to_rgb16;
- my $gauss16 = test($imbase16, {type=>'gaussian', stddev=>5 },
- 'testout/t61_gaussian16.ppm');
- is_image_similar($gauss, $gauss16, 250000, "8 and 16 gaussian match");
-}
-
-
-test($imbase, { type=>'gradgen', dist=>1,
- xo=>[ 10, 10, 120 ],
- yo=>[ 10, 140, 60 ],
- colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
- 'testout/t61_gradgen.ppm');
-
-test($imbase, {type=>'mosaic', size=>8}, 'testout/t61_mosaic.ppm');
-
-test($imbase, {type=>'hardinvert'}, 'testout/t61_hardinvert.ppm');
-
-{ # invert - 8 bit
- my $im = Imager->new(xsize => 1, ysize => 1, channels => 4);
- ok($im, "make test image for invert test");
- ok($im->setpixel(x => 0, y => 0, color => "000010C0"),
- "set a test pixel");
- my $copy = $im->copy;
- ok($im->filter(type => "hardinvert"), "hardinvert it");
- is_color4($im->getpixel(x => 0, y => 0), 255, 255, 0xEF, 0xC0,
- "check only colour inverted");
- ok($copy->filter(type => "hardinvertall"), "hardinvertall copy");
- is_color4($copy->getpixel(x => 0, y => 0), 255, 255, 0xEF, 0x3f,
- "check all inverted");
-}
-
-{ # invert - double image
- my $im = Imager->new(xsize => 1, ysize => 1, channels => 4, bits => "double");
- ok($im, "make double test image for invert test");
- ok($im->setpixel(x => 0, y => 0, color => Imager::Color::Float->new(0, 0, 0.125, 0.75)),
- "set a test pixel");
- my $copy = $im->copy;
- ok($im->filter(type => "hardinvert"), "hardinvert it");
- is_fcolor4($im->getpixel(x => 0, y => 0, type => "double"),
- 1.0, 1.0, 0.875, 0.75, 1e-5,
- "check only colour inverted");
- ok($copy->filter(type => "hardinvertall"), "hardinvertall copy");
- is_fcolor4($copy->getpixel(x => 0, y => 0, type =>"double"),
- 1.0, 1.0, 0.875, 0.25, 1e-5,
- "check all inverted");
-}
-
-test($imbase, {type=>'noise'}, 'testout/t61_noise.ppm');
-
-test($imbase, {type=>'radnoise'}, 'testout/t61_radnoise.ppm');
-
-test($imbase, {type=>'turbnoise'}, 'testout/t61_turbnoise.ppm');
-
-test($imbase, {type=>'bumpmap', bump=>$im_other, lightx=>30, lighty=>30},
- 'testout/t61_bumpmap.ppm');
-
-test($imbase, {type=>'bumpmap_complex', bump=>$im_other}, 'testout/t61_bumpmap_complex.ppm');
-
-test($imbase, {type=>'postlevels', levels=>3}, 'testout/t61_postlevels.ppm');
-
-test($imbase, {type=>'watermark', wmark=>$im_other },
- 'testout/t61_watermark.ppm');
-
-test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>85, yb=>30,
- repeat=>'triangle', #ftype=>'radial',
- super_sample=>'circle', ssample_param => 16,
- },
- 'testout/t61_fountain.ppm');
-use Imager::Fountain;
-
-my $f1 = Imager::Fountain->new;
-$f1->add(end=>0.2, c0=>NC(255, 0,0), c1=>NC(255, 255,0));
-$f1->add(start=>0.2, c0=>NC(255,255,0), c1=>NC(0,0,255,0));
-test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
- #repeat=>'triangle',
- segments=>$f1
- },
- 'testout/t61_fountain2.ppm');
-my $f2 = Imager::Fountain->new
- ->add(end=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'hueup')
- ->add(start=>0.5, c0=>NC(255,0,0), c1=>NC(255,0,0), color=>'huedown');
-#use Data::Dumper;
-#print Dumper($f2);
-test($imbase, { type=>'fountain', xa=>20, ya=>130, xb=>130, yb=>20,
- segments=>$f2 },
- 'testout/t61_fount_hsv.ppm');
-my $f3 = Imager::Fountain->read(gimp=>'testimg/gimpgrad');
-ok($f3, "read gimpgrad");
-test($imbase, { type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
- segments=>$f3, super_sample=>'grid',
- ftype=>'radial_square', combine=>'color' },
- 'testout/t61_fount_gimp.ppm');
-{ # test new fountain with no parameters
- my $warn = '';
- local $SIG{__WARN__} = sub { $warn .= "@_" };
- my $f4 = Imager::Fountain->read();
- ok(!$f4, "read with no parameters does nothing");
- like($warn, qr/Nothing to do!/, "check the warning");
-}
-{ # test with missing file
- my $warn = '';
- local $SIG{__WARN__} = sub { $warn .= "@_" };
- my $f = Imager::Fountain->read(gimp => "no-such-file");
- ok(!$f, "try to read a fountain defintion that doesn't exist");
- is($warn, "", "should be no warning");
- like(Imager->errstr, qr/^Cannot open no-such-file: /, "check message");
-}
-SKIP:
-{
- my $fh = IO::File->new("testimg/gimpgrad", "r");
- ok($fh, "opened gradient")
- or skip "Couldn't open gradient: $!", 1;
- my $f = Imager::Fountain->read(gimp => $fh);
- ok($f, "read gradient from file handle");
-}
-{
- # not a gradient
- my $f = Imager::Fountain->read(gimp => "t/t61filters.t");
- ok(!$f, "fail to read non-gradient");
- is(Imager->errstr, "t/t61filters.t is not a GIMP gradient file",
- "check error message");
-}
-{ # an invalid gradient file
- my $f = Imager::Fountain->read(gimp => "testimg/gradbad.ggr");
- ok(!$f, "fail to read bad gradient (bad seg count)");
- is(Imager->errstr, "testimg/gradbad.ggr is missing the segment count",
- "check error message");
-}
-{ # an invalid gradient file
- my $f = Imager::Fountain->read(gimp => "testimg/gradbad2.ggr");
- ok(!$f, "fail to read bad gradient (bad segment)");
- is(Imager->errstr, "Bad segment definition",
- "check error message");
-}
-test($imbase, { type=>'unsharpmask', stddev=>2.0 },
- 'testout/t61_unsharp.ppm');
-test($imbase, {type=>'conv', coef=>[ -1, 3, -1, ], },
- 'testout/t61_conv_sharp.ppm');
-
-test($imbase, { type=>'nearest_color', dist=>1,
- xo=>[ 10, 10, 120 ],
- yo=>[ 10, 140, 60 ],
- colors=> [ NC('#FF0000'), NC('#FFFF00'), NC('#00FFFF') ]},
- 'testout/t61_nearest.ppm');
-
-# Regression test: the checking of the segment type was incorrect
-# (the comparison was checking the wrong variable against the wrong value)
-my $f4 = [ [ 0, 0.5, 1, NC(0,0,0), NC(255,255,255), 5, 0 ] ];
-test($imbase, {type=>'fountain', xa=>75, ya=>75, xb=>90, yb=>15,
- segments=>$f4, super_sample=>'grid',
- ftype=>'linear', combine=>'color' },
- 'testout/t61_regress_fount.ppm');
-my $im2 = $imbase->copy;
-$im2->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
-$im2->write(file=>'testout/t61_diff_base.ppm');
-my $im3 = Imager->new(xsize=>150, ysize=>150, channels=>3);
-$im3->box(xmin=>20, ymin=>20, xmax=>40, ymax=>40, color=>'FF0000', filled=>1);
-my $diff = $imbase->difference(other=>$im2);
-ok($diff, "got difference image");
-SKIP:
-{
- skip(1, "missing comp or diff image") unless $im3 && $diff;
-
- is(Imager::i_img_diff($im3->{IMG}, $diff->{IMG}), 0,
- "compare test image and diff image");
-}
-
-# newer versions of gimp add a line to the gradient file
-my $name;
-my $f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr',
- name => \$name);
-ok($f5, "read newer gimp gradient")
- or print "# ",Imager->errstr,"\n";
-is($name, "imager test gradient", "check name read correctly");
-$f5 = Imager::Fountain->read(gimp=>'testimg/newgimpgrad.ggr');
-ok($f5, "check we handle case of no name reference correctly")
- or print "# ",Imager->errstr,"\n";
-
-# test writing of gradients
-ok($f2->write(gimp=>'testout/t61grad1.ggr'), "save a gradient")
- or print "# ",Imager->errstr,"\n";
-undef $name;
-my $f6 = Imager::Fountain->read(gimp=>'testout/t61grad1.ggr',
- name=>\$name);
-ok($f6, "read what we wrote")
- or print "# ",Imager->errstr,"\n";
-ok(!defined $name, "we didn't set the name, so shouldn't get one");
-
-# try with a name
-ok($f2->write(gimp=>'testout/t61grad2.ggr', name=>'test gradient'),
- "write gradient with a name")
- or print "# ",Imager->errstr,"\n";
-undef $name;
-my $f7 = Imager::Fountain->read(gimp=>'testout/t61grad2.ggr', name=>\$name);
-ok($f7, "read what we wrote")
- or print "# ",Imager->errstr,"\n";
-is($name, "test gradient", "check the name matches");
-
-# we attempt to convert color names in segments to segments now
-{
- my @segs =
- (
- [ 0.0, 0.5, 1.0, '000000', '#FFF', 0, 0 ],
- );
- my $im = Imager->new(xsize=>50, ysize=>50);
- ok($im->filter(type=>'fountain', segments => \@segs,
- xa=>0, ya=>30, xb=>49, yb=>30),
- "fountain with color names instead of objects in segments");
- my $left = $im->getpixel('x'=>0, 'y'=>20);
- ok(color_close($left, Imager::Color->new(0,0,0)),
- "check black converted correctly");
- my $right = $im->getpixel('x'=>49, 'y'=>20);
- ok(color_close($right, Imager::Color->new(255,255,255)),
- "check white converted correctly");
-
- # check that invalid color names are handled correctly
- my @segs2 =
- (
- [ 0.0, 0.5, 1.0, '000000', 'FxFxFx', 0, 0 ],
- );
- ok(!$im->filter(type=>'fountain', segments => \@segs2,
- xa=>0, ya=>30, xb=>49, yb=>30),
- "fountain with invalid color name");
- cmp_ok($im->errstr, '=~', 'No color named', "check error message");
-}
-
-{
- # test simple gradient creation
- my @colors = map Imager::Color->new($_), qw/white blue red/;
- my $s = Imager::Fountain->simple(positions => [ 0, 0.3, 1.0 ],
- colors => \@colors);
- ok($s, "made simple gradient");
- my $start = $s->[0];
- is($start->[0], 0, "check start of first correct");
- is_color4($start->[3], 255, 255, 255, 255, "check color at start");
-}
-{
- # simple gradient error modes
- {
- my $warn = '';
- local $SIG{__WARN__} = sub { $warn .= "@_" };
- my $s = Imager::Fountain->simple();
- ok(!$s, "no parameters to simple()");
- like($warn, qr/Nothing to do/);
- }
- {
- my $s = Imager::Fountain->simple(positions => [ 0, 1 ],
- colors => [ NC(0, 0, 0) ]);
- ok(!$s, "mismatch of positions and colors fails");
- is(Imager->errstr, "positions and colors must be the same size",
- "check message");
- }
- {
- my $s = Imager::Fountain->simple(positions => [ 0 ],
- colors => [ NC(0, 0, 0) ]);
- ok(!$s, "not enough positions");
- is(Imager->errstr, "not enough segments");
- }
-}
-
-{
- my $im = Imager->new(xsize=>100, ysize=>100);
- # build the gradient the hard way - linear from black to white,
- # then back again
- my @simple =
- (
- [ 0, 0.25, 0.5, 'black', 'white', 0, 0 ],
- [ 0.5. 0.75, 1.0, 'white', 'black', 0, 0 ],
- );
- # across
- my $linear = $im->filter(type => "fountain",
- ftype => 'linear',
- repeat => 'sawtooth',
- xa => 0,
- ya => $im->getheight / 2,
- xb => $im->getwidth - 1,
- yb => $im->getheight / 2);
- ok($linear, "linear fountain sample");
- # around
- my $revolution = $im->filter(type => "fountain",
- ftype => 'revolution',
- xa => $im->getwidth / 2,
- ya => $im->getheight / 2,
- xb => $im->getwidth / 2,
- yb => 0);
- ok($revolution, "revolution fountain sample");
- # out from the middle
- my $radial = $im->filter(type => "fountain",
- ftype => 'radial',
- xa => $im->getwidth / 2,
- ya => $im->getheight / 2,
- xb => $im->getwidth / 2,
- yb => 0);
- ok($radial, "radial fountain sample");
-}
-
-{
- # try a simple custom filter that uses the Perl image interface
- sub perl_filt {
- my %args = @_;
-
- my $im = $args{imager};
-
- my $channels = $args{channels};
- unless (@$channels) {
- $channels = [ reverse(0 .. $im->getchannels-1) ];
- }
- my @chans = @$channels;
- push @chans, 0 while @chans < 4;
-
- for my $y (0 .. $im->getheight-1) {
- my $row = $im->getsamples(y => $y, channels => \@chans);
- $im->setscanline(y => $y, pixels => $row);
- }
- }
- Imager->register_filter(type => 'perl_test',
- callsub => \&perl_filt,
- defaults => { channels => [] },
- callseq => [ qw/imager channels/ ]);
- test($imbase, { type => 'perl_test' }, 'testout/t61perl.ppm');
-}
-
-{ # check the difference method out
- my $im1 = Imager->new(xsize => 3, ysize => 2);
- $im1->box(filled => 1, color => '#FF0000');
- my $im2 = $im1->copy;
- $im1->setpixel(x => 1, 'y' => 0, color => '#FF00FF');
- $im2->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
- $im1->setpixel(x => 2, 'y' => 0, color => '#FF00FF');
- $im2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
-
- my $diff1 = $im1->difference(other => $im2);
- my $cmp1 = Imager->new(xsize => 3, ysize => 2, channels => 4);
- $cmp1->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
- $cmp1->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
- is_image($diff1, $cmp1, "difference() - check image with mindist 0");
-
- my $diff2 = $im1->difference(other => $im2, mindist => 1);
- my $cmp2 = Imager->new(xsize => 3, ysize => 2, channels => 4);
- $cmp2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
- is_image($diff2, $cmp2, "difference() - check image with mindist 1");
-}
-
-{
- # and again with large samples
- my $im1 = Imager->new(xsize => 3, ysize => 2, bits => 'double');
- $im1->box(filled => 1, color => '#FF0000');
- my $im2 = $im1->copy;
- $im1->setpixel(x => 1, 'y' => 0, color => '#FF00FF');
- $im2->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
- $im1->setpixel(x => 2, 'y' => 0, color => '#FF00FF');
- $im2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
-
- my $diff1 = $im1->difference(other => $im2);
- my $cmp1 = Imager->new(xsize => 3, ysize => 2, channels => 4);
- $cmp1->setpixel(x => 1, 'y' => 0, color => '#FF01FF');
- $cmp1->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
- is_image($diff1, $cmp1, "difference() - check image with mindist 0 - large samples");
-
- my $diff2 = $im1->difference(other => $im2, mindist => 1.1);
- my $cmp2 = Imager->new(xsize => 3, ysize => 2, channels => 4);
- $cmp2->setpixel(x => 2, 'y' => 0, color => '#FF02FF');
- is_image($diff2, $cmp2, "difference() - check image with mindist 1.1 - large samples");
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->filter(type => "hardinvert"), "can't filter an empty image");
- is($empty->errstr, "filter: empty input image",
- "check error message");
- ok(!$empty->difference(other => $imbase), "can't difference empty image");
- is($empty->errstr, "difference: empty input image",
- "check error message");
- ok(!$imbase->difference(other => $empty),
- "can't difference against empty image");
- is($imbase->errstr, "difference: empty input image (other image)",
- "check error message");
-}
-
-sub test {
- my ($in, $params, $out) = @_;
-
- my $copy = $in->copy;
- if (ok($copy->filter(%$params), $params->{type})) {
- ok($copy->write(file=>$out), "write $params->{type}")
- or print "# ",$copy->errstr,"\n";
- }
- else {
- diag($copy->errstr);
- SKIP:
- {
- skip("couldn't filter", 1);
- }
- }
- $copy;
-}
-
-sub color_close {
- my ($c1, $c2) = @_;
-
- my @c1 = $c1->rgba;
- my @c2 = $c2->rgba;
-
- for my $i (0..2) {
- if (abs($c1[$i]-$c2[$i]) > 2) {
- return 0;
- }
- }
- return 1;
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager qw(:handy);
-use Test::More tests => 120;
-use Imager::Test qw(is_image is_imaged);
-
--d "testout" or mkdir "testout";
-
-Imager::init_log("testout/t62compose.log", 1);
-
-my @files;
-
-my %types =
- (
- double =>
- {
- blue => NCF(0, 0, 1),
- red => NCF(1, 0, 0),
- green2 => NCF(0, 1, 0, 0.5),
- green2_on_blue => NCF(0, 0.5, 0.5),
- red3_on_blue => NCF(1/3, 0, 2/3),
- green6_on_blue => NCF(0, 1/6, 5/6),
- red2_on_blue => NCF(0.5, 0, 0.5),
- green4_on_blue => NCF(0, 0.25, 0.75),
- gray100 => NCF(1.0, 0, 0),
- gray50 => NCF(0.5, 0, 0),
- is_image => \&is_imaged,
- },
- 8 =>
- {
- blue => NC(0, 0, 255),
- red => NC(255, 0, 0),
- green2 => NC(0, 255, 0, 128),
- green2_on_blue => NC(0, 128, 127),
- red3_on_blue => NC(85, 0, 170),
- green6_on_blue => NC(0, 42, 213),
- red2_on_blue => NC(128, 0, 127),
- green4_on_blue => NC(0, 64, 191),
- gray100 => NC(255, 0, 0),
- gray50 => NC(128, 0, 0),
- is_image => \&is_image,
- },
- );
-
-for my $type_id (sort keys %types) {
- my $type = $types{$type_id};
- my $blue = $type->{blue};
- my $red = $type->{red};
- my $green2 = $type->{green2};
- my $green2_on_blue = $type->{green2_on_blue};
- my $red3_on_blue = $type->{red3_on_blue};
- my $green6_on_blue = $type->{green6_on_blue};
- my $red2_on_blue = $type->{red2_on_blue};
- my $green4_on_blue = $type->{green4_on_blue};
- my $gray100 = $type->{gray100};
- my $gray50 = $type->{gray50};
- my $is_image = $type->{is_image};
-
- print "# type $type_id\n";
- my $targ = Imager->new(xsize => 100, ysize => 100, bits => $type_id);
- $targ->box(color => $blue, filled => 1);
- is($targ->type, "direct", "check target image type");
- is($targ->bits, $type_id, "check target bits");
-
- my $src = Imager->new(xsize => 40, ysize => 40, channels => 4, bits => $type_id);
- $src->box(filled => 1, color => $red, xmax => 19, ymax => 19);
- $src->box(filled => 1, xmin => 20, color => $green2);
- save_to($src, "${type_id}_src");
-
- my $mask_ones = Imager->new(channels => 1, xsize => 40, ysize => 40, bits => $type_id);
- $mask_ones->box(filled => 1, color => NC(255, 255, 255));
-
-
- # mask or full mask, should be the same
- for my $mask_info ([ "nomask" ], [ "fullmask", mask => $mask_ones ]) {
- my ($mask_type, @mask_extras) = @$mask_info;
- print "# $mask_type\n";
- {
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin=> 5, ymin => 10, xmax => 24, ymax => 29);
- $cmp->box(filled => 1, color => $green2_on_blue,
- xmin => 25, ymin => 10, xmax => 44, ymax => 49);
- {
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 5, ty => 10, @mask_extras),
- "$mask_type - simple compose");
- $is_image->($work, $cmp, "check match");
- save_to($work, "${type_id}_${mask_type}_simple");
- }
- { # >1 opacity
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 5, ty => 10, opacity => 2.0, @mask_extras),
- "$mask_type - compose with opacity > 1.0 acts like opacity=1.0");
- $is_image->($work, $cmp, "check match");
- }
- { # 0 opacity is a failure
- my $work = $targ->copy;
- ok(!$work->compose(src => $src, tx => 5, ty => 10, opacity => 0.0, @mask_extras),
- "$mask_type - compose with opacity = 0 is an error");
- is($work->errstr, "opacity must be positive", "check message");
- }
- }
- { # compose at 1/3
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 7, ty => 33, opacity => 1/3, @mask_extras),
- "$mask_type - simple compose at 1/3");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red3_on_blue,
- xmin => 7, ymin => 33, xmax => 26, ymax => 52);
- $cmp->box(filled => 1, color => $green6_on_blue,
- xmin => 27, ymin => 33, xmax => 46, ymax => 72);
- $is_image->($work, $cmp, "check match");
- }
- { # targ off top left
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => -5, ty => -3, @mask_extras),
- "$mask_type - compose off top left");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin=> 0, ymin => 0, xmax => 14, ymax => 16);
- $cmp->box(filled => 1, color => $green2_on_blue,
- xmin => 15, ymin => 0, xmax => 34, ymax => 36);
- $is_image->($work, $cmp, "check match");
- }
- { # targ off bottom right
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 65, ty => 67, @mask_extras),
- "$mask_type - targ off bottom right");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin=> 65, ymin => 67, xmax => 84, ymax => 86);
- $cmp->box(filled => 1, color => $green2_on_blue,
- xmin => 85, ymin => 67, xmax => 99, ymax => 99);
- $is_image->($work, $cmp, "check match");
- }
- { # src off top left
- my $work = $targ->copy;
- my @more_mask_extras;
- if (@mask_extras) {
- push @more_mask_extras,
- (
- mask_left => -5,
- mask_top => -15,
- );
- }
- ok($work->compose(src => $src, tx => 10, ty => 20,
- src_left => -5, src_top => -15,
- @mask_extras, @more_mask_extras),
- "$mask_type - source off top left");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin=> 15, ymin => 35, xmax => 34, ymax => 54);
- $cmp->box(filled => 1, color => $green2_on_blue,
- xmin => 35, ymin => 35, xmax => 54, ymax => 74);
- $is_image->($work, $cmp, "check match");
- }
- {
- # src off bottom right
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 10, ty => 20,
- src_left => 10, src_top => 15,
- width => 40, height => 40, @mask_extras),
- "$mask_type - source off bottom right");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin=> 10, ymin => 20, xmax => 19, ymax => 24);
- $cmp->box(filled => 1, color => $green2_on_blue,
- xmin => 20, ymin => 20, xmax => 39, ymax => 44);
- $is_image->($work, $cmp, "check match");
- }
- {
- # simply out of bounds
- my $work = $targ->copy;
- ok(!$work->compose(src => $src, tx => 100, @mask_extras),
- "$mask_type - off the right of the target");
- $is_image->($work, $targ, "no changes");
- ok(!$work->compose(src => $src, ty => 100, @mask_extras),
- "$mask_type - off the bottom of the target");
- $is_image->($work, $targ, "no changes");
- ok(!$work->compose(src => $src, tx => -40, @mask_extras),
- "$mask_type - off the left of the target");
- $is_image->($work, $targ, "no changes");
- ok(!$work->compose(src => $src, ty => -40, @mask_extras),
- "$mask_type - off the top of the target");
- $is_image->($work, $targ, "no changes");
- }
- }
-
- # masked tests
- my $mask = Imager->new(xsize => 40, ysize => 40, channels => 1, bits => $type_id);
- $mask->box(filled => 1, xmax => 19, color => $gray100);
- $mask->box(filled => 1, xmin => 20, ymax => 14, xmax => 34,
- color => $gray50);
- is($mask->bits, $type_id, "check mask bits");
- {
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 5, ty => 7,
- mask => $mask),
- "simple draw masked");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin => 5, ymin => 7, xmax => 24, ymax => 26);
- $cmp->box(filled => 1, color => $green4_on_blue,
- xmin => 25, ymin => 7, xmax => 39, ymax => 21);
- $is_image->($work, $cmp, "check match");
- save_to($work, "${type_id}_simp_masked");
- save_to($work, "${type_id}_simp_masked_cmp");
- }
- {
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 5, ty => 7,
- mask_left => 5, mask_top => 2,
- mask => $mask),
- "draw with mask offset");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin => 5, ymin => 7, xmax => 19, ymax => 26);
- $cmp->box(filled => 1, color => $red2_on_blue,
- xmin => 20, ymin => 7, xmax => 24, ymax => 19);
- $cmp->box(filled => 1, color => $green4_on_blue,
- xmin => 25, ymin => 7, xmax => 34, ymax => 19);
- $is_image->($work, $cmp, "check match");
- }
- {
- my $work = $targ->copy;
- ok($work->compose(src => $src, tx => 5, ty => 7,
- mask_left => -3, mask_top => -2,
- mask => $mask),
- "draw with negative mask offsets");
- my $cmp = $targ->copy;
- $cmp->box(filled => 1, color => $red,
- xmin => 8, ymin => 9, xmax => 24, ymax => 26);
- $cmp->box(filled => 1, color => $green2_on_blue,
- xmin => 25, ymin => 9, xmax => 27, ymax => 46);
- $cmp->box(filled => 1, color => $green4_on_blue,
- xmin => 28, ymin => 9, xmax => 42, ymax => 23);
- $is_image->($work, $cmp, "check match");
- }
-}
-
-{
- my $empty = Imager->new;
- my $good = Imager->new(xsize => 1, ysize => 1);
- ok(!$empty->compose(src => $good), "can't compose to empty image");
- is($empty->errstr, "compose: empty input image",
- "check error message");
- ok(!$good->compose(src => $empty), "can't compose from empty image");
- is($good->errstr, "compose: empty input image (for src)",
- "check error message");
- ok(!$good->compose(src => $good, mask => $empty),
- "can't compose with empty mask");
- is($good->errstr, "compose: empty input image (for mask)",
- "check error message");
-}
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink @files;
-}
-
-sub save_to {
- my ($im, $name) = @_;
-
- my $type = $ENV{IMAGER_SAVE_TYPE} || "ppm";
- $name = "testout/t62_$name.$type";
- $im->write(file => $name,
- pnm_write_wide_data => 1);
- push @files, $name;
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager;
-use Test::More tests => 31;
-use Imager::Test qw/test_image test_image_double is_image/;
-
-my $test_im = test_image;
-my $test_im_dbl = test_image_double;
-
-{
- # split out channels and put it back together
- my $red = Imager->combine(src => [ $test_im ]);
- ok($red, "extracted the red channel");
- is($red->getchannels, 1, "red should be a single channel");
- my $green = Imager->combine(src => [ $test_im ], channels => [ 1 ]);
- ok($green, "extracted the green channel");
- is($green->getchannels, 1, "green should be a single channel");
- my $blue = $test_im->convert(preset => "blue");
- ok($blue, "extracted blue (via convert)");
-
- # put them back together
- my $combined = Imager->combine(src => [ $red, $green, $blue ]);
- is($combined->getchannels, 3, "check we got a three channel image");
- is_image($combined, $test_im, "presto! check it's the same");
-}
-
-{
- # no src
- ok(!Imager->combine(), "no src");
- is(Imager->errstr, "src parameter missing", "check message");
-}
-
-{
- # bad image error
- my $im = Imager->new;
- ok(!Imager->combine(src => [ $im ]), "empty image");
- is(Imager->errstr, "combine: empty input image (src->[0])",
- "check message");
-}
-
-{
- # not an image
- my $im = {};
- ok(!Imager->combine(src => [ $im ]), "not an image");
- is(Imager->errstr, "src must contain image objects", "check message");
-}
-
-{
- # no images
- ok(!Imager->combine(src => []), "no images");
- is(Imager->errstr, "At least one image must be supplied",
- "check message");
-}
-
-{
- # too many images
- ok(!Imager->combine(src => [ ($test_im) x 5 ]), "too many source images");
- is(Imager->errstr, "Maximum of 4 channels, you supplied 5",
- "check message");
-}
-
-{
- # negative channel
- ok(!Imager->combine(src => [ $test_im ], channels => [ -1 ]),
- "negative channel");
- is(Imager->errstr, "Channel numbers must be zero or positive",
- "check message");
-}
-
-{
- # channel too high
- ok(!Imager->combine(src => [ $test_im ], channels => [ 3 ]),
- "too high channel");
- is(Imager->errstr, "Channel 3 for image 0 is too high (3 channels)",
- "check message");
-}
-
-{
- # make sure we get the higher of the bits
- my $out = Imager->combine(src => [ $test_im, $test_im_dbl ]);
- ok($out, "make from 8 and double/sample images");
- is($out->bits, "double", "check output bits");
-}
-
-{
- # check high-bit processing
- # split out channels and put it back together
- my $red = Imager->combine(src => [ $test_im_dbl ]);
- ok($red, "extracted the red channel");
- is($red->getchannels, 1, "red should be a single channel");
- my $green = Imager->combine(src => [ $test_im_dbl ], channels => [ 1 ]);
- ok($green, "extracted the green channel");
- is($green->getchannels, 1, "green should be a single channel");
- my $blue = $test_im_dbl->convert(preset => "blue");
- ok($blue, "extracted blue (via convert)");
-
- # put them back together
- my $combined = Imager->combine(src => [ $red, $green, $blue ]);
- is($combined->getchannels, 3, "check we got a three channel image");
- is_image($combined, $test_im_dbl, "presto! check it's the same");
- is($combined->bits, "double", "and we got a double image output");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 95;
-use Imager;
-use Imager::Test qw(is_color3 is_image is_imaged test_image_double test_image isnt_image is_image_similar);
-
-#$Imager::DEBUG=1;
-
--d "testout" or mkdir "testout";
-
-Imager::init('log'=>'testout/t64copyflip.log');
-
-my $img=Imager->new() or die "unable to create image object\n";
-
-$img->open(file=>'testimg/scale.ppm',type=>'pnm');
-my $nimg = $img->copy();
-ok($nimg, "copy returned something");
-
-# test if ->copy() works
-
-my $diff = Imager::i_img_diff($img->{IMG}, $nimg->{IMG});
-is_image($img, $nimg, "copy matches source");
-
-{
- my $empty = Imager->new;
- ok(!$empty->copy, "fail to copy an empty image");
- is($empty->errstr, "copy: empty input image", "check error message");
-}
-
-# test if ->flip(dir=>'h')->flip(dir=>'h') doesn't alter the image
-$nimg->flip(dir=>"h")->flip(dir=>"h");
-is_image($nimg, $img, "double horiz flipped matches original");
-
-# test if ->flip(dir=>'v')->flip(dir=>'v') doesn't alter the image
-$nimg->flip(dir=>"v")->flip(dir=>"v");
-is_image($nimg, $img, "double vertically flipped image matches original");
-
-
-# test if ->flip(dir=>'h')->flip(dir=>'v') is same as ->flip(dir=>'hv')
-$nimg->flip(dir=>"v")->flip(dir=>"h")->flip(dir=>"hv");;
-is_image($img, $nimg, "check flip with hv matches flip v then flip h");
-
-{
- my $empty = Imager->new;
- ok(!$empty->flip(dir => "v"), "fail to flip an empty image");
- is($empty->errstr, "flip: empty input image", "check error message");
-}
-
-{
- my $imsrc = test_image_double;
- my $imcp = $imsrc->copy;
- is_imaged($imsrc, $imcp, "copy double image");
- $imcp->flip(dir=>"v")->flip(dir=>"v");
- is_imaged($imsrc, $imcp, "flip v twice");
- $imcp->flip(dir=>"h")->flip(dir=>"h");
- is_imaged($imsrc, $imcp, "flip h twice");
- $imcp->flip(dir=>"h")->flip(dir=>"v")->flip(dir=>"hv");
- is_imaged($imsrc, $imcp, "flip h,v,hv twice");
-}
-
-{
- my $impal = test_image()->to_paletted;
- my $imcp = $impal->copy;
- is($impal->type, "paletted", "check paletted test image is");
- is($imcp->type, "paletted", "check copy test image is paletted");
- ok($impal->flip(dir => "h"), "flip paletted h");
- isnt_image($impal, $imcp, "check it changed");
- ok($impal->flip(dir => "v"), "flip paletted v");
- ok($impal->flip(dir => "hv"), "flip paletted hv");
- is_image($impal, $imcp, "should be back to original image");
- is($impal->type, "paletted", "and still paletted");
-}
-
-rot_test($img, 90, 4);
-rot_test($img, 180, 2);
-rot_test($img, 270, 4);
-rot_test($img, 0, 1);
-
-my $pimg = $img->to_paletted();
-rot_test($pimg, 90, 4);
-rot_test($pimg, 180, 2);
-rot_test($pimg, 270, 4);
-rot_test($pimg, 0, 1);
-
-my $timg = $img->rotate(right=>90)->rotate(right=>270);
-is(Imager::i_img_diff($img->{IMG}, $timg->{IMG}), 0,
- "check rotate 90 then 270 matches original");
-$timg = $img->rotate(right=>90)->rotate(right=>180)->rotate(right=>90);
-is(Imager::i_img_diff($img->{IMG}, $timg->{IMG}), 0,
- "check rotate 90 then 180 then 90 matches original");
-
-# this could use more tests
-my $rimg = $img->rotate(degrees=>10);
-ok($rimg, "rotation by 10 degrees gave us an image");
-if (!$rimg->write(file=>"testout/t64_rot10.ppm")) {
- print "# Cannot save: ",$rimg->errstr,"\n";
-}
-
-# rotate with background
-$rimg = $img->rotate(degrees=>10, back=>Imager::Color->new(builtin=>'red'));
-ok($rimg, "rotate with background gave us an image");
-if (!$rimg->write(file=>"testout/t64_rot10_back.ppm")) {
- print "# Cannot save: ",$rimg->errstr,"\n";
-}
-
-{
- # rotate with text background
- my $rimg = $img->rotate(degrees => 45, back => '#FF00FF');
- ok($rimg, "rotate with background as text gave us an image");
-
- # check the color set correctly
- my $c = $rimg->getpixel(x => 0, 'y' => 0);
- is_deeply([ 255, 0, 255 ], [ ($c->rgba)[0, 1, 2] ],
- "check background set correctly");
-
- # check error handling for background color
- $rimg = $img->rotate(degrees => 45, back => "some really unknown color");
- ok(!$rimg, "should fail due to bad back color");
- cmp_ok($img->errstr, '=~', "^No color named ", "check error message");
-}
-SKIP:
-{ # rotate in double mode
- my $dimg = $img->to_rgb16;
- my $rimg = $dimg->rotate(degrees => 10);
- ok($rimg, "rotate 16-bit image gave us an image")
- or skip("could not rotate", 3);
- ok($rimg->write(file => "testout/t64_rotf10.ppm", pnm_write_wide_data => 1),
- "save wide data rotated")
- or diag($rimg->errstr);
-
- # with a background color
- my $rimgb = $dimg->rotate(degrees => 10, back => "#FF8000");
- ok($rimgb, "rotate 16-bit image with back gave us an image")
- or skip("could not rotate", 1);
- ok($rimgb->write(file => "testout/t64_rotfb10.ppm", pnm_write_wide_data => 1),
- "save wide data rotated")
- or diag($rimgb->errstr);
-}
-{ # rotate in paletted mode
- my $rimg = $pimg->rotate(degrees => 10);
- ok($rimg, "rotated paletted image 10 degrees");
- ok($rimg->write(file => "testout/t64_rotp10.ppm"),
- "save paletted rotated")
- or diag($rimg->errstr);
-}
-
-my $trimg = $img->matrix_transform(matrix=>[ 1.2, 0, 0,
- 0, 1, 0,
- 0, 0, 1]);
-ok($trimg, "matrix_transform() returned an image");
-$trimg->write(file=>"testout/t64_trans.ppm")
- or print "# Cannot save: ",$trimg->errstr,"\n";
-
-$trimg = $img->matrix_transform(matrix=>[ 1.2, 0, 0,
- 0, 1, 0,
- 0, 0, 1],
- back=>Imager::Color->new(builtin=>'blue'));
-ok($trimg, "matrix_transform() with back returned an image");
-
-$trimg->write(file=>"testout/t64_trans_back.ppm")
- or print "# Cannot save: ",$trimg->errstr,"\n";
-
-{
- my $empty = Imager->new;
- ok(!$empty->matrix_transform(matrix => [ 1, 0, 0,
- 0, 1, 0,
- 0, 0, 1 ]),
- "can't transform an empty image");
- is($empty->errstr, "matrix_transform: empty input image",
- "check error message");
-}
-
-sub rot_test {
- my ($src, $degrees, $count) = @_;
-
- my $cimg = $src->copy();
- my $in;
- for (1..$count) {
- $in = $cimg;
- $cimg = $cimg->rotate(right=>$degrees)
- or last;
- }
- SKIP:
- {
- ok($cimg, "got a rotated image")
- or skip("no image to check", 4);
- my $diff = Imager::i_img_diff($src->{IMG}, $cimg->{IMG});
- is($diff, 0, "check it matches source")
- or skip("didn't match", 3);
-
- # check that other parameters match
- is($src->type, $cimg->type, "type check");
- is($src->bits, $cimg->bits, "bits check");
- is($src->getchannels, $cimg->getchannels, "channels check");
- }
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
- my $warning;
- local $SIG{__WARN__} =
- sub {
- $warning = "@_";
- my $printed = $warning;
- $printed =~ s/\n$//;
- $printed =~ s/\n/\n\#/g;
- print "# ",$printed, "\n";
- };
- my $img = Imager->new(xsize=>10, ysize=>10);
- $img->copy();
- cmp_ok($warning, '=~', 'void', "correct warning");
- cmp_ok($warning, '=~', 't64copyflip\\.t', "correct file");
- $warning = '';
- $img->rotate(degrees=>5);
- cmp_ok($warning, '=~', 'void', "correct warning");
- cmp_ok($warning, '=~', 't64copyflip\\.t', "correct file");
- $warning = '';
- $img->matrix_transform(matrix=>[1, 1, 1]);
- cmp_ok($warning, '=~', 'void', "correct warning");
- cmp_ok($warning, '=~', 't64copyflip\\.t', "correct file");
-}
-
-{
- # 29936 - matrix_transform() should use fabs() instead of abs()
- # range checking sz
-
- # this meant that when sz was < 1 (which it often is for these
- # transformations), it treated the values out of range, producing a
- # blank output image
-
- my $src = Imager->new(xsize => 20, ysize => 20);
- $src->box(filled => 1, color => 'FF0000');
- my $out = $src->matrix_transform(matrix => [ 1, 0, 0,
- 0, 1, 0,
- 0, 0, 0.9999 ])
- or print "# ", $src->errstr, "\n";
- my $blank = Imager->new(xsize => 20, ysize => 20);
- # they have to be different, surely that would be easy
- my $diff = Imager::i_img_diff($out->{IMG}, $blank->{IMG});
- ok($diff, "RT#29936 - check non-blank output");
-}
-
-{
- my $im = Imager->new(xsize => 10, ysize => 10, channels => 4);
- $im->box(filled => 1, color => 'FF0000');
- my $back = Imager::Color->new(0, 0, 0, 0);
- my $rot = $im->rotate(degrees => 10, back => $back);
- # drop the alpha and make sure there's only 2 colors used
- my $work = $rot->convert(preset => 'noalpha');
- my $im_pal = $work->to_paletted(make_colors => 'mediancut');
- my @colors = $im_pal->getcolors;
- is(@colors, 2, "should be only 2 colors")
- or do {
- print "# ", join(",", $_->rgba), "\n" for @colors;
- };
- @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
- is_color3($colors[0], 0, 0, 0, "check we got black");
- is_color3($colors[1], 255, 0, 0, "and red");
-}
-
-{ # RT #77063 rotate with degrees => 270 gives a black border
- # so be a little less strict about rounding up
- # I've also:
- # - improved calculation of the rotation matrix
- # - added rounding to interpolation for 1/3 channel images
- my $im = test_image;
- $im->box(color => "#00F");
- my $right = $im->rotate(right => 270);
- my $deg = $im->rotate(degrees => 270, back => "#FFF");
- is($deg->getwidth, 150, "check degrees => 270 width");
- is($deg->getheight, 150, "check degrees => 270 height");
- ok($deg->write(file => "testout/t64rotdeg270.ppm"), "save it");
- $right->write(file => "testout/t64rotright270.ppm");
- is_image($deg, $right, "check right and degrees result the same");
- #$deg = $deg->convert(preset => "addalpha");
- # $right = $right->convert(preset => "addalpha");
- # my $diff = $right->difference(other => $deg, mindist => 1);
- # $diff->write(file => "testout/t64rotdiff.png");
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->rotate(degrees => 90), "can't rotate an empty image");
- is($empty->errstr, "rotate: empty input image",
- "check error message");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 66;
-use Imager;
-use Imager::Test qw(test_image);
-
-#$Imager::DEBUG=1;
-
--d "testout" or mkdir "testout";
-
-Imager::init('log'=>'testout/t65crop.log');
-
-my $img=Imager->new() || die "unable to create image object\n";
-
-ok($img, "created image ph");
-
-SKIP:
-{
- skip("couldn't load source image", 2)
- unless ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'), "loaded source");
- my $nimg = $img->crop(top=>10, left=>10, bottom=>25, right=>25);
- ok($nimg, "got an image");
- ok($nimg->write(file=>"testout/t65.ppm"), "save to file");
-}
-
-{ # https://rt.cpan.org/Ticket/Display.html?id=7578
- # make sure we get the right type of image on crop
- my $src = Imager->new(xsize=>50, ysize=>50, channels=>2, bits=>16);
- is($src->getchannels, 2, "check src channels");
- is($src->bits, 16, "check src bits");
- my $out = $src->crop(left=>10, right=>40, top=>10, bottom=>40);
- is($out->getchannels, 2, "check out channels");
- is($out->bits, 16, "check out bits");
-}
-{ # https://rt.cpan.org/Ticket/Display.html?id=7578
- print "# try it for paletted too\n";
- my $src = Imager->new(xsize=>50, ysize=>50, channels=>3, type=>'paletted');
- # make sure color index zero is defined so there's something to copy
- $src->addcolors(colors=>[Imager::Color->new(0,0,0)]);
- is($src->type, 'paletted', "check source type");
- my $out = $src->crop(left=>10, right=>40, top=>10, bottom=>40);
- is($out->type, 'paletted', 'check output type');
-}
-
-{ # https://rt.cpan.org/Ticket/Display.html?id=7581
- # crop() documentation says width/height takes precedence, but is unclear
- # from looking at the existing code, setting width/height will go from
- # the left of the image, even if left/top are provided, despite the
- # sample in the docs
- # Let's make sure that things happen as documented
- my $src = test_image();
- # make sure we get what we want
- is($src->getwidth, 150, "src width");
- is($src->getheight, 150, "src height");
-
- # the test data is:
- # - description
- # - hash ref containing args to crop()
- # - expected left, top, right, bottom values
- # we call crop using the given arguments then call it using the
- # hopefully stable left/top/right/bottom/arguments
- # this is kind of lame, but I don't want to include a rewritten
- # crop in this file
- my @tests =
- (
- [
- "basic",
- { left=>10, top=>10, right=>70, bottom=>80 },
- 10, 10, 70, 80,
- ],
- [
- "middle",
- { width=>50, height=>50 },
- 50, 50, 100, 100,
- ],
- [
- "lefttop",
- { left=>20, width=>70, top=>30, height=>90 },
- 20, 30, 90, 120,
- ],
- [
- "bottomright",
- { right=>140, width=>50, bottom=>130, height=>60 },
- 90, 70, 140, 130,
- ],
- [
- "acrossmiddle",
- { top=>40, bottom=>110 },
- 0, 40, 150, 110,
- ],
- [
- "downmiddle",
- { left=>40, right=>110 },
- 40, 0, 110, 150,
- ],
- [
- "rightside",
- { left=>80, },
- 80, 0, 150, 150,
- ],
- [
- "leftside",
- { right=>40 },
- 0, 0, 40, 150,
- ],
- [
- "topside",
- { bottom=>40, },
- 0, 0, 150, 40,
- ],
- [
- "bottomside",
- { top=>90 },
- 0, 90, 150, 150,
- ],
- [
- "overright",
- { left=>100, right=>200 },
- 100, 0, 150, 150,
- ],
- [
- "overtop",
- { bottom=>50, height=>70 },
- 0, 0, 150, 50,
- ],
- [
- "overleft",
- { right=>30, width=>60 },
- 0, 0, 30, 150,
- ],
- [
- "overbottom",
- { top=>120, height=>60 },
- 0, 120, 150, 150,
- ],
- );
- for my $test (@tests) {
- my ($desc, $args, $left, $top, $right, $bottom) = @$test;
- my $out = $src->crop(%$args);
- ok($out, "got output for $desc");
- my $cmp = $src->crop(left=>$left, top=>$top, right=>$right, bottom=>$bottom);
- ok($cmp, "got cmp for $desc");
- # make sure they're the same
- my $diff = Imager::i_img_diff($out->{IMG}, $cmp->{IMG});
- is($diff, 0, "difference should be 0 for $desc");
- }
-}
-{ # https://rt.cpan.org/Ticket/Display.html?id=7581
- # previously we didn't check that the result had some pixels
- # make sure we do
- my $src = test_image();
- ok(!$src->crop(left=>50, right=>50), "nothing across");
- cmp_ok($src->errstr, '=~', qr/resulting image would have no content/,
- "and message");
- ok(!$src->crop(top=>60, bottom=>60), "nothing down");
- cmp_ok($src->errstr, '=~', qr/resulting image would have no content/,
- "and message");
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
- my $warning;
- local $SIG{__WARN__} =
- sub {
- $warning = "@_";
- my $printed = $warning;
- $printed =~ s/\n$//;
- $printed =~ s/\n/\n\#/g;
- print "# ",$printed, "\n";
- };
- my $img = Imager->new(xsize=>10, ysize=>10);
- $img->crop(left=>5);
- cmp_ok($warning, '=~', 'void', "correct warning");
- cmp_ok($warning, '=~', 't65crop\\.t', "correct file");
-}
-
-{
- my $src = test_image();
- ok(!$src->crop( top=>1000, bottom=>1500, left=>0, right=>100 ),
- "outside of image" );
- cmp_ok($src->errstr, '=~', qr/outside of the image/, "and message");
- ok(!$src->crop( top=>100, bottom=>1500, left=>1000, right=>1500 ),
- "outside of image" );
- cmp_ok($src->errstr, '=~', qr/outside of the image/, "and message");
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->crop(left => 10), "can't crop an empty image");
- is($empty->errstr, "crop: empty input image", "check message");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 60;
-
-use Imager;
-use Imager::Test qw(is_image);
-
-#$Imager::DEBUG=1;
-
--d "testout" or mkdir "testout";
-
-Imager::init('log'=>'testout/t66paste.log');
-
-# the original smoke tests
-my $img=Imager->new() || die "unable to create image object\n";
-
-ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'), "load test img");
-
-my $nimg=Imager->new() or die "Unable to create image object\n";
-ok($nimg->open(file=>'testimg/scale.ppm',type=>'pnm'), "load test img again");
-
-ok($img->paste(img=>$nimg, top=>30, left=>30), "paste it")
- or print "# ", $img->errstr, "\n";;
-
-ok($img->write(type=>'pnm',file=>'testout/t66.ppm'), "save it")
- or print "# ", $img->errstr, "\n";
-
-{
- my $empty = Imager->new;
- ok(!$empty->paste(src => $nimg), "paste into empty image");
- is($empty->errstr, "paste: empty input image",
- "check error message");
-
- ok(!$img->paste(src => $empty), "paste from empty image");
- is($img->errstr, "paste: empty input image (for src)",
- "check error message");
-
- ok(!$img->paste(), "no source image");
- is($img->errstr, "no source image");
-}
-
-# more stringent tests
-{
- my $src = Imager->new(xsize => 100, ysize => 110);
- $src->box(filled=>1, color=>'FF0000');
-
- $src->box(filled=>1, color=>'0000FF', xmin => 20, ymin=>20,
- xmax=>79, ymax=>79);
-
- my $targ = Imager->new(xsize => 100, ysize => 110);
- $targ->box(filled=>1, color =>'00FFFF');
- $targ->box(filled=>1, color=>'00FF00', xmin=>20, ymin=>20, xmax=>79,
- ymax=>79);
- my $work = $targ->copy;
- ok($work->paste(src=>$src, left => 15, top => 10), "paste whole image");
- # build comparison image
- my $cmp = $targ->copy;
- $cmp->box(filled=>1, xmin=>15, ymin => 10, color=>'FF0000');
- $cmp->box(filled=>1, xmin=>35, ymin => 30, xmax=>94, ymax=>89,
- color=>'0000FF');
-
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "compare pasted and expected");
-
- $work = $targ->copy;
- ok($work->paste(src=>$src, left=>2, top=>7, src_minx => 10, src_miny => 15),
- "paste from inside src");
- $cmp = $targ->copy;
- $cmp->box(filled=>1, xmin=>2, ymin=>7, xmax=>91, ymax=>101, color=>'FF0000');
- $cmp->box(filled=>1, xmin=>12, ymin=>12, xmax=>71, ymax=>71,
- color=>'0000FF');
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "compare pasted and expected");
-
- # paste part source
- $work = $targ->copy;
- ok($work->paste(src=>$src, left=>15, top=>20,
- src_minx=>10, src_miny=>15, src_maxx=>80, src_maxy =>70),
- "paste src cropped all sides");
- $cmp = $targ->copy;
- $cmp->box(filled=>1, xmin=>15, ymin=>20, xmax=>84, ymax=>74,
- color=>'FF0000');
- $cmp->box(filled=>1, xmin=>25, ymin=>25, xmax=>84, ymax=>74,
- color=>'0000FF');
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "compare pasted and expected");
-
- # go by width instead
- $work = $targ->copy;
- ok($work->paste(src=>$src, left=>15, top=>20,
- src_minx=>10, src_miny => 15, width => 70, height => 55),
- "same but specify width/height instead");
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "compare pasted and expected");
-
- # use src_coords
- $work = $targ->copy;
- ok($work->paste(src=>$src, left => 15, top => 20,
- src_coords => [ 10, 15, 80, 70 ]),
- "using src_coords");
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "compare pasted and expected");
-
- {
- # Issue #18712
- # supplying just src_maxx would set the internal maxy to undef
- # supplying just src_maxy would be ignored
- # src_maxy (or it's derived value) was being bounds checked against
- # the image width instead of the image height
- $work = $targ->copy;
- my @warns;
- local $SIG{__WARN__} = sub { push @warns, "@_"; print "# @_"; };
-
- ok($work->paste(src=>$src, left => 15, top => 20,
- src_maxx => 50),
- "paste with just src_maxx");
- ok(!@warns, "shouldn't warn");
- my $cmp = $targ->copy;
- $cmp->box(filled=>1, color => 'FF0000', xmin => 15, ymin => 20,
- xmax => 64, ymax => 109);
- $cmp->box(filled=>1, color => '0000FF', xmin => 35, ymin => 40,
- xmax => 64, ymax => 99);
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "check correctly pasted");
-
- $work = $targ->copy;
- @warns = ();
- ok($work->paste(src=>$src, left=>15, top=>20,
- src_maxy => 60),
- "paste with just src_maxy");
- ok(!@warns, "shouldn't warn");
- $cmp = $targ->copy;
- $cmp->box(filled => 1, color => 'FF0000', xmin => 15, ymin => 20,
- xmax => 99, ymax => 79);
- $cmp->box(filled => 1, color => '0000FF', xmin => 35, ymin => 40,
- xmax => 94, ymax => 79);
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "check pasted correctly");
-
- $work = $targ->copy;
- @warns = ();
- ok($work->paste(src=>$src, left=>15, top=>20,
- src_miny => 20, src_maxy => 105),
- "paste with src_maxy > source width");
-
- $cmp = $targ->copy;
- $cmp->box(filled => 1, color => 'FF0000', xmin => 15, ymin => 20,
- ymax => 104);
- $cmp->box(filled => 1, color => '0000FF', xmin => 35, ymin => 20,
- xmax => 94, ymax => 79);
- is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
- "check pasted correctly");
- }
-}
-
-{ # https://rt.cpan.org/Ticket/Display.html?id=30908
- # we now adapt the source channels to the target
- # check each combination works as expected
-
- # various source images
- my $src1 = Imager->new(xsize => 50, ysize => 50, channels => 1);
- my $g_grey_full = Imager::Color->new(128, 255, 0, 0);
- my $g_white_50 = Imager::Color->new(255, 128, 0, 0);
- $src1->box(filled => 1, xmax => 24, color => $g_grey_full);
-
- my $src2 = Imager->new(xsize => 50, ysize => 50, channels => 2);
- $src2->box(filled => 1, xmax => 24, color => $g_grey_full);
- $src2->box(filled => 1, xmin => 25, color => $g_white_50);
-
- my $c_red_full = Imager::Color->new(255, 0, 0);
- my $c_blue_full = Imager::Color->new(0, 0, 255);
- my $src3 = Imager->new(xsize => 50, ysize => 50, channels => 3);
- $src3->box(filled => 1, xmax => 24, color => $c_red_full);
- $src3->box(filled => 1, xmin => 25, color => $c_blue_full);
-
- my $c_green_50 = Imager::Color->new(0, 255, 0, 127);
- my $src4 = Imager->new(xsize => 50, ysize => 50, channels => 4);
- $src4->box(filled => 1, xmax => 24, color => $c_blue_full);
- $src4->box(filled => 1, xmin => 25, color => $c_green_50);
-
- my @left_box = ( box => [ 25, 25, 49, 74 ] );
- my @right_box = ( box => [ 50, 25, 74, 74 ] );
-
- { # 1 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 1);
- $base->box(filled => 1, color => Imager::Color->new(64, 255, 0, 0));
-
- my $work = $base->copy;
- ok($work->paste(left => 25, top => 25, src => $src1), "paste 1 to 1");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => $g_grey_full, @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(left => 25, top => 25, src => $src2), "paste 2 to 1");
- $comp = $base->copy;
- $comp->box(filled => 1, @left_box, color => $g_grey_full);
- $comp->box(filled => 1, @right_box, color => [ 128, 0, 0, 0 ]);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(left => 25, top => 25, src => $src3), "paste 3 to 1");
- $comp = $base->copy;
- $comp->box(filled => 1, @left_box, color => [ 57, 255, 0, 0 ]);
- $comp->box(filled => 1, @right_box, color => [ 18, 255, 0, 0 ]);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(left => 25, top => 25, src => $src4), "paste 4 to 1");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 90, 255, 0, 0 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
- }
-
- { # 2 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 2);
- $base->box(filled => 1, color => [ 128, 128, 0, 0 ]);
-
- my $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 2");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => $g_grey_full, @left_box);
- $comp->box(filled => 1, color => [ 0, 255, 0, 0 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 2");
- $comp = $base->copy;
- $comp->box(filled => 1, color => $g_grey_full, @left_box);
- $comp->box(filled => 1, color => $g_white_50, @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 2");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 57, 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 2");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 180, 127, 0, 0 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
- }
-
- { # 3 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 3);
- $base->box(filled => 1, color => [ 128, 255, 0, 0 ]);
-
- my $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 3");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 3");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 3");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 3");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 0, 0, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 127, 0 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
- }
-
- { # 4 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 4);
- $base->box(filled => 1, color => [ 128, 255, 64, 128 ]);
-
- my $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 4");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 0, 255 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 4");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 255, 255, 255, 128 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 4");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
- is_image($work, $comp, "compare paste target to expected");
-
- $work = $base->copy;
- ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 4");
- $comp = $base->copy;
- $comp->box(filled => 1, color => $c_blue_full, @left_box);
- $comp->box(filled => 1, color => $c_green_50, @right_box);
- is_image($work, $comp, "compare paste target to expected");
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager qw(:all :handy);
-use Test::More tests => 31;
-use Imager::Test qw(test_colorf_gpix is_fcolor1 is_fcolor3);
-
--d "testout" or mkdir "testout";
-
-Imager::init("log"=>'testout/t67convert.log');
-
-my $imbase = Imager::ImgRaw::new(200,300,3);
-
-# first a basic test, make sure the basic things happen ok
-# make a 1 channel image from the above (black) image
-# but with 1 as the 'extra' value
-SKIP:
-{
- my $im_white = i_convert($imbase, [ [ 0, 0, 0, 1 ] ]);
- skip("convert to white failed", 3)
- unless ok($im_white, "convert to white");
-
- my ($w, $h, $ch) = i_img_info($im_white);
-
- # the output image should now have one channel
- is($ch, 1, "one channel image now");
- # should have the same width and height
- ok($w == 200 && $h == 300, "check converted size is the same");
-
- # should be a white image now, let's check
- my $c = Imager::i_get_pixel($im_white, 20, 20);
- my @c = $c->rgba;
- print "# @c\n";
- is($c[0], 255, "check image is white");
-}
-
-# test the highlevel interface
-# currently this requires visual inspection of the output files
-my $im = Imager->new;
-SKIP:
-{
- skip("could not load scale.ppm", 3)
- unless $im->read(file=>'testimg/scale.ppm');
- my $out = $im->convert(preset=>'gray');
- ok($out, "convert preset gray");
- ok($out->write(file=>'testout/t67_gray.ppm', type=>'pnm'),
- "save grey image");
- $out = $im->convert(preset=>'blue');
- ok($out, "convert preset blue");
-
- ok($out->write(file=>'testout/t67_blue.ppm', type=>'pnm'),
- "save blue image");
-}
-
-# test against 16-bit/sample images
-{
- SKIP:
- {
- my $imbase16 = Imager::i_img_16_new(200, 200, 3);
-
- my $im16targ = i_convert($imbase16, [ [ 0, 0, 0, 1 ],
- [ 0, 0, 0, 0 ],
- [ 0, 0, 0, 0 ] ]);
- ok($im16targ, "convert 16/bit sample image")
- or skip("could not convert 16-bit image", 2);
-
- # image should still be 16-bit
- is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");
-
- # make sure that it's roughly red
- test_colorf_gpix($im16targ, 0, 0, NCF(1, 0, 0), 0.001, "image roughly red");
- }
- SKIP:
- {
- my $imbase16 = Imager->new(xsize => 10, ysize => 10, bits => 16);
- ok($imbase16->setpixel
- (x => 5, y => 2, color => Imager::Color::Float->new(0.1, 0.2, 0.3)),
- "set a sample pixel");
- my $c1 = $imbase16->getpixel(x => 5, y => 2, type => "float");
- is_fcolor3($c1, 0.1, 0.2, 0.3, "check it was set")
- or print "#", join(",", $c1->rgba), "\n";
-
- my $targ16 = $imbase16->convert(matrix => [ [ 0.05, 0.15, 0.01, 0.5 ] ]);
- ok($targ16, "convert another 16/bit sample image")
- or skip("could not convert", 3);
- is($targ16->getchannels, 1, "convert should be 1 channel");
- is($targ16->bits, 16, "and 16-bits");
- my $c = $targ16->getpixel(x => 5, y => 2, type => "float");
- is_fcolor1($c, 0.538, 1/32768, "check grey value");
- }
-}
-
-# test against palette based images
-my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
-my $black = NC(0, 0, 0);
-my $blackindex = Imager::i_addcolors($impal, $black);
-ok($blackindex, "add black to paletted");
-for my $y (0..299) {
- Imager::i_ppal($impal, 0, $y, ($blackindex) x 200);
-}
-
-SKIP:
-{
- my $impalout = i_convert($impal, [ [ 0, 0, 0, 0 ],
- [ 0, 0, 0, 1 ],
- [ 0, 0, 0, 0 ] ]);
- skip("could not convert paletted", 3)
- unless ok($impalout, "convert paletted");
- is(Imager::i_img_type($impalout), 1, "image still paletted");
- is(Imager::i_colorcount($impalout), 1, "still only one colour");
- my $c = Imager::i_getcolors($impalout, $blackindex);
- ok($c, "get color from palette");
- my @ch = $c->rgba;
- print "# @ch\n";
- ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0,
- "colour is as expected");
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
- # methods that return a new image should warn in void context
- my $warning;
- local $SIG{__WARN__} =
- sub {
- $warning = "@_";
- my $printed = $warning;
- $printed =~ s/\n$//;
- $printed =~ s/\n/\n\#/g;
- print "# ",$printed, "\n";
- };
- my $img = Imager->new(xsize=>10, ysize=>10);
- $img->convert(preset=>"grey");
- cmp_ok($warning, '=~', 'void', "correct warning");
- cmp_ok($warning, '=~', 't67convert\\.t', "correct file");
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=28492
- # convert() doesn't preserve image sample size
- my $im = Imager->new(xsize => 20, ysize => 20, channels => 3,
- bits => 'double');
- is($im->bits, 'double', 'check source bits');
- my $conv = $im->convert(preset => 'grey');
- is($conv->bits, 'double', 'make sure result has extra bits');
-}
-
-{ # http://rt.cpan.org/NoAuth/Bug.html?id=79922
- # Segfault in convert with bad params
- my $im = Imager->new(xsize => 10, ysize => 10);
- ok(!$im->convert(matrix => [ 10, 10, 10 ]),
- "this would crash");
- is($im->errstr, "convert: invalid matrix: element 0 is not an array ref",
- "check the error message");
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->convert(preset => "addalpha"), "can't convert an empty image");
- is($empty->errstr, "convert: empty input image", "check error message");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 8;
-
--d "testout" or mkdir "testout";
-
-Imager::init("log"=>'testout/t68map.log');
-
-use Imager qw(:all :handy);
-
-my $imbase = Imager::ImgRaw::new(200,300,3);
-
-
-my @map1 = map { int($_/2) } 0..255;
-my @map2 = map { 255-int($_/2) } 0..255;
-my @map3 = 0..255;
-my @maps = 0..24;
-my @mapl = 0..400;
-
-my $tst = 1;
-
-ok(i_map($imbase, [ [], [], \@map1 ]), "map1 in ch 3");
-ok(i_map($imbase, [ \@map1, \@map1, \@map1 ]), "map1 in ch1-3");
-
-ok(i_map($imbase, [ \@map1, \@map2, \@map3 ]), "map1-3 in ch 1-3");
-
-ok(i_map($imbase, [ \@maps, \@mapl, \@map3 ]), "incomplete maps");
-
-# test the highlevel interface
-# currently this requires visual inspection of the output files
-
-SKIP: {
- my $im = Imager->new;
- $im->read(file=>'testimg/scale.ppm')
- or skip "Cannot load test image testimg/scale.ppm", 2;
-
- ok( $im->map(red=>\@map1, green=>\@map2, blue=>\@map3),
- "test OO interface (maps by color)");
- ok( $im->map(maps=>[\@map1, [], \@map2]),
- "test OO interface (maps by maps)");
-}
-
-{
- my $empty = Imager->new;
- ok(!$empty->map(maps => [ \@map1, \@map2, \@map3 ]),
- "can't map an empty image");
- is($empty->errstr, "map: empty input image", "check error message");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 76;
-use Imager qw(:all :handy);
-use Imager::Test qw(is_image);
-
--d "testout" or mkdir "testout";
-
-init_log("testout/t69rubthru.log", 1);
-
-my $src_height = 80;
-my $src_width = 80;
-
-# raw interface
-my $targ = Imager::ImgRaw::new(100, 100, 3);
-my $src = Imager::ImgRaw::new($src_height, $src_width, 4);
-my $halfred = NC(255, 0, 0, 128);
-i_box_filled($src, 20, 20, 60, 60, $halfred);
-ok(i_rubthru($targ, $src, 10, 10, 0, 0, $src_width, $src_height),
- "low level rubthrough");
-my $c = Imager::i_get_pixel($targ, 10, 10);
-ok($c, "get pixel at (10, 10)");
-ok(color_cmp($c, NC(0, 0, 0)) == 0, "check for correct color");
-$c = Imager::i_get_pixel($targ, 30, 30);
-ok($c, "get pixel at (30, 30)");
-ok(color_cmp($c, NC(128, 0, 0)) == 0, "check color");
-
-my $black = NC(0, 0, 0);
-# reset the target and try a grey+alpha source
-i_box_filled($targ, 0, 0, 100, 100, $black);
-my $gsrc = Imager::ImgRaw::new($src_width, $src_height, 2);
-my $halfwhite = NC(255, 128, 0);
-i_box_filled($gsrc, 20, 20, 60, 60, $halfwhite);
-ok(i_rubthru($targ, $gsrc, 10, 10, 0, 0, $src_width, $src_height),
- "low level with grey/alpha source");
-$c = Imager::i_get_pixel($targ, 15, 15);
-ok($c, "get at (15, 15)");
-ok(color_cmp($c, NC(0, 0, 0)) == 0, "check color");
-$c = Imager::i_get_pixel($targ, 30, 30);
-ok($c, "get pixel at (30, 30)");
-ok(color_cmp($c, NC(128, 128, 128)) == 0, "check color");
-
-# try grey target and grey alpha source
-my $gtarg = Imager::ImgRaw::new(100, 100, 1);
-ok(i_rubthru($gtarg, $gsrc, 10, 10, 0, 0, $src_width, $src_height),
- "low level with grey target and gray/alpha source");
-$c = Imager::i_get_pixel($gtarg, 10, 10);
-ok($c, "get pixel at 10, 10");
-is(($c->rgba)[0], 0, "check grey level");
-is((Imager::i_get_pixel($gtarg, 30, 30)->rgba)[0], 128,
- "check grey level at 30, 30");
-
-# simple test for 16-bit/sample images
-my $targ16 = Imager::i_img_16_new(100, 100, 3);
-ok(i_rubthru($targ16, $src, 10, 10, 0, 0, $src_width, $src_height),
- "smoke test vs 16-bit/sample image");
-$c = Imager::i_get_pixel($targ16, 30, 30);
-ok($c, "get pixel at 30, 30");
-ok(color_cmp($c, NC(128, 0, 0)) == 0, "check color");
-
-# check the OO interface
-my $ootarg = Imager->new(xsize=>100, ysize=>100);
-my $oosrc = Imager->new(xsize=>80, ysize=>80, channels=>4);
-$oosrc->box(color=>$halfred, xmin=>20, ymin=>20, xmax=>60, ymax=>60,
- filled=>1);
-ok($ootarg->rubthrough(src=>$oosrc, tx=>10, ty=>10),
- "oo rubthrough");
-ok(color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 10, 10), NC(0, 0, 0)) == 0,
- "check pixel at 10, 10");
-ok(color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 30, 30), NC(128, 0, 0)) == 0,
- "check pixel at 30, 30");
-
-my $oogtarg = Imager->new(xsize=>100, ysize=>100, channels=>1);
-
-{ # check empty image errors
- my $empty = Imager->new;
- ok(!$empty->rubthrough(src => $oosrc), "check empty target");
- is($empty->errstr, 'rubthrough: empty input image', "check error message");
- ok(!$oogtarg->rubthrough(src=>$empty), "check empty source");
- is($oogtarg->errstr, 'rubthrough: empty input image (for src)',
- "check error message");
-}
-
-{
- # alpha source and target
- for my $method (qw/rubthrough compose/) {
-
- my $src = Imager->new(xsize => 10, ysize => 1, channels => 4);
- my $targ = Imager->new(xsize => 10, ysize => 2, channels => 4);
-
- # simple initialization
- $targ->setscanline('y' => 1, x => 1,
- pixels =>
- [
- NC(255, 128, 0, 255),
- NC(255, 128, 0, 128),
- NC(255, 128, 0, 0),
- NC(255, 128, 0, 255),
- NC(255, 128, 0, 128),
- NC(255, 128, 0, 0),
- NC(255, 128, 0, 255),
- NC(255, 128, 0, 128),
- NC(255, 128, 0, 0),
- ]);
- $src->setscanline('y' => 0,
- pixels =>
- [
- NC(0, 128, 255, 0),
- NC(0, 128, 255, 0),
- NC(0, 128, 255, 0),
- NC(0, 128, 255, 128),
- NC(0, 128, 255, 128),
- NC(0, 128, 255, 128),
- NC(0, 128, 255, 255),
- NC(0, 128, 255, 255),
- NC(0, 128, 255, 255),
- ]);
- ok($targ->$method(src => $src, combine => 'normal',
- tx => 1, ty => 1), "do 4 on 4 $method");
- iscolora($targ->getpixel(x => 1, 'y' => 1), NC(255, 128, 0, 255),
- "check at zero source coverage on full targ coverage");
- iscolora($targ->getpixel(x => 2, 'y' => 1), NC(255, 128, 0, 128),
- "check at zero source coverage on half targ coverage");
- iscolora($targ->getpixel(x => 3, 'y' => 1), NC(255, 128, 0, 0),
- "check at zero source coverage on zero targ coverage");
- iscolora($targ->getpixel(x => 4, 'y' => 1), NC(127, 128, 128, 255),
- "check at half source_coverage on full targ coverage");
- iscolora($targ->getpixel(x => 5, 'y' => 1), NC(85, 128, 170, 191),
- "check at half source coverage on half targ coverage");
- iscolora($targ->getpixel(x => 6, 'y' => 1), NC(0, 128, 255, 128),
- "check at half source coverage on zero targ coverage");
- iscolora($targ->getpixel(x => 7, 'y' => 1), NC(0, 128, 255, 255),
- "check at full source_coverage on full targ coverage");
- iscolora($targ->getpixel(x => 8, 'y' => 1), NC(0, 128, 255, 255),
- "check at full source coverage on half targ coverage");
- iscolora($targ->getpixel(x => 9, 'y' => 1), NC(0, 128, 255, 255),
- "check at full source coverage on zero targ coverage");
- }
-}
-
-{ # https://rt.cpan.org/Ticket/Display.html?id=30908
- # we now adapt the source channels to the target
- # check each combination works as expected
-
- # various source images
- my $src1 = Imager->new(xsize => 50, ysize => 50, channels => 1);
- my $g_grey_full = Imager::Color->new(128, 255, 0, 0);
- my $g_white_50 = Imager::Color->new(255, 128, 0, 0);
- $src1->box(filled => 1, xmax => 24, color => $g_grey_full);
-
- my $src2 = Imager->new(xsize => 50, ysize => 50, channels => 2);
- $src2->box(filled => 1, xmax => 24, color => $g_grey_full);
- $src2->box(filled => 1, xmin => 25, color => $g_white_50);
-
- my $c_red_full = Imager::Color->new(255, 0, 0);
- my $c_blue_full = Imager::Color->new(0, 0, 255);
- my $src3 = Imager->new(xsize => 50, ysize => 50, channels => 3);
- $src3->box(filled => 1, xmax => 24, color => $c_red_full);
- $src3->box(filled => 1, xmin => 25, color => $c_blue_full);
-
- my $c_green_50 = Imager::Color->new(0, 255, 0, 127);
- my $src4 = Imager->new(xsize => 50, ysize => 50, channels => 4);
- $src4->box(filled => 1, xmax => 24, color => $c_blue_full);
- $src4->box(filled => 1, xmin => 25, color => $c_green_50);
-
- my @left_box = ( box => [ 25, 25, 49, 74 ] );
- my @right_box = ( box => [ 50, 25, 74, 74 ] );
-
- { # 1 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 1);
- $base->box(filled => 1, color => Imager::Color->new(64, 255, 0, 0));
-
- my $work = $base->copy;
- ok($work->rubthrough(left => 25, top => 25, src => $src1), "rubthrough 1 to 1");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => $g_grey_full, @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(left => 25, top => 25, src => $src2), "rubthrough 2 to 1");
- $comp = $base->copy;
- $comp->box(filled => 1, @left_box, color => $g_grey_full);
- $comp->box(filled => 1, @right_box, color => [ 159, 0, 0, 0 ]);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(left => 25, top => 25, src => $src3), "rubthrough 3 to 1");
- $comp = $base->copy;
- $comp->box(filled => 1, @left_box, color => [ 57, 255, 0, 0 ]);
- $comp->box(filled => 1, @right_box, color => [ 18, 255, 0, 0 ]);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(left => 25, top => 25, src => $src4), "rubthrough 4 to 1");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 121, 255, 0, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
- }
-
- { # 2 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 2);
- $base->box(filled => 1, color => [ 128, 128, 0, 0 ]);
-
- my $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 2");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => $g_grey_full, @left_box);
- $comp->box(filled => 1, color => [ 0, 255, 0, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 2");
- $comp = $base->copy;
- $comp->box(filled => 1, color => $g_grey_full, @left_box);
- $comp->box(filled => 1, color => [ 213, 191, 0, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 2");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 57, 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 2");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 162, 191, 0, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
- }
-
- { # 3 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 3);
- $base->box(filled => 1, color => [ 128, 255, 0, 0 ]);
-
- my $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 3");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 3");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 191, 255, 128, 255 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 3");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 3");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 0, 0, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 64, 255, 0 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
- }
-
- { # 4 channel output
- my $base = Imager->new(xsize => 100, ysize => 100, channels => 4);
- $base->box(filled => 1, color => [ 128, 255, 64, 128 ]);
-
- my $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 4");
- my $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 0, 255 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 4");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
- $comp->box(filled => 1, color => [ 213, 255, 192, 191 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 4");
- $comp = $base->copy;
- $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
- $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
-
- $work = $base->copy;
- ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 4");
- $comp = $base->copy;
- $comp->box(filled => 1, color => $c_blue_full, @left_box);
- $comp->box(filled => 1, color => [ 43, 255, 21, 191], @right_box);
- is_image($work, $comp, "compare rubthrough target to expected");
- }
-}
-
-sub color_cmp {
- my ($l, $r) = @_;
- my @l = $l->rgba;
- my @r = $r->rgba;
- print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
- return $l[0] <=> $r[0]
- || $l[1] <=> $r[1]
- || $l[2] <=> $r[2];
-}
-
-sub iscolora {
- my ($c1, $c2, $msg) = @_;
-
- my $builder = Test::Builder->new;
- my @c1 = $c1->rgba;
- my @c2 = $c2->rgba;
- if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2]
- && $c1[3] == $c2[3],
- $msg)) {
- $builder->diag(<<DIAG);
- got color: [ @c1 ]
- expected color: [ @c2 ]
-DIAG
- }
-}
-
+++ /dev/null
-#!perl -w
-
-use strict;
-use Test::More tests => 18;
-
-use Imager qw/NC/;
-use Imager::Test qw(is_image is_color3);
-
-sub PI () { 3.14159265358979323846 }
-
--d "testout" or mkdir "testout";
-
-Imager::init_log("testout/t75aapolyaa.log",1);
-
-my $red = Imager::Color->new(255,0,0);
-my $green = Imager::Color->new(0,255,0);
-my $blue = Imager::Color->new(0,0,255);
-my $white = Imager::Color->new(255,255,255);
-
-{ # artifacts with multiple vertical lobes
- # https://rt.cpan.org/Ticket/Display.html?id=43518
- # previously this would have a full coverage pixel at (0,0) caused
- # by the (20,0.5) point in the right lobe
-
- my @pts =
- (
- [ 0.5, -9 ],
- [ 10, -9 ],
- [ 10, 11 ],
- [ 15, 11 ],
- [ 15, -9 ],
- [ 17, -9 ],
- [ 20, 0.5 ],
- [ 17, 11 ],
- [ 0.5, 11 ],
- );
- my $im = Imager->new(xsize => 10, ysize => 2);
- ok($im->polygon(points => \@pts,
- color => $white),
- "draw with inside point");
- ok($im->write(file => "testout/t75inside.ppm"), "save to file");
- # both scanlines should be the same
- my $line0 = $im->crop(top => 0, height => 1);
- my $line1 = $im->crop(top => 1, height => 1);
- is_image($line0, $line1, "both scanlines should be the same");
-}
-
-{ # check vertical edges are consistent
- my $im = Imager->new(xsize => 10, ysize => 10);
- ok($im->polygon(points => [ [ 0.5, 0 ], [ 9.25, 0 ],
- [ 9.25, 10 ], [ 0.5, 10 ] ],
- color => $white,
- aa => 1),
- "draw polygon with mid pixel vertical edges")
- or diag $im->errstr;
- my @line0 = $im->getscanline(y => 0);
- my $im2 = Imager->new(xsize => 10, ysize => 10);
- for my $y (0..9) {
- $im2->setscanline(y => $y, pixels => \@line0);
- }
- is_image($im, $im2, "all scan lines should be the same");
- is_color3($line0[0], 128, 128, 128, "(0,0) should be 50% coverage");
- is_color3($line0[9], 64, 64, 64, "(9,0) should be 25% coverage");
-}
-
-{ # check horizontal edges are consistent
- my $im = Imager->new(xsize => 10, ysize => 10);
- ok($im->polygon(points => [ [ 0, 0.5 ], [ 0, 9.25 ],
- [ 10, 9.25 ], [ 10, 0.5 ] ],
- color => $white,
- aa => 1),
- "draw polygon with mid-pixel horizontal edges");
- is_deeply([ $im->getsamples(y => 0, channels => [ 0 ]) ],
- [ (128) x 10 ],
- "all of line 0 should be 50% coverage");
- is_deeply([ $im->getsamples(y => 9, channels => [ 0 ]) ],
- [ (64) x 10 ],
- "all of line 9 should be 25% coverage");
-}
-
-{
- my $img = Imager->new(xsize=>20, ysize=>10);
- my @data = translate(5.5,5,
- rotate(0,
- scale(5, 5,
- get_polygon(n_gon => 5)
- )
- )
- );
-
-
- my ($x, $y) = array_to_refpair(@data);
- ok(Imager::i_poly_aa($img->{IMG}, $x, $y, $white), "primitive poly");
-
- ok($img->write(file=>"testout/t75.ppm"), "write to file")
- or diag $img->errstr;
-
- my $zoom = make_zoom($img, 8, \@data, $red);
- ok($zoom, "make zoom of primitive");
- $zoom->write(file=>"testout/t75zoom.ppm") or die $zoom->errstr;
-}
-
-{
- my $img = Imager->new(xsize=>300, ysize=>100);
-
- my $good = 1;
- for my $n (0..55) {
- my @data = translate(20+20*($n%14),18+20*int($n/14),
- rotate(15*$n/PI,
- scale(15, 15,
- get_polygon('box')
- )
- )
- );
- my ($x, $y) = array_to_refpair(@data);
- Imager::i_poly_aa($img->{IMG}, $x, $y, NC(rand(255), rand(255), rand(255)))
- or $good = 0;
- }
-
- $img->write(file=>"testout/t75big.ppm") or die $img->errstr;
-
- ok($good, "primitive squares");
-}
-
-{
- my $img = Imager->new(xsize => 300, ysize => 300);
- ok($img -> polygon(color=>$white,
- points => [
- translate(150,150,
- rotate(45*PI/180,
- scale(70,70,
- get_polygon('wavycircle', 32*8, sub { 1.2+1*cos(4*$_) }))))
- ],
- ), "method call")
- or diag $img->errstr();
-
- $img->write(file=>"testout/t75wave.ppm") or die $img->errstr;
-}
-
-{
- my $img = Imager->new(xsize=>10,ysize=>6);
- my @data = translate(165,5,
- scale(80,80,
- get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })));
-
- ok($img -> polygon(color=>$white,
- points => [
- translate(165,5,
- scale(80,80,
- get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
- ],
- ), "bug check")
- or diag $img->errstr();
-
- make_zoom($img,20,\@data, $blue)->write(file=>"testout/t75wavebug.ppm") or die $img->errstr;
-
-}
-
-{
- my $img = Imager->new(xsize=>300, ysize=>300);
- ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF', dx=>3 },
- points => [
- translate(150,150,
- scale(70,70,
- get_polygon('wavycircle', 32*8, sub { 1+1*cos(4*$_) })))
- ],
- ), "poly filled with hatch")
- or diag $img->errstr();
- $img->write(file=>"testout/t75wave_fill.ppm") or die $img->errstr;
-}
-
-{
- my $img = Imager->new(xsize=>300, ysize=>300, bits=>16);
- ok($img->polygon(fill=>{ hatch=>'cross1', fg=>'00FF00', bg=>'0000FF' },
- points => [
- translate(150,150,
- scale(70,70,
- get_polygon('wavycircle', 32*8, sub { 1+1*cos(5*$_) })))
- ],
- ), "hatched to 16-bit image")
- or diag $img->errstr();
- $img->write(file=>"testout/t75wave_fill16.ppm") or die $img->errstr;
-}
-
-Imager::malloc_state();
-
-
-#initialized in a BEGIN, later
-my %primitives;
-my %polygens;
-
-sub get_polygon {
- my $name = shift;
- if (exists $primitives{$name}) {
- return @{$primitives{$name}};
- }
-
- if (exists $polygens{$name}) {
- return $polygens{$name}->(@_);
- }
-
- die "polygon spec: $name unknown\n";
-}
-
-
-sub make_zoom {
- my ($img, $sc, $polydata, $linecolor) = @_;
-
- # scale with nearest neighboor sampling
- my $timg = $img->scale(scalefactor=>$sc, qtype=>'preview');
-
- # draw the grid
- for(my $lx=0; $lx<$timg->getwidth(); $lx+=$sc) {
- $timg->line(color=>$green, x1=>$lx, x2=>$lx, y1=>0, y2=>$timg->getheight(), antialias=>0);
- }
-
- for(my $ly=0; $ly<$timg->getheight(); $ly+=$sc) {
- $timg->line(color=>$green, y1=>$ly, y2=>$ly, x1=>0, x2=>$timg->getwidth(), antialias=>0);
- }
- my @data = scale($sc, $sc, @$polydata);
- push(@data, $data[0]);
- my ($x, $y) = array_to_refpair(@data);
-
- $timg->polyline(color=>$linecolor, 'x'=>$x, 'y'=>$y, antialias=>0);
- return $timg;
-}
-
-# utility functions to manipulate point data
-
-sub scale {
- my ($x, $y, @data) = @_;
- return map { [ $_->[0]*$x , $_->[1]*$y ] } @data;
-}
-
-sub translate {
- my ($x, $y, @data) = @_;
- map { [ $_->[0]+$x , $_->[1]+$y ] } @data;
-}
-
-sub rotate {
- my ($rad, @data) = @_;
- map { [ $_->[0]*cos($rad)+$_->[1]*sin($rad) , $_->[1]*cos($rad)-$_->[0]*sin($rad) ] } @data;
-}
-
-sub array_to_refpair {
- my (@x, @y);
- for (@_) {
- push(@x, $_->[0]);
- push(@y, $_->[1]);
- }
- return \@x, \@y;
-}
-
-
-
-BEGIN {
-%primitives = (
- box => [ [-0.5,-0.5], [0.5,-0.5], [0.5,0.5], [-0.5,0.5] ],
- triangle => [ [0,0], [1,0], [1,1] ],
- );
-
-%polygens = (
- wavycircle => sub {
- my $numv = shift;
- my $radfunc = shift;
- my @radians = map { $_*2*PI/$numv } 0..$numv-1;
- my @radius = map { $radfunc->($_) } @radians;
- map {
- [ $radius[$_] * cos($radians[$_]), $radius[$_] * sin($radians[$_]) ]
- } 0..$#radians;
- },
- n_gon => sub {
- my $N = shift;
- map {
- [ cos($_*2*PI/$N), sin($_*2*PI/$N) ]
- } 0..$N-1;
- },
-);
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 13;
-
-BEGIN { use_ok('Imager') }
-
--d "testout" or mkdir "testout";
-
-require_ok('Imager::Font::Wrap');
-
-my $img = Imager->new(xsize=>400, ysize=>400);
-
-my $text = <<EOS;
-This is a test of text wrapping. This is a test of text wrapping. This =
-is a test of text wrapping. This is a test of text wrapping. This is a =
-test of text wrapping. This is a test of text wrapping. This is a test =
-of text wrapping. This is a test of text wrapping. This is a test of =
-text wrapping. XX.
-
-Xxxxxxxxxxxxxxxxxxxxxxxxxxxwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww xxxx.
-
-This is a test of text wrapping. This is a test of text wrapping. This =
-is a test of text wrapping. This is a test of text wrapping. This is a =
-test of text wrapping. This is a test of text wrapping. This is a test =
-of text wrapping. This is a test of text wrapping. This is a test of =
-text wrapping. This is a test of text wrapping. This is a test of text =
-wrapping. This is a test of text wrapping. This is a test of text =
-wrapping. This is a test of text wrapping. This is a test of text =
-wrapping. This is a test of text wrapping. This is a test of text =
-wrapping. XX.
-EOS
-
-$text =~ s/=\n//g;
-
-my $fontfile = $ENV{WRAPTESTFONT} || $ENV{TTFONTTEST} || "fontfiles/ImUgly.ttf";
-
-my $font = Imager::Font->new(file=>$fontfile);
-
-SKIP:
-{
- $Imager::formats{'tt'} || $Imager::formats{'ft2'}
- or skip("Need Freetype 1.x or 2.x to test", 11);
-
- ok($font, "loading font")
- or skip("Could not load test font", 8);
-
- Imager::Font->priorities(qw(t1 ft2 tt));
- ok(scalar Imager::Font::Wrap->wrap_text(string => $text,
- font=>$font,
- image=>$img,
- size=>13,
- width => 380, aa=>1,
- x=>10, 'y'=>10,
- justify=>'fill',
- color=>'FFFFFF'),
- "basic test");
- ok($img->write(file=>'testout/t80wrapped.ppm'), "save to file");
- ok(scalar Imager::Font::Wrap->wrap_text(string => $text,
- font=>$font,
- image=>undef,
- size=>13,
- width => 380,
- x=>10, 'y'=>10,
- justify=>'left',
- color=>'FFFFFF'),
- "no image test");
- my $bbox = $font->bounding_box(string=>"Xx", size=>13);
- ok($bbox, "get height for check");
-
- my $used;
- ok(scalar Imager::Font::Wrap->wrap_text
- (string=>$text, font=>$font, image=>undef, size=>13, width=>380,
- savepos=> \$used, height => $bbox->font_height), "savepos call");
- ok($used > 20 && $used < length($text), "savepos value");
- print "# $used\n";
- my @box = Imager::Font::Wrap->wrap_text
- (string=>substr($text, 0, $used), font=>$font, image=>undef, size=>13,
- width=>380);
-
- ok(@box == 4, "bounds list count");
- print "# @box\n";
- ok($box[3] == $bbox->font_height, "check height");
-
- { # regression
- # http://rt.cpan.org/Ticket/Display.html?id=29771
- # the length of the trailing line wasn't included in the text consumed
- my $used;
- ok(scalar Imager::Font::Wrap->wrap_text
- ( string => "test", font => $font, image => undef, size => 12,
- width => 200, savepos => \$used, height => $bbox->font_height),
- "regression 29771 - call wrap_text");
- is($used, 4, "all text should be consumed");
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-use Imager;
-
-# this script tests an internal set of functions for Imager, they
-# aren't intended to be used at the perl level.
-# these functions aren't present in all Imager builds
-
-unless (Imager::Internal::Hlines::testing()) {
- plan skip_all => 'Imager not built to run this test';
-}
-
-plan tests => 15;
-
-my $hline = Imager::Internal::Hlines::new(0, 100, 0, 100);
-my $base_text = 'start_y: 0 limit_y: 100 start_x: 0 limit_x: 100';
-ok($hline, "made hline");
-is($hline->dump, "$base_text\n", "check values");
-$hline->add(5, -5, 7);
-is($hline->dump, <<EOS, "check (-5, 7) added");
-$base_text
- 5 (1): [0, 2)
-EOS
-$hline->add(5, 8, 4);
-is($hline->dump, <<EOS, "check (8, 4) added");
-$base_text
- 5 (2): [0, 2) [8, 12)
-EOS
-$hline->add(5, 3, 3);
-is($hline->dump, <<EOS, "check (3, 3) added");
-$base_text
- 5 (3): [0, 2) [3, 6) [8, 12)
-EOS
-$hline->add(5, 2, 6);
-is($hline->dump, <<EOS, "check (2, 6) added");
-$base_text
- 5 (1): [0, 12)
-EOS
-# adding out of range should do nothing
-my $current = <<EOS;
-$base_text
- 5 (1): [0, 12)
-EOS
-$hline->add(6, -5, 5);
-is($hline->dump, $current, "check (6, -5, 5) not added");
-$hline->add(6, 100, 5);
-is($hline->dump, $current, "check (6, 100, 5) not added");
-$hline->add(-1, 5, 2);
-is($hline->dump, $current, "check (-1, 5, 2) not added");
-$hline->add(100, 5, 2);
-is($hline->dump, $current, "check (10, 5, 2) not added");
-
-# overlapped add check
-$hline->add(6, 2, 6);
-$hline->add(6, 3, 4);
-is($hline->dump, <<EOS, "check internal overlap merged");
-$base_text
- 5 (1): [0, 12)
- 6 (1): [2, 8)
-EOS
-
-# white box test: try to force reallocation of an entry
-for my $i (0..20) {
- $hline->add(7, $i*2, 1);
-}
-is($hline->dump, <<EOS, "lots of segments");
-$base_text
- 5 (1): [0, 12)
- 6 (1): [2, 8)
- 7 (21): [0, 1) [2, 3) [4, 5) [6, 7) [8, 9) [10, 11) [12, 13) [14, 15) [16, 17) [18, 19) [20, 21) [22, 23) [24, 25) [26, 27) [28, 29) [30, 31) [32, 33) [34, 35) [36, 37) [38, 39) [40, 41)
-EOS
-# now merge them
-$hline->add(7, 1, 39);
-is($hline->dump, <<EOS, "merge lots of segments");
-$base_text
- 5 (1): [0, 12)
- 6 (1): [2, 8)
- 7 (1): [0, 41)
-EOS
-
-# clean object
-$hline = Imager::Internal::Hlines::new(50, 50, 50, 50);
-$base_text = 'start_y: 50 limit_y: 100 start_x: 50 limit_x: 100';
-
-# left merge
-$hline->add(51, 45, 10);
-$hline->add(51, 55, 4);
-is($hline->dump, <<EOS, "left merge");
-$base_text
- 51 (1): [50, 59)
-EOS
-
-# right merge
-$hline->add(52, 90, 5);
-$hline->add(52, 87, 5);
-is($hline->dump, <<EOS, "right merge");
-$base_text
- 51 (1): [50, 59)
- 52 (1): [87, 95)
-EOS
-
-undef $hline;
+++ /dev/null
-#!perl -w
-#
-# this tests both the Inline interface and the API
-use strict;
-use Test::More;
-use Imager::Test qw(is_color3 is_color4);
-eval "require Inline::C;";
-plan skip_all => "Inline required for testing API" if $@;
-
-eval "require Parse::RecDescent;";
-plan skip_all => "Could not load Parse::RecDescent" if $@;
-
-use Cwd 'getcwd';
-plan skip_all => "Inline won't work in directories with spaces"
- if getcwd() =~ / /;
-
-plan skip_all => "perl 5.005_04, 5.005_05 too buggy"
- if $] =~ /^5\.005_0[45]$/;
-
--d "testout" or mkdir "testout";
-
-print STDERR "Inline version $Inline::VERSION\n";
-
-plan tests => 117;
-require Inline;
-Inline->import(with => 'Imager');
-Inline->import("FORCE"); # force rebuild
-#Inline->import(C => Config => OPTIMIZE => "-g");
-
-Inline->bind(C => <<'EOS');
-#include <math.h>
-
-int pixel_count(Imager::ImgRaw im) {
- return im->xsize * im->ysize;
-}
-
-int count_color(Imager::ImgRaw im, Imager::Color c) {
- int count = 0, x, y, chan;
- i_color read_c;
-
- for (x = 0; x < im->xsize; ++x) {
- for (y = 0; y < im->ysize; ++y) {
- int match = 1;
- i_gpix(im, x, y, &read_c);
- for (chan = 0; chan < im->channels; ++chan) {
- if (read_c.channel[chan] != c->channel[chan]) {
- match = 0;
- break;
- }
- }
- if (match)
- ++count;
- }
- }
-
- return count;
-}
-
-Imager make_10x10() {
- i_img *im = i_img_8_new(10, 10, 3);
- i_color c;
- c.channel[0] = c.channel[1] = c.channel[2] = 255;
- i_box_filled(im, 0, 0, im->xsize-1, im->ysize-1, &c);
-
- return im;
-}
-
-/* tests that all of the APIs are visible - most of them anyway */
-Imager do_lots(Imager src) {
- i_img *im = i_img_8_new(100, 100, 3);
- i_img *fill_im = i_img_8_new(5, 5, 3);
- i_img *testim;
- i_color red, blue, green, black, temp_color;
- i_fcolor redf, bluef;
- i_fill_t *hatch, *fhatch_fill;
- i_fill_t *im_fill;
- i_fill_t *solid_fill, *fsolid_fill;
- i_fill_t *fount_fill;
- void *block;
- double matrix[9] = /* 30 degree rotation */
- {
- 0.866025, -0.5, 0,
- 0.5, 0.866025, 0,
- 0, 0, 1,
- };
- i_fountain_seg fseg;
- i_img_tags tags;
- int entry;
- double temp_double;
-
- red.channel[0] = 255; red.channel[1] = 0; red.channel[2] = 0;
- red.channel[3] = 255;
- blue.channel[0] = 0; blue.channel[1] = 0; blue.channel[2] = 255;
- blue.channel[3] = 255;
- green.channel[0] = 0; green.channel[1] = 255; green.channel[2] = 0;
- green.channel[3] = 255;
- black.channel[0] = black.channel[1] = black.channel[2] = 0;
- black.channel[3] = 255;
- hatch = i_new_fill_hatch(&red, &blue, 0, 1, NULL, 0, 0);
-
- i_box(im, 0, 0, 9, 9, &red);
- i_box_filled(im, 10, 0, 19, 9, &blue);
- i_box_cfill(im, 20, 0, 29, 9, hatch);
-
- /* make an image fill, and try it */
- i_box_cfill(fill_im, 0, 0, 4, 4, hatch);
- im_fill = i_new_fill_image(fill_im, matrix, 2, 2, 0);
-
- i_box_cfill(im, 30, 0, 39, 9, im_fill);
-
- /* make a solid fill and try it */
- solid_fill = i_new_fill_solid(&red, 0);
- i_box_cfill(im, 40, 0, 49, 9, solid_fill);
-
- /* floating fills */
- redf.channel[0] = 1.0; redf.channel[1] = 0; redf.channel[2] = 0;
- redf.channel[3] = 1.0;
- bluef.channel[0] = 0; bluef.channel[1] = 0; bluef.channel[2] = 1.0;
- bluef.channel[3] = 1.0;
-
- fsolid_fill = i_new_fill_solidf(&redf, 0);
- i_box_cfill(im, 50, 0, 59, 9, fsolid_fill);
-
- fhatch_fill = i_new_fill_hatchf(&redf, &bluef, 0, 2, NULL, 0, 0);
- i_box_cfill(im, 60, 0, 69, 9, fhatch_fill);
-
- /* fountain fill */
- fseg.start = 0;
- fseg.middle = 0.5;
- fseg.end = 1.0;
- fseg.c[0] = redf;
- fseg.c[1] = bluef;
- fseg.type = i_fst_linear;
- fseg.color = i_fc_hue_down;
- fount_fill = i_new_fill_fount(70, 0, 80, 0, i_ft_linear, i_fr_triangle, 0, i_fts_none, 1, 1, &fseg);
-
- i_box_cfill(im, 70, 0, 79, 9, fount_fill);
-
- i_line(im, 0, 10, 10, 15, &blue, 1);
- i_line_aa(im, 0, 19, 10, 15, &red, 1);
-
- i_arc(im, 15, 15, 4, 45, 160, &blue);
- i_arc_aa(im, 25, 15, 4, 75, 280, &red);
- i_arc_cfill(im, 35, 15, 4, 0, 215, hatch);
- i_arc_aa_cfill(im, 45, 15, 4, 30, 210, hatch);
- i_circle_aa(im, 55, 15, 4, &red);
-
- i_box(im, 61, 11, 68, 18, &red);
- i_flood_fill(im, 65, 15, &blue);
- i_box(im, 71, 11, 78, 18, &red);
- i_flood_cfill(im, 75, 15, hatch);
-
- i_box_filled(im, 1, 21, 9, 24, &red);
- i_box_filled(im, 1, 25, 9, 29, &blue);
- i_flood_fill_border(im, 5, 25, &green, &black);
-
- i_box_filled(im, 11, 21, 19, 24, &red);
- i_box_filled(im, 11, 25, 19, 29, &blue);
- i_flood_cfill_border(im, 15, 25, hatch, &black);
-
- i_fill_destroy(fount_fill);
- i_fill_destroy(fhatch_fill);
- i_fill_destroy(solid_fill);
- i_fill_destroy(fsolid_fill);
- i_fill_destroy(hatch);
- i_fill_destroy(im_fill);
- i_img_destroy(fill_im);
-
- /* make sure we can make each image type */
- testim = i_img_16_new(100, 100, 3);
- i_img_destroy(testim);
- testim = i_img_double_new(100, 100, 3);
- i_img_destroy(testim);
- testim = i_img_pal_new(100, 100, 3, 256);
- i_img_destroy(testim);
- testim = i_sametype(im, 50, 50);
- i_img_destroy(testim);
- testim = i_sametype_chans(im, 50, 50, 4);
- i_img_destroy(testim);
-
- i_clear_error();
- i_push_error(0, "Hello");
- i_push_errorf(0, "%s", "World");
-
- /* make sure tags create/destroy work */
- i_tags_new(&tags);
- i_tags_destroy(&tags);
-
- block = mymalloc(20);
- block = myrealloc(block, 50);
- myfree(block);
-
- i_tags_set(&im->tags, "lots_string", "foo", -1);
- i_tags_setn(&im->tags, "lots_number", 101);
-
- if (!i_tags_find(&im->tags, "lots_number", 0, &entry)) {
- i_push_error(0, "lots_number tag not found");
- i_img_destroy(im);
- return NULL;
- }
- i_tags_delete(&im->tags, entry);
-
- /* these won't delete anything, but it makes sure the macros and function
- pointers are correct */
- i_tags_delbyname(&im->tags, "unknown");
- i_tags_delbycode(&im->tags, 501);
- i_tags_set_float(&im->tags, "lots_float", 0, 3.14);
- if (!i_tags_get_float(&im->tags, "lots_float", 0, &temp_double)) {
- i_push_error(0, "lots_float not found");
- i_img_destroy(im);
- return NULL;
- }
- if (fabs(temp_double - 3.14) > 0.001) {
- i_push_errorf(0, "lots_float incorrect %g", temp_double);
- i_img_destroy(im);
- return NULL;
- }
- i_tags_set_float2(&im->tags, "lots_float2", 0, 100 * sqrt(2.0), 5);
- if (!i_tags_get_int(&im->tags, "lots_float2", 0, &entry)) {
- i_push_error(0, "lots_float2 not found as int");
- i_img_destroy(im);
- return NULL;
- }
- if (entry != 141) {
- i_push_errorf(0, "lots_float2 unexpected value %d", entry);
- i_img_destroy(im);
- return NULL;
- }
-
- i_tags_set_color(&im->tags, "lots_color", 0, &red);
- if (!i_tags_get_color(&im->tags, "lots_color", 0, &temp_color)) {
- i_push_error(0, "lots_color not found as color");
- i_img_destroy(im);
- return NULL;
- }
-
- return im;
-}
-
-void
-io_fd(int fd) {
- Imager::IO io = io_new_fd(fd);
- i_io_write(io, "test", 4);
- i_io_close(io);
- io_glue_destroy(io);
-}
-
-int
-io_bufchain_test() {
- Imager::IO io = io_new_bufchain();
- unsigned char *result;
- size_t size;
- if (i_io_write(io, "test2", 5) != 5) {
- fprintf(stderr, "write failed\n");
- return 0;
- }
- if (!i_io_flush(io)) {
- fprintf(stderr, "flush failed\n");
- return 0;
- }
- if (i_io_close(io) != 0) {
- fprintf(stderr, "close failed\n");
- return 0;
- }
- size = io_slurp(io, &result);
- if (size != 5) {
- fprintf(stderr, "wrong size\n");
- return 0;
- }
- if (memcmp(result, "test2", 5)) {
- fprintf(stderr, "data mismatch\n");
- return 0;
- }
- if (i_io_seek(io, 0, 0) != 0) {
- fprintf(stderr, "seek failure\n");
- return 0;
- }
- myfree(result);
- io_glue_destroy(io);
-
- return 1;
-}
-
-const char *
-io_buffer_test(SV *in) {
- STRLEN len;
- const char *in_str = SvPV(in, len);
- static char buf[100];
- Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
- ssize_t read_size;
-
- read_size = i_io_read(io, buf, sizeof(buf)-1);
- io_glue_destroy(io);
- if (read_size < 0 || read_size >= sizeof(buf)) {
- return "";
- }
-
- buf[read_size] = '\0';
-
- return buf;
-}
-
-const char *
-io_peekn_test(SV *in) {
- STRLEN len;
- const char *in_str = SvPV(in, len);
- static char buf[100];
- Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
- ssize_t read_size;
-
- read_size = i_io_peekn(io, buf, sizeof(buf)-1);
- io_glue_destroy(io);
- if (read_size < 0 || read_size >= sizeof(buf)) {
- return "";
- }
-
- buf[read_size] = '\0';
-
- return buf;
-}
-
-const char *
-io_gets_test(SV *in) {
- STRLEN len;
- const char *in_str = SvPV(in, len);
- static char buf[100];
- Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
- ssize_t read_size;
-
- read_size = i_io_gets(io, buf, sizeof(buf), 's');
- io_glue_destroy(io);
- if (read_size < 0 || read_size >= sizeof(buf)) {
- return "";
- }
-
- return buf;
-}
-
-int
-io_getc_test(SV *in) {
- STRLEN len;
- const char *in_str = SvPV(in, len);
- static char buf[100];
- Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
- int result;
-
- result = i_io_getc(io);
- io_glue_destroy(io);
-
- return result;
-}
-
-int
-io_peekc_test(SV *in) {
- STRLEN len;
- const char *in_str = SvPV(in, len);
- static char buf[100];
- Imager::IO io = io_new_buffer(in_str, len, NULL, NULL);
- int result;
-
- i_io_set_buffered(io, 0);
-
- result = i_io_peekc(io);
- io_glue_destroy(io);
-
- return result;
-}
-
-
-
-int
-test_render_color(Imager work_8) {
- i_render *r8;
- i_color c;
- unsigned char render_coverage[3];
-
- render_coverage[0] = 0;
- render_coverage[1] = 128;
- render_coverage[2] = 255;
-
- r8 = i_render_new(work_8, 10);
- c.channel[0] = 128;
- c.channel[1] = 255;
- c.channel[2] = 0;
- c.channel[3] = 255;
- i_render_color(r8, 0, 0, sizeof(render_coverage), render_coverage, &c);
-
- c.channel[3] = 128;
- i_render_color(r8, 0, 1, sizeof(render_coverage), render_coverage, &c);
-
- c.channel[3] = 0;
- i_render_color(r8, 0, 2, sizeof(render_coverage), render_coverage, &c);
-
- i_render_delete(r8);
-
- return 1;
-}
-
-int
-raw_psamp(Imager im, int chan_count) {
- static i_sample_t samps[] = { 0, 127, 255 };
-
- i_clear_error();
- return i_psamp(im, 0, 1, 0, samps, NULL, chan_count);
-}
-
-int
-raw_psampf(Imager im, int chan_count) {
- static i_fsample_t samps[] = { 0, 0.5, 1.0 };
-
- i_clear_error();
- return i_psampf(im, 0, 1, 0, samps, NULL, chan_count);
-}
-
-int
-test_mutex() {
- i_mutex_t m;
-
- m = i_mutex_new();
- i_mutex_lock(m);
- i_mutex_unlock(m);
- i_mutex_destroy(m);
-
- return 1;
-}
-
-int
-test_slots() {
- im_slot_t slot = im_context_slot_new(NULL);
-
- if (im_context_slot_get(aIMCTX, slot)) {
- fprintf(stderr, "slots should default to NULL\n");
- return 0;
- }
- if (!im_context_slot_set(aIMCTX, slot, &slot)) {
- fprintf(stderr, "set slot failed\n");
- return 0;
- }
-
- if (im_context_slot_get(aIMCTX, slot) != &slot) {
- fprintf(stderr, "get slot didn't match\n");
- return 0;
- }
-
- return 1;
-}
-
-EOS
-
-my $im = Imager->new(xsize=>50, ysize=>50);
-is(pixel_count($im), 2500, "pixel_count");
-
-my $black = Imager::Color->new(0,0,0);
-is(count_color($im, $black), 2500, "count_color black on black image");
-
-my $im2 = make_10x10();
-my $white = Imager::Color->new(255, 255, 255);
-is(count_color($im2, $white), 100, "check new image white count");
-ok($im2->box(filled=>1, xmin=>1, ymin=>1, xmax => 8, ymax=>8, color=>$black),
- "try new image");
-is(count_color($im2, $black), 64, "check modified black count");
-is(count_color($im2, $white), 36, "check modified white count");
-
-my $im3 = do_lots($im2);
-ok($im3, "do_lots()")
- or print "# ", Imager->_error_as_msg, "\n";
-ok($im3->write(file=>'testout/t82lots.ppm'), "write t82lots.ppm");
-
-{ # RT #24992
- # the T_IMAGER_FULL_IMAGE typemap entry was returning a blessed
- # hash with an extra ref, causing memory leaks
-
- my $im = make_10x10();
- my $im2 = Imager->new(xsize => 10, ysize => 10);
- require B;
- my $imb = B::svref_2object($im);
- my $im2b = B::svref_2object($im2);
- is ($imb->REFCNT, $im2b->REFCNT,
- "check refcnt of imager object hash between normal and typemap generated");
-}
-
-SKIP:
-{
- use IO::File;
- my $fd_filename = "testout/t82fd.txt";
- {
- my $fh = IO::File->new($fd_filename, "w")
- or skip("Can't create file: $!", 1);
- io_fd(fileno($fh));
- $fh->close;
- }
- {
- my $fh = IO::File->new($fd_filename, "r")
- or skip("Can't open file: $!", 1);
- my $data = <$fh>;
- is($data, "test", "make sure data written to fd");
- }
- unlink $fd_filename;
-}
-
-ok(io_bufchain_test(), "check bufchain functions");
-
-is(io_buffer_test("test3"), "test3", "check io_new_buffer() and i_io_read");
-
-is(io_peekn_test("test5"), "test5", "check i_io_peekn");
-
-is(io_gets_test("test"), "tes", "check i_io_gets()");
-
-is(io_getc_test("ABC"), ord "A", "check i_io_getc(_imp)?");
-
-is(io_getc_test("XYZ"), ord "X", "check i_io_peekc(_imp)?");
-
-for my $bits (8, 16) {
- print "# bits: $bits\n";
-
- # the floating point processing is a little more accurate
- my $bump = $bits == 16 ? 1 : 0;
- {
- my $im = Imager->new(xsize => 10, ysize => 10, channels => 3, bits => $bits);
- ok($im->box(filled => 1, color => '#808080'), "fill work image with gray");
- ok(test_render_color($im),
- "call render_color on 3 channel image");
- is_color3($im->getpixel(x => 0, y => 0), 128, 128, 128,
- "check zero coverage, alpha 255 color, bits $bits");
- is_color3($im->getpixel(x => 1, y => 0), 128, 191+$bump, 63+$bump,
- "check 128 coverage, alpha 255 color, bits $bits");
- is_color3($im->getpixel(x => 2, y => 0), 128, 255, 0,
- "check 255 coverage, alpha 255 color, bits $bits");
-
- is_color3($im->getpixel(x => 0, y => 1), 128, 128, 128,
- "check zero coverage, alpha 128 color, bits $bits");
- is_color3($im->getpixel(x => 1, y => 1), 128, 159+$bump, 95+$bump,
- "check 128 coverage, alpha 128 color, bits $bits");
- is_color3($im->getpixel(x => 2, y => 1), 128, 191+$bump, 63+$bump,
- "check 255 coverage, alpha 128 color, bits $bits");
-
- is_color3($im->getpixel(x => 0, y => 2), 128, 128, 128,
- "check zero coverage, alpha 0 color, bits $bits");
- is_color3($im->getpixel(x => 1, y => 2), 128, 128, 128,
- "check 128 coverage, alpha 0 color, bits $bits");
- is_color3($im->getpixel(x => 2, y => 2), 128, 128, 128,
- "check 255 coverage, alpha 0 color, bits $bits");
- }
- {
- my $im = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => $bits);
- ok($im->box(filled => 1, color => '#808080'), "fill work image with opaque gray");
- ok(test_render_color($im),
- "call render_color on 4 channel image");
- is_color4($im->getpixel(x => 0, y => 0), 128, 128, 128, 255,
- "check zero coverage, alpha 255 color, bits $bits");
- is_color4($im->getpixel(x => 1, y => 0), 128, 191+$bump, 63+$bump, 255,
- "check 128 coverage, alpha 255 color, bits $bits");
- is_color4($im->getpixel(x => 2, y => 0), 128, 255, 0, 255,
- "check 255 coverage, alpha 255 color, bits $bits");
-
- is_color4($im->getpixel(x => 0, y => 1), 128, 128, 128, 255,
- "check zero coverage, alpha 128 color, bits $bits");
- is_color4($im->getpixel(x => 1, y => 1), 128, 159+$bump, 95+$bump, 255,
- "check 128 coverage, alpha 128 color, bits $bits");
- is_color4($im->getpixel(x => 2, y => 1), 128, 191+$bump, 63+$bump, 255,
- "check 255 coverage, alpha 128 color, bits $bits");
-
- is_color4($im->getpixel(x => 0, y => 2), 128, 128, 128, 255,
- "check zero coverage, alpha 0 color, bits $bits");
- is_color4($im->getpixel(x => 1, y => 2), 128, 128, 128, 255,
- "check 128 coverage, alpha 0 color, bits $bits");
- is_color4($im->getpixel(x => 2, y => 2), 128, 128, 128, 255,
- "check 255 coverage, alpha 0 color, bits $bits");
- }
-
- {
- my $im = Imager->new(xsize => 10, ysize => 10, channels => 4, bits => $bits);
- ok($im->box(filled => 1, color => Imager::Color->new(128, 128, 128, 64)), "fill work image with translucent gray");
- ok(test_render_color($im),
- "call render_color on 4 channel image");
- is_color4($im->getpixel(x => 0, y => 0), 128, 128, 128, 64,
- "check zero coverage, alpha 255 color, bits $bits");
- is_color4($im->getpixel(x => 1, y => 0), 128, 230, 25+$bump, 159+$bump,
- "check 128 coverage, alpha 255 color, bits $bits");
- is_color4($im->getpixel(x => 2, y => 0), 128, 255, 0, 255,
- "check 255 coverage, alpha 255 color, bits $bits");
-
- is_color4($im->getpixel(x => 0, y => 1), 128, 128, 128, 64,
- "check zero coverage, alpha 128 color, bits $bits");
- is_color4($im->getpixel(x => 1, y => 1), 129-$bump, 202-$bump, 55, 111+$bump,
- "check 128 coverage, alpha 128 color, bits $bits");
- is_color4($im->getpixel(x => 2, y => 1), 128, 230, 25+$bump, 159+$bump,
- "check 255 coverage, alpha 128 color, bits $bits");
-
- is_color4($im->getpixel(x => 0, y => 2), 128, 128, 128, 64,
- "check zero coverage, alpha 0 color, bits $bits");
- is_color4($im->getpixel(x => 1, y => 2), 128, 128, 128, 64,
- "check 128 coverage, alpha 0 color, bits $bits");
- is_color4($im->getpixel(x => 2, y => 2), 128, 128, 128, 64,
- "check 255 coverage, alpha 0 color, bits $bits");
- }
-}
-
-{
- my $im = Imager->new(xsize => 10, ysize => 10);
- is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psamp($im, 0), -1, "bad channel list (0) for psamp should fail");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
-}
-
-{
- my $im = Imager->new(xsize => 10, ysize => 10, bits => 16);
- is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail (16-bit)");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psamp($im, 0), -1, "bad channel list (0) for psamp should fail (16-bit)");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail (16-bit)");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail (16-bit)");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
-}
-
-{
- my $im = Imager->new(xsize => 10, ysize => 10, bits => 'double');
- is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail (double)");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psamp($im, 0), -1,, "bad channel list (0) for psamp should fail (double)");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail (double)");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail (double)");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
-}
-
-{
- my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
- is(raw_psamp($im, 4), -1, "bad channel list (4) for psamp should fail (paletted)");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psamp($im, 0), -1, "bad channel list (0) for psamp should fail (paletted)");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 4), -1, "bad channel list (4) for psampf should fail (paletted)");
- is(_get_error(), "chan_count 4 out of range, must be >0, <= channels",
- "check message");
- is(raw_psampf($im, 0), -1, "bad channel list (0) for psampf should fail (paletted)");
- is(_get_error(), "chan_count 0 out of range, must be >0, <= channels",
- "check message");
- is($im->type, "paletted", "make sure we kept the image type");
-}
-
-ok(test_mutex(), "call mutex APIs");
-
-ok(test_slots(), "call slot APIs");
-
-sub _get_error {
- my @errors = Imager::i_errors();
- return join(": ", map $_->[0], @errors);
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 6;
-use File::Spec;
-
-{ # RT 37353
- local @INC = @INC;
-
- unshift @INC, File::Spec->catdir('blib', 'lib');
- unshift @INC, File::Spec->catdir('blib', 'arch');
- require Imager::ExtUtils;
- my $path = Imager::ExtUtils->base_dir;
- ok(File::Spec->file_name_is_absolute($path), "check dirs absolute")
- or print "# $path\n";
-}
-
-{ # includes
- my $includes = Imager::ExtUtils->includes;
- ok($includes =~ s/^-I//, "has the -I");
- ok(-e File::Spec->catfile($includes, "imext.h"), "found a header");
-}
-
-{ # typemap
- my $typemap = Imager::ExtUtils->typemap;
- ok($typemap, "got a typemap path");
- ok(-f $typemap, "it exists");
- open TYPEMAP, "< $typemap";
- my $tm_content = do { local $/; <TYPEMAP>; };
- close TYPEMAP;
- cmp_ok($tm_content, '=~', "Imager::Color\\s+T_PTROBJ",
- "it seems to be the right file");
-}
+++ /dev/null
-#!perl -w
-#
-# this tests both the Inline interface and the API with IMAGER_NO_CONTEXT
-use strict;
-use Test::More;
-use Imager::Test qw(is_color3 is_color4);
-eval "require Inline::C;";
-plan skip_all => "Inline required for testing API" if $@;
-
-eval "require Parse::RecDescent;";
-plan skip_all => "Could not load Parse::RecDescent" if $@;
-
-use Cwd 'getcwd';
-plan skip_all => "Inline won't work in directories with spaces"
- if getcwd() =~ / /;
-
-plan skip_all => "perl 5.005_04, 5.005_05 too buggy"
- if $] =~ /^5\.005_0[45]$/;
-
--d "testout" or mkdir "testout";
-
-plan tests => 5;
-require Inline;
-Inline->import(C => Config => AUTO_INCLUDE => "#define IMAGER_NO_CONTEXT\n");
-Inline->import(with => 'Imager');
-Inline->import("FORCE"); # force rebuild
-#Inline->import(C => Config => OPTIMIZE => "-g");
-
-Inline->bind(C => <<'EOS');
-#include <math.h>
-
-Imager make_10x10() {
- dIMCTX;
- i_img *im = i_img_8_new(10, 10, 3);
- i_color c;
- c.channel[0] = c.channel[1] = c.channel[2] = 255;
- i_box_filled(im, 0, 0, im->xsize-1, im->ysize-1, &c);
-
- return im;
-}
-
-void error_dIMCTX() {
- dIMCTX;
- im_clear_error(aIMCTX);
- im_push_error(aIMCTX, 0, "test1");
- im_push_errorf(aIMCTX, 0, "test%d", 2);
-
- im_log((aIMCTX, 0, "test logging\n"));
-}
-
-void error_dIMCTXim(Imager im) {
- dIMCTXim(im);
- im_clear_error(aIMCTX);
- im_push_error(aIMCTX, 0, "test1");
-}
-
-int context_refs() {
- dIMCTX;
-
- im_context_refinc(aIMCTX, "context_refs");
- im_context_refdec(aIMCTX, "context_refs");
-
- return 1;
-}
-
-EOS
-
-Imager->open_log(log => "testout/t84inlinectx.log");
-
-my $im2 = make_10x10();
-ok($im2, "make an image");
-is_color3($im2->getpixel(x => 0, y => 0), 255, 255, 255,
- "check the colors");
-error_dIMCTX();
-is(_get_error(), "test2: test1", "check dIMCTX");
-
-my $im = Imager->new(xsize => 1, ysize => 1);
-error_dIMCTXim($im);
-is(_get_error(), "test1", "check dIMCTXim");
-
-ok(context_refs(), "check refcount functions");
-
-Imager->close_log();
-
-unless ($ENV{IMAGER_KEEP_FILES}) {
- unlink "testout/t84inlinectx.log";
-}
-
-sub _get_error {
- my @errors = Imager::i_errors();
- return join(": ", map $_->[0], @errors);
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More tests => 22;
-
-use Imager;
-
--d "testout" or mkdir "testout";
-
-Imager::init('log'=>'testout/t90cc.log');
-
-{
- my $img=Imager->new();
- ok($img->open(file=>'testimg/scale.ppm'), 'load test image')
- or print "failed: ",$img->{ERRSTR},"\n";
-
- ok(defined($img->getcolorcount(maxcolors=>10000)), 'check color count is small enough');
- print "# color count: ".$img->getcolorcount()."\n";
- is($img->getcolorcount(), 86, 'expected number of colors');
- is($img->getcolorcount(maxcolors => 50), undef, 'check overflow handling');
-}
-
-{
- my $black = Imager::Color->new(0, 0, 0);
- my $blue = Imager::Color->new(0, 0, 255);
- my $red = Imager::Color->new(255, 0, 0);
-
- my $im = Imager->new(xsize=>50, ysize=>50);
-
- my $count = $im->getcolorcount();
- is ($count, 1, "getcolorcount is 1");
- my @colour_usage = $im->getcolorusage();
- is_deeply (\@colour_usage, [2500], "2500 are in black");
-
- $im->box(filled=>1, color=>$blue, xmin=>25);
-
- $count = $im->getcolorcount();
- is ($count, 2, "getcolorcount is 2");
- @colour_usage = $im->getcolorusage();
- is_deeply(\@colour_usage, [1250, 1250] , "1250, 1250: Black and blue");
-
- $im->box(filled=>1, color=>$red, ymin=>25);
-
- $count = $im->getcolorcount();
- is ($count, 3, "getcolorcount is 3");
- @colour_usage = $im->getcolorusage();
- is_deeply(\@colour_usage, [625, 625, 1250] ,
- "625, 625, 1250: Black blue and red");
- @colour_usage = $im->getcolorusage(maxcolors => 2);
- is(@colour_usage, 0, 'test overflow check');
-
- my $colour_usage = $im->getcolorusagehash();
- my $red_pack = pack("CCC", 255, 0, 0);
- my $blue_pack = pack("CCC", 0, 0, 255);
- my $black_pack = pack("CCC", 0, 0, 0);
- is_deeply( $colour_usage,
- { $black_pack => 625, $blue_pack => 625, $red_pack => 1250 },
- "625, 625, 1250: Black blue and red (hash)");
- is($im->getcolorusagehash(maxcolors => 2), undef,
- 'test overflow check');
-
- # test with a greyscale image
- my $im_g = $im->convert(preset => 'grey');
- # since the grey preset scales each source channel differently
- # each of the original colors will be converted to different colors
- is($im_g->getcolorcount, 3, '3 colors (grey)');
- is_deeply([ $im_g->getcolorusage ], [ 625, 625, 1250 ],
- 'color counts (grey)');
- is_deeply({ "\x00" => 625, "\x12" => 625, "\x38" => 1250 },
- $im_g->getcolorusagehash,
- 'color usage hash (grey)');
-}
-
-{
- my $empty = Imager->new;
- is($empty->getcolorcount, undef, "can't getcolorcount an empty image");
- is($empty->errstr, "getcolorcount: empty input image",
- "check error message");
- is($empty->getcolorusagehash, undef, "can't getcolorusagehash an empty image");
- is($empty->errstr, "getcolorusagehash: empty input image",
- "check error message");
- is($empty->getcolorusage, undef, "can't getcolorusage an empty image");
- is($empty->errstr, "getcolorusage: empty input image",
- "check error message");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-use ExtUtils::Manifest qw(maniread);
-eval "use Test::Pod 1.00;";
-plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
-my $manifest = maniread();
-my @pod = grep /\.(pm|pl|pod|PL)$/, keys %$manifest;
-plan tests => scalar(@pod);
-for my $file (@pod) {
- pod_file_ok($file, "pod ok in $file");
-}
+++ /dev/null
-#!perl -w
-# packaging test - make sure we included the samples in the MANIFEST <sigh>
-use Test::More;
-use ExtUtils::Manifest qw(maniread);
-
-# first build a list of samples from samples/README
-open SAMPLES, "< samples/README"
- or die "Cannot open samples/README: $!";
-my @sample_files;
-while (<SAMPLES>) {
- chomp;
- /^\w[\w.-]+\.\w+$/ and push @sample_files, $_;
-}
-
-close SAMPLES;
-
-plan tests => scalar(@sample_files);
-
-my $manifest = maniread();
-
-for my $filename (@sample_files) {
- ok(exists($manifest->{"samples/$filename"}),
- "sample file $filename in manifest");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use lib 't';
-use Test::More;
-use ExtUtils::Manifest qw(maniread);
-#sub Pod::Coverage::TRACE_ALL() { 1 }
-eval "use Test::Pod::Coverage 1.08;";
-# 1.08 required for coverage_class support
-plan skip_all => "Test::Pod::Coverage 1.08 required for POD coverage" if $@;
-
-# scan for a list of files to get Imager method documentation from
-my $manifest = maniread();
-my @pods = ( 'Imager.pm', grep /\.pod$/, keys %$manifest );
-
-my @private =
- (
- '^io?_',
- '^DSO_',
- '^Inline$',
- '^yatf$',
- '^malloc_state$',
- '^init_log$',
- '^polybezier$', # not ready for public consumption
- '^border$', # I don't know what it is, expect it to go away
- );
-my @trustme = ( '^open$', );
-
-plan tests => 20;
-
-{
- pod_coverage_ok('Imager', { also_private => \@private,
- pod_from => \@pods,
- trustme => \@trustme,
- coverage_class => 'Pod::Coverage::Imager' });
- pod_coverage_ok('Imager::Font');
- my @color_private = ( '^i_', '_internal$' );
- pod_coverage_ok('Imager::Color',
- { also_private => \@color_private });
- pod_coverage_ok('Imager::Color::Float',
- { also_private => \@color_private });
- pod_coverage_ok('Imager::Color::Table');
- pod_coverage_ok('Imager::ExtUtils');
- pod_coverage_ok('Imager::Expr');
- my $trust_parents = { coverage_class => 'Pod::Coverage::CountParents' };
- pod_coverage_ok('Imager::Expr::Assem', $trust_parents);
- pod_coverage_ok('Imager::Fill');
- pod_coverage_ok('Imager::Font::BBox');
- pod_coverage_ok('Imager::Font::Wrap');
- pod_coverage_ok('Imager::Fountain');
- pod_coverage_ok('Imager::Matrix2d');
- pod_coverage_ok('Imager::Regops');
- pod_coverage_ok('Imager::Transform');
- pod_coverage_ok('Imager::Test');
- pod_coverage_ok('Imager::IO',
- {
- pod_from => "lib/Imager/IO.pod",
- coverage_class => "Pod::Coverage::Imager",
- module => "Imager",
- });
-}
-
-{
- # check all documented methods/functions are in the method index
- my $coverage =
- Pod::Coverage::Imager->new(package => 'Imager',
- pod_from => \@pods,
- trustme => \@trustme,
- also_private => \@private);
- my %methods = map { $_ => 1 } $coverage->covered;
- open IMAGER, "< Imager.pm"
- or die "Cannot open Imager.pm: $!";
- while (<IMAGER>) {
- last if /^=head1 METHOD INDEX/;
- }
- my @indexed;
- my @unknown_indexed;
- while (<IMAGER>) {
- last if /^=\w/ && !/^=for\b/;
-
- if (/^(\w+)\(/) {
- push @indexed, $1;
- unless (delete $methods{$1}) {
- push @unknown_indexed, $1;
- }
- }
- }
-
- unless (is(keys %methods, 0, "all methods in method index")) {
- diag "the following methods are documented but not in the index:";
- diag $_ for sort keys %methods;
- }
- unless (is(@unknown_indexed, 0, "only methods in method index")) {
- diag "the following names are in the method index but not documented";
- diag $_ for sort @unknown_indexed;
- }
-
- sub dict_cmp_func;
- is_deeply(\@indexed, [ sort dict_cmp_func @indexed ],
- "check method index is alphabetically sorted");
-}
-
-sub dict_cmp_func {
- (my $tmp_a = lc $a) =~ tr/_//d;
- (my $tmp_b = lc $b) =~ tr/_//d;
-
- $tmp_a cmp $tmp_b;
-}
+++ /dev/null
-#!perl -w
-# this is intended for various kwalitee tests
-use strict;
-use Test::More;
-use ExtUtils::Manifest qw(maniread);
-
-my $manifest = maniread;
-
-# work up counts first
-
-my @pl_files = grep /\.(p[lm]|PL|perl)$/, keys %$manifest;
-
-plan tests => scalar(@pl_files);
-
-for my $filename (@pl_files) {
- open PL, "< $filename"
- or die "Cannot open $filename: $!";
- my $found_strict;
- while (<PL>) {
- if (/^use strict;/) {
- ++$found_strict;
- last;
- }
- }
- close PL;
- ok($found_strict, "file $filename has use strict");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Imager;
-use Test::More tests => 6;
-
-my $log_name = "testout/t95log.log";
-
-my $log_message = "test message 12345";
-
-SKIP: {
- skip("Logging not build", 3)
- unless Imager::i_log_enabled();
- ok(Imager->open_log(log => $log_name), "open log")
- or diag("Open log: " . Imager->errstr);
- ok(-f $log_name, "file is there");
- Imager->log($log_message);
- Imager->close_log();
-
- my $data = '';
- if (open LOG, "< $log_name") {
- $data = do { local $/; <LOG> };
- close LOG;
- }
- like($data, qr/\Q$log_message/, "check message made it to the log");
-}
-
-SKIP: {
- skip("Logging built", 3)
- if Imager::i_log_enabled();
-
- ok(!Imager->open_log(log => $log_name), "should be no logfile");
- is(Imager->errstr, "Logging disabled", "check error message");
- ok(!-f $log_name, "file shouldn't be there");
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-plan skip_all => "Only run as part of the dist"
- unless -f "META.yml";
-eval "use CPAN::Meta 2.110580;";
-plan skip_all => "CPAN::Meta required for testing META.yml"
- if $@;
-plan skip_all => "Only if automated or author testing"
- unless $ENV{AUTOMATED_TESTING} || -d "../.git";
-plan tests => 1;
-
-my $meta;
-unless (ok(eval {
- $meta = CPAN::Meta->load_file("META.yml",
- { lazy_validation => 0 }) },
- "loaded META.yml successfully")) {
- diag($@);
-}
+++ /dev/null
-#!perl
-use strict;
-use Imager;
-use Imager::Color::Float;
-use Imager::Fill;
-use Config;
-my $loaded_threads;
-BEGIN {
- if ($Config{useithreads} && $] > 5.008007) {
- $loaded_threads =
- eval {
- require threads;
- threads->import;
- 1;
- };
- }
-}
-use Test::More;
-
-$Config{useithreads}
- or plan skip_all => "can't test Imager's threads support with no threads";
-$] > 5.008007
- or plan skip_all => "require a perl with CLONE_SKIP to test Imager's threads support";
-$loaded_threads
- or plan skip_all => "couldn't load threads";
-
-$INC{"Devel/Cover.pm"}
- and plan skip_all => "threads and Devel::Cover don't get along";
-
-# https://rt.cpan.org/Ticket/Display.html?id=65812
-# https://github.com/schwern/test-more/issues/labels/Test-Builder2#issue/100
-$Test::More::VERSION =~ /^2\.00_/
- and plan skip_all => "threads are hosed in 2.00_06 and presumably all 2.00_*";
-
-plan tests => 13;
-
-my $thread = threads->create(sub { 1; });
-ok($thread->join, "join first thread");
-
-# these are all, or contain, XS allocated objects, if we don't handle
-# CLONE requests, or provide a CLONE_SKIP, we'll probably see a
-# double-free, one from the thread, and the other from the main line
-# of control.
-#
-# So make one of each
-
-my $im = Imager->new(xsize => 10, ysize => 10);
-my $c = Imager::Color->new(0, 0, 0); # make some sort of color
-ok($c, "made the color");
-my $cf = Imager::Color::Float->new(0, 0, 0);
-ok($cf, "made the float color");
-my $hl;
-SKIP:
-{
- Imager::Internal::Hlines::testing()
- or skip "no hlines visible to test", 1;
- $hl = Imager::Internal::Hlines::new(0, 100, 0, 100);
- ok($hl, "made the hlines");
-}
-my $io = Imager::io_new_bufchain();
-ok($io, "made the io");
-my $tt;
-SKIP:
-{
- $Imager::formats{tt}
- or skip("No TT font support", 1);
- $tt = Imager::Font->new(type => "tt", file => "fontfiles/dodge.ttf");
- ok($tt, "made the font");
-}
-my $ft2;
-SKIP:
-{
- $Imager::formats{ft2}
- or skip "No FT2 support", 1;
- $ft2 = Imager::Font->new(type => "ft2", file => "fontfiles/dodge.ttf");
- ok($ft2, "made ft2 font");
-}
-my $fill = Imager::Fill->new(solid => $c);
-ok($fill, "made the fill");
-
-my $t2 = threads->create
- (
- sub {
- ok(!UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
- "the low level image object should become unblessed");
- ok(!$im->_valid_image, "image no longer considered valid");
- is($im->errstr, "images do not cross threads",
- "check error message");
- 1;
- }
- );
-ok($t2->join, "join second thread");
-#print STDERR $im->{IMG}, "\n";
-ok(UNIVERSAL::isa($im->{IMG}, "Imager::ImgRaw"),
- "but the object should be fine in the main thread");
-
+++ /dev/null
-#!perl -w
-# regression test for RT issue 18561
-#
-use strict;
-use Test::More tests => 1;
-eval {
- use Imager;
-
- my $i = Imager->new(
- xsize => 50,
- ysize => 50,
- );
-
- $i->setpixel(
- x => 10,
- y => 10,
- color => [0, 0, 0],
- );
-};
-ok(!$@, "shouldn't crash")
- or print "# $@\n";
+++ /dev/null
-#!perl -w
-# variant on the code that produces 18561
-# the old _color() code could return floating colors in some cases
-# but in most cases the caller couldn't handle it
-use strict;
-use Test::More tests => 1;
-eval {
- use Imager;
- use Imager::Color::Float; # prevent the actual 18561 crash
- my $i = Imager->new(
- xsize => 50,
- ysize => 50,
- );
- $i->line(x1 => 0, y1 => 0, x2 => 99, y2=>99, color => [ 0, 0, 0 ]);
-};
-ok(!$@, "shouldn't crash")
- or print "# $@\n";
+++ /dev/null
-#!perl -w
-# Extra BMP tests not shipped
-use strict;
-use Test::More;
-use Imager::Test qw(is_image);
-use Imager;
-
-# test images from
-my @tests =
- (
- [ "g01bg.bmp", "1-bit blue/green", 0 ],
- [ "g01bw.bmp", "1-bit black and white", 0 ],
- [ "g01p1.bmp", "1-bit single colour", 0 ],
- [ "g01wb.bmp", "1-bit white and black", 0 ],
- [ "g04.bmp", "4-bit", 0 ],
- [ "g04p4.bmp", "4-bit gray", 0 ],
- [ "g04rle.bmp", "4-bit rle", "currently broken" ],
- [ "g08.bmp", "8-bit", 0 ],
- [ "g08offs.bmp", "8-bit with image data offset", 0 ],
- [ "g08os2.bmp", "8-bit OS/2", "OS/2 BMP not implemented" ],
- [ "g08p256.bmp", "8-bit, no important", 0 ],
- [ "g08p64.bmp", "8-bit, 64 greyscale entries", 0 ],
- [ "g08pi256.bmp", "8-bit 256 important", 0 ],
- [ "g08pi64.bmp", "8-bit 64 important", 0 ],
- [ "g08res11.bmp", "8-bit, 100x100 dpi", 0 ],
- [ "g08res21.bmp", "8-bit, 200x100 dpi", 0 ],
- [ "g08res22.bmp", "8-bit, 200x200 dpi", 0 ],
- [ "g08rle.bmp", "8-bit rle", 0 ],
- [ "g08s0.bmp", "8-bit, bits size not given", 0 ],
- [ "g08w124.bmp", "8-bit 124x61", 0 ],
- [ "g08w125.bmp", "8-bit 125x62", 0 ],
- [ "g08w126.bmp", "8-bit 126x63", 0 ],
- [ "g16bf555.bmp", "16-bit bitfield 555", 0 ],
- [ "g16bf565.bmp", "16-bit bitfield 565", 0 ],
- [ "g16def555.bmp", "16-bit default 555", 0 ],
- [ "g24.bmp", "24-bit", 0 ],
- [ "g32bf.bmp", "32-bit bitfields", 0 ],
- [ "g32def.bmp", "32-bit defaults", 0 ],
- [ "test32bfv4.bmp", "32-bit bitfields, v4", "v4 BMP not implemented" ],
- [ "test32v5.bmp", "32-bit, v5", "v5 BMP not implemented" ],
- [ "test4os2v2.bmp", "4-bit OS/2", "OS/2 BMP not implemented" ],
- [ "trans.bmp", "transparency", "alpha BMPs not implemented" ],
- [ "width.bmp", "odd-width rle", "currently broken" ],
- );
-
-Imager->open_log(log => "testout/x107bmp.log");
-
-plan tests => 3 * @tests;
-
-for my $test (@tests) {
- my ($in, $note, $todo) = @$test;
-
- my $im = Imager->new(file => "xtestimg/bmp/$in");
- local $TODO = $todo;
- ok($im, "load $in ($note)")
- or diag "$in: ".Imager->errstr;
- (my $alt = $in) =~ s/\.bmp$/.sgi/;
-
- my $ref = Imager->new(file => "xtestimg/bmp/$alt");
- {
- local $TODO; # should always pass
- ok($ref, "load reference image for $in")
- or diag "$alt: ".Imager->errstr;
- if ($ref->getchannels == 1) {
- $ref = $ref->convert(preset => "rgb");
- }
- }
- is_image($im, $ref, "compare $note");
-}
-
-Imager->close_log();
-
+++ /dev/null
-#!perl -w
-use strict;
-use Imager;
-use Imager::Test qw(is_image);
-use Test::More;
-
-$Imager::formats{"tiff"}
- or plan skip_all => "no tiff support";
-
--d "testout" or mkdir "testout";
-
-plan tests => 2;
-
-my $dest = Imager->new(xsize => 100, ysize => 100, channels => 4);
-$dest->box(filled => 1, color => '0000FF');
-my $src = Imager->new(xsize => 100, ysize => 100, channels => 4);
-$src->circle(color => 'FF0000', x => 50, y => 60, r => 40, aa => 1);
-ok($dest->rubthrough(src => $src, src_minx => 10, src_miny => 20, src_maxx => 90,
- tx => 10, ty => 10), "rubthrough");
-ok($dest->write(file => "testout/x11rubthru.tif"), "save it");
-
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-use ExtUtils::Manifest qw(maniread);
-use File::Temp;
-eval "use Pod::Spell 1.01";
-plan skip_all => "Pod::Spell 1.01 required for spellchecking POD" if $@;
-my $manifest = maniread();
-my @pod = sort grep !/^inc/ && /\.(pm|pl|pod|PL)$/, keys %$manifest;
-plan tests => scalar(@pod);
-my @stopwords = qw/
-API
-Arnar
-BMP
-Blit
-CGI
-chromaticities
-CMYK
-CPAN
-FreeType
-GIF
-HSV
-Hrafnkelsson
-ICO
-IMAGER
-Imager
-Imager's
-JPEG
-POSIX
-PNG
-PNM
-RGB
-RGBA
-SGI
-sRGB
-TGA
-TIFF
-UTF-8
-Uncategorized
-bilevel
-const
-dpi
-eg
-gaussian
-ie
-infix
-invocant
-metadata
-multi-threaded
-mutex
-paletted
-postfix
-preload
-preloading
-preloads
-renderer
-tuple
-unary
-unseekable
-varargs
-/;
-
-local %Pod::Wordlist::Wordlist = %Pod::Wordlist::Wordlist;
-for my $stop (@stopwords) {
- $Pod::Wordlist::Wordlist{$stop} = 1;
-}
-
-# see for example:
-# https://bugs.launchpad.net/ubuntu/+source/aspell/+bug/71322
-$ENV{LANG} = "C";
-$ENV{LC_ALL} = "C";
-for my $file (@pod) {
- my $check_fh = File::Temp->new;
- my $check_filename = $check_fh->filename;
- open POD, "< $file"
- or die "Cannot open $file for spell check: $!\n";
- Pod::Spell->new->parse_from_filehandle(\*POD, $check_fh);
- close $check_fh;
-
- my @out = `aspell list <$check_filename`;
- unless (ok(@out == 0, "spell check $file")) {
- chomp @out;
- diag $_ for @out;
- print "#----\n";
- open my $fh, "<", $check_filename;
- while (<$fh>) {
- chomp;
- print "# $_\n";
- }
- print "#----\n";
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-BEGIN {
- eval 'use Pod::Parser 1.50;';
- plan skip_all => "Pod::Parser 1.50 required for podlinkcheck" if $@;
-}
-use File::Find;
-use File::Spec::Functions qw(rel2abs abs2rel splitdir);
-
-# external stuff we refer to
-my @known =
- qw(perl Affix::Infix2Postfix Parse::RecDescent GD Image::Magick Graphics::Magick CGI Image::ExifTool XSLoader DynaLoader Prima::Image IPA PDL);
-
-# also known since we supply them, but we don't always install them
-push @known, qw(Imager::Font::FT2 Imager::Font::W32 Imager::Font::T1
- Imager::File::JPEG Imager::File::GIF Imager::File::PNG Imager::File::TIFF);
-
-my @pod; # files with pod
-
-my $base = rel2abs("blib/lib");
-
-my @files;
-find(sub {
- -f && /\.(pod|pm)$/
- and push @files, $File::Find::name;
- }, $base);
-
-my %targets = map { $_ => {} } @known;
-my %item_in;
-
-for my $file (@files) {
- my $parser = PodPreparse->new;
-
- my $link = abs2rel($file, $base);
- $link =~ s/\.(pod|pm|pl|PL)$//;
- $link = join("::", splitdir($link));
-
- $parser->{'targets'} = \%targets;
- $parser->{'link'} = $link;
- $parser->{'file'} = $file;
- $parser->{item_in} = \%item_in;
- $parser->parse_from_file($file);
- if ($targets{$link}) {
- push @pod, $file;
- }
-}
-
-plan tests => scalar(@pod);
-
-for my $file (@pod) {
- my $parser = PodLinkCheck->new;
- $parser->{"targets"} = \%targets;
- my $relfile = abs2rel($file, $base);
- (my $link = $relfile) =~ s/\.(pod|pm|pl|PL)$//;
- $link = join("::", splitdir($link));
- $parser->{"file"} = $relfile;
- $parser->{"link"} = $link;
- my @errors;
- $parser->{"errors"} = \@errors;
- $parser->{item_in} = \%item_in;
- $parser->parse_from_file($file);
-
- unless (ok(!@errors, "check links in $relfile")) {
- print STDERR "# $_\n" for @errors;
- }
-}
-
-package PodPreparse;
-BEGIN { our @ISA = qw(Pod::Parser); }
-
-sub command {
- my ($self, $cmd, $para) = @_;
-
- my $targets = $self->{"targets"};
- my $link = $self->{"link"};
- $targets->{$link} ||= {};
-
- if ($cmd =~ /^(head[1-5]|item)/) {
- $para =~ s/X<.*?>//g;
- $para =~ s/\s+$//;
- $targets->{$link}{$para} = 1;
- push @{$self->{item_in}{$para}}, $link;
- }
-}
-
-sub verbatim {}
-
-sub textblock {}
-
-package PodLinkCheck;
-BEGIN { our @ISA = qw(Pod::Parser); }
-
-sub command {}
-
-sub verbatim {}
-
-sub textblock {
- my ($self, $para, $line_num) = @_;
-
- $self->parse_text
- (
- { -expand_seq => "sequence" },
- $para, $line_num,
- );
-}
-
-sub sequence {
- my ($self, $seq) = @_;
-
- if ($seq->cmd_name eq "L") {
- my $raw = $seq->raw_text;
- my $base_link = $seq->parse_tree->raw_text;
- (my $link = $base_link) =~ s/.*\|//s;
- $link =~ /^(https?|ftp|mailto):/
- and return '';
- my ($pod, $part) = split m(/), $link, 2;
- $pod ||= $self->{link};
- if ($part) {
- $part =~ s/^\"//;
- $part =~ s/"$//;
- }
- my $targets = $self->{targets};
- my $errors = $self->{errors};
- (undef, my $line) = $seq->file_line;
-
- if (!$targets->{$pod}) {
- push @$errors, "$line: No $pod found ($raw)";
- }
- elsif ($part && !$targets{$pod}{$part}) {
- push @$errors, "$line: No item/section '$part' found in $pod ($raw)";
- if ($self->{item_in}{$part}) {
- push @$errors, " $part can be found in:";
- push @$errors, map " $_", @{$self->{item_in}{$part}};
- }
- }
- }
-
- return $seq->raw_text;
-}
-
+++ /dev/null
-#!perl -w
-#
-# Each sub-module ships with our custom Devel::CheckLib, make sure
-# they all match
-use strict;
-use Test::More;
-
-my @subs = qw(FT2 GIF JPEG PNG T1 TIFF W32);
-
-plan tests => 1 + @subs;
-
-# load the base file
-
-my $base = load("inc/Devel/CheckLib.pm");
-
-ok($base, "Loaded base file");
-
-for my $sub (@subs) {
- my $data = load("$sub/inc/Devel/CheckLib.pm");
-
- # I'd normally use is() here, but it's excessively noisy when
- # comparing this size of data
- ok(defined($data) && $data eq $base, "check $sub");
-}
-
-sub load {
- my ($filename) = @_;
-
- if (open my $f, "<", $filename) {
- my $data = do { local $/; <$f> };
- close $f;
-
- return $data;
- }
- else {
- diag "Cannot load $filename: $!\n";
- return;
- }
-}
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-use ExtUtils::MakeMaker;
-use ExtUtils::Manifest 'maniread';
-use File::Spec::Functions qw(devnull);
-
-my $last_tag = `git describe --abbrev=0`;
-chomp $last_tag;
-
-$last_tag
- or plan skip_all => "Only usable in a git checkout";
-
-my $mani = maniread();
-
-my @subdirs = qw(PNG TIFF GIF JPEG W32 T1 FT2 ICO SGI Mandelbrot CountColor DynTest);
-
-my $subdir_re = "^(?:" . join("|", @subdirs) . ")/";
-
-my @pm_files = sort
- grep /\.pm$/ && !/$subdir_re/ && !/^t\// && $_ ne 'Imager.pm', keys %$mani;
-
-plan tests => scalar(@subdirs) + scalar(@pm_files);
-
-for my $dir (@subdirs) {
- my @changes = `git log --abbrev --oneline $last_tag..HEAD $dir`;
- my @more_changes = `git status --porcelain $dir`;
- SKIP:
- {
- @changes || @more_changes
- or skip "No changes for $dir", 1;
- my $vfile = "$dir/$dir.pm";
- my $current = eval { MM->parse_version($vfile) };
- my $last_rel_content = get_file_from_git($vfile, $last_tag);
- my $last = eval { MM->parse_version(\$last_rel_content) };
- unless (isnt($current, $last, "$dir updated, $vfile version bump")) {
- diag(@changes, @more_changes);
- }
- }
-}
-
-for my $file (@pm_files) {
- my @changes = `git log --abbrev --oneline $last_tag..HEAD $file`;
- my @more_changes = `git status --porcelain $file`;
- SKIP:
- {
- @changes || @more_changes
- or skip "No changes for $file", 1;
- my $current = eval { MM->parse_version($file) };
- my $last_rel_content = get_file_from_git($file, $last_tag);
- my $last = eval { MM->parse_version(\$last_rel_content) };
- unless (isnt($current, $last, "$file updated, version bump")) {
- diag(@changes, @more_changes);
- }
- }
-}
-
-sub get_file_from_git {
- my ($file, $tag) = @_;
- my $null = devnull();
- local $/;
- return scalar `git --no-pager show $tag:$file 2>$null`;
-}
+++ /dev/null
-#!perl -w
-use strict;
-use ExtUtils::Manifest qw(maniread);
-use Test::More;
-use File::Spec;
-
-my @sub_dirs = qw(T1 FT2 W32 TIFF PNG GIF JPEG);
-
-plan tests => scalar @sub_dirs;
-
-my $base_mani = maniread();
-my @base_mani = keys %$base_mani;
-for my $sub_dir (@sub_dirs) {
- my @expected = map { my $x = $_; $x =~ s(^$sub_dir/)(); $x }
- grep /^$sub_dir\b/, @base_mani;
- push @expected,
- "MANIFEST", "MANIFEST.SKIP", "Changes", "inc/Devel/CheckLib.pm";
- @expected = sort @expected;
-
- my $found = maniread(File::Spec->catfile($sub_dir, "MANIFEST"));
- my @found = sort keys %$found;
- is_deeply(\@found, \@expected, "check sub-MANIFEST for $sub_dir");
-}
--- /dev/null
+#!perl -w
+# Extra BMP tests not shipped
+use strict;
+use Test::More;
+use Imager::Test qw(is_image);
+use Imager;
+
+# test images from
+my @tests =
+ (
+ [ "g01bg.bmp", "1-bit blue/green", 0 ],
+ [ "g01bw.bmp", "1-bit black and white", 0 ],
+ [ "g01p1.bmp", "1-bit single colour", 0 ],
+ [ "g01wb.bmp", "1-bit white and black", 0 ],
+ [ "g04.bmp", "4-bit", 0 ],
+ [ "g04p4.bmp", "4-bit gray", 0 ],
+ [ "g04rle.bmp", "4-bit rle", "currently broken" ],
+ [ "g08.bmp", "8-bit", 0 ],
+ [ "g08offs.bmp", "8-bit with image data offset", 0 ],
+ [ "g08os2.bmp", "8-bit OS/2", "OS/2 BMP not implemented" ],
+ [ "g08p256.bmp", "8-bit, no important", 0 ],
+ [ "g08p64.bmp", "8-bit, 64 greyscale entries", 0 ],
+ [ "g08pi256.bmp", "8-bit 256 important", 0 ],
+ [ "g08pi64.bmp", "8-bit 64 important", 0 ],
+ [ "g08res11.bmp", "8-bit, 100x100 dpi", 0 ],
+ [ "g08res21.bmp", "8-bit, 200x100 dpi", 0 ],
+ [ "g08res22.bmp", "8-bit, 200x200 dpi", 0 ],
+ [ "g08rle.bmp", "8-bit rle", 0 ],
+ [ "g08s0.bmp", "8-bit, bits size not given", 0 ],
+ [ "g08w124.bmp", "8-bit 124x61", 0 ],
+ [ "g08w125.bmp", "8-bit 125x62", 0 ],
+ [ "g08w126.bmp", "8-bit 126x63", 0 ],
+ [ "g16bf555.bmp", "16-bit bitfield 555", 0 ],
+ [ "g16bf565.bmp", "16-bit bitfield 565", 0 ],
+ [ "g16def555.bmp", "16-bit default 555", 0 ],
+ [ "g24.bmp", "24-bit", 0 ],
+ [ "g32bf.bmp", "32-bit bitfields", 0 ],
+ [ "g32def.bmp", "32-bit defaults", 0 ],
+ [ "test32bfv4.bmp", "32-bit bitfields, v4", "v4 BMP not implemented" ],
+ [ "test32v5.bmp", "32-bit, v5", "v5 BMP not implemented" ],
+ [ "test4os2v2.bmp", "4-bit OS/2", "OS/2 BMP not implemented" ],
+ [ "trans.bmp", "transparency", "alpha BMPs not implemented" ],
+ [ "width.bmp", "odd-width rle", "currently broken" ],
+ );
+
+Imager->open_log(log => "testout/x107bmp.log");
+
+plan tests => 3 * @tests;
+
+for my $test (@tests) {
+ my ($in, $note, $todo) = @$test;
+
+ my $im = Imager->new(file => "xtestimg/bmp/$in");
+ local $TODO = $todo;
+ ok($im, "load $in ($note)")
+ or diag "$in: ".Imager->errstr;
+ (my $alt = $in) =~ s/\.bmp$/.sgi/;
+
+ my $ref = Imager->new(file => "xtestimg/bmp/$alt");
+ {
+ local $TODO; # should always pass
+ ok($ref, "load reference image for $in")
+ or diag "$alt: ".Imager->errstr;
+ if ($ref->getchannels == 1) {
+ $ref = $ref->convert(preset => "rgb");
+ }
+ }
+ is_image($im, $ref, "compare $note");
+}
+
+Imager->close_log();
+
--- /dev/null
+#!perl -w
+use strict;
+use Imager;
+use Imager::Test qw(is_image);
+use Test::More;
+
+$Imager::formats{"tiff"}
+ or plan skip_all => "no tiff support";
+
+-d "testout" or mkdir "testout";
+
+plan tests => 2;
+
+my $dest = Imager->new(xsize => 100, ysize => 100, channels => 4);
+$dest->box(filled => 1, color => '0000FF');
+my $src = Imager->new(xsize => 100, ysize => 100, channels => 4);
+$src->circle(color => 'FF0000', x => 50, y => 60, r => 40, aa => 1);
+ok($dest->rubthrough(src => $src, src_minx => 10, src_miny => 20, src_maxx => 90,
+ tx => 10, ty => 10), "rubthrough");
+ok($dest->write(file => "testout/x11rubthru.tif"), "save it");
+
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+use ExtUtils::Manifest qw(maniread);
+use File::Temp;
+eval "use Pod::Spell 1.01";
+plan skip_all => "Pod::Spell 1.01 required for spellchecking POD" if $@;
+my $manifest = maniread();
+my @pod = sort grep !/^inc/ && /\.(pm|pl|pod|PL)$/, keys %$manifest;
+plan tests => scalar(@pod);
+my @stopwords = qw/
+API
+Arnar
+BMP
+Blit
+CGI
+chromaticities
+CMYK
+CPAN
+FreeType
+GIF
+HSV
+Hrafnkelsson
+ICO
+IMAGER
+Imager
+Imager's
+JPEG
+POSIX
+PNG
+PNM
+RGB
+RGBA
+SGI
+sRGB
+TGA
+TIFF
+UTF-8
+Uncategorized
+bilevel
+const
+dpi
+eg
+gaussian
+ie
+infix
+invocant
+metadata
+multi-threaded
+mutex
+paletted
+postfix
+preload
+preloading
+preloads
+renderer
+tuple
+unary
+unseekable
+varargs
+/;
+
+local %Pod::Wordlist::Wordlist = %Pod::Wordlist::Wordlist;
+for my $stop (@stopwords) {
+ $Pod::Wordlist::Wordlist{$stop} = 1;
+}
+
+# see for example:
+# https://bugs.launchpad.net/ubuntu/+source/aspell/+bug/71322
+$ENV{LANG} = "C";
+$ENV{LC_ALL} = "C";
+for my $file (@pod) {
+ my $check_fh = File::Temp->new;
+ my $check_filename = $check_fh->filename;
+ open POD, "< $file"
+ or die "Cannot open $file for spell check: $!\n";
+ Pod::Spell->new->parse_from_filehandle(\*POD, $check_fh);
+ close $check_fh;
+
+ my @out = `aspell list <$check_filename`;
+ unless (ok(@out == 0, "spell check $file")) {
+ chomp @out;
+ diag $_ for @out;
+ print "#----\n";
+ open my $fh, "<", $check_filename;
+ while (<$fh>) {
+ chomp;
+ print "# $_\n";
+ }
+ print "#----\n";
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+BEGIN {
+ eval 'use Pod::Parser 1.50;';
+ plan skip_all => "Pod::Parser 1.50 required for podlinkcheck" if $@;
+}
+use File::Find;
+use File::Spec::Functions qw(rel2abs abs2rel splitdir);
+
+# external stuff we refer to
+my @known =
+ qw(perl Affix::Infix2Postfix Parse::RecDescent GD Image::Magick Graphics::Magick CGI Image::ExifTool XSLoader DynaLoader Prima::Image IPA PDL);
+
+# also known since we supply them, but we don't always install them
+push @known, qw(Imager::Font::FT2 Imager::Font::W32 Imager::Font::T1
+ Imager::File::JPEG Imager::File::GIF Imager::File::PNG Imager::File::TIFF);
+
+my @pod; # files with pod
+
+my $base = rel2abs("blib/lib");
+
+my @files;
+find(sub {
+ -f && /\.(pod|pm)$/
+ and push @files, $File::Find::name;
+ }, $base);
+
+my %targets = map { $_ => {} } @known;
+my %item_in;
+
+for my $file (@files) {
+ my $parser = PodPreparse->new;
+
+ my $link = abs2rel($file, $base);
+ $link =~ s/\.(pod|pm|pl|PL)$//;
+ $link = join("::", splitdir($link));
+
+ $parser->{'targets'} = \%targets;
+ $parser->{'link'} = $link;
+ $parser->{'file'} = $file;
+ $parser->{item_in} = \%item_in;
+ $parser->parse_from_file($file);
+ if ($targets{$link}) {
+ push @pod, $file;
+ }
+}
+
+plan tests => scalar(@pod);
+
+for my $file (@pod) {
+ my $parser = PodLinkCheck->new;
+ $parser->{"targets"} = \%targets;
+ my $relfile = abs2rel($file, $base);
+ (my $link = $relfile) =~ s/\.(pod|pm|pl|PL)$//;
+ $link = join("::", splitdir($link));
+ $parser->{"file"} = $relfile;
+ $parser->{"link"} = $link;
+ my @errors;
+ $parser->{"errors"} = \@errors;
+ $parser->{item_in} = \%item_in;
+ $parser->parse_from_file($file);
+
+ unless (ok(!@errors, "check links in $relfile")) {
+ print STDERR "# $_\n" for @errors;
+ }
+}
+
+package PodPreparse;
+BEGIN { our @ISA = qw(Pod::Parser); }
+
+sub command {
+ my ($self, $cmd, $para) = @_;
+
+ my $targets = $self->{"targets"};
+ my $link = $self->{"link"};
+ $targets->{$link} ||= {};
+
+ if ($cmd =~ /^(head[1-5]|item)/) {
+ $para =~ s/X<.*?>//g;
+ $para =~ s/\s+$//;
+ $targets->{$link}{$para} = 1;
+ push @{$self->{item_in}{$para}}, $link;
+ }
+}
+
+sub verbatim {}
+
+sub textblock {}
+
+package PodLinkCheck;
+BEGIN { our @ISA = qw(Pod::Parser); }
+
+sub command {}
+
+sub verbatim {}
+
+sub textblock {
+ my ($self, $para, $line_num) = @_;
+
+ $self->parse_text
+ (
+ { -expand_seq => "sequence" },
+ $para, $line_num,
+ );
+}
+
+sub sequence {
+ my ($self, $seq) = @_;
+
+ if ($seq->cmd_name eq "L") {
+ my $raw = $seq->raw_text;
+ my $base_link = $seq->parse_tree->raw_text;
+ (my $link = $base_link) =~ s/.*\|//s;
+ $link =~ /^(https?|ftp|mailto):/
+ and return '';
+ my ($pod, $part) = split m(/), $link, 2;
+ $pod ||= $self->{link};
+ if ($part) {
+ $part =~ s/^\"//;
+ $part =~ s/"$//;
+ }
+ my $targets = $self->{targets};
+ my $errors = $self->{errors};
+ (undef, my $line) = $seq->file_line;
+
+ if (!$targets->{$pod}) {
+ push @$errors, "$line: No $pod found ($raw)";
+ }
+ elsif ($part && !$targets{$pod}{$part}) {
+ push @$errors, "$line: No item/section '$part' found in $pod ($raw)";
+ if ($self->{item_in}{$part}) {
+ push @$errors, " $part can be found in:";
+ push @$errors, map " $_", @{$self->{item_in}{$part}};
+ }
+ }
+ }
+
+ return $seq->raw_text;
+}
+
--- /dev/null
+#!perl -w
+#
+# Each sub-module ships with our custom Devel::CheckLib, make sure
+# they all match
+use strict;
+use Test::More;
+
+my @subs = qw(FT2 GIF JPEG PNG T1 TIFF W32);
+
+plan tests => 1 + @subs;
+
+# load the base file
+
+my $base = load("inc/Devel/CheckLib.pm");
+
+ok($base, "Loaded base file");
+
+for my $sub (@subs) {
+ my $data = load("$sub/inc/Devel/CheckLib.pm");
+
+ # I'd normally use is() here, but it's excessively noisy when
+ # comparing this size of data
+ ok(defined($data) && $data eq $base, "check $sub");
+}
+
+sub load {
+ my ($filename) = @_;
+
+ if (open my $f, "<", $filename) {
+ my $data = do { local $/; <$f> };
+ close $f;
+
+ return $data;
+ }
+ else {
+ diag "Cannot load $filename: $!\n";
+ return;
+ }
+}
--- /dev/null
+#!perl -w
+use strict;
+use Test::More;
+use ExtUtils::MakeMaker;
+use ExtUtils::Manifest 'maniread';
+use File::Spec::Functions qw(devnull);
+
+my $last_tag = `git describe --abbrev=0`;
+chomp $last_tag;
+
+$last_tag
+ or plan skip_all => "Only usable in a git checkout";
+
+my $mani = maniread();
+
+my @subdirs = qw(PNG TIFF GIF JPEG W32 T1 FT2 ICO SGI Mandelbrot CountColor DynTest);
+
+my $subdir_re = "^(?:" . join("|", @subdirs) . ")/";
+
+my @pm_files = sort
+ grep /\.pm$/ && !/$subdir_re/ && !/^t\// && $_ ne 'Imager.pm', keys %$mani;
+
+plan tests => scalar(@subdirs) + scalar(@pm_files);
+
+for my $dir (@subdirs) {
+ my @changes = `git log --abbrev --oneline $last_tag..HEAD $dir`;
+ my @more_changes = `git status --porcelain $dir`;
+ SKIP:
+ {
+ @changes || @more_changes
+ or skip "No changes for $dir", 1;
+ my $vfile = "$dir/$dir.pm";
+ my $current = eval { MM->parse_version($vfile) };
+ my $last_rel_content = get_file_from_git($vfile, $last_tag);
+ my $last = eval { MM->parse_version(\$last_rel_content) };
+ unless (isnt($current, $last, "$dir updated, $vfile version bump")) {
+ diag(@changes, @more_changes);
+ }
+ }
+}
+
+for my $file (@pm_files) {
+ my @changes = `git log --abbrev --oneline $last_tag..HEAD $file`;
+ my @more_changes = `git status --porcelain $file`;
+ SKIP:
+ {
+ @changes || @more_changes
+ or skip "No changes for $file", 1;
+ my $current = eval { MM->parse_version($file) };
+ my $last_rel_content = get_file_from_git($file, $last_tag);
+ my $last = eval { MM->parse_version(\$last_rel_content) };
+ unless (isnt($current, $last, "$file updated, version bump")) {
+ diag(@changes, @more_changes);
+ }
+ }
+}
+
+sub get_file_from_git {
+ my ($file, $tag) = @_;
+ my $null = devnull();
+ local $/;
+ return scalar `git --no-pager show $tag:$file 2>$null`;
+}
--- /dev/null
+#!perl -w
+use strict;
+use ExtUtils::Manifest qw(maniread);
+use Test::More;
+use File::Spec;
+
+my @sub_dirs = qw(T1 FT2 W32 TIFF PNG GIF JPEG);
+
+plan tests => scalar @sub_dirs;
+
+my $base_mani = maniread();
+my @base_mani = keys %$base_mani;
+for my $sub_dir (@sub_dirs) {
+ my @expected = map { my $x = $_; $x =~ s(^$sub_dir/)(); $x }
+ grep /^$sub_dir\b/, @base_mani;
+ push @expected,
+ "MANIFEST", "MANIFEST.SKIP", "Changes", "inc/Devel/CheckLib.pm";
+ @expected = sort @expected;
+
+ my $found = maniread(File::Spec->catfile($sub_dir, "MANIFEST"));
+ my @found = sort keys %$found;
+ is_deeply(\@found, \@expected, "check sub-MANIFEST for $sub_dir");
+}
projects / imager.git / commitdiff