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