]>
Commit | Line | Data |
---|---|---|
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 | |
5 | use strict; | |
b3aa972f | 6 | use Test::More tests => 223; |
faa9b3e7 | 7 | |
61753090 | 8 | BEGIN { use_ok(Imager => qw(:handy :all)) } |
faa9b3e7 | 9 | |
1501d9b3 TC |
10 | require "t/testtools.pl"; |
11 | ||
b3aa972f | 12 | use Imager::Test qw(image_bounds_checks is_color4 is_fcolor4); |
837a4b43 | 13 | |
faa9b3e7 TC |
14 | init_log("testout/t01introvert.log",1); |
15 | ||
16 | my $im_g = Imager::ImgRaw::new(100, 101, 1); | |
17 | ||
ca4d914e TC |
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 | ||
61753090 TC |
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"); | |
faa9b3e7 TC |
33 | |
34 | my @ginfo = Imager::i_img_info($im_g); | |
61753090 TC |
35 | is($ginfo[0], 100, "1 channel image width"); |
36 | is($ginfo[1], 101, "1 channel image height"); | |
faa9b3e7 TC |
37 | |
38 | undef $im_g; # can we check for release after this somehow? | |
39 | ||
40 | my $im_rgb = Imager::ImgRaw::new(100, 101, 3); | |
41 | ||
61753090 TC |
42 | is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count"); |
43 | is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask"); | |
44 | is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample"); | |
45 | is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct"); | |
faa9b3e7 TC |
46 | |
47 | undef $im_rgb; | |
48 | ||
49 | my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256); | |
50 | ||
61753090 TC |
51 | ok($im_pal, "make paletted image"); |
52 | is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count"); | |
53 | is(Imager::i_img_bits($im_pal), 8, "pal img bits"); | |
54 | is(Imager::i_img_type($im_pal), 1, "pal img is paletted"); | |
faa9b3e7 | 55 | |
61753090 TC |
56 | my $red_idx = check_add($im_pal, $red, 0); |
57 | my $green_idx = check_add($im_pal, $green, 1); | |
58 | my $blue_idx = check_add($im_pal, $blue, 2); | |
faa9b3e7 TC |
59 | |
60 | # basic writing of palette indicies | |
61 | # fill with red | |
61753090 TC |
62 | is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100, |
63 | "write red 100 times"); | |
faa9b3e7 | 64 | # and blue |
61753090 TC |
65 | is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50, |
66 | "write blue 50 times"); | |
faa9b3e7 TC |
67 | |
68 | # make sure we get it back | |
69 | my @pals = Imager::i_gpal($im_pal, 0, 100, 0); | |
61753090 TC |
70 | ok(!grep($_ != $red_idx, @pals[0..49]), "check for red"); |
71 | ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue"); | |
72 | is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50, | |
73 | "gpal in scalar context"); | |
faa9b3e7 | 74 | my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2); |
61753090 | 75 | is(@samp, 300, "gsamp count in list context"); |
faa9b3e7 | 76 | my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50); |
61753090 | 77 | is_deeply(\@samp, \@samp_exp, "gsamp list deep compare"); |
faa9b3e7 | 78 | my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2); |
61753090 TC |
79 | is(length($samp), 300, "gsamp scalar length"); |
80 | is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes"); | |
faa9b3e7 TC |
81 | |
82 | # reading indicies as colors | |
61753090 TC |
83 | my $c_red = Imager::i_get_pixel($im_pal, 0, 0); |
84 | ok($c_red, "got the red pixel"); | |
85 | ok(color_cmp($red, $c_red) == 0, "and it's red"); | |
86 | my $c_blue = Imager::i_get_pixel($im_pal, 50, 0); | |
87 | ok($c_blue, "got the blue pixel"); | |
88 | ok(color_cmp($blue, $c_blue) == 0, "and it's blue"); | |
faa9b3e7 TC |
89 | |
90 | # drawing with colors | |
61753090 | 91 | ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette"); |
faa9b3e7 | 92 | # that was in the palette, should still be paletted |
61753090 | 93 | is(Imager::i_img_type($im_pal), 1, "image still paletted"); |
faa9b3e7 | 94 | |
61753090 TC |
95 | my $c_green = Imager::i_get_pixel($im_pal, 0, 0); |
96 | ok($c_green, "got green pixel"); | |
97 | ok(color_cmp($green, $c_green) == 0, "and it's green"); | |
faa9b3e7 | 98 | |
61753090 TC |
99 | is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette"); |
100 | is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second"); | |
faa9b3e7 TC |
101 | |
102 | my $black = NC(0, 0, 0); | |
103 | # this should convert the image to RGB | |
61753090 TC |
104 | ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)"); |
105 | is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now"); | |
faa9b3e7 TC |
106 | |
107 | my %quant = | |
108 | ( | |
109 | colors => [$red, $green, $blue, $black], | |
110 | makemap => 'none', | |
111 | ); | |
112 | my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant); | |
61753090 TC |
113 | ok($im_pal2, "got an image from quantizing"); |
114 | is(@{$quant{colors}}, 4, "has the right number of colours"); | |
115 | is(Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2), | |
116 | "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50, | |
117 | "colors are still correct"); | |
faa9b3e7 TC |
118 | |
119 | # test the OO interfaces | |
61753090 TC |
120 | my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201); |
121 | ok($impal2, "make paletted via OO"); | |
122 | is($impal2->getchannels, 3, "check channels"); | |
123 | is($impal2->bits, 8, "check bits"); | |
124 | is($impal2->type, 'paletted', "check type"); | |
faa9b3e7 TC |
125 | |
126 | { | |
61753090 TC |
127 | my $red_idx = $impal2->addcolors(colors=>[$red]); |
128 | ok($red_idx, "add red to OO"); | |
129 | is(0+$red_idx, 0, "and it's expected index for red"); | |
130 | my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]); | |
131 | ok($blue_idx, "add blue/green via OO"); | |
132 | is($blue_idx, 1, "and it's expected index for blue"); | |
faa9b3e7 TC |
133 | my $green_idx = $blue_idx + 1; |
134 | my $c = $impal2->getcolors(start=>$green_idx); | |
61753090 | 135 | ok(color_cmp($green, $c) == 0, "found green where expected"); |
faa9b3e7 | 136 | my @cols = $impal2->getcolors; |
61753090 | 137 | is(@cols, 3, "got 3 colors"); |
faa9b3e7 | 138 | my @exp = ( $red, $blue, $green ); |
61753090 | 139 | my $good = 1; |
faa9b3e7 TC |
140 | for my $i (0..2) { |
141 | if (color_cmp($cols[$i], $exp[$i])) { | |
61753090 | 142 | $good = 0; |
faa9b3e7 TC |
143 | last; |
144 | } | |
145 | } | |
61753090 TC |
146 | ok($good, "all colors in palette as expected"); |
147 | is($impal2->colorcount, 3, "and colorcount returns 3"); | |
148 | is($impal2->maxcolors, 256, "maxcolors as expected"); | |
149 | is($impal2->findcolor(color=>$blue), 1, "findcolors found blue"); | |
150 | ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]), | |
151 | "we can setcolors"); | |
faa9b3e7 TC |
152 | |
153 | # make an rgb version | |
154 | my $imrgb2 = $impal2->to_rgb8(); | |
61753090 | 155 | is($imrgb2->type, 'direct', "converted is direct"); |
faa9b3e7 TC |
156 | |
157 | # and back again, specifying the palette | |
158 | my @colors = ( $red, $blue, $green ); | |
159 | my $impal3 = $imrgb2->to_paletted(colors=>\@colors, | |
160 | make_colors=>'none', | |
61753090 TC |
161 | translate=>'closest'); |
162 | ok($impal3, "got a paletted image from conversion"); | |
faa9b3e7 TC |
163 | dump_colors(@colors); |
164 | print "# in image\n"; | |
165 | dump_colors($impal3->getcolors); | |
61753090 TC |
166 | is($impal3->colorcount, 3, "new image has expected color table size"); |
167 | is($impal3->type, 'paletted', "and is paletted"); | |
faa9b3e7 TC |
168 | } |
169 | ||
61753090 TC |
170 | ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image"); |
171 | cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/, | |
1501d9b3 | 172 | "0 height error message check"); |
61753090 TC |
173 | ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image"); |
174 | cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/, | |
1501d9b3 | 175 | "0 width error message check"); |
61753090 TC |
176 | ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image"); |
177 | cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/, | |
1501d9b3 | 178 | "-ve width error message check"); |
61753090 TC |
179 | ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image"); |
180 | cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/, | |
1501d9b3 | 181 | "-ve height error message check"); |
61753090 TC |
182 | ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image"); |
183 | cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/, | |
1501d9b3 TC |
184 | "-ve width/height error message check"); |
185 | ||
61753090 TC |
186 | ok(!Imager->new(xsize=>1, ysize=>1, channels=>0), |
187 | "fail to create a zero channel image"); | |
188 | cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/, | |
1501d9b3 | 189 | "out of range channel message check"); |
61753090 TC |
190 | ok(!Imager->new(xsize=>1, ysize=>1, channels=>5), |
191 | "fail to create a five channel image"); | |
192 | cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/, | |
1501d9b3 TC |
193 | "out of range channel message check"); |
194 | ||
653ea321 TC |
195 | { |
196 | # https://rt.cpan.org/Ticket/Display.html?id=8213 | |
197 | # check for handling of memory allocation of very large images | |
198 | # only test this on 32-bit machines - on a 64-bit machine it may | |
199 | # result in trying to allocate 4Gb of memory, which is unfriendly at | |
200 | # least and may result in running out of memory, causing a different | |
201 | # type of exit | |
61753090 TC |
202 | SKIP: |
203 | { | |
204 | use Config; | |
205 | skip("don't want to allocate 4Gb", 8) unless $Config{intsize} == 4; | |
206 | ||
f8906310 | 207 | my $uint_range = 256 ** $Config{intsize}; |
653ea321 TC |
208 | print "# range $uint_range\n"; |
209 | my $dim1 = int(sqrt($uint_range))+1; | |
210 | ||
211 | my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1); | |
61753090 | 212 | is($im_b, undef, "integer overflow check - 1 channel"); |
653ea321 TC |
213 | |
214 | $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1); | |
61753090 | 215 | ok($im_b, "but same width ok"); |
653ea321 | 216 | $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1); |
61753090 TC |
217 | ok($im_b, "but same height ok"); |
218 | cmp_ok(Imager->errstr, '=~', qr/integer overflow/, | |
653ea321 TC |
219 | "check the error message"); |
220 | ||
221 | # do a similar test with a 3 channel image, so we're sure we catch | |
222 | # the same case where the third dimension causes the overflow | |
223 | my $dim3 = int(sqrt($uint_range / 3))+1; | |
224 | ||
225 | $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3); | |
61753090 | 226 | is($im_b, undef, "integer overflow check - 3 channel"); |
653ea321 TC |
227 | |
228 | $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3); | |
61753090 | 229 | ok($im_b, "but same width ok"); |
653ea321 | 230 | $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3); |
61753090 | 231 | ok($im_b, "but same height ok"); |
653ea321 | 232 | |
61753090 | 233 | cmp_ok(Imager->errstr, '=~', qr/integer overflow/, |
653ea321 TC |
234 | "check the error message"); |
235 | } | |
653ea321 | 236 | } |
1501d9b3 | 237 | |
34b3f7e6 TC |
238 | { # http://rt.cpan.org/NoAuth/Bug.html?id=9672 |
239 | my $warning; | |
240 | local $SIG{__WARN__} = | |
241 | sub { | |
242 | $warning = "@_"; | |
243 | my $printed = $warning; | |
244 | $printed =~ s/\n$//; | |
245 | $printed =~ s/\n/\n\#/g; | |
246 | print "# ",$printed, "\n"; | |
247 | }; | |
248 | my $img = Imager->new(xsize=>10, ysize=>10); | |
249 | $img->to_rgb8(); # doesn't really matter what the source is | |
250 | cmp_ok($warning, '=~', 'void', "correct warning"); | |
251 | cmp_ok($warning, '=~', 't01introvert\\.t', "correct file"); | |
252 | } | |
253 | ||
12b1fac2 TC |
254 | { # http://rt.cpan.org/NoAuth/Bug.html?id=11860 |
255 | my $im = Imager->new(xsize=>2, ysize=>2); | |
256 | $im->setpixel(x=>0, 'y'=>0, color=>$red); | |
257 | $im->setpixel(x=>1, 'y'=>0, color=>$blue); | |
258 | ||
259 | my @row = Imager::i_glin($im->{IMG}, 0, 2, 0); | |
260 | is(@row, 2, "got 2 pixels from i_glin"); | |
261 | ok(color_cmp($row[0], $red) == 0, "red first"); | |
262 | ok(color_cmp($row[1], $blue) == 0, "then blue"); | |
263 | } | |
264 | ||
241defe8 TC |
265 | { # general tag tests |
266 | ||
267 | # we don't care much about the image itself | |
268 | my $im = Imager::ImgRaw::new(10, 10, 1); | |
269 | ||
270 | ok(Imager::i_tags_addn($im, 'alpha', 0, 101), "i_tags_addn(...alpha, 0, 101)"); | |
271 | ok(Imager::i_tags_addn($im, undef, 99, 102), "i_tags_addn(...undef, 99, 102)"); | |
272 | is(Imager::i_tags_count($im), 2, "should have 2 tags"); | |
273 | ok(Imager::i_tags_addn($im, undef, 99, 103), "i_tags_addn(...undef, 99, 103)"); | |
274 | is(Imager::i_tags_count($im), 3, "should have 3 tags, despite the dupe"); | |
275 | is(Imager::i_tags_find($im, 'alpha', 0), '0 but true', "find alpha"); | |
276 | is(Imager::i_tags_findn($im, 99, 0), 1, "find 99"); | |
277 | is(Imager::i_tags_findn($im, 99, 2), 2, "find 99 again"); | |
278 | is(Imager::i_tags_get($im, 0), 101, "check first"); | |
279 | is(Imager::i_tags_get($im, 1), 102, "check second"); | |
280 | is(Imager::i_tags_get($im, 2), 103, "check third"); | |
281 | ||
282 | ok(Imager::i_tags_add($im, 'beta', 0, "hello", 0), | |
283 | "add string with string key"); | |
284 | ok(Imager::i_tags_add($im, 'gamma', 0, "goodbye", 0), | |
285 | "add another one"); | |
286 | ok(Imager::i_tags_add($im, undef, 199, "aloha", 0), | |
287 | "add one keyed by number"); | |
288 | is(Imager::i_tags_find($im, 'beta', 0), 3, "find beta"); | |
289 | is(Imager::i_tags_find($im, 'gamma', 0), 4, "find gamma"); | |
290 | is(Imager::i_tags_findn($im, 199, 0), 5, "find 199"); | |
291 | ok(Imager::i_tags_delete($im, 2), "delete"); | |
292 | is(Imager::i_tags_find($im, 'beta', 0), 2, 'find beta after deletion'); | |
293 | ok(Imager::i_tags_delbyname($im, 'beta'), 'delete beta by name'); | |
294 | is(Imager::i_tags_find($im, 'beta', 0), undef, 'beta not there now'); | |
295 | is(Imager::i_tags_get_string($im, "gamma"), "goodbye", | |
296 | 'i_tags_get_string() on a string'); | |
297 | is(Imager::i_tags_get_string($im, 99), 102, | |
298 | 'i_tags_get_string() on a number entry'); | |
299 | ok(Imager::i_tags_delbycode($im, 99), 'delete by code'); | |
300 | is(Imager::i_tags_findn($im, 99, 0), undef, '99 not there now'); | |
301 | is(Imager::i_tags_count($im), 3, 'final count of 3'); | |
302 | } | |
303 | ||
ca4d914e TC |
304 | { |
305 | print "# low-level scan line function tests\n"; | |
306 | my $im = Imager::ImgRaw::new(10, 10, 4); | |
307 | Imager::i_ppix($im, 5, 0, $red); | |
308 | ||
309 | # i_glin/i_glinf | |
310 | my @colors = Imager::i_glin($im, 0, 10, 0); | |
311 | is_deeply([ (0) x 20, (255, 0, 0, 255), (0) x 16 ], | |
312 | [ map $_->rgba, @colors ], | |
313 | "i_glin - list context"); | |
314 | my $colors = Imager::i_glin($im, 0, 10, 0); | |
315 | is("00" x 20 . "FF0000FF" . "00" x 16, | |
316 | uc unpack("H*", $colors), "i_glin - scalar context"); | |
317 | my @fcolors = Imager::i_glinf($im, 0, 10, 0); | |
318 | is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ], | |
319 | [ map $_->rgba, @fcolors ], | |
320 | "i_glinf - list context"); | |
321 | my $fcolors = Imager::i_glinf($im, 0, 10, 0); | |
322 | is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ], | |
323 | [ unpack "d*", $fcolors ], | |
324 | "i_glinf - scalar context"); | |
325 | ||
326 | # i_plin/i_plinf | |
327 | my @plin_colors = (($black) x 4, $red, $blue, ($black) x 4); | |
328 | is(Imager::i_plin($im, 0, 1, @plin_colors), | |
329 | 10, "i_plin - pass in a list"); | |
330 | # make sure we get it back | |
331 | is_deeply([ map [ $_->rgba ], @plin_colors ], | |
332 | [ map [ $_->rgba ], Imager::i_glin($im, 0, 10, 1) ], | |
333 | "check i_plin wrote to the image"); | |
334 | my @scalar_plin = | |
335 | ( | |
336 | (0,0,0,0) x 4, | |
337 | (0, 255, 0, 255), | |
338 | (0, 0, 255, 255), | |
339 | (0, 0, 0, 0) x 4, | |
340 | ); | |
341 | is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)), | |
342 | 10, "i_plin - pass in a scalar"); | |
343 | is_deeply(\@scalar_plin, | |
344 | [ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ], | |
345 | "check i_plin scalar wrote to the image"); | |
346 | ||
347 | my @plinf_colors = # Note: only 9 pixels | |
348 | ( | |
349 | ($f_blue) x 4, | |
350 | $f_red, | |
351 | ($f_black) x 3, | |
352 | $f_black | |
353 | ); | |
354 | is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9, | |
355 | "i_plinf - list"); | |
356 | is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ], | |
357 | [ map $_->rgba, @plinf_colors ], | |
358 | "check colors were written"); | |
359 | my @scalar_plinf = | |
360 | ( | |
361 | ( 1.0, 1.0, 0, 1.0 ) x 3, | |
362 | ( 0, 1.0, 1.0, 1.0 ) x 2, | |
363 | ( 0, 0, 0, 0 ), | |
364 | ( 1.0, 0, 1.0, 1.0 ), | |
365 | ); | |
366 | is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)), | |
367 | 7, "i_plinf - scalar"); | |
368 | is_deeply(\@scalar_plinf, | |
369 | [ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ], | |
370 | "check colors were written"); | |
371 | ||
372 | is_deeply([ Imager::i_gsamp($im, 0, 10, 0, (0, 3)) ], | |
373 | [ (0, 0) x 5, (255, 255), (0, 0) x 4 ], | |
374 | "i_gsamp list context"); | |
375 | is("0000" x 5 . "FFFF" . "0000" x 4, | |
376 | uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, (0, 3))), | |
377 | "i_gsamp scalar context"); | |
378 | is_deeply([ Imager::i_gsampf($im, 2, 9, 4, 0, 2, 3) ], | |
379 | [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0), | |
380 | (1.0, 1.0, 1.0) ], "i_gsampf - list context"); | |
381 | is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, 0, 2, 3)) ], | |
382 | [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0), | |
383 | (1.0, 1.0, 1.0) ], "i_gsampf - scalar context"); | |
384 | print "# end low-level scan-line function tests\n"; | |
385 | } | |
386 | ||
387 | { | |
388 | print "# OO level scanline function tests\n"; | |
389 | my $im = Imager->new(xsize=>10, ysize=>10, channels=>4); | |
390 | $im->setpixel(color=>$red, 'x'=>5, 'y'=>0); | |
391 | ok(!$im->getscanline(), "getscanline() - supply nothing, get nothing"); | |
392 | is($im->errstr, "missing y parameter", "check message"); | |
393 | is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0) ], | |
394 | [ ([ 0,0,0,0]) x 5, [ 255, 0, 0, 255 ], ([ 0,0,0,0]) x 4 ], | |
395 | "getscanline, list context, default x, width"); | |
396 | is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>3) ], | |
397 | [ ([0,0,0,0]) x 2, [ 255, 0, 0, 255 ], ([0,0,0,0]) x 4 ], | |
398 | "getscanline, list context, default width"); | |
399 | is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>4, width=>4) ], | |
400 | [ [0,0,0,0], [ 255, 0, 0, 255 ], ([0,0,0,0]) x 2 ], | |
401 | "getscanline, list context, no defaults"); | |
402 | is(uc unpack("H*", $im->getscanline('y'=>0)), | |
403 | "00000000" x 5 . "FF0000FF" . "00000000" x 4, | |
404 | "getscanline, scalar context, default x, width"); | |
405 | is_deeply([ map [ $_->rgba ], | |
406 | $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ], | |
407 | [ [0,0,0,0], [ 1.0, 0, 0, 1.0 ], ([0,0,0,0]) x 2 ], | |
408 | "getscanline float, list context, no defaults"); | |
409 | is_deeply([ unpack "d*", | |
410 | $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ], | |
411 | [ (0,0,0,0), ( 1.0, 0, 0, 1.0 ), (0,0,0,0) x 2 ], | |
412 | "getscanline float, scalar context, no defaults"); | |
413 | ||
414 | ok(!$im->getscanline('y'=>0, type=>'invalid'), | |
415 | "check invalid type checking"); | |
416 | like($im->errstr, qr/invalid type parameter/, | |
417 | "check message for invalid type"); | |
418 | ||
419 | my @plin_colors = (($black) x 4, $red, $blue, ($green) x 4); | |
420 | is($im->setscanline('y'=>1, pixels=>\@plin_colors), 10, | |
421 | "setscanline - arrayref, default x"); | |
422 | is_deeply([ map [ $_->rgba ], @plin_colors ], | |
423 | [ map [ $_->rgba ], $im->getscanline('y'=>1) ], | |
424 | "check colors were written"); | |
425 | ||
426 | my @plin_colors2 = ( $green, $red, $blue, $red ); | |
427 | is($im->setscanline('y'=>2, 'x'=>3, pixels=>\@plin_colors2), 4, | |
428 | "setscanline - arrayref"); | |
a3ca0e81 TC |
429 | |
430 | # using map instead of x here due to a bug in some versions of Test::More | |
431 | # fixed in the latest Test::More | |
432 | is_deeply([ ( map [ 0,0,0,0 ], 1..3), (map [ $_->rgba ], @plin_colors2), | |
433 | ( map [ 0,0,0,0 ], 1..3) ], | |
ca4d914e TC |
434 | [ map [ $_->rgba ], $im->getscanline('y'=>2) ], |
435 | "check write to middle of line"); | |
436 | ||
437 | my $raw_colors = pack "H*", "FF00FFFF"."FF0000FF"."FFFFFFFF"; | |
438 | is($im->setscanline('y'=>3, 'x'=>2, pixels=>$raw_colors), 3, | |
439 | "setscanline - scalar, default raw type") | |
440 | or print "# ",$im->errstr,"\n"; | |
441 | is(uc unpack("H*", $im->getscanline('y'=>3, 'x'=>1, 'width'=>5)), | |
442 | "00000000".uc(unpack "H*", $raw_colors)."00000000", | |
443 | "check write"); | |
444 | ||
445 | # float colors | |
446 | my @fcolors = ( $f_red, $f_blue, $f_black, $f_green ); | |
447 | is($im->setscanline('y'=>4, 'x'=>3, pixels=>\@fcolors), 4, | |
448 | "setscanline - float arrayref"); | |
449 | is_deeply([ map [ $_->rgba ], @fcolors ], | |
450 | [ map [ $_->rgba ], $im->getscanline('y'=>4, 'x'=>3, width=>4, type=>'float') ], | |
451 | "check write"); | |
452 | # packed | |
453 | my $packed_fcolors = pack "d*", map $_->rgba, @fcolors; | |
454 | is($im->setscanline('y'=>5, 'x'=>4, pixels=>$packed_fcolors, type=>'float'), 4, | |
455 | "setscanline - float scalar"); | |
456 | is_deeply([ map [ $_->rgba ], @fcolors ], | |
457 | [ map [ $_->rgba ], $im->getscanline('y'=>5, 'x'=>4, width=>4, type=>'float') ], | |
458 | "check write"); | |
459 | ||
460 | # get samples | |
461 | is_deeply([ $im->getsamples('y'=>1, channels=>[ 0 ]) ], | |
462 | [ map +($_->rgba)[0], @plin_colors ], | |
463 | "get channel 0, list context, default x, width"); | |
464 | is_deeply([ unpack "C*", $im->getsamples('y'=>1, channels=>[0, 2]) ], | |
465 | [ map { ($_->rgba)[0, 2] } @plin_colors ], | |
466 | "get channel 0, 1, scalar context"); | |
467 | is_deeply([ $im->getsamples('y'=>4, 'x'=>3, width=>4, type=>'float', | |
468 | channels=>[1,3]) ], | |
469 | [ map { ($_->rgba)[1,3] } @fcolors ], | |
470 | "get channels 1,3, list context, float samples"); | |
471 | is_deeply([ unpack "d*", | |
472 | $im->getsamples('y'=>4, 'x'=>3, width=>4, | |
473 | type=>'float', channels=>[3,2,1,0]) ], | |
474 | [ map { ($_->rgba)[3,2,1,0] } @fcolors ], | |
475 | "get channels 3..0 as scalar, float samples"); | |
476 | ||
477 | print "# end OO level scanline function tests\n"; | |
478 | } | |
479 | ||
b3aa972f TC |
480 | { # to avoid confusion, i_glin/i_glinf modified to return 0 in unused |
481 | # channels at the perl level | |
482 | my $im = Imager->new(xsize => 4, ysize => 4, channels => 2); | |
483 | my $fill = Imager::Color->new(128, 255, 0, 0); | |
484 | ok($im->box(filled => 1, color => $fill), 'fill it up'); | |
485 | my $data = $im->getscanline('y' => 0); | |
486 | is(unpack("H*", $data), "80ff000080ff000080ff000080ff0000", | |
487 | "check we get zeros"); | |
488 | my @colors = $im->getscanline('y' => 0); | |
489 | is_color4($colors[0], 128, 255, 0, 0, "check object interface[0]"); | |
490 | is_color4($colors[1], 128, 255, 0, 0, "check object interface[1]"); | |
491 | is_color4($colors[2], 128, 255, 0, 0, "check object interface[2]"); | |
492 | is_color4($colors[3], 128, 255, 0, 0, "check object interface[3]"); | |
493 | ||
494 | my $dataf = $im->getscanline('y' => 0, type => 'float'); | |
495 | is_deeply([ unpack("d*", $dataf) ], | |
496 | [ ( 128.0 / 255.0, 1.0, 0, 0, ) x 4 ], | |
497 | "check we get zeroes (double)"); | |
498 | my @fcolors = $im->getscanline('y' => 0, type => 'float'); | |
499 | is_fcolor4($fcolors[0], 128.0/255.0, 1.0, 0, 0, "check object interface[0]"); | |
500 | is_fcolor4($fcolors[1], 128.0/255.0, 1.0, 0, 0, "check object interface[1]"); | |
501 | is_fcolor4($fcolors[2], 128.0/255.0, 1.0, 0, 0, "check object interface[2]"); | |
502 | is_fcolor4($fcolors[3], 128.0/255.0, 1.0, 0, 0, "check object interface[3]"); | |
503 | } | |
504 | ||
9b8ce4f4 TC |
505 | { # check the channel mask function |
506 | ||
507 | my $im = Imager->new(xsize => 10, ysize=>10, bits=>8); | |
508 | ||
509 | mask_tests($im, 0.005); | |
510 | } | |
511 | ||
837a4b43 TC |
512 | { # check bounds checking |
513 | my $im = Imager->new(xsize => 10, ysize => 10); | |
514 | ||
515 | image_bounds_checks($im); | |
516 | } | |
517 | ||
faa9b3e7 | 518 | sub check_add { |
61753090 TC |
519 | my ($im, $color, $expected) = @_; |
520 | my $index = Imager::i_addcolors($im, $color); | |
521 | ok($index, "got index"); | |
faa9b3e7 | 522 | print "# $index\n"; |
61753090 TC |
523 | is(0+$index, $expected, "index matched expected"); |
524 | my ($new) = Imager::i_getcolors($im, $index); | |
525 | ok($new, "got the color"); | |
526 | ok(color_cmp($new, $color) == 0, "color matched what was added"); | |
faa9b3e7 TC |
527 | |
528 | $index; | |
529 | } | |
530 | ||
61753090 TC |
531 | # sub array_ncmp { |
532 | # my ($a1, $a2) = @_; | |
533 | # my $len = @$a1 < @$a2 ? @$a1 : @$a2; | |
534 | # for my $i (0..$len-1) { | |
535 | # my $diff = $a1->[$i] <=> $a2->[$i] | |
536 | # and return $diff; | |
537 | # } | |
538 | # return @$a1 <=> @$a2; | |
539 | # } | |
faa9b3e7 TC |
540 | |
541 | sub dump_colors { | |
542 | for my $col (@_) { | |
543 | print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n"; | |
544 | } | |
545 | } |