ensure alpha channels are initialized for mediancut make_colors
[imager.git] / t / 150-type / 040-palette.t
CommitLineData
1501d9b3
TC
1#!perl -w
2# some of this is tested in t01introvert.t too
3use strict;
a3b721bb 4use Test::More;
9676c1d1 5BEGIN { use_ok("Imager", ':handy'); }
1501d9b3 6
93eab01e 7use Imager::Test qw(image_bounds_checks test_image is_color3 isnt_image is_color4 is_fcolor3);
837a4b43 8
cc59eadc
TC
9Imager->open_log(log => "testout/t023palette.log");
10
4cda4e76
TC
11sub isbin($$$);
12
1501d9b3
TC
13my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
14
61753090 15ok($img, "paletted image created");
1501d9b3 16
5386861e 17is($img->type, 'paletted', "got a paletted image");
1501d9b3
TC
18
19my $black = Imager::Color->new(0,0,0);
20my $red = Imager::Color->new(255,0,0);
21my $green = Imager::Color->new(0,255,0);
22my $blue = Imager::Color->new(0,0,255);
23
24my $white = Imager::Color->new(255,255,255);
25
26# add some color
27my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
28
29print "# blacki $blacki\n";
61753090 30ok(defined $blacki && $blacki == 0, "we got the first color");
1501d9b3 31
1136f089
TC
32is($img->colorcount(), 4, "should have 4 colors");
33is($img->maxcolors, 256, "maxcolors always 256");
34
1501d9b3
TC
35my ($redi, $greeni, $bluei) = 1..3;
36
37my @all = $img->getcolors;
61753090 38ok(@all == 4, "all colors is 4");
1501d9b3
TC
39coloreq($all[0], $black, "first black");
40coloreq($all[1], $red, "then red");
41coloreq($all[2], $green, "then green");
42coloreq($all[3], $blue, "and finally blue");
43
44# keep this as an assignment, checking for scalar context
45# we don't want the last color, otherwise if the behaviour changes to
46# get all up to the last (count defaulting to size-index) we'd get a
47# false positive
48my $one_color = $img->getcolors(start=>$redi);
61753090 49ok($one_color->isa('Imager::Color'), "check scalar context");
1501d9b3
TC
50coloreq($one_color, $red, "and that it's what we want");
51
52# make sure we can find colors
61753090 53ok(!defined($img->findcolor(color=>$white)),
1501d9b3 54 "shouldn't be able to find white");
61753090
TC
55ok($img->findcolor(color=>$black) == $blacki, "find black");
56ok($img->findcolor(color=>$red) == $redi, "find red");
57ok($img->findcolor(color=>$green) == $greeni, "find green");
58ok($img->findcolor(color=>$blue) == $bluei, "find blue");
1501d9b3
TC
59
60# various failure tests for setcolors
61753090 61ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
1501d9b3 62 "expect failure: low index");
61753090 63ok(!defined($img->setcolors(start=>1, colors=>[])),
1501d9b3 64 "expect failure: no colors");
61753090 65ok(!defined($img->setcolors(start=>5, colors=>[$white])),
1501d9b3
TC
66 "expect failure: high index");
67
68# set the green index to white
61753090 69ok($img->setcolors(start => $greeni, colors => [$white]),
1501d9b3
TC
70 "set a color");
71# and check it
72coloreq(scalar($img->getcolors(start=>$greeni)), $white,
73 "make sure it was set");
61753090
TC
74ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
75ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
1501d9b3
TC
76
77# write a few colors
61753090 78ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
1501d9b3
TC
79 "save multiple");
80coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
81coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
82
83# put it back
84$img->setcolors(start=>$red, colors=>[$red, $green]);
85
86# draw on the image, make sure it stays paletted when it should
61753090 87ok($img->box(color=>$red, filled=>1), "fill with red");
5386861e 88is($img->type, 'paletted', "paletted after fill");
61753090 89ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
1501d9b3 90 xmax=>40, ymax=>40), "green box");
5386861e 91is($img->type, 'paletted', 'still paletted after box');
1501d9b3
TC
92# an AA line will almost certainly convert the image to RGB, don't use
93# an AA line here
61753090 94ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
1501d9b3 95 "draw a line");
5386861e 96is($img->type, 'paletted', 'still paletted after line');
1501d9b3
TC
97
98# draw with white - should convert to direct
61753090 99ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
1501d9b3 100 xmax=>30, ymax=>30), "white box");
5386861e 101is($img->type, 'direct', "now it should be direct");
1501d9b3
TC
102
103# various attempted to make a paletted image from our now direct image
104my $palimg = $img->to_paletted;
61753090 105ok($palimg, "we got an image");
1501d9b3 106# they should be the same pixel for pixel
61753090 107ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
1501d9b3
TC
108
109# strange case: no color picking, and no colors
110# this was causing a segmentation fault
111$palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
61753090 112ok(!defined $palimg, "to paletted with an empty palette is an error");
1501d9b3 113print "# ",$img->errstr,"\n";
61753090 114ok(scalar($img->errstr =~ /no colors available for translation/),
1501d9b3
TC
115 "and got the correct msg");
116
61753090 117ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
1501d9b3 118 "fail on -ve height");
61753090 119cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 120 "and correct error message");
61753090 121ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
1501d9b3 122 "fail on -ve width");
61753090 123cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 124 "and correct error message");
61753090 125ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
1501d9b3 126 "fail on -ve width/height");
61753090 127cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3
TC
128 "and correct error message");
129
61753090 130ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
1501d9b3 131 "fail on 0 channels");
61753090 132cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
1501d9b3 133 "and correct error message");
61753090 134ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
1501d9b3 135 "fail on 5 channels");
61753090 136cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
1501d9b3
TC
137 "and correct error message");
138
653ea321
TC
139{
140 # https://rt.cpan.org/Ticket/Display.html?id=8213
141 # check for handling of memory allocation of very large images
142 # only test this on 32-bit machines - on a 64-bit machine it may
143 # result in trying to allocate 4Gb of memory, which is unfriendly at
144 # least and may result in running out of memory, causing a different
145 # type of exit
146 use Config;
61753090
TC
147 SKIP:
148 {
f0960b14 149 skip("don't want to allocate 4Gb", 10)
8d14daab 150 unless $Config{ptrsize} == 4;
61753090 151
f8906310 152 my $uint_range = 256 ** $Config{intsize};
653ea321
TC
153 my $dim1 = int(sqrt($uint_range))+1;
154
155 my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
61753090 156 is($im_b, undef, "integer overflow check - 1 channel");
653ea321
TC
157
158 $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
61753090 159 ok($im_b, "but same width ok");
653ea321 160 $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
61753090
TC
161 ok($im_b, "but same height ok");
162 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
653ea321
TC
163 "check the error message");
164
165 # do a similar test with a 3 channel image, so we're sure we catch
166 # the same case where the third dimension causes the overflow
167 # for paletted images the third dimension can't cause an overflow
168 # but make sure we didn't anything too dumb in the checks
169 my $dim3 = $dim1;
170
171 $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
61753090 172 is($im_b, undef, "integer overflow check - 3 channel");
653ea321 173
f0960b14 174 $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
61753090 175 ok($im_b, "but same width ok");
f0960b14 176 $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
61753090 177 ok($im_b, "but same height ok");
653ea321 178
61753090 179 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
653ea321 180 "check the error message");
f0960b14
TC
181
182 # test the scanline allocation check
183 # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
184 # doesn't integer overflow, but the scanline of i_color (4/pixel) does
8d14daab 185 my $dim4 = $uint_range / 3;
f0960b14
TC
186 my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
187 is($im_o, undef, "integer overflow check - scanline size");
188 cmp_ok(Imager->errstr, '=~',
189 qr/integer overflow calculating scanline allocation/,
190 "check error message");
653ea321 191 }
653ea321
TC
192}
193
34b3f7e6
TC
194{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
195 my $warning;
196 local $SIG{__WARN__} =
197 sub {
198 $warning = "@_";
199 my $printed = $warning;
200 $printed =~ s/\n$//;
201 $printed =~ s/\n/\n\#/g;
202 print "# ",$printed, "\n";
203 };
204 my $img = Imager->new(xsize=>10, ysize=>10);
205 $img->to_paletted();
206 cmp_ok($warning, '=~', 'void', "correct warning");
5664d5c8 207 cmp_ok($warning, '=~', 'palette\\.t', "correct file");
34b3f7e6
TC
208}
209
8efd1577
TC
210{ # http://rt.cpan.org/NoAuth/Bug.html?id=12676
211 # setcolors() has a fencepost error
212 my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
213
214 is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
215 "add test colors");
216 ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
217 ok(!$img->setcolors(start=>2, colors=>[ $black ]),
218 "set after the last color");
219}
220
32b97571
TC
221{ # https://rt.cpan.org/Ticket/Display.html?id=20056
222 # added named color support to addcolor/setcolor
223 my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
224 is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
225 "add colors as strings instead of objects");
226 my @colors = $img->getcolors;
227 iscolor($colors[0], $black, "check first color");
228 iscolor($colors[1], $red, "check second color");
229 ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
230 "setcolors as strings instead of objects");
231 @colors = $img->getcolors;
232 iscolor($colors[0], $green, "check first color");
233 iscolor($colors[1], $blue, "check second color");
c5fa077c
TC
234
235 # make sure we handle bad colors correctly
236 is($img->colorcount, 2, "start from a known state");
237 is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
238 "fail to add unknown color");
239 is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
240 is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
241 "fail to set to unknown color");
242 is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
32b97571
TC
243}
244
4cda4e76
TC
245{ # https://rt.cpan.org/Ticket/Display.html?id=20338
246 # OO interface to i_glin/i_plin
247 my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
248 is($im->addcolors(colors => [ "#000", "#F00", "#0F0", "#00F" ]), "0 but true",
249 "add some test colors")
250 or print "# ", $im->errstr, "\n";
251 # set a pixel to check
252 $im->setpixel(x => 1, 'y' => 0, color => "#0F0");
253 is_deeply([ $im->getscanline('y' => 0, type=>'index') ],
254 [ 0, 2, (0) x 8 ], "getscanline index in list context");
255 isbin($im->getscanline('y' => 0, type=>'index'),
256 "\x00\x02" . "\x00" x 8,
257 "getscanline index in scalar context");
258 is($im->setscanline('y' => 0, pixels => [ 1, 2, 0, 3 ], type => 'index'),
259 4, "setscanline with list");
260 is($im->setscanline('y' => 0, x => 4, pixels => pack("C*", 3, 2, 1, 0, 3),
261 type => 'index'),
262 5, "setscanline with pv");
263 is_deeply([ $im->getscanline(type => 'index', 'y' => 0) ],
264 [ 1, 2, 0, 3, 3, 2, 1, 0, 3, 0 ],
265 "check values set");
266 eval { # should croak on OOR index
267 $im->setscanline('y' => 1, pixels => [ 255 ], type=>'index');
268 };
269 ok($@, "croak on setscanline() to invalid index");
270 eval { # same again with pv
271 $im->setscanline('y' => 1, pixels => "\xFF", type => 'index');
272 };
273 ok($@, "croak on setscanline() with pv to invalid index");
274}
275
21dd0ebb
TC
276{
277 print "# make_colors => mono\n";
278 # test mono make_colors
279 my $imrgb = Imager->new(xsize => 10, ysize => 10);
280 $imrgb->setpixel(x => 0, 'y' => 0, color => '#FFF');
281 $imrgb->setpixel(x => 1, 'y' => 0, color => '#FF0');
282 $imrgb->setpixel(x => 2, 'y' => 0, color => '#000');
283 my $mono = $imrgb->to_paletted(make_colors => 'mono',
284 translate => 'closest');
285 is($mono->type, 'paletted', "check we get right image type");
286 is($mono->colorcount, 2, "only 2 colors");
bd8052a6
TC
287 my ($is_mono, $ziw) = $mono->is_bilevel;
288 ok($is_mono, "check monochrome check true");
289 is($ziw, 0, "check ziw false");
21dd0ebb
TC
290 my @colors = $mono->getcolors;
291 iscolor($colors[0], $black, "check first entry");
292 iscolor($colors[1], $white, "check second entry");
293 my @pixels = $mono->getscanline(x => 0, 'y' => 0, width => 3, type=>'index');
294 is($pixels[0], 1, "check white pixel");
295 is($pixels[1], 1, "check yellow pixel");
296 is($pixels[2], 0, "check black pixel");
297}
298
bd8052a6
TC
299{ # check for the various mono images we accept
300 my $mono_8_bw_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
301 type => 'paletted');
302 ok($mono_8_bw_3->addcolors(colors => [ qw/000000 FFFFFF/ ]),
303 "mono8bw3 - add colors");
304 ok($mono_8_bw_3->is_bilevel, "it's mono");
305 is(($mono_8_bw_3->is_bilevel)[1], 0, 'zero not white');
306
307 my $mono_8_wb_3 = Imager->new(xsize => 2, ysize => 2, channels => 3,
308 type => 'paletted');
309 ok($mono_8_wb_3->addcolors(colors => [ qw/FFFFFF 000000/ ]),
310 "mono8wb3 - add colors");
311 ok($mono_8_wb_3->is_bilevel, "it's mono");
312 is(($mono_8_wb_3->is_bilevel)[1], 1, 'zero is white');
313
314 my $mono_8_bw_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
315 type => 'paletted');
316 ok($mono_8_bw_1->addcolors(colors => [ qw/000000 FFFFFF/ ]),
317 "mono8bw - add colors");
318 ok($mono_8_bw_1->is_bilevel, "it's mono");
319 is(($mono_8_bw_1->is_bilevel)[1], 0, 'zero not white');
320
321 my $mono_8_wb_1 = Imager->new(xsize => 2, ysize => 2, channels => 1,
322 type => 'paletted');
323 ok($mono_8_wb_1->addcolors(colors => [ qw/FFFFFF 000000/ ]),
324 "mono8wb - add colors");
325 ok($mono_8_wb_1->is_bilevel, "it's mono");
326 is(($mono_8_wb_1->is_bilevel)[1], 1, 'zero is white');
327}
328
837a4b43
TC
329{ # check bounds checking
330 my $im = Imager->new(xsize => 10, ysize => 10, type=>'paletted');
331 ok($im->addcolors(colors => [ $black ]), "add color of pixel bounds check writes");
332
333 image_bounds_checks($im);
334}
335
5c0d0ddf
TC
336{ # test colors array returns colors
337 my $data;
338 my $im = test_image();
339 my @colors;
340 my $imp = $im->to_paletted(colors => \@colors,
341 make_colors => 'webmap',
342 translate => 'closest');
343 ok($imp, "made paletted");
344 is(@colors, 216, "should be 216 colors in the webmap");
345 is_color3($colors[0], 0, 0, 0, "first should be 000000");
346 is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
347 is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
348}
349
6d068d36
TC
350{ # RT 68508
351 my $im = Imager->new(xsize => 10, ysize => 10);
352 $im->box(filled => 1, color => Imager::Color->new(255, 0, 0));
353 my $palim = $im->to_paletted(make_colors => "mono", translate => "errdiff");
354 ok($palim, "convert to mono with error diffusion");
355 my $blank = Imager->new(xsize => 10, ysize => 10);
356 isnt_image($palim, $blank, "make sure paletted isn't all black");
357}
358
ebe9b189
TC
359{ # check validation of palette entries
360 my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
361 $im->addcolors(colors => [ $black, $red ]);
362 {
363 my $no_croak = eval {
364 $im->setscanline(y => 0, type => 'index', pixels => [ 0, 1 ]);
365 1;
366 };
367 ok($no_croak, "valid values don't croak");
368 }
369 {
370 my $no_croak = eval {
371 $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 0, 1));
372 1;
373 };
374 ok($no_croak, "valid values don't croak (packed)");
375 }
376 {
377 my $no_croak = eval {
378 $im->setscanline(y => 0, type => 'index', pixels => [ 2, 255 ]);
379 1;
380 };
381 ok(!$no_croak, "invalid values do croak");
382 }
383 {
384 my $no_croak = eval {
385 $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 2, 255));
386 1;
387 };
388 ok(!$no_croak, "invalid values do croak (packed)");
389 }
390}
391
5e9a7fbd
TC
392{
393 my $im = Imager->new(xsize => 1, ysize => 1);
394 my $im_bad = Imager->new;
395 {
396 my @map = Imager->make_palette({});
397 ok(!@map, "make_palette should fail with no images");
398 is(Imager->errstr, "make_palette: supply at least one image",
399 "check error message");
400 }
401 {
402 my @map = Imager->make_palette({}, $im, $im_bad, $im);
403 ok(!@map, "make_palette should fail with an empty image");
404 is(Imager->errstr, "make_palette: image 2 is empty",
405 "check error message");
406 }
407 {
408 my @map = Imager->make_palette({ make_colors => "mono" }, $im);
409 is(@map, 2, "mono should make 2 color palette")
410 or skip("unexpected color count", 2);
411 is_color4($map[0], 0, 0, 0, 255, "check map[0]");
412 is_color4($map[1], 255, 255, 255, 255, "check map[1]");
413 }
414 {
415 my @map = Imager->make_palette({ make_colors => "gray4" }, $im);
416 is(@map, 4, "gray4 should make 4 color palette")
417 or skip("unexpected color count", 4);
418 is_color4($map[0], 0, 0, 0, 255, "check map[0]");
419 is_color4($map[1], 85, 85, 85, 255, "check map[1]");
420 is_color4($map[2], 170, 170, 170, 255, "check map[2]");
421 is_color4($map[3], 255, 255, 255, 255, "check map[3]");
422 }
423 {
424 my @map = Imager->make_palette({ make_colors => "gray16" }, $im);
425 is(@map, 16, "gray16 should make 16 color palette")
426 or skip("unexpected color count", 4);
427 is_color4($map[0], 0, 0, 0, 255, "check map[0]");
428 is_color4($map[1], 17, 17, 17, 255, "check map[1]");
429 is_color4($map[2], 34, 34, 34, 255, "check map[2]");
430 is_color4($map[15], 255, 255, 255, 255, "check map[15]");
431 }
432 {
433 my @map = Imager->make_palette({ make_colors => "gray" }, $im);
434 is(@map, 256, "gray16 should make 256 color palette")
435 or skip("unexpected color count", 4);
436 is_color4($map[0], 0, 0, 0, 255, "check map[0]");
437 is_color4($map[1], 1, 1, 1, 255, "check map[1]");
438 is_color4($map[33], 33, 33, 33, 255, "check map[2]");
439 is_color4($map[255], 255, 255, 255, 255, "check map[15]");
440 }
a3b721bb
TC
441 {
442 my @map = Imager->make_palette({ make_colors => "xxx" }, $im);
443 is(@map, 0, "fail with bad make_colors");
444 is(Imager->errstr, "unknown value 'xxx' for make_colors");
445 }
5e9a7fbd
TC
446}
447
9676c1d1
TC
448my $psamp_outside_error = "Image position outside of image";
449{ # psamp
450 print "# psamp\n";
451 my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
452 my @colors =
453 (
454 NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
455 NC(64, 0, 192), NC(255, 128, 0), NC(64, 32, 0),
456 NC(128, 63, 32), NC(255, 128, 32), NC(64, 32, 16),
457 );
458 is(Imager::i_addcolors($imraw, @colors), "0 but true",
459 "add colors needed for testing");
460 {
461 is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
462 "i_psamp def channels, 3 samples");
463 is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
464 "check color written");
465 Imager::i_img_setmask($imraw, 5);
466 is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
467 "i_psamp def channels, 3 samples, masked");
468 is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
469 "check color written");
470 is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
471 "i_psamp channels listed, 3 samples, masked");
472 is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
473 "check color written");
474 Imager::i_img_setmask($imraw, ~0);
475 is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
476 "i_psamp channels [0, 1], 4 samples");
477 is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
478 "check first color written");
479 is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
480 "check second color written");
481 is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
482 "write a full row");
483 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
484 [ (128, 63, 32) x 10 ],
485 "check full row");
486 is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
487 [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
488 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
489 }
490 { # errors we catch
491 is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
492 undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
493 is(_get_error(), "No channel 3 in this image",
494 "check error message");
495 is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
496 undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
497 is(_get_error(), "No channel -1 in this image",
498 "check error message");
499 is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
500 "negative y");
501 is(_get_error(), $psamp_outside_error, "check message");
502 is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
503 "y overflow");
504 is(_get_error(), $psamp_outside_error, "check message");
505 is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
506 "negative x");
507 is(_get_error(), $psamp_outside_error, "check message");
508 is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
509 "x overflow");
510 is(_get_error(), $psamp_outside_error, "check message");
511 }
512 ok(Imager::i_img_type($imraw), "still paletted");
513 print "# end psamp tests\n";
514}
515
516{ # psampf
517 print "# psampf\n";
518 my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
519 my @colors =
520 (
29b38678
TC
521 NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
522 NC(64, 0, 191), NC(255, 128, 0), NC(64, 32, 0),
523 NC(128, 64, 32), NC(255, 128, 32), NC(64, 32, 16),
9676c1d1
TC
524 );
525 is(Imager::i_addcolors($imraw, @colors), "0 but true",
526 "add colors needed for testing");
527 {
528 is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
529 "i_psampf def channels, 3 samples");
29b38678 530 is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
9676c1d1
TC
531 "check color written");
532 Imager::i_img_setmask($imraw, 5);
533 is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
534 "i_psampf def channels, 3 samples, masked");
29b38678 535 is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
9676c1d1
TC
536 "check color written");
537 is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
538 "i_psampf channels listed, 3 samples, masked");
29b38678 539 is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
9676c1d1
TC
540 "check color written");
541 Imager::i_img_setmask($imraw, ~0);
542 is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
543 "i_psampf channels [0, 1], 4 samples");
29b38678 544 is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
9676c1d1 545 "check first color written");
29b38678 546 is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
9676c1d1
TC
547 "check second color written");
548 is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
549 "write a full row");
550 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
29b38678 551 [ (128, 64, 32) x 10 ],
9676c1d1
TC
552 "check full row");
553 is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
554 [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
555 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
556 }
557 { # errors we catch
558 is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
559 undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
560 is(_get_error(), "No channel 3 in this image",
561 "check error message");
562 is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
563 undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
564 is(_get_error(), "No channel -1 in this image",
565 "check error message");
566 is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
567 "negative y");
568 is(_get_error(), $psamp_outside_error, "check message");
569 is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
570 "y overflow");
571 is(_get_error(), $psamp_outside_error, "check message");
572 is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
573 "negative x");
574 is(_get_error(), $psamp_outside_error, "check message");
575 is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
576 "x overflow");
577 is(_get_error(), $psamp_outside_error, "check message");
578 }
579 ok(Imager::i_img_type($imraw), "still paletted");
580 print "# end psampf tests\n";
581}
582
93eab01e
TC
583{ # 75258 - gpixf() broken for paletted images
584 my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
585 ok($im, "make a test image");
586 my @colors = ( $black, $red, $green, $blue );
587 is($im->addcolors(colors => \@colors), "0 but true",
588 "add some colors");
589 $im->setpixel(x => 0, y => 0, color => $red);
590 $im->setpixel(x => 1, y => 0, color => $green);
591 $im->setpixel(x => 2, y => 0, color => $blue);
592 is_fcolor3($im->getpixel(x => 0, y => 0, type => "float"),
593 1.0, 0, 0, "get a pixel in float form, make sure it's red");
594 is_fcolor3($im->getpixel(x => 1, y => 0, type => "float"),
595 0, 1.0, 0, "get a pixel in float form, make sure it's green");
596 is_fcolor3($im->getpixel(x => 2, y => 0, type => "float"),
597 0, 0, 1.0, "get a pixel in float form, make sure it's blue");
598}
599
1136f089
TC
600{
601 my $empty = Imager->new;
602 ok(!$empty->to_paletted, "can't convert an empty image");
603 is($empty->errstr, "to_paletted: empty input image",
604 "check error message");
605
606 is($empty->addcolors(colors => [ $black ]), -1,
607 "can't addcolors() to an empty image");
608 is($empty->errstr, "addcolors: empty input image",
609 "check error message");
610
611 ok(!$empty->setcolors(colors => [ $black ]),
612 "can't setcolors() to an empty image");
613 is($empty->errstr, "setcolors: empty input image",
614 "check error message");
615
616 ok(!$empty->getcolors(),
617 "can't getcolors() from an empty image");
618 is($empty->errstr, "getcolors: empty input image",
619 "check error message");
620
621 is($empty->colorcount, -1, "can't colorcount() an empty image");
622 is($empty->errstr, "colorcount: empty input image",
623 "check error message");
624
625 is($empty->maxcolors, -1, "can't maxcolors() an empty image");
626 is($empty->errstr, "maxcolors: empty input image",
627 "check error message");
628
629 is($empty->findcolor(color => $blue), undef,
630 "can't findcolor an empty image");
631 is($empty->errstr, "findcolor: empty input image",
632 "check error message");
633}
634
a3b721bb
TC
635{
636 # check error handling with zero error diffusion matrix
637 my $im = test_image;
638 my $new = $im->to_paletted
639 (
640 make_colors => "webmap",
641 translate => "errdiff",
642 errdiff => "custom",
643 errdiff_width => 2,
644 errdiff_height => 2,
645 errdiff_map => [ 0, 0, 0, 0 ],
646 );
647 ok(!$new, "can't errdiff with an all zero map");
648 is($im->errstr, "error diffusion map must contain some non-zero values",
649 "check error message");
650}
651
7cbdbb3e
TC
652{
653 # https://rt.cpan.org/Ticket/Display.html?id=132237
654 # a 4 channel opaque image with a default to_paletted would
655 # return palette values with non-max alpha values
656 my $im = test_image()->convert(preset => 'addalpha')->to_paletted;
657 my @col = $im->getcolors;
658 is($im->getchannels, 4, "still 4 channels");
659 is($col[0]->alpha, 255, "should have a 255 alpha");
660}
661
cc59eadc
TC
662Imager->close_log;
663
a3b721bb
TC
664done_testing();
665
cc59eadc
TC
666unless ($ENV{IMAGER_KEEP_FILES}) {
667 unlink "testout/t023palette.log"
668}
669
32b97571
TC
670sub iscolor {
671 my ($c1, $c2, $msg) = @_;
672
673 my $builder = Test::Builder->new;
674 my @c1 = $c1->rgba;
675 my @c2 = $c2->rgba;
676 if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
677 $msg)) {
678 $builder->diag(<<DIAG);
679 got color: [ @c1 ]
680 expected color: [ @c2 ]
681DIAG
682 }
683}
684
4cda4e76
TC
685sub isbin ($$$) {
686 my ($got, $expected, $msg) = @_;
687
688 my $builder = Test::Builder->new;
689 if (!$builder->ok($got eq $expected, $msg)) {
690 (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
691 (my $exp_dec = $expected) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
692 $builder->diag(<<DIAG);
693 got: "$got_dec"
694 expected: "$exp_dec"
695DIAG
696 }
697}
698
1501d9b3
TC
699sub coloreq {
700 my ($left, $right, $comment) = @_;
701
702 my ($rl, $gl, $bl, $al) = $left->rgba;
703 my ($rr, $gr, $br, $ar) = $right->rgba;
704
705 print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
61753090 706 ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
1501d9b3
TC
707 $comment);
708}
709
9676c1d1
TC
710sub _get_error {
711 my @errors = Imager::i_errors();
712 return join(": ", map $_->[0], @errors);
713}