2 # some of this is tested in t01introvert.t too
5 use Test::More tests => 83;
6 BEGIN { use_ok("Imager"); }
10 my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
12 ok($img, "paletted image created");
14 is($img->type, 'paletted', "got a paletted image");
16 my $black = Imager::Color->new(0,0,0);
17 my $red = Imager::Color->new(255,0,0);
18 my $green = Imager::Color->new(0,255,0);
19 my $blue = Imager::Color->new(0,0,255);
21 my $white = Imager::Color->new(255,255,255);
24 my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
26 print "# blacki $blacki\n";
27 ok(defined $blacki && $blacki == 0, "we got the first color");
29 ok($img->colorcount() == 4, "should have 4 colors");
30 my ($redi, $greeni, $bluei) = 1..3;
32 my @all = $img->getcolors;
33 ok(@all == 4, "all colors is 4");
34 coloreq($all[0], $black, "first black");
35 coloreq($all[1], $red, "then red");
36 coloreq($all[2], $green, "then green");
37 coloreq($all[3], $blue, "and finally blue");
39 # keep this as an assignment, checking for scalar context
40 # we don't want the last color, otherwise if the behaviour changes to
41 # get all up to the last (count defaulting to size-index) we'd get a
43 my $one_color = $img->getcolors(start=>$redi);
44 ok($one_color->isa('Imager::Color'), "check scalar context");
45 coloreq($one_color, $red, "and that it's what we want");
47 # make sure we can find colors
48 ok(!defined($img->findcolor(color=>$white)),
49 "shouldn't be able to find white");
50 ok($img->findcolor(color=>$black) == $blacki, "find black");
51 ok($img->findcolor(color=>$red) == $redi, "find red");
52 ok($img->findcolor(color=>$green) == $greeni, "find green");
53 ok($img->findcolor(color=>$blue) == $bluei, "find blue");
55 # various failure tests for setcolors
56 ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
57 "expect failure: low index");
58 ok(!defined($img->setcolors(start=>1, colors=>[])),
59 "expect failure: no colors");
60 ok(!defined($img->setcolors(start=>5, colors=>[$white])),
61 "expect failure: high index");
63 # set the green index to white
64 ok($img->setcolors(start => $greeni, colors => [$white]),
67 coloreq(scalar($img->getcolors(start=>$greeni)), $white,
68 "make sure it was set");
69 ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
70 ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
73 ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
75 coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
76 coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
79 $img->setcolors(start=>$red, colors=>[$red, $green]);
81 # draw on the image, make sure it stays paletted when it should
82 ok($img->box(color=>$red, filled=>1), "fill with red");
83 is($img->type, 'paletted', "paletted after fill");
84 ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
85 xmax=>40, ymax=>40), "green box");
86 is($img->type, 'paletted', 'still paletted after box');
87 # an AA line will almost certainly convert the image to RGB, don't use
89 ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
91 is($img->type, 'paletted', 'still paletted after line');
93 # draw with white - should convert to direct
94 ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
95 xmax=>30, ymax=>30), "white box");
96 is($img->type, 'direct', "now it should be direct");
98 # various attempted to make a paletted image from our now direct image
99 my $palimg = $img->to_paletted;
100 ok($palimg, "we got an image");
101 # they should be the same pixel for pixel
102 ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
104 # strange case: no color picking, and no colors
105 # this was causing a segmentation fault
106 $palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
107 ok(!defined $palimg, "to paletted with an empty palette is an error");
108 print "# ",$img->errstr,"\n";
109 ok(scalar($img->errstr =~ /no colors available for translation/),
110 "and got the correct msg");
112 ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
113 "fail on -ve height");
114 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
115 "and correct error message");
116 ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
117 "fail on -ve width");
118 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
119 "and correct error message");
120 ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
121 "fail on -ve width/height");
122 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
123 "and correct error message");
125 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
126 "fail on 0 channels");
127 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
128 "and correct error message");
129 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
130 "fail on 5 channels");
131 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
132 "and correct error message");
135 # https://rt.cpan.org/Ticket/Display.html?id=8213
136 # check for handling of memory allocation of very large images
137 # only test this on 32-bit machines - on a 64-bit machine it may
138 # result in trying to allocate 4Gb of memory, which is unfriendly at
139 # least and may result in running out of memory, causing a different
144 skip("don't want to allocate 4Gb", 10)
145 unless $Config{intsize} == 4;
147 my $uint_range = 256 ** $Config{intsize};
148 my $dim1 = int(sqrt($uint_range))+1;
150 my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
151 is($im_b, undef, "integer overflow check - 1 channel");
153 $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
154 ok($im_b, "but same width ok");
155 $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
156 ok($im_b, "but same height ok");
157 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
158 "check the error message");
160 # do a similar test with a 3 channel image, so we're sure we catch
161 # the same case where the third dimension causes the overflow
162 # for paletted images the third dimension can't cause an overflow
163 # but make sure we didn't anything too dumb in the checks
166 $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
167 is($im_b, undef, "integer overflow check - 3 channel");
169 $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
170 ok($im_b, "but same width ok");
171 $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
172 ok($im_b, "but same height ok");
174 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
175 "check the error message");
177 # test the scanline allocation check
178 # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
179 # doesn't integer overflow, but the scanline of i_color (4/pixel) does
180 my $dim4 = $uint_range / 2 / 3;
181 my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
182 is($im_o, undef, "integer overflow check - scanline size");
183 cmp_ok(Imager->errstr, '=~',
184 qr/integer overflow calculating scanline allocation/,
185 "check error message");
189 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
191 local $SIG{__WARN__} =
194 my $printed = $warning;
196 $printed =~ s/\n/\n\#/g;
197 print "# ",$printed, "\n";
199 my $img = Imager->new(xsize=>10, ysize=>10);
201 cmp_ok($warning, '=~', 'void', "correct warning");
202 cmp_ok($warning, '=~', 't023palette\\.t', "correct file");
205 { # http://rt.cpan.org/NoAuth/Bug.html?id=12676
206 # setcolors() has a fencepost error
207 my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
209 is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
211 ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
212 ok(!$img->setcolors(start=>2, colors=>[ $black ]),
213 "set after the last color");
216 { # https://rt.cpan.org/Ticket/Display.html?id=20056
217 # added named color support to addcolor/setcolor
218 my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
219 is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
220 "add colors as strings instead of objects");
221 my @colors = $img->getcolors;
222 iscolor($colors[0], $black, "check first color");
223 iscolor($colors[1], $red, "check second color");
224 ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
225 "setcolors as strings instead of objects");
226 @colors = $img->getcolors;
227 iscolor($colors[0], $green, "check first color");
228 iscolor($colors[1], $blue, "check second color");
230 # make sure we handle bad colors correctly
231 is($img->colorcount, 2, "start from a known state");
232 is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
233 "fail to add unknown color");
234 is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
235 is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
236 "fail to set to unknown color");
237 is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
240 { # https://rt.cpan.org/Ticket/Display.html?id=20338
241 # OO interface to i_glin/i_plin
242 my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
243 is($im->addcolors(colors => [ "#000", "#F00", "#0F0", "#00F" ]), "0 but true",
244 "add some test colors")
245 or print "# ", $im->errstr, "\n";
246 # set a pixel to check
247 $im->setpixel(x => 1, 'y' => 0, color => "#0F0");
248 is_deeply([ $im->getscanline('y' => 0, type=>'index') ],
249 [ 0, 2, (0) x 8 ], "getscanline index in list context");
250 isbin($im->getscanline('y' => 0, type=>'index'),
251 "\x00\x02" . "\x00" x 8,
252 "getscanline index in scalar context");
253 is($im->setscanline('y' => 0, pixels => [ 1, 2, 0, 3 ], type => 'index'),
254 4, "setscanline with list");
255 is($im->setscanline('y' => 0, x => 4, pixels => pack("C*", 3, 2, 1, 0, 3),
257 5, "setscanline with pv");
258 is_deeply([ $im->getscanline(type => 'index', 'y' => 0) ],
259 [ 1, 2, 0, 3, 3, 2, 1, 0, 3, 0 ],
261 eval { # should croak on OOR index
262 $im->setscanline('y' => 1, pixels => [ 255 ], type=>'index');
264 ok($@, "croak on setscanline() to invalid index");
265 eval { # same again with pv
266 $im->setscanline('y' => 1, pixels => "\xFF", type => 'index');
268 ok($@, "croak on setscanline() with pv to invalid index");
272 my ($c1, $c2, $msg) = @_;
274 my $builder = Test::Builder->new;
277 if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
279 $builder->diag(<<DIAG);
281 expected color: [ @c2 ]
287 my ($got, $expected, $msg) = @_;
289 my $builder = Test::Builder->new;
290 if (!$builder->ok($got eq $expected, $msg)) {
291 (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
292 (my $exp_dec = $expected) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
293 $builder->diag(<<DIAG);
301 my ($left, $right, $comment) = @_;
303 my ($rl, $gl, $bl, $al) = $left->rgba;
304 my ($rr, $gr, $br, $ar) = $right->rgba;
306 print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
307 ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,