a5976b7a5e2ef50aecd74e55284558c4476e1aa4
[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 tests => 226;
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
443 my $psamp_outside_error = "Image position outside of image";
444 { # psamp
445   print "# psamp\n";
446   my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
447   my @colors =
448     (
449      NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
450      NC(64, 0, 192), NC(255, 128, 0), NC(64, 32, 0),
451      NC(128, 63, 32), NC(255, 128, 32), NC(64, 32, 16),
452     );
453   is(Imager::i_addcolors($imraw, @colors), "0 but true",
454      "add colors needed for testing");
455   {
456     is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
457        "i_psamp def channels, 3 samples");
458     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
459               "check color written");
460     Imager::i_img_setmask($imraw, 5);
461     is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
462        "i_psamp def channels, 3 samples, masked");
463     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
464               "check color written");
465     is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
466        "i_psamp channels listed, 3 samples, masked");
467     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
468               "check color written");
469     Imager::i_img_setmask($imraw, ~0);
470     is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
471        "i_psamp channels [0, 1], 4 samples");
472     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
473               "check first color written");
474     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
475               "check second color written");
476     is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
477        "write a full row");
478     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
479               [ (128, 63, 32) x 10 ],
480               "check full row");
481     is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
482                        [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
483        6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
484   }
485   { # errors we catch
486     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
487        undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
488     is(_get_error(), "No channel 3 in this image",
489        "check error message");
490     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
491        undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
492     is(_get_error(), "No channel -1 in this image",
493        "check error message");
494     is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
495        "negative y");
496     is(_get_error(), $psamp_outside_error, "check message");
497     is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
498        "y overflow");
499     is(_get_error(), $psamp_outside_error, "check message");
500     is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
501        "negative x");
502     is(_get_error(), $psamp_outside_error, "check message");
503     is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
504        "x overflow");
505     is(_get_error(), $psamp_outside_error, "check message");
506   }
507   ok(Imager::i_img_type($imraw), "still paletted");
508   print "# end psamp tests\n";
509 }
510
511 { # psampf
512   print "# psampf\n";
513   my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
514   my @colors =
515     (
516      NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
517      NC(64, 0, 191), NC(255, 128, 0), NC(64, 32, 0),
518      NC(128, 64, 32), NC(255, 128, 32), NC(64, 32, 16),
519     );
520   is(Imager::i_addcolors($imraw, @colors), "0 but true",
521      "add colors needed for testing");
522   {
523     is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
524        "i_psampf def channels, 3 samples");
525     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
526               "check color written");
527     Imager::i_img_setmask($imraw, 5);
528     is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
529        "i_psampf def channels, 3 samples, masked");
530     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
531               "check color written");
532     is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
533        "i_psampf channels listed, 3 samples, masked");
534     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
535               "check color written");
536     Imager::i_img_setmask($imraw, ~0);
537     is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
538        "i_psampf channels [0, 1], 4 samples");
539     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
540               "check first color written");
541     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
542               "check second color written");
543     is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
544        "write a full row");
545     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
546               [ (128, 64, 32) x 10 ],
547               "check full row");
548     is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
549                         [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
550        6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
551   }
552   { # errors we catch
553     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
554        undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
555     is(_get_error(), "No channel 3 in this image",
556        "check error message");
557     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
558        undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
559     is(_get_error(), "No channel -1 in this image",
560        "check error message");
561     is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
562        "negative y");
563     is(_get_error(), $psamp_outside_error, "check message");
564     is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
565        "y overflow");
566     is(_get_error(), $psamp_outside_error, "check message");
567     is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
568        "negative x");
569     is(_get_error(), $psamp_outside_error, "check message");
570     is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
571        "x overflow");
572     is(_get_error(), $psamp_outside_error, "check message");
573   }
574   ok(Imager::i_img_type($imraw), "still paletted");
575   print "# end psampf tests\n";
576 }
577
578 { # 75258 - gpixf() broken for paletted images
579   my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
580   ok($im, "make a test image");
581   my @colors = ( $black, $red, $green, $blue );
582   is($im->addcolors(colors => \@colors), "0 but true",
583      "add some colors");
584   $im->setpixel(x => 0, y => 0, color => $red);
585   $im->setpixel(x => 1, y => 0, color => $green);
586   $im->setpixel(x => 2, y => 0, color => $blue);
587   is_fcolor3($im->getpixel(x => 0, y => 0, type => "float"),
588              1.0, 0, 0, "get a pixel in float form, make sure it's red");
589   is_fcolor3($im->getpixel(x => 1, y => 0, type => "float"),
590              0, 1.0, 0, "get a pixel in float form, make sure it's green");
591   is_fcolor3($im->getpixel(x => 2, y => 0, type => "float"),
592              0, 0, 1.0, "get a pixel in float form, make sure it's blue");
593 }
594
595 {
596   my $empty = Imager->new;
597   ok(!$empty->to_paletted, "can't convert an empty image");
598   is($empty->errstr, "to_paletted: empty input image",
599     "check error message");
600
601   is($empty->addcolors(colors => [ $black ]), -1,
602      "can't addcolors() to an empty image");
603   is($empty->errstr, "addcolors: empty input image",
604      "check error message");
605
606   ok(!$empty->setcolors(colors => [ $black ]),
607      "can't setcolors() to an empty image");
608   is($empty->errstr, "setcolors: empty input image",
609      "check error message");
610
611   ok(!$empty->getcolors(),
612      "can't getcolors() from an empty image");
613   is($empty->errstr, "getcolors: empty input image",
614      "check error message");
615
616   is($empty->colorcount, -1, "can't colorcount() an empty image");
617   is($empty->errstr, "colorcount: empty input image",
618      "check error message");
619
620   is($empty->maxcolors, -1, "can't maxcolors() an empty image");
621   is($empty->errstr, "maxcolors: empty input image",
622      "check error message");
623
624   is($empty->findcolor(color => $blue), undef,
625      "can't findcolor an empty image");
626   is($empty->errstr, "findcolor: empty input image",
627      "check error message");
628 }
629
630 Imager->close_log;
631
632 unless ($ENV{IMAGER_KEEP_FILES}) {
633   unlink "testout/t023palette.log"
634 }
635
636 sub iscolor {
637   my ($c1, $c2, $msg) = @_;
638
639   my $builder = Test::Builder->new;
640   my @c1 = $c1->rgba;
641   my @c2 = $c2->rgba;
642   if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
643                     $msg)) {
644     $builder->diag(<<DIAG);
645       got color: [ @c1 ]
646  expected color: [ @c2 ]
647 DIAG
648   }
649 }
650
651 sub isbin ($$$) {
652   my ($got, $expected, $msg) = @_;
653
654   my $builder = Test::Builder->new;
655   if (!$builder->ok($got eq $expected, $msg)) {
656     (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
657     (my $exp_dec = $expected)  =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
658     $builder->diag(<<DIAG);
659       got: "$got_dec"
660  expected: "$exp_dec"
661 DIAG
662   }
663 }
664
665 sub coloreq {
666   my ($left, $right, $comment) = @_;
667
668   my ($rl, $gl, $bl, $al) = $left->rgba;
669   my ($rr, $gr, $br, $ar) = $right->rgba;
670
671   print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
672   ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
673       $comment);
674 }
675
676 sub _get_error {
677   my @errors = Imager::i_errors();
678   return join(": ", map $_->[0], @errors);
679 }