- creating an image where the size of the allocated image buffer would
[imager.git] / t / t01introvert.t
1 #!perl -w
2 # t/t01introvert.t - tests internals of image formats
3 # to make sure we get expected values
4 #
5 # Change 1..1 below to 1..last_test_to_print .
6 # (It may become useful if the test is moved to ./t subdirectory.)
7
8 use strict;
9
10 my $loaded;
11 BEGIN { $| = 1; print "1..93\n"; }
12 END {print "not ok 1\n" unless $loaded;}
13 use Imager qw(:handy :all);
14 $loaded = 1;
15 print "ok 1\n";
16
17 require "t/testtools.pl";
18
19 init_log("testout/t01introvert.log",1);
20
21 my $im_g = Imager::ImgRaw::new(100, 101, 1);
22
23 print Imager::i_img_getchannels($im_g) == 1 
24   ? "ok 2\n" : "not ok 2 # 1 channel image channel count mismatch\n";
25 print Imager::i_img_getmask($im_g) & 1 
26   ? "ok 3\n" : "not ok 3 # 1 channel image bad mask\n";
27 print Imager::i_img_virtual($im_g) 
28   ? "not ok 4 # 1 channel image thinks it is virtual\n" : "ok 4\n";
29 print Imager::i_img_bits($im_g) == 8
30   ? "ok 5\n" : "not ok 5 # 1 channel image has bits != 8\n";
31 print Imager::i_img_type($im_g) == 0 # direct
32   ? "ok 6\n" : "not ok 6 # 1 channel image isn't direct\n";
33
34 my @ginfo = Imager::i_img_info($im_g);
35 print $ginfo[0] == 100 
36   ? "ok 7\n" : "not ok 7 # 1 channel image width incorrect\n";
37 print $ginfo[1] == 101
38   ? "ok 8\n" : "not ok 8 # 1 channel image height incorrect\n";
39
40 undef $im_g; # can we check for release after this somehow?
41
42 my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
43
44 print Imager::i_img_getchannels($im_rgb) == 3
45   ? "ok 9\n" : "not ok 9 # 3 channel image channel count mismatch\n";
46 print +(Imager::i_img_getmask($im_rgb) & 7) == 7
47   ? "ok 10\n" : "not ok 10 # 3 channel image bad mask\n";
48 print Imager::i_img_bits($im_rgb) == 8
49   ? "ok 11\n" : "not ok 11 # 3 channel image has bits != 8\n";
50 print Imager::i_img_type($im_rgb) == 0 # direct
51   ? "ok 12\n" : "not ok 12 # 3 channel image isn't direct\n";
52
53 undef $im_rgb;
54
55 my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
56
57 print $im_pal ? "ok 13\n" : "not ok 13 # couldn't make paletted image\n";
58 print Imager::i_img_getchannels($im_pal) == 3
59   ? "ok 14\n" : "not ok 14 # pal img channel count mismatch\n";
60 print Imager::i_img_bits($im_pal) == 8
61   ? "ok 15\n" : "not ok 15 # pal img bits != 8\n";
62 print Imager::i_img_type($im_pal) == 1
63   ? "ok 16\n" : "not ok 16 # pal img isn't paletted\n";
64
65 my $red = NC(255, 0, 0);
66 my $green = NC(0, 255, 0);
67 my $blue = NC(0, 0, 255);
68
69 my $red_idx = check_add(17, $im_pal, $red, 0);
70 my $green_idx = check_add(21, $im_pal, $green, 1);
71 my $blue_idx = check_add(25, $im_pal, $blue, 2);
72
73 # basic writing of palette indicies
74 # fill with red
75 Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100) == 100
76   or print "not ";
77 print "ok 29\n";
78 # and blue
79 Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50) == 50
80   or print "not ";
81 print "ok 30\n";
82
83 # make sure we get it back
84 my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
85 grep($_ != $red_idx, @pals[0..49]) and print "not ";
86 print "ok 31\n";
87 grep($_ != $blue_idx, @pals[50..99]) and print "not ";
88 print "ok 32\n";
89 Imager::i_gpal($im_pal, 0, 100, 0) eq "\0" x 50 . "\2" x 50 or print "not ";
90 print "ok 33\n";
91 my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
92 @samp == 300 or print "not ";
93 print "ok 34\n";
94 my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
95 my $diff = array_ncmp(\@samp, \@samp_exp);
96 $diff == 0 or print "not ";
97 print "ok 35\n";
98 my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, 0, 1, 2);
99 length($samp) == 300 or print "not ";
100 print "ok 36\n";
101 $samp eq "\xFF\0\0" x 50 . "\0\0\xFF" x 50
102   or print "not ";
103 print "ok 37\n";
104
105 # reading indicies as colors
106 my $c_red = Imager::i_get_pixel($im_pal, 0, 0)
107   or print "not ";
108 print "ok 38\n";
109 color_cmp($red, $c_red) == 0
110   or print "not ";
111 print "ok 39\n";
112 my $c_blue = Imager::i_get_pixel($im_pal, 50, 0)
113   or print "not ";
114 print "ok 40\n";
115 color_cmp($blue, $c_blue) == 0
116   or print "not ";
117 print "ok 41\n";
118
119 # drawing with colors
120 Imager::i_ppix($im_pal, 0, 0, $green) and print "not ";
121 print "ok 42\n";
122 # that was in the palette, should still be paletted
123 print Imager::i_img_type($im_pal) == 1
124   ? "ok 43\n" : "not ok 43 # pal img isn't paletted (but still should be)\n";
125
126 my $c_green = Imager::i_get_pixel($im_pal, 0, 0)
127   or print "not ";
128 print "ok 44\n";
129 color_cmp($green, $c_green) == 0
130   or print "not ";
131 print "ok 45\n";
132
133 Imager::i_colorcount($im_pal) == 3 or print "not ";
134 print "ok 46\n";
135 Imager::i_findcolor($im_pal, $green) == 1 or print "not ";
136 print "ok 47\n";
137
138 my $black = NC(0, 0, 0);
139 # this should convert the image to RGB
140 Imager::i_ppix($im_pal, 1, 0, $black) and print "not ";
141 print "ok 48\n";
142 print Imager::i_img_type($im_pal) == 0
143   ? "ok 49\n" : "not ok 49 # pal img shouldn't be paletted now\n";
144
145 my %quant =
146   (
147    colors => [$red, $green, $blue, $black],
148    makemap => 'none',
149   );
150 my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
151 $im_pal2 or print "not ";
152 print "ok 50\n";
153 @{$quant{colors}} == 4 or print "not ";
154 print "ok 51\n";
155 Imager::i_gsamp($im_pal2, 0, 100, 0, 0, 1, 2) 
156   eq "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50
157   or print "not ";
158 print "ok 52\n";
159
160 # test the OO interfaces
161 my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201)
162   or print "not ";
163 print "ok 53\n";
164 $impal2->getchannels == 3 or print "not ";
165 print "ok 54\n";
166 $impal2->bits == 8 or print "not ";
167 print "ok 55\n";
168 $impal2->type eq 'paletted' or print "not ";
169 print "ok 56\n";
170
171 {
172   my $red_idx = $impal2->addcolors(colors=>[$red])
173     or print "not ";
174   print "ok 57\n";
175   $red_idx == 0 or print "not ";
176   print "ok 58\n";
177   my $blue_idx = $impal2->addcolors(colors=>[$blue, $green])
178     or print "not ";
179   print "ok 59\n";
180   $blue_idx == 1 or print "not ";
181   print "ok 60\n";
182   my $green_idx = $blue_idx + 1;
183   my $c = $impal2->getcolors(start=>$green_idx);
184   color_cmp($green, $c) == 0 or print "not ";
185   print "ok 61\n";
186   my @cols = $impal2->getcolors;
187   @cols == 3 or print "not ";
188   print "ok 62\n";
189   my @exp = ( $red, $blue, $green );
190   for my $i (0..2) {
191     if (color_cmp($cols[$i], $exp[$i])) {
192       print "not ";
193       last;
194     }
195   }
196   print "ok 63\n";
197   $impal2->colorcount == 3 or print "not ";
198   print "ok 64\n";
199   $impal2->maxcolors == 256 or print "not ";
200   print "ok 65\n";
201   $impal2->findcolor(color=>$blue) == 1 or print "not ";
202   print "ok 66\n";
203   $impal2->setcolors(start=>0, colors=>[ $blue, $red ]) or print "not ";
204   print "ok 67\n";
205
206   # make an rgb version
207   my $imrgb2 = $impal2->to_rgb8();
208   $imrgb2->type eq 'direct' or print "not ";
209   print "ok 68\n";
210
211   # and back again, specifying the palette
212   my @colors = ( $red, $blue, $green );
213   my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
214                                     make_colors=>'none',
215                                     translate=>'closest')
216     or print "not ";
217   print "ok 69\n";
218   dump_colors(@colors);
219   print "# in image\n";
220   dump_colors($impal3->getcolors);
221   $impal3->colorcount == 3 or print "not ";
222   print "ok 70\n";
223   $impal3->type eq 'paletted' or print "not ";
224   print "ok 71\n";
225 }
226
227 my $num = 72;
228 okn($num++, !Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
229 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
230        "0 height error message check");
231 okn($num++, !Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
232 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
233        "0 width error message check");
234 okn($num++, !Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
235 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
236        "-ve width error message check");
237 okn($num++, !Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
238 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
239        "-ve height error message check");
240 okn($num++, !Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
241 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
242        "-ve width/height error message check");
243
244 okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>0),
245     "fail to create a zero channel image");
246 matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
247        "out of range channel message check");
248 okn($num++, !Imager->new(xsize=>1, ysize=>1, channels=>5),
249     "fail to create a five channel image");
250 matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
251        "out of range channel message check");
252
253 {
254   # https://rt.cpan.org/Ticket/Display.html?id=8213
255   # check for handling of memory allocation of very large images
256   # only test this on 32-bit machines - on a 64-bit machine it may
257   # result in trying to allocate 4Gb of memory, which is unfriendly at
258   # least and may result in running out of memory, causing a different
259   # type of exit
260   use Config;
261   if ($Config{ivsize} == 4) {
262     my $uint_range = 256 ** $Config{ivsize};
263     print "# range $uint_range\n";
264     my $dim1 = int(sqrt($uint_range))+1;
265     
266     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
267     isn($num++, $im_b, undef, "integer overflow check - 1 channel");
268     
269     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
270     okn($num++, $im_b, "but same width ok");
271     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
272     okn($num++, $im_b, "but same height ok");
273     matchn($num++, Imager->errstr, qr/integer overflow/,
274            "check the error message");
275
276     # do a similar test with a 3 channel image, so we're sure we catch
277     # the same case where the third dimension causes the overflow
278     my $dim3 = int(sqrt($uint_range / 3))+1;
279     
280     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
281     isn($num++, $im_b, undef, "integer overflow check - 3 channel");
282     
283     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
284     okn($num++, $im_b, "but same width ok");
285     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
286     okn($num++, $im_b, "but same height ok");
287
288     matchn($num++, Imager->errstr, qr/integer overflow/,
289            "check the error message");
290   }
291   else {
292     skipn($num, 8, "don't want to allocate 4Gb");
293     $num += 8;
294   }
295 }
296
297 sub check_add {
298   my ($base, $im, $color, $expected) = @_;
299   my $index = Imager::i_addcolors($im, $color)
300     or print "not ";
301   print "ok ",$base++,"\n";
302   print "# $index\n";
303   $index == $expected
304     or print "not ";
305   print "ok ",$base++,"\n";
306   my ($new) = Imager::i_getcolors($im, $index)
307     or print "not ";
308   print "ok ",$base++,"\n";
309   color_cmp($new, $color) == 0
310     or print "not ";
311   print "ok ",$base++,"\n";
312
313   $index;
314 }
315
316 sub color_cmp {
317   my ($l, $r) = @_;
318   my @l = $l->rgba;
319   my @r = $r->rgba;
320   return $l[0] <=> $r[0]
321     || $l[1] <=> $r[1]
322       || $l[2] <=> $r[2];
323 }
324
325 sub array_ncmp {
326   my ($a1, $a2) = @_;
327   my $len = @$a1 < @$a2 ? @$a1 : @$a2;
328   for my $i (0..$len-1) {
329     my $diff = $a1->[$i] <=> $a2->[$i] 
330       and return $diff;
331   }
332   return @$a1 <=> @$a2;
333 }
334
335 sub dump_colors {
336   for my $col (@_) {
337     print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
338   }
339 }