invalid quantization options now result in an error rather than defaults
[imager.git] / t / 100-base / 010-introvert.t
CommitLineData
faa9b3e7
TC
1#!perl -w
2# t/t01introvert.t - tests internals of image formats
3# to make sure we get expected values
faa9b3e7
TC
4
5use strict;
35db02fc 6use Test::More tests => 492;
faa9b3e7 7
61753090 8BEGIN { use_ok(Imager => qw(:handy :all)) }
faa9b3e7 9
2a27eeff 10use Imager::Test qw(image_bounds_checks is_color3 is_color4 is_fcolor4 color_cmp mask_tests is_fcolor3);
837a4b43 11
40e78f96
TC
12-d "testout" or mkdir "testout";
13
10ea52a3 14Imager->open_log(log => "testout/t01introvert.log");
faa9b3e7
TC
15
16my $im_g = Imager::ImgRaw::new(100, 101, 1);
17
ca4d914e
TC
18my $red = NC(255, 0, 0);
19my $green = NC(0, 255, 0);
20my $blue = NC(0, 0, 255);
21
22use Imager::Color::Float;
23my $f_black = Imager::Color::Float->new(0, 0, 0);
24my $f_red = Imager::Color::Float->new(1.0, 0, 0);
25my $f_green = Imager::Color::Float->new(0, 1.0, 0);
26my $f_blue = Imager::Color::Float->new(0, 0, 1.0);
27
61753090
TC
28is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
29ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
30ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
31is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
32is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
3b000586
TC
33is(Imager::i_img_get_width($im_g), 100, "100 pixels wide");
34is(Imager::i_img_get_height($im_g), 101, "101 pixels high");
faa9b3e7
TC
35
36my @ginfo = Imager::i_img_info($im_g);
61753090
TC
37is($ginfo[0], 100, "1 channel image width");
38is($ginfo[1], 101, "1 channel image height");
faa9b3e7
TC
39
40undef $im_g; # can we check for release after this somehow?
41
42my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
43
61753090
TC
44is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
45is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
46is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
47is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
faa9b3e7
TC
48
49undef $im_rgb;
50
51my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
52
61753090
TC
53ok($im_pal, "make paletted image");
54is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
55is(Imager::i_img_bits($im_pal), 8, "pal img bits");
56is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
faa9b3e7 57
61753090
TC
58my $red_idx = check_add($im_pal, $red, 0);
59my $green_idx = check_add($im_pal, $green, 1);
60my $blue_idx = check_add($im_pal, $blue, 2);
faa9b3e7
TC
61
62# basic writing of palette indicies
63# fill with red
61753090
TC
64is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100,
65 "write red 100 times");
faa9b3e7 66# and blue
61753090
TC
67is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
68 "write blue 50 times");
faa9b3e7
TC
69
70# make sure we get it back
71my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
61753090
TC
72ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
73ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
74is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50,
75 "gpal in scalar context");
6a9807e8 76my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
61753090 77is(@samp, 300, "gsamp count in list context");
faa9b3e7 78my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
61753090 79is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
6a9807e8 80my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
61753090
TC
81is(length($samp), 300, "gsamp scalar length");
82is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
faa9b3e7
TC
83
84# reading indicies as colors
61753090
TC
85my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
86ok($c_red, "got the red pixel");
8927ff88 87is_color3($c_red, 255, 0, 0, "and it's red");
61753090
TC
88my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
89ok($c_blue, "got the blue pixel");
8927ff88 90is_color3($c_blue, 0, 0, 255, "and it's blue");
faa9b3e7
TC
91
92# drawing with colors
61753090 93ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
faa9b3e7 94# that was in the palette, should still be paletted
61753090 95is(Imager::i_img_type($im_pal), 1, "image still paletted");
faa9b3e7 96
61753090
TC
97my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
98ok($c_green, "got green pixel");
8927ff88 99is_color3($c_green, 0, 255, 0, "and it's green");
faa9b3e7 100
61753090
TC
101is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
102is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
faa9b3e7
TC
103
104my $black = NC(0, 0, 0);
105# this should convert the image to RGB
61753090
TC
106ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
107is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
faa9b3e7 108
560ef450
TC
109{
110 my %quant =
111 (
112 colors => [$red, $green, $blue, $black],
113 make_colors => 'none',
114 );
115 my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
a3b721bb
TC
116 ok($im_pal2, "got an image from quantizing")
117 or diag _get_error();
560ef450
TC
118 is(@{$quant{colors}}, 4, "quant has the right number of colours");
119 is(Imager::i_colorcount($im_pal2), 4, "and so does the image");
120 my @colors = Imager::i_getcolors($im_pal2, 0, 4);
121 my ($first) = Imager::i_getcolors($im_pal2, 0);
122 my @first = $colors[0]->rgba;
123 is_color3($first, $first[0], $first[1], $first[2],
124 "check first color is first for multiple or single fetch");
125 is_color3($colors[0], 255, 0, 0, "still red");
126 is_color3($colors[1], 0, 255, 0, "still green");
127 is_color3($colors[2], 0, 0, 255, "still blue");
128 is_color3($colors[3], 0, 0, 0, "still black");
3f35d283
TC
129 my @samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
130 my @expect = unpack("C*", "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50);
131 my $match_list = is_deeply(\@samples, \@expect, "colors are still correct");
132 my $samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
133 my $match_scalar = is_deeply([ unpack("C*", $samples) ],
134 \@expect, "colors are still correct (scalar)");
135 unless ($match_list && $match_scalar) {
136 # this has been failing on a particular smoker, provide more
137 # diagnostic information
138 print STDERR "Pallete:\n";
139 print STDERR " $_: ", join(",", $colors[$_]->rgba), "\n" for 0..$#colors;
140 print STDERR "Samples (list): ", join(",", @samples), "\n";
141 print STDERR "Samples (scalar): ", join(",", unpack("C*", $samples)), "\n";
142 print STDERR "Indexes: ", join(",", Imager::i_gpal($im_pal2, 0, 100, 0)), "\n";
143 }
560ef450 144}
faa9b3e7
TC
145
146# test the OO interfaces
61753090 147my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
3bcba6df
TC
148ok($impal2, "make paletted via OO")
149 or diag(Imager->errstr);
61753090
TC
150is($impal2->getchannels, 3, "check channels");
151is($impal2->bits, 8, "check bits");
152is($impal2->type, 'paletted', "check type");
3b000586
TC
153is($impal2->getwidth, 200, "check width");
154is($impal2->getheight, 201, "check height");
35db02fc
TC
155is($impal2->colormodel, "rgb", "check color model (string)");
156is($impal2->colormodel(numeric => 1), 3, "check color model (numeric)");
157is($impal2->alphachannel, undef, "check alpha channel (has none)");
158is($impal2->colorchannels, 3, "check colorchannels");
faa9b3e7
TC
159
160{
61753090
TC
161 my $red_idx = $impal2->addcolors(colors=>[$red]);
162 ok($red_idx, "add red to OO");
163 is(0+$red_idx, 0, "and it's expected index for red");
164 my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
165 ok($blue_idx, "add blue/green via OO");
166 is($blue_idx, 1, "and it's expected index for blue");
faa9b3e7
TC
167 my $green_idx = $blue_idx + 1;
168 my $c = $impal2->getcolors(start=>$green_idx);
8927ff88 169 is_color3($c, 0, 255, 0, "found green where expected");
faa9b3e7 170 my @cols = $impal2->getcolors;
61753090 171 is(@cols, 3, "got 3 colors");
faa9b3e7 172 my @exp = ( $red, $blue, $green );
61753090 173 my $good = 1;
faa9b3e7
TC
174 for my $i (0..2) {
175 if (color_cmp($cols[$i], $exp[$i])) {
61753090 176 $good = 0;
faa9b3e7
TC
177 last;
178 }
179 }
61753090
TC
180 ok($good, "all colors in palette as expected");
181 is($impal2->colorcount, 3, "and colorcount returns 3");
182 is($impal2->maxcolors, 256, "maxcolors as expected");
183 is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
184 ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
185 "we can setcolors");
faa9b3e7
TC
186
187 # make an rgb version
3bcba6df
TC
188 my $imrgb2 = $impal2->to_rgb8()
189 or diag($impal2->errstr);
61753090 190 is($imrgb2->type, 'direct', "converted is direct");
faa9b3e7
TC
191
192 # and back again, specifying the palette
193 my @colors = ( $red, $blue, $green );
194 my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
195 make_colors=>'none',
61753090
TC
196 translate=>'closest');
197 ok($impal3, "got a paletted image from conversion");
faa9b3e7
TC
198 dump_colors(@colors);
199 print "# in image\n";
200 dump_colors($impal3->getcolors);
61753090
TC
201 is($impal3->colorcount, 3, "new image has expected color table size");
202 is($impal3->type, 'paletted', "and is paletted");
faa9b3e7
TC
203}
204
1136f089 205{
3bcba6df
TC
206 my $im = Imager->new;
207 ok($im, "make empty image");
208 ok(!$im->to_rgb8, "convert to rgb8");
1136f089
TC
209 is($im->errstr, "to_rgb8: empty input image", "check message");
210 is($im->bits, undef, "can't call bits on an empty image");
211 is($im->errstr, "bits: empty input image", "check message");
212 is($im->type, undef, "can't call type on an empty image");
213 is($im->errstr, "type: empty input image", "check message");
214 is($im->virtual, undef, "can't call virtual on an empty image");
215 is($im->errstr, "virtual: empty input image", "check message");
216 is($im->is_bilevel, undef, "can't call virtual on an empty image");
217 is($im->errstr, "is_bilevel: empty input image", "check message");
218 ok(!$im->getscanline(y => 0), "can't call getscanline on an empty image");
219 is($im->errstr, "getscanline: empty input image", "check message");
220 ok(!$im->setscanline(y => 0, pixels => [ $red, $blue ]),
221 "can't call setscanline on an empty image");
222 is($im->errstr, "setscanline: empty input image", "check message");
223 ok(!$im->getsamples(y => 0), "can't call getsamples on an empty image");
224 is($im->errstr, "getsamples: empty input image", "check message");
225 is($im->getwidth, undef, "can't get width of empty image");
226 is($im->errstr, "getwidth: empty input image", "check message");
227 is($im->getheight, undef, "can't get height of empty image");
228 is($im->errstr, "getheight: empty input image", "check message");
229 is($im->getchannels, undef, "can't get channels of empty image");
230 is($im->errstr, "getchannels: empty input image", "check message");
231 is($im->getmask, undef, "can't get mask of empty image");
232 is($im->errstr, "getmask: empty input image", "check message");
233 is($im->setmask, undef, "can't set mask of empty image");
234 is($im->errstr, "setmask: empty input image", "check message");
35db02fc
TC
235 is($im->colorchannels, undef, "can't get colorchannels of empty image");
236 is($im->errstr, "colorchannels: empty input image", "check message");
237 is($im->alphachannel, undef, "can't get alphachannel of empty image");
238 is($im->errstr, "alphachannel: empty input image", "check message");
239 is($im->colormodel, undef, "can't get colormodel of empty image");
240 is($im->errstr, "colormodel: empty input image", "check message");
3bcba6df
TC
241}
242
bd8052a6
TC
243{ # basic checks, 8-bit direct images
244 my $im = Imager->new(xsize => 2, ysize => 3);
245 ok($im, 'create 8-bit direct image');
246 is($im->bits, 8, '8 bits');
247 ok(!$im->virtual, 'not virtual');
248 is($im->type, 'direct', 'direct image');
249 ok(!$im->is_bilevel, 'not mono');
250}
251
61753090
TC
252ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
253cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 254 "0 height error message check");
61753090
TC
255ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
256cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 257 "0 width error message check");
61753090
TC
258ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
259cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 260 "-ve width error message check");
61753090
TC
261ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
262cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 263 "-ve height error message check");
61753090
TC
264ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
265cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3
TC
266 "-ve width/height error message check");
267
61753090
TC
268ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
269 "fail to create a zero channel image");
270cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
1501d9b3 271 "out of range channel message check");
61753090
TC
272ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
273 "fail to create a five channel image");
274cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
1501d9b3
TC
275 "out of range channel message check");
276
653ea321
TC
277{
278 # https://rt.cpan.org/Ticket/Display.html?id=8213
279 # check for handling of memory allocation of very large images
280 # only test this on 32-bit machines - on a 64-bit machine it may
281 # result in trying to allocate 4Gb of memory, which is unfriendly at
282 # least and may result in running out of memory, causing a different
283 # type of exit
61753090
TC
284 SKIP:
285 {
286 use Config;
8d14daab 287 skip("don't want to allocate 4Gb", 8) unless $Config{ptrsize} == 4;
61753090 288
f8906310 289 my $uint_range = 256 ** $Config{intsize};
653ea321
TC
290 print "# range $uint_range\n";
291 my $dim1 = int(sqrt($uint_range))+1;
292
293 my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
61753090 294 is($im_b, undef, "integer overflow check - 1 channel");
653ea321
TC
295
296 $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
61753090 297 ok($im_b, "but same width ok");
653ea321 298 $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
61753090
TC
299 ok($im_b, "but same height ok");
300 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
653ea321
TC
301 "check the error message");
302
303 # do a similar test with a 3 channel image, so we're sure we catch
304 # the same case where the third dimension causes the overflow
305 my $dim3 = int(sqrt($uint_range / 3))+1;
306
307 $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
61753090 308 is($im_b, undef, "integer overflow check - 3 channel");
653ea321
TC
309
310 $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
61753090 311 ok($im_b, "but same width ok");
653ea321 312 $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
61753090 313 ok($im_b, "but same height ok");
653ea321 314
61753090 315 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
653ea321
TC
316 "check the error message");
317 }
653ea321 318}
1501d9b3 319
34b3f7e6
TC
320{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
321 my $warning;
322 local $SIG{__WARN__} =
323 sub {
324 $warning = "@_";
325 my $printed = $warning;
326 $printed =~ s/\n$//;
327 $printed =~ s/\n/\n\#/g;
328 print "# ",$printed, "\n";
329 };
330 my $img = Imager->new(xsize=>10, ysize=>10);
331 $img->to_rgb8(); # doesn't really matter what the source is
332 cmp_ok($warning, '=~', 'void', "correct warning");
5664d5c8 333 cmp_ok($warning, '=~', 'introvert\\.t', "correct file");
34b3f7e6
TC
334}
335
12b1fac2
TC
336{ # http://rt.cpan.org/NoAuth/Bug.html?id=11860
337 my $im = Imager->new(xsize=>2, ysize=>2);
338 $im->setpixel(x=>0, 'y'=>0, color=>$red);
339 $im->setpixel(x=>1, 'y'=>0, color=>$blue);
340
341 my @row = Imager::i_glin($im->{IMG}, 0, 2, 0);
342 is(@row, 2, "got 2 pixels from i_glin");
8927ff88
TC
343 is_color3($row[0], 255, 0, 0, "red first");
344 is_color3($row[1], 0, 0, 255, "then blue");
12b1fac2
TC
345}
346
241defe8
TC
347{ # general tag tests
348
349 # we don't care much about the image itself
350 my $im = Imager::ImgRaw::new(10, 10, 1);
351
352 ok(Imager::i_tags_addn($im, 'alpha', 0, 101), "i_tags_addn(...alpha, 0, 101)");
353 ok(Imager::i_tags_addn($im, undef, 99, 102), "i_tags_addn(...undef, 99, 102)");
354 is(Imager::i_tags_count($im), 2, "should have 2 tags");
355 ok(Imager::i_tags_addn($im, undef, 99, 103), "i_tags_addn(...undef, 99, 103)");
356 is(Imager::i_tags_count($im), 3, "should have 3 tags, despite the dupe");
357 is(Imager::i_tags_find($im, 'alpha', 0), '0 but true', "find alpha");
358 is(Imager::i_tags_findn($im, 99, 0), 1, "find 99");
359 is(Imager::i_tags_findn($im, 99, 2), 2, "find 99 again");
360 is(Imager::i_tags_get($im, 0), 101, "check first");
361 is(Imager::i_tags_get($im, 1), 102, "check second");
362 is(Imager::i_tags_get($im, 2), 103, "check third");
363
364 ok(Imager::i_tags_add($im, 'beta', 0, "hello", 0),
365 "add string with string key");
366 ok(Imager::i_tags_add($im, 'gamma', 0, "goodbye", 0),
367 "add another one");
368 ok(Imager::i_tags_add($im, undef, 199, "aloha", 0),
369 "add one keyed by number");
370 is(Imager::i_tags_find($im, 'beta', 0), 3, "find beta");
371 is(Imager::i_tags_find($im, 'gamma', 0), 4, "find gamma");
372 is(Imager::i_tags_findn($im, 199, 0), 5, "find 199");
373 ok(Imager::i_tags_delete($im, 2), "delete");
374 is(Imager::i_tags_find($im, 'beta', 0), 2, 'find beta after deletion');
375 ok(Imager::i_tags_delbyname($im, 'beta'), 'delete beta by name');
376 is(Imager::i_tags_find($im, 'beta', 0), undef, 'beta not there now');
377 is(Imager::i_tags_get_string($im, "gamma"), "goodbye",
378 'i_tags_get_string() on a string');
379 is(Imager::i_tags_get_string($im, 99), 102,
380 'i_tags_get_string() on a number entry');
381 ok(Imager::i_tags_delbycode($im, 99), 'delete by code');
382 is(Imager::i_tags_findn($im, 99, 0), undef, '99 not there now');
383 is(Imager::i_tags_count($im), 3, 'final count of 3');
384}
385
ca4d914e
TC
386{
387 print "# low-level scan line function tests\n";
388 my $im = Imager::ImgRaw::new(10, 10, 4);
389 Imager::i_ppix($im, 5, 0, $red);
390
391 # i_glin/i_glinf
392 my @colors = Imager::i_glin($im, 0, 10, 0);
393 is_deeply([ (0) x 20, (255, 0, 0, 255), (0) x 16 ],
394 [ map $_->rgba, @colors ],
395 "i_glin - list context");
396 my $colors = Imager::i_glin($im, 0, 10, 0);
397 is("00" x 20 . "FF0000FF" . "00" x 16,
398 uc unpack("H*", $colors), "i_glin - scalar context");
399 my @fcolors = Imager::i_glinf($im, 0, 10, 0);
400 is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
401 [ map $_->rgba, @fcolors ],
402 "i_glinf - list context");
403 my $fcolors = Imager::i_glinf($im, 0, 10, 0);
404 is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
405 [ unpack "d*", $fcolors ],
406 "i_glinf - scalar context");
407
408 # i_plin/i_plinf
409 my @plin_colors = (($black) x 4, $red, $blue, ($black) x 4);
410 is(Imager::i_plin($im, 0, 1, @plin_colors),
411 10, "i_plin - pass in a list");
412 # make sure we get it back
413 is_deeply([ map [ $_->rgba ], @plin_colors ],
414 [ map [ $_->rgba ], Imager::i_glin($im, 0, 10, 1) ],
415 "check i_plin wrote to the image");
416 my @scalar_plin =
417 (
418 (0,0,0,0) x 4,
419 (0, 255, 0, 255),
420 (0, 0, 255, 255),
421 (0, 0, 0, 0) x 4,
422 );
423 is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)),
424 10, "i_plin - pass in a scalar");
425 is_deeply(\@scalar_plin,
426 [ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ],
427 "check i_plin scalar wrote to the image");
428
429 my @plinf_colors = # Note: only 9 pixels
430 (
431 ($f_blue) x 4,
432 $f_red,
433 ($f_black) x 3,
434 $f_black
435 );
436 is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9,
437 "i_plinf - list");
438 is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ],
439 [ map $_->rgba, @plinf_colors ],
440 "check colors were written");
441 my @scalar_plinf =
442 (
443 ( 1.0, 1.0, 0, 1.0 ) x 3,
444 ( 0, 1.0, 1.0, 1.0 ) x 2,
445 ( 0, 0, 0, 0 ),
446 ( 1.0, 0, 1.0, 1.0 ),
447 );
448 is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)),
449 7, "i_plinf - scalar");
450 is_deeply(\@scalar_plinf,
451 [ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ],
452 "check colors were written");
453
6a9807e8 454 is_deeply([ Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ]) ],
ca4d914e
TC
455 [ (0, 0) x 5, (255, 255), (0, 0) x 4 ],
456 "i_gsamp list context");
457 is("0000" x 5 . "FFFF" . "0000" x 4,
6a9807e8 458 uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ])),
ca4d914e 459 "i_gsamp scalar context");
6a9807e8 460 is_deeply([ Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ]) ],
ca4d914e
TC
461 [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
462 (1.0, 1.0, 1.0) ], "i_gsampf - list context");
6a9807e8 463 is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ])) ],
ca4d914e
TC
464 [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
465 (1.0, 1.0, 1.0) ], "i_gsampf - scalar context");
466 print "# end low-level scan-line function tests\n";
467}
468
f1d3d94a 469my $psamp_outside_error = "Image position outside of image";
7b5f7619
TC
470{ # psamp
471 print "# psamp\n";
848b7f32 472 my $imraw = Imager::ImgRaw::new(10, 20, 3);
7b5f7619
TC
473 {
474 is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
475 "i_psamp def channels, 3 samples");
476 is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
477 "check color written");
478 Imager::i_img_setmask($imraw, 5);
479 is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
480 "i_psamp def channels, 3 samples, masked");
481 is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
482 "check color written");
483 is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
484 "i_psamp channels listed, 3 samples, masked");
485 is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
486 "check color written");
487 Imager::i_img_setmask($imraw, ~0);
488 is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
489 "i_psamp channels [0, 1], 4 samples");
490 is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
491 "check first color written");
492 is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
493 "check second color written");
494 is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
495 "write a full row");
496 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
497 [ (128, 63, 32) x 10 ],
498 "check full row");
499 is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
500 [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
501 6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
848b7f32
TC
502 is(Imager::i_psamp($imraw, 4, 6, undef, [ 0 .. 18 ], 1), 18,
503 "psamp with offset");
504 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
505 [ (0) x 12, 1 .. 18 ],
506 "check result");
507 is(Imager::i_psamp($imraw, 4, 11, undef, [ 0 .. 18 ], 1, 3), 9,
508 "psamp with offset and width");
509 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
510 [ (0) x 12, 1 .. 9, (0) x 9 ],
511 "check result");
7b5f7619
TC
512 }
513 { # errors we catch
514 is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
515 undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
516 is(_get_error(), "No channel 3 in this image",
517 "check error message");
518 is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
519 undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
520 is(_get_error(), "No channel -1 in this image",
521 "check error message");
522 is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
523 "negative y");
524 is(_get_error(), $psamp_outside_error,
525 "check error message");
848b7f32 526 is(Imager::i_psamp($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
7b5f7619
TC
527 "y overflow");
528 is(_get_error(), $psamp_outside_error,
529 "check error message");
530 is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
531 "negative x");
532 is(_get_error(), $psamp_outside_error,
533 "check error message");
534 is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
535 "x overflow");
536 is(_get_error(), $psamp_outside_error,
537 "check error message");
538 }
539 { # test the im_sample_list typemap
540 ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], undef); 1 },
541 "pass undef as the sample list");
542 like($@, qr/data must be a scalar or an arrayref/,
543 "check message");
544 ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
545 "hashref as the sample list");
546 like($@, qr/data must be a scalar or an arrayref/,
547 "check message");
548 ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], []); 1 },
549 "empty sample list");
550 like($@, qr/i_psamp: no samples provided in data/,
551 "check message");
552 ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], ""); 1 },
553 "empty scalar sample list");
554 like($@, qr/i_psamp: no samples provided in data/,
555 "check message");
556
557 # not the typemap
848b7f32
TC
558 is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
559 "negative offset");
560 is(_get_error(), "offset must be non-negative",
561 "check message");
562
563 is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
564 "too high offset");
565 is(_get_error(), "offset greater than number of samples supplied",
566 "check message");
7b5f7619
TC
567 }
568 print "# end psamp tests\n";
569}
570
571{ # psampf
572 print "# psampf\n";
848b7f32 573 my $imraw = Imager::ImgRaw::new(10, 20, 3);
7b5f7619
TC
574 {
575 is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
576 "i_psampf def channels, 3 samples");
29b38678 577 is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
7b5f7619
TC
578 "check color written");
579 Imager::i_img_setmask($imraw, 5);
580 is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
581 "i_psampf def channels, 3 samples, masked");
29b38678 582 is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
7b5f7619
TC
583 "check color written");
584 is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
585 "i_psampf channels listed, 3 samples, masked");
29b38678 586 is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
7b5f7619
TC
587 "check color written");
588 Imager::i_img_setmask($imraw, ~0);
589 is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
590 "i_psampf channels [0, 1], 4 samples");
29b38678 591 is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
7b5f7619 592 "check first color written");
29b38678 593 is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
7b5f7619
TC
594 "check second color written");
595 is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
596 "write a full row");
597 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
29b38678 598 [ (128, 64, 32) x 10 ],
7b5f7619
TC
599 "check full row");
600 is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
601 [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
602 6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
848b7f32
TC
603 is(Imager::i_psampf($imraw, 4, 6, undef, [ map $_/254.9, 0 .. 18 ], 1), 18,
604 "psampf with offset");
605 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
606 [ (0) x 12, 1 .. 18 ],
607 "check result");
608 is(Imager::i_psampf($imraw, 4, 11, undef, [ map $_/254.9, 0 .. 18 ], 1, 3), 9,
609 "psampf with offset and width");
610 is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
611 [ (0) x 12, 1 .. 9, (0) x 9 ],
612 "check result");
7b5f7619
TC
613 }
614 { # errors we catch
615 is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
616 undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
617 is(_get_error(), "No channel 3 in this image",
618 "check error message");
619 is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
620 undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
621 is(_get_error(), "No channel -1 in this image",
622 "check error message");
623 is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
624 "negative y");
625 is(_get_error(), $psamp_outside_error,
626 "check error message");
848b7f32 627 is(Imager::i_psampf($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
7b5f7619
TC
628 "y overflow");
629 is(_get_error(), $psamp_outside_error,
630 "check error message");
631 is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
632 "negative x");
633 is(_get_error(), $psamp_outside_error,
634 "check error message");
635 is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
636 "x overflow");
637 is(_get_error(), $psamp_outside_error,
638 "check error message");
639 }
640 { # test the im_fsample_list typemap
641 ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], undef); 1 },
642 "pass undef as the sample list");
643 like($@, qr/data must be a scalar or an arrayref/,
644 "check message");
645 ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
646 "hashref as the sample list");
647 like($@, qr/data must be a scalar or an arrayref/,
648 "check message");
649 ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], []); 1 },
650 "empty sample list");
651 like($@, qr/i_psampf: no samples provided in data/,
652 "check message");
653 ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], ""); 1 },
654 "empty scalar sample list");
655 like($@, qr/i_psampf: no samples provided in data/,
656 "check message");
657
658 # not the typemap
848b7f32
TC
659 is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
660 "negative offset");
661 is(_get_error(), "offset must be non-negative",
662 "check message");
663
664 is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
665 "too high offset");
666 is(_get_error(), "offset greater than number of samples supplied",
667 "check message");
7b5f7619
TC
668 }
669 print "# end psampf tests\n";
670}
671
ca4d914e
TC
672{
673 print "# OO level scanline function tests\n";
674 my $im = Imager->new(xsize=>10, ysize=>10, channels=>4);
675 $im->setpixel(color=>$red, 'x'=>5, 'y'=>0);
676 ok(!$im->getscanline(), "getscanline() - supply nothing, get nothing");
677 is($im->errstr, "missing y parameter", "check message");
678 is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0) ],
679 [ ([ 0,0,0,0]) x 5, [ 255, 0, 0, 255 ], ([ 0,0,0,0]) x 4 ],
680 "getscanline, list context, default x, width");
681 is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>3) ],
682 [ ([0,0,0,0]) x 2, [ 255, 0, 0, 255 ], ([0,0,0,0]) x 4 ],
683 "getscanline, list context, default width");
684 is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>4, width=>4) ],
685 [ [0,0,0,0], [ 255, 0, 0, 255 ], ([0,0,0,0]) x 2 ],
686 "getscanline, list context, no defaults");
687 is(uc unpack("H*", $im->getscanline('y'=>0)),
688 "00000000" x 5 . "FF0000FF" . "00000000" x 4,
689 "getscanline, scalar context, default x, width");
690 is_deeply([ map [ $_->rgba ],
691 $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
692 [ [0,0,0,0], [ 1.0, 0, 0, 1.0 ], ([0,0,0,0]) x 2 ],
693 "getscanline float, list context, no defaults");
694 is_deeply([ unpack "d*",
695 $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
696 [ (0,0,0,0), ( 1.0, 0, 0, 1.0 ), (0,0,0,0) x 2 ],
697 "getscanline float, scalar context, no defaults");
698
699 ok(!$im->getscanline('y'=>0, type=>'invalid'),
700 "check invalid type checking");
701 like($im->errstr, qr/invalid type parameter/,
702 "check message for invalid type");
703
704 my @plin_colors = (($black) x 4, $red, $blue, ($green) x 4);
705 is($im->setscanline('y'=>1, pixels=>\@plin_colors), 10,
706 "setscanline - arrayref, default x");
707 is_deeply([ map [ $_->rgba ], @plin_colors ],
708 [ map [ $_->rgba ], $im->getscanline('y'=>1) ],
709 "check colors were written");
710
711 my @plin_colors2 = ( $green, $red, $blue, $red );
712 is($im->setscanline('y'=>2, 'x'=>3, pixels=>\@plin_colors2), 4,
713 "setscanline - arrayref");
a3ca0e81
TC
714
715 # using map instead of x here due to a bug in some versions of Test::More
716 # fixed in the latest Test::More
717 is_deeply([ ( map [ 0,0,0,0 ], 1..3), (map [ $_->rgba ], @plin_colors2),
718 ( map [ 0,0,0,0 ], 1..3) ],
ca4d914e
TC
719 [ map [ $_->rgba ], $im->getscanline('y'=>2) ],
720 "check write to middle of line");
721
722 my $raw_colors = pack "H*", "FF00FFFF"."FF0000FF"."FFFFFFFF";
723 is($im->setscanline('y'=>3, 'x'=>2, pixels=>$raw_colors), 3,
724 "setscanline - scalar, default raw type")
725 or print "# ",$im->errstr,"\n";
726 is(uc unpack("H*", $im->getscanline('y'=>3, 'x'=>1, 'width'=>5)),
727 "00000000".uc(unpack "H*", $raw_colors)."00000000",
728 "check write");
729
730 # float colors
731 my @fcolors = ( $f_red, $f_blue, $f_black, $f_green );
732 is($im->setscanline('y'=>4, 'x'=>3, pixels=>\@fcolors), 4,
733 "setscanline - float arrayref");
734 is_deeply([ map [ $_->rgba ], @fcolors ],
735 [ map [ $_->rgba ], $im->getscanline('y'=>4, 'x'=>3, width=>4, type=>'float') ],
736 "check write");
737 # packed
738 my $packed_fcolors = pack "d*", map $_->rgba, @fcolors;
739 is($im->setscanline('y'=>5, 'x'=>4, pixels=>$packed_fcolors, type=>'float'), 4,
740 "setscanline - float scalar");
741 is_deeply([ map [ $_->rgba ], @fcolors ],
742 [ map [ $_->rgba ], $im->getscanline('y'=>5, 'x'=>4, width=>4, type=>'float') ],
743 "check write");
744
745 # get samples
746 is_deeply([ $im->getsamples('y'=>1, channels=>[ 0 ]) ],
747 [ map +($_->rgba)[0], @plin_colors ],
748 "get channel 0, list context, default x, width");
749 is_deeply([ unpack "C*", $im->getsamples('y'=>1, channels=>[0, 2]) ],
750 [ map { ($_->rgba)[0, 2] } @plin_colors ],
751 "get channel 0, 1, scalar context");
752 is_deeply([ $im->getsamples('y'=>4, 'x'=>3, width=>4, type=>'float',
753 channels=>[1,3]) ],
754 [ map { ($_->rgba)[1,3] } @fcolors ],
755 "get channels 1,3, list context, float samples");
756 is_deeply([ unpack "d*",
757 $im->getsamples('y'=>4, 'x'=>3, width=>4,
758 type=>'float', channels=>[3,2,1,0]) ],
759 [ map { ($_->rgba)[3,2,1,0] } @fcolors ],
760 "get channels 3..0 as scalar, float samples");
761
762 print "# end OO level scanline function tests\n";
763}
764
b759736e
TC
765{ # RT 74882
766 # for the non-gsamp_bits case with a target parameter it was
767 # treating the target parameter as a hashref
768 {
769 my $im = Imager->new(xsize => 10, ysize => 10);
770 my $c1 = NC(0, 63, 255);
771 my $c2 = NC(255, 128, 255);
772 is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
773 10, "set some test data")
774 or diag "setscanline: ", $im->errstr;
775 my @target;
776 is($im->getsamples(y => 1, x => 1, target => \@target, width => 3),
777 9, "getsamples to target");
778 is_deeply(\@target, [ 255, 128, 255, 0, 63, 255, 255, 128, 255 ],
779 "check result");
780 }
781 {
782 my $im = Imager->new(xsize => 10, ysize => 10, bits => "double");
783 my $c1 = NCF(0, 0.25, 1.0);
784 my $c2 = NCF(1.0, 0.5, 1.0);
785 is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
786 10, "set some test data")
787 or diag "setscanline: ", $im->errstr;
788 my @target;
789 is($im->getsamples(y => 1, x => 1, target => \@target, width => 3, type => "float"),
790 9, "getsamples to target");
791 is_deeply(\@target, [ 1.0, 0.5, 1.0, 0, 0.25, 1.0, 1.0, 0.5, 1.0 ],
792 "check result");
793 }
794}
795
b3aa972f
TC
796{ # to avoid confusion, i_glin/i_glinf modified to return 0 in unused
797 # channels at the perl level
798 my $im = Imager->new(xsize => 4, ysize => 4, channels => 2);
799 my $fill = Imager::Color->new(128, 255, 0, 0);
800 ok($im->box(filled => 1, color => $fill), 'fill it up');
801 my $data = $im->getscanline('y' => 0);
802 is(unpack("H*", $data), "80ff000080ff000080ff000080ff0000",
803 "check we get zeros");
804 my @colors = $im->getscanline('y' => 0);
805 is_color4($colors[0], 128, 255, 0, 0, "check object interface[0]");
806 is_color4($colors[1], 128, 255, 0, 0, "check object interface[1]");
807 is_color4($colors[2], 128, 255, 0, 0, "check object interface[2]");
808 is_color4($colors[3], 128, 255, 0, 0, "check object interface[3]");
809
810 my $dataf = $im->getscanline('y' => 0, type => 'float');
76411e99
TC
811 # the extra pack/unpack is to force double precision rather than long
812 # double, otherwise the test fails
b3aa972f 813 is_deeply([ unpack("d*", $dataf) ],
76411e99 814 [ unpack("d*", pack("d*", ( 128.0 / 255.0, 1.0, 0, 0, ) x 4)) ],
b3aa972f
TC
815 "check we get zeroes (double)");
816 my @fcolors = $im->getscanline('y' => 0, type => 'float');
817 is_fcolor4($fcolors[0], 128.0/255.0, 1.0, 0, 0, "check object interface[0]");
818 is_fcolor4($fcolors[1], 128.0/255.0, 1.0, 0, 0, "check object interface[1]");
819 is_fcolor4($fcolors[2], 128.0/255.0, 1.0, 0, 0, "check object interface[2]");
820 is_fcolor4($fcolors[3], 128.0/255.0, 1.0, 0, 0, "check object interface[3]");
821}
822
9b8ce4f4
TC
823{ # check the channel mask function
824
825 my $im = Imager->new(xsize => 10, ysize=>10, bits=>8);
826
827 mask_tests($im, 0.005);
828}
829
837a4b43
TC
830{ # check bounds checking
831 my $im = Imager->new(xsize => 10, ysize => 10);
832
833 image_bounds_checks($im);
834}
835
f1d3d94a
TC
836{ # setsamples() interface to psamp()
837 my $im = Imager->new(xsize => 10, ysize => 10);
838 is($im->setsamples(y => 1, x => 2, data => [ 1 .. 6 ]), 6,
839 "simple put (array), default channels");
840 is_deeply([ $im->getsamples(y => 1, x => 0) ],
841 [ (0) x 6, 1 .. 6, (0) x 18 ], "check they were stored");
842 is($im->setsamples(y => 3, x => 3, data => pack("C*", 2 .. 10 )), 9,
843 "simple put (scalar), default channels")
844 or diag $im->errstr;
845 is_deeply([ $im->getsamples(y => 3, x => 0) ],
846 [ (0) x 9, 2 .. 10, (0) x 12 ], "check they were stored");
847 is($im->setsamples(y => 4, x => 4, data => [ map $_ / 254.5, 1 .. 6 ], type => 'float'),
848 6, "simple put (float array), default channels");
849 is_deeply([ $im->getsamples(y => 4, x => 0) ],
850 [ (0) x 12, 1 .. 6, (0) x 12 ], "check they were stored");
851
852 is($im->setsamples(y => 5, x => 3, data => pack("d*", map $_ / 254.5, 1 .. 6), type => 'float'),
853 6, "simple put (float scalar), default channels");
854 is_deeply([ $im->getsamples(y => 5, x => 0) ],
855 [ (0) x 9, 1 .. 6, (0) x 15 ], "check they were stored");
856
848b7f32
TC
857 is($im->setsamples(y => 7, x => 3, data => [ 0 .. 18 ], offset => 1), 18,
858 "setsamples offset");
859 is_deeply([ $im->getsamples(y => 7) ],
860 [ (0) x 9, 1 .. 18, (0) x 3 ],
861 "check result");
862
863 is($im->setsamples(y => 8, x => 3, data => [ map $_ / 254.9, 0 .. 18 ],
864 offset => 1, type => 'float'),
865 18, "setsamples offset (float)");
866 is_deeply([ $im->getsamples(y => 8) ],
867 [ (0) x 9, 1 .. 18, (0) x 3 ],
868 "check result");
869
f1d3d94a
TC
870 is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ]) ],
871 [], "check out of range result (8bit)");
872 is($im->errstr, $psamp_outside_error, "check error message");
873
874 is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ], type => "float") ],
875 [], "check out of range result (float)");
876 is($im->errstr, $psamp_outside_error, "check error message");
877
878 is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
879 data => [ (0) x 3 ]) ],
880 [], "check bad channels (8bit)");
881 is($im->errstr, "No channel 3 in this image",
882 "check error message");
883
884 is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
885 data => [ (0) x 3 ], type => "float") ],
886 [], "check bad channels (float)");
887 is($im->errstr, "No channel 3 in this image",
888 "check error message");
889
890 is($im->setsamples(y => 5, data => [ (0) x 3 ], type => "bad"),
891 undef, "setsamples with bad type");
892 is($im->errstr, "setsamples: type parameter invalid",
893 "check error message");
894 is($im->setsamples(y => 5),
895 undef, "setsamples with no data");
896 is($im->errstr, "setsamples: data parameter missing",
897 "check error message");
898
88ace6cd
TC
899 is($im->setsamples(y => 5, data => undef),
900 undef, "setsamples with undef data");
901 is($im->errstr, "setsamples: data parameter not defined",
902 "check error message");
903
f1d3d94a
TC
904 my $imempty = Imager->new;
905 is($imempty->setsamples(y => 0, data => [ (0) x 3 ]), undef,
906 "setsamples to empty image");
907 is($imempty->errstr, "setsamples: empty input image",
908 "check error message");
909}
910
2a27eeff
TC
911{ # getpixel parameters
912 my $im = Imager->new(xsize => 10, ysize => 10);
913 $im->box(filled => 1, xmax => 4, color => NC(255, 0, 0));
914 $im->box(filled => 1, xmin => 5, ymax => 4, color => NC(0, 255, 255));
915 $im->box(filled => 1, xmin => 5, ymin => 5, color => NC(255, 0, 255));
916 { # error handling
917 my $empty = Imager->new;
918 ok(!$empty->getpixel(x => 0, y => 0), "getpixel empty image");
919 is($empty->errstr, "getpixel: empty input image", "check message");
920
921 ok(!$im->getpixel(y => 0), "missing x");
922 is($im->errstr, "getpixel: missing x or y parameter", "check message");
923
924 $im->_set_error("something different");
925 ok(!$im->getpixel(x => 0), "missing y");
926 is($im->errstr, "getpixel: missing x or y parameter", "check message");
927
928 ok(!$im->getpixel(x => [], y => 0), "empty x array ref");
929 is($im->errstr, "getpixel: x is a reference to an empty array",
930 "check message");
931
932 ok(!$im->getpixel(x => 0, y => []), "empty y array ref");
933 is($im->errstr, "getpixel: y is a reference to an empty array",
934 "check message");
935
936 ok(!$im->getpixel(x => 0, y => 0, type => "bad"), "bad type (scalar path)");
937 is($im->errstr, "getpixel: type must be '8bit' or 'float'",
938 "check message");
939
940 $im->_set_error("something different");
941 ok(!$im->getpixel(x => [ 0 ], y => [ 0 ], type => "bad"),
942 "bad type (array path)");
943 is($im->errstr, "getpixel: type must be '8bit' or 'float'",
944 "check message");
945 }
946
947 # simple calls
2ea4aa42 948 is_color4($im->getpixel(x => 1, y => 0), 255, 0, 0, 0,
2a27eeff 949 "getpixel(1, 0)");
2ea4aa42 950 is_color4($im->getpixel(x => 8, y => 1), 0, 255, 255, 0,
2a27eeff 951 "getpixel(8, 1)");
2ea4aa42 952 is_color4($im->getpixel(x => 8, y => 7), 255, 0, 255, 0,
2a27eeff
TC
953 "getpixel(8, 7)");
954
955 {
956 # simple arrayrefs
957 my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ]);
958 is(@colors, 3, "getpixel 2 3 element array refs");
959 is_color3($colors[0], 255, 0, 0, "check first color");
960 is_color3($colors[1], 255, 0, 255, "check second color");
961 is_color3($colors[2], 0, 255, 255, "check third color");
962 }
963
964 # array and scalar
965 {
966 my @colors = $im->getpixel(x => 5, y => [ 4, 5, 9 ]);
967 is(@colors, 3, "getpixel x scalar, y arrayref of 3");
968 is_color3($colors[0], 0, 255, 255, "check first color");
969 is_color3($colors[1], 255, 0, 255, "check second color");
970 is_color3($colors[2], 255, 0, 255, "check third color");
971 }
972
973 {
974 my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => 2);
975 is(@colors, 3, "getpixel y scalar, x arrayref of 3");
976 is_color3($colors[0], 255, 0, 0, "check first color");
977 is_color3($colors[1], 255, 0, 0, "check second color");
978 is_color3($colors[2], 0, 255, 255, "check third color");
979 }
980
981 { # float
982 is_fcolor3($im->getpixel(x => 1, y => 0, type => 'float'),
983 1.0, 0, 0, "getpixel(1,0) float");
2ea4aa42
TC
984 is_fcolor4($im->getpixel(x => 8, y => 1, type => 'float'),
985 0, 1.0, 1.0, 0, "getpixel(8,1) float");
986 is_fcolor4($im->getpixel(x => 8, y => 7, type => 'float'),
987 1.0, 0, 1.0, 0, "getpixel(8,7) float");
2a27eeff
TC
988
989 my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], type => 'float');
990 is(@colors, 3, "getpixel 2 3 element array refs (float)");
991 is_fcolor3($colors[0], 1, 0, 0, "check first color");
992 is_fcolor3($colors[1], 1, 0, 1, "check second color");
993 is_fcolor3($colors[2], 0, 1, 1, "check third color");
994 }
995
996 { # out of bounds
997 my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0);
998 is(@colors, 4, "should be 4 entries")
999 or diag $im->errstr;
1000 is_color3($colors[0], 255, 0, 0, "first red");
1001 is($colors[1], undef, "second undef");
1002 is_color3($colors[2], 0, 255, 255, "third cyan");
1003 is($colors[3], undef, "fourth undef");
1004 }
1005
1006 { # out of bounds
1007 my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0, type => "float");
1008 is(@colors, 4, "should be 4 entries")
1009 or diag $im->errstr;
1010 is_fcolor3($colors[0], 1.0, 0, 0, "first red");
1011 is($colors[1], undef, "second undef");
1012 is_fcolor3($colors[2], 0, 1.0, 1.0, "third cyan");
1013 is($colors[3], undef, "fourth undef");
1014 }
1015}
1016
1017{ # setpixel
1018 my $im = Imager->new(xsize => 10, ysize => 10);
1019 { # errors
1020 my $empty = Imager->new;
5daeb11a 1021 is_deeply([ $empty->setpixel(x => 0, y => 0, color => $red) ], [],
2a27eeff
TC
1022 "setpixel on empty image");
1023 is($empty->errstr, "setpixel: empty input image", "check message");
1024
5daeb11a 1025 is_deeply([ $im->setpixel(y => 0, color => $red) ], [], "missing x");
2a27eeff
TC
1026 is($im->errstr, "setpixel: missing x or y parameter", "check message");
1027
1028 $im->_set_error("something different");
5daeb11a 1029 is_deeply([$im->setpixel(x => 0, color => $red)], [], "missing y");
2a27eeff
TC
1030 is($im->errstr, "setpixel: missing x or y parameter", "check message");
1031
5daeb11a
TC
1032 is_deeply([ $im->setpixel(x => [], y => 0, color => $red) ], [],
1033 "empty x array ref");
2a27eeff
TC
1034 is($im->errstr, "setpixel: x is a reference to an empty array",
1035 "check message");
1036
5daeb11a
TC
1037 is_deeply([$im->setpixel(x => 0, y => [], color => $red)], [],
1038 "empty y array ref");
2a27eeff
TC
1039 is($im->errstr, "setpixel: y is a reference to an empty array",
1040 "check message");
1041
5daeb11a 1042 is_deeply([ $im->setpixel(x => 0, y => 0, color => "not really a color") ], [],
2a27eeff
TC
1043 "color not a color");
1044 is($im->errstr, "setpixel: No color named not really a color found",
1045 "check message");
1046 }
1047
1048 # simple set
5daeb11a 1049 is($im->setpixel(x => 0, y => 0, color => $red), 1,
2a27eeff
TC
1050 "simple setpixel")
1051 or diag "simple set float: ", $im->errstr;
1052 is_color3($im->getpixel(x => 0, y => 0), 255, 0, 0, "check stored pixel");
1053
5daeb11a 1054 is($im->setpixel(x => 1, y => 2, color => $f_red), 1,
2a27eeff
TC
1055 "simple setpixel (float)")
1056 or diag "simple set float: ", $im->errstr;
1057 is_color3($im->getpixel(x => 1, y => 2), 255, 0, 0, "check stored pixel");
1058
5daeb11a 1059 is($im->setpixel(x => -1, y => 0, color => $red), "0 but true",
2a27eeff 1060 "simple setpixel outside of image");
5daeb11a 1061 is($im->setpixel(x => 0, y => -1, color => $f_red), "0 but true",
2a27eeff
TC
1062 "simple setpixel (float) outside of image");
1063
1064 # simple arrayrefs
1065 is($im->setpixel( x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], color => $blue),
1066 3, "setpixel with 3 element array refs");
1067 my @colors = $im->getpixel(x => [ 8, 7, 0 ], y => [ 7, 3, 0 ]);
1068 is_color3($colors[0], 0, 0, 255, "check first color");
1069 is_color3($colors[1], 0, 0, 255, "check second color");
1070 is_color3($colors[2], 0, 0, 255, "check third color");
1071
1072 # array and scalar
1073 {
1074 is($im->setpixel(x => 5, y => [ 4, 5, 9 ], color => $green), 3,
1075 "setpixel with x scalar, y arrayref of 3");
1076 my @colors = $im->getpixel(x => [ 5, 5, 5 ], y => [ 4, 5, 9 ]);
1077 is_color3($colors[0], 0, 255, 0, "check first color");
1078 is_color3($colors[1], 0, 255, 0, "check second color");
1079 is_color3($colors[2], 0, 255, 0, "check third color");
1080 }
1081
1082 {
1083 is($im->setpixel(x => [ 0, 4, 5 ], y => 2, color => $blue), 3,
1084 "setpixel with y scalar, x arrayref of 3");
1085 my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => [ 2, 2, 2 ]);
1086 is_color3($colors[0], 0, 0, 255, "check first color");
1087 is_color3($colors[1], 0, 0, 255, "check second color");
1088 is_color3($colors[2], 0, 0, 255, "check third color");
1089 }
1090
1091 {
1092 is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $blue), 3,
1093 "set array with two bad locations")
1094 or diag "set array bad locations: ", $im->errstr;
1095 my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
1096 is_color3($colors[0], 0, 0, 255, "check first color");
1097 is_color3($colors[1], 0, 0, 255, "check second color");
1098 is_color3($colors[2], 0, 0, 255, "check third color");
1099 }
1100 {
1101 is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $f_green), 3,
1102 "set array with two bad locations (float)")
1103 or diag "set array bad locations (float): ", $im->errstr;
1104 my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
1105 is_color3($colors[0], 0, 255, 0, "check first color");
1106 is_color3($colors[1], 0, 255, 0, "check second color");
1107 is_color3($colors[2], 0, 255, 0, "check third color");
1108 }
1109 { # default color
5daeb11a 1110 is($im->setpixel(x => 0, y => 9), 1, "setpixel() default color")
2a27eeff
TC
1111 or diag "setpixel default color: ", $im->errstr;
1112 is_color3($im->getpixel(x => 0, y => 9), 255, 255, 255,
1113 "check color set");
1114 }
1115}
1116
1136f089
TC
1117{
1118 my $empty = Imager->new;
1119 ok(!$empty->addtag(name => "foo", value => 1),
1120 "can't addtag on an empty image");
1121 is($empty->errstr, "addtag: empty input image",
1122 "check error message");
1123 ok(!$empty->settag(name => "foo", value => 1),
1124 "can't settag on an empty image");
1125 is($empty->errstr, "settag: empty input image",
1126 "check error message");
1127 ok(!$empty->deltag(name => "foo"), "can't deltag on an empty image");
1128 is($empty->errstr, "deltag: empty input image",
1129 "check error message");
1130 ok(!$empty->tags(name => "foo"), "can't tags on an empty image");
1131 is($empty->errstr, "tags: empty input image",
1132 "check error message");
1133}
1134
35db02fc
TC
1135{
1136 my @tests =
1137 (
1138 [ "gray", 1, undef ],
1139 [ "graya", 1, 1 ],
1140 [ "rgb", 3, undef ],
1141 [ "rgba", 3, 3 ],
1142 );
1143 for my $test (@tests) {
1144 my ($model, $color_channels, $alpha) = @$test;
1145 my $im = Imager->new(model => $model, xsize => 10, ysize => 10)
1146 or die "Cannot create $model image:", Imager->errstr;
1147 ok($im, "make a $model image via model");
1148 is($im->colormodel, $model, "check colormodel is $model");
1149 is($im->alphachannel, $alpha, "check alphachannel");
1150 is($im->colorchannels, $color_channels, "check colorchannels");
1151 }
1152}
1153
10ea52a3
TC
1154Imager->close_log();
1155
1156unless ($ENV{IMAGER_KEEP_FILES}) {
1157 unlink "testout/t01introvert.log";
1158}
1159
faa9b3e7 1160sub check_add {
61753090
TC
1161 my ($im, $color, $expected) = @_;
1162 my $index = Imager::i_addcolors($im, $color);
1163 ok($index, "got index");
faa9b3e7 1164 print "# $index\n";
61753090
TC
1165 is(0+$index, $expected, "index matched expected");
1166 my ($new) = Imager::i_getcolors($im, $index);
1167 ok($new, "got the color");
1168 ok(color_cmp($new, $color) == 0, "color matched what was added");
faa9b3e7
TC
1169
1170 $index;
1171}
1172
61753090
TC
1173# sub array_ncmp {
1174# my ($a1, $a2) = @_;
1175# my $len = @$a1 < @$a2 ? @$a1 : @$a2;
1176# for my $i (0..$len-1) {
1177# my $diff = $a1->[$i] <=> $a2->[$i]
1178# and return $diff;
1179# }
1180# return @$a1 <=> @$a2;
1181# }
faa9b3e7
TC
1182
1183sub dump_colors {
1184 for my $col (@_) {
1185 print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
1186 }
1187}
7b5f7619
TC
1188
1189sub _get_error {
1190 my @errors = Imager::i_errors();
1191 return join(": ", map $_->[0], @errors);
1192}