- the setcolors() had a fencepost error making it impossible to
[imager.git] / t / t023palette.t
CommitLineData
1501d9b3
TC
1#!perl -w
2# some of this is tested in t01introvert.t too
3use strict;
61753090 4use lib 't';
8efd1577 5use Test::More tests => 62;
61753090 6BEGIN { use_ok("Imager"); }
1501d9b3
TC
7
8my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
9
61753090 10ok($img, "paletted image created");
1501d9b3 11
61753090 12ok($img->type eq 'paletted', "got a paletted image");
1501d9b3
TC
13
14my $black = Imager::Color->new(0,0,0);
15my $red = Imager::Color->new(255,0,0);
16my $green = Imager::Color->new(0,255,0);
17my $blue = Imager::Color->new(0,0,255);
18
19my $white = Imager::Color->new(255,255,255);
20
21# add some color
22my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
23
24print "# blacki $blacki\n";
61753090 25ok(defined $blacki && $blacki == 0, "we got the first color");
1501d9b3 26
61753090 27ok($img->colorcount() == 4, "should have 4 colors");
1501d9b3
TC
28my ($redi, $greeni, $bluei) = 1..3;
29
30my @all = $img->getcolors;
61753090 31ok(@all == 4, "all colors is 4");
1501d9b3
TC
32coloreq($all[0], $black, "first black");
33coloreq($all[1], $red, "then red");
34coloreq($all[2], $green, "then green");
35coloreq($all[3], $blue, "and finally blue");
36
37# keep this as an assignment, checking for scalar context
38# we don't want the last color, otherwise if the behaviour changes to
39# get all up to the last (count defaulting to size-index) we'd get a
40# false positive
41my $one_color = $img->getcolors(start=>$redi);
61753090 42ok($one_color->isa('Imager::Color'), "check scalar context");
1501d9b3
TC
43coloreq($one_color, $red, "and that it's what we want");
44
45# make sure we can find colors
61753090 46ok(!defined($img->findcolor(color=>$white)),
1501d9b3 47 "shouldn't be able to find white");
61753090
TC
48ok($img->findcolor(color=>$black) == $blacki, "find black");
49ok($img->findcolor(color=>$red) == $redi, "find red");
50ok($img->findcolor(color=>$green) == $greeni, "find green");
51ok($img->findcolor(color=>$blue) == $bluei, "find blue");
1501d9b3
TC
52
53# various failure tests for setcolors
61753090 54ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
1501d9b3 55 "expect failure: low index");
61753090 56ok(!defined($img->setcolors(start=>1, colors=>[])),
1501d9b3 57 "expect failure: no colors");
61753090 58ok(!defined($img->setcolors(start=>5, colors=>[$white])),
1501d9b3
TC
59 "expect failure: high index");
60
61# set the green index to white
61753090 62ok($img->setcolors(start => $greeni, colors => [$white]),
1501d9b3
TC
63 "set a color");
64# and check it
65coloreq(scalar($img->getcolors(start=>$greeni)), $white,
66 "make sure it was set");
61753090
TC
67ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
68ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
1501d9b3
TC
69
70# write a few colors
61753090 71ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
1501d9b3
TC
72 "save multiple");
73coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
74coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
75
76# put it back
77$img->setcolors(start=>$red, colors=>[$red, $green]);
78
79# draw on the image, make sure it stays paletted when it should
61753090
TC
80ok($img->box(color=>$red, filled=>1), "fill with red");
81ok($img->type eq 'paletted', "paletted after fill");
82ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
1501d9b3 83 xmax=>40, ymax=>40), "green box");
61753090 84ok($img->type eq 'paletted', 'still paletted after box');
1501d9b3
TC
85# an AA line will almost certainly convert the image to RGB, don't use
86# an AA line here
61753090 87ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
1501d9b3 88 "draw a line");
61753090 89ok($img->type eq 'paletted', 'still paletted after line');
1501d9b3
TC
90
91# draw with white - should convert to direct
61753090 92ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20,
1501d9b3 93 xmax=>30, ymax=>30), "white box");
61753090 94ok($img->type eq 'direct', "now it should be direct");
1501d9b3
TC
95
96# various attempted to make a paletted image from our now direct image
97my $palimg = $img->to_paletted;
61753090 98ok($palimg, "we got an image");
1501d9b3 99# they should be the same pixel for pixel
61753090 100ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
1501d9b3
TC
101
102# strange case: no color picking, and no colors
103# this was causing a segmentation fault
104$palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
61753090 105ok(!defined $palimg, "to paletted with an empty palette is an error");
1501d9b3 106print "# ",$img->errstr,"\n";
61753090 107ok(scalar($img->errstr =~ /no colors available for translation/),
1501d9b3
TC
108 "and got the correct msg");
109
61753090 110ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'),
1501d9b3 111 "fail on -ve height");
61753090 112cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 113 "and correct error message");
61753090 114ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'),
1501d9b3 115 "fail on -ve width");
61753090 116cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3 117 "and correct error message");
61753090 118ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'),
1501d9b3 119 "fail on -ve width/height");
61753090 120cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
1501d9b3
TC
121 "and correct error message");
122
61753090 123ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
1501d9b3 124 "fail on 0 channels");
61753090 125cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
1501d9b3 126 "and correct error message");
61753090 127ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
1501d9b3 128 "fail on 5 channels");
61753090 129cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
1501d9b3
TC
130 "and correct error message");
131
653ea321
TC
132{
133 # https://rt.cpan.org/Ticket/Display.html?id=8213
134 # check for handling of memory allocation of very large images
135 # only test this on 32-bit machines - on a 64-bit machine it may
136 # result in trying to allocate 4Gb of memory, which is unfriendly at
137 # least and may result in running out of memory, causing a different
138 # type of exit
139 use Config;
61753090
TC
140 SKIP:
141 {
142 skip("don't want to allocate 4Gb", 8)
143 unless $Config{intsize} == 4;
144
f8906310 145 my $uint_range = 256 ** $Config{intsize};
653ea321
TC
146 my $dim1 = int(sqrt($uint_range))+1;
147
148 my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
61753090 149 is($im_b, undef, "integer overflow check - 1 channel");
653ea321
TC
150
151 $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
61753090 152 ok($im_b, "but same width ok");
653ea321 153 $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
61753090
TC
154 ok($im_b, "but same height ok");
155 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
653ea321
TC
156 "check the error message");
157
158 # do a similar test with a 3 channel image, so we're sure we catch
159 # the same case where the third dimension causes the overflow
160 # for paletted images the third dimension can't cause an overflow
161 # but make sure we didn't anything too dumb in the checks
162 my $dim3 = $dim1;
163
164 $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
61753090 165 is($im_b, undef, "integer overflow check - 3 channel");
653ea321
TC
166
167 $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, type=>'paletted');
61753090 168 ok($im_b, "but same width ok");
653ea321 169 $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, type=>'paletted');
61753090 170 ok($im_b, "but same height ok");
653ea321 171
61753090 172 cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
653ea321
TC
173 "check the error message");
174 }
653ea321
TC
175}
176
34b3f7e6
TC
177{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
178 my $warning;
179 local $SIG{__WARN__} =
180 sub {
181 $warning = "@_";
182 my $printed = $warning;
183 $printed =~ s/\n$//;
184 $printed =~ s/\n/\n\#/g;
185 print "# ",$printed, "\n";
186 };
187 my $img = Imager->new(xsize=>10, ysize=>10);
188 $img->to_paletted();
189 cmp_ok($warning, '=~', 'void', "correct warning");
190 cmp_ok($warning, '=~', 't023palette\\.t', "correct file");
191}
192
8efd1577
TC
193{ # http://rt.cpan.org/NoAuth/Bug.html?id=12676
194 # setcolors() has a fencepost error
195 my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
196
197 is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
198 "add test colors");
199 ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
200 ok(!$img->setcolors(start=>2, colors=>[ $black ]),
201 "set after the last color");
202}
203
1501d9b3
TC
204sub coloreq {
205 my ($left, $right, $comment) = @_;
206
207 my ($rl, $gl, $bl, $al) = $left->rgba;
208 my ($rr, $gr, $br, $ar) = $right->rgba;
209
210 print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
61753090 211 ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
1501d9b3
TC
212 $comment);
213}
214