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