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