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