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