ensure alpha channels are initialized for mediancut make_colors
[imager.git] / t / 150-type / 040-palette.t
1 #!perl -w
2 # some of this is tested in t01introvert.t too
3 use strict;
4 use Test::More;
5 BEGIN { use_ok("Imager", ':handy'); }
6
7 use Imager::Test qw(image_bounds_checks test_image is_color3 isnt_image is_color4 is_fcolor3);
8
9 Imager->open_log(log => "testout/t023palette.log");
10
11 sub isbin($$$);
12
13 my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
14
15 ok($img, "paletted image created");
16
17 is($img->type, 'paletted', "got a paletted image");
18
19 my $black = Imager::Color->new(0,0,0);
20 my $red = Imager::Color->new(255,0,0);
21 my $green = Imager::Color->new(0,255,0);
22 my $blue = Imager::Color->new(0,0,255);
23
24 my $white = Imager::Color->new(255,255,255);
25
26 # add some color
27 my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
28
29 print "# blacki $blacki\n";
30 ok(defined $blacki && $blacki == 0, "we got the first color");
31
32 is($img->colorcount(), 4, "should have 4 colors");
33 is($img->maxcolors, 256, "maxcolors always 256");
34
35 my ($redi, $greeni, $bluei) = 1..3;
36
37 my @all = $img->getcolors;
38 ok(@all == 4, "all colors is 4");
39 coloreq($all[0], $black, "first black");
40 coloreq($all[1], $red, "then red");
41 coloreq($all[2], $green, "then green");
42 coloreq($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
48 my $one_color = $img->getcolors(start=>$redi);
49 ok($one_color->isa('Imager::Color'), "check scalar context");
50 coloreq($one_color, $red, "and that it's what we want");
51
52 # make sure we can find colors
53 ok(!defined($img->findcolor(color=>$white)), 
54     "shouldn't be able to find white");
55 ok($img->findcolor(color=>$black) == $blacki, "find black");
56 ok($img->findcolor(color=>$red) == $redi, "find red");
57 ok($img->findcolor(color=>$green) == $greeni, "find green");
58 ok($img->findcolor(color=>$blue) == $bluei, "find blue");
59
60 # various failure tests for setcolors
61 ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
62     "expect failure: low index");
63 ok(!defined($img->setcolors(start=>1, colors=>[])),
64     "expect failure: no colors");
65 ok(!defined($img->setcolors(start=>5, colors=>[$white])),
66     "expect failure: high index");
67
68 # set the green index to white
69 ok($img->setcolors(start => $greeni, colors => [$white]),
70     "set a color");
71 # and check it
72 coloreq(scalar($img->getcolors(start=>$greeni)), $white,
73         "make sure it was set");
74 ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
75 ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
76
77 # write a few colors
78 ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
79            "save multiple");
80 coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
81 coloreq(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
87 ok($img->box(color=>$red, filled=>1), "fill with red");
88 is($img->type, 'paletted', "paletted after fill");
89 ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
90               xmax=>40, ymax=>40), "green box");
91 is($img->type, 'paletted', 'still paletted after box');
92 # an AA line will almost certainly convert the image to RGB, don't use
93 # an AA line here
94 ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
95     "draw a line");
96 is($img->type, 'paletted', 'still paletted after line');
97
98 # draw with white - should convert to direct
99 ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20, 
100               xmax=>30, ymax=>30), "white box");
101 is($img->type, 'direct', "now it should be direct");
102
103 # various attempted to make a paletted image from our now direct image
104 my $palimg = $img->to_paletted;
105 ok($palimg, "we got an image");
106 # they should be the same pixel for pixel
107 ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
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');
112 ok(!defined $palimg, "to paletted with an empty palette is an error");
113 print "# ",$img->errstr,"\n";
114 ok(scalar($img->errstr =~ /no colors available for translation/),
115     "and got the correct msg");
116
117 ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'), 
118     "fail on -ve height");
119 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
120        "and correct error message");
121 ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'), 
122     "fail on -ve width");
123 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
124        "and correct error message");
125 ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'), 
126     "fail on -ve width/height");
127 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
128        "and correct error message");
129
130 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
131     "fail on 0 channels");
132 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
133        "and correct error message");
134 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
135     "fail on 5 channels");
136 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
137        "and correct error message");
138
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;
147  SKIP:
148   {
149     skip("don't want to allocate 4Gb", 10)
150       unless $Config{ptrsize} == 4;
151
152     my $uint_range = 256 ** $Config{intsize};
153     my $dim1 = int(sqrt($uint_range))+1;
154     
155     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
156     is($im_b, undef, "integer overflow check - 1 channel");
157     
158     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
159     ok($im_b, "but same width ok");
160     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
161     ok($im_b, "but same height ok");
162     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
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');
172     is($im_b, undef, "integer overflow check - 3 channel");
173     
174     $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
175     ok($im_b, "but same width ok");
176     $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
177     ok($im_b, "but same height ok");
178
179     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
180            "check the error message");
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
185     my $dim4 = $uint_range / 3;
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");
191   }
192 }
193
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");
207   cmp_ok($warning, '=~', 'palette\\.t', "correct file");
208 }
209
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
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");
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');
243 }
244
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
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");
287   my ($is_mono, $ziw) = $mono->is_bilevel;
288   ok($is_mono, "check monochrome check true");
289   is($ziw, 0, "check ziw false");
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
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
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
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
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
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
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   }
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   }
446 }
447
448 my $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     (
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),
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");
530     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
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");
535     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
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");
539     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
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");
544     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
545               "check first color written");
546     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
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 ]) ],
551               [ (128, 64, 32) x 10 ],
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
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
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
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
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
662 Imager->close_log;
663
664 done_testing();
665
666 unless ($ENV{IMAGER_KEEP_FILES}) {
667   unlink "testout/t023palette.log"
668 }
669
670 sub 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 ]
681 DIAG
682   }
683 }
684
685 sub 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"
695 DIAG
696   }
697 }
698
699 sub 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";
706   ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
707       $comment);
708 }
709
710 sub _get_error {
711   my @errors = Imager::i_errors();
712   return join(": ", map $_->[0], @errors);
713 }