- the setcolors() had a fencepost error making it impossible to
[imager.git] / t / t023palette.t
1 #!perl -w
2 # some of this is tested in t01introvert.t too
3 use strict;
4 use lib 't';
5 use Test::More tests => 62;
6 BEGIN { use_ok("Imager"); }
7
8 my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
9
10 ok($img, "paletted image created");
11
12 ok($img->type eq 'paletted', "got a paletted image");
13
14 my $black = Imager::Color->new(0,0,0);
15 my $red = Imager::Color->new(255,0,0);
16 my $green = Imager::Color->new(0,255,0);
17 my $blue = Imager::Color->new(0,0,255);
18
19 my $white = Imager::Color->new(255,255,255);
20
21 # add some color
22 my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
23
24 print "# blacki $blacki\n";
25 ok(defined $blacki && $blacki == 0, "we got the first color");
26
27 ok($img->colorcount() == 4, "should have 4 colors");
28 my ($redi, $greeni, $bluei) = 1..3;
29
30 my @all = $img->getcolors;
31 ok(@all == 4, "all colors is 4");
32 coloreq($all[0], $black, "first black");
33 coloreq($all[1], $red, "then red");
34 coloreq($all[2], $green, "then green");
35 coloreq($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
41 my $one_color = $img->getcolors(start=>$redi);
42 ok($one_color->isa('Imager::Color'), "check scalar context");
43 coloreq($one_color, $red, "and that it's what we want");
44
45 # make sure we can find colors
46 ok(!defined($img->findcolor(color=>$white)), 
47     "shouldn't be able to find white");
48 ok($img->findcolor(color=>$black) == $blacki, "find black");
49 ok($img->findcolor(color=>$red) == $redi, "find red");
50 ok($img->findcolor(color=>$green) == $greeni, "find green");
51 ok($img->findcolor(color=>$blue) == $bluei, "find blue");
52
53 # various failure tests for setcolors
54 ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
55     "expect failure: low index");
56 ok(!defined($img->setcolors(start=>1, colors=>[])),
57     "expect failure: no colors");
58 ok(!defined($img->setcolors(start=>5, colors=>[$white])),
59     "expect failure: high index");
60
61 # set the green index to white
62 ok($img->setcolors(start => $greeni, colors => [$white]),
63     "set a color");
64 # and check it
65 coloreq(scalar($img->getcolors(start=>$greeni)), $white,
66         "make sure it was set");
67 ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
68 ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
69
70 # write a few colors
71 ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
72            "save multiple");
73 coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
74 coloreq(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
80 ok($img->box(color=>$red, filled=>1), "fill with red");
81 ok($img->type eq 'paletted', "paletted after fill");
82 ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
83               xmax=>40, ymax=>40), "green box");
84 ok($img->type eq 'paletted', 'still paletted after box');
85 # an AA line will almost certainly convert the image to RGB, don't use
86 # an AA line here
87 ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
88     "draw a line");
89 ok($img->type eq 'paletted', 'still paletted after line');
90
91 # draw with white - should convert to direct
92 ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20, 
93               xmax=>30, ymax=>30), "white box");
94 ok($img->type eq 'direct', "now it should be direct");
95
96 # various attempted to make a paletted image from our now direct image
97 my $palimg = $img->to_paletted;
98 ok($palimg, "we got an image");
99 # they should be the same pixel for pixel
100 ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
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');
105 ok(!defined $palimg, "to paletted with an empty palette is an error");
106 print "# ",$img->errstr,"\n";
107 ok(scalar($img->errstr =~ /no colors available for translation/),
108     "and got the correct msg");
109
110 ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'), 
111     "fail on -ve height");
112 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
113        "and correct error message");
114 ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'), 
115     "fail on -ve width");
116 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
117        "and correct error message");
118 ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'), 
119     "fail on -ve width/height");
120 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
121        "and correct error message");
122
123 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
124     "fail on 0 channels");
125 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
126        "and correct error message");
127 ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
128     "fail on 5 channels");
129 cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
130        "and correct error message");
131
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;
140  SKIP:
141   {
142     skip("don't want to allocate 4Gb", 8)
143       unless $Config{intsize} == 4;
144
145     my $uint_range = 256 ** $Config{intsize};
146     my $dim1 = int(sqrt($uint_range))+1;
147     
148     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
149     is($im_b, undef, "integer overflow check - 1 channel");
150     
151     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
152     ok($im_b, "but same width ok");
153     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
154     ok($im_b, "but same height ok");
155     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
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');
165     is($im_b, undef, "integer overflow check - 3 channel");
166     
167     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, type=>'paletted');
168     ok($im_b, "but same width ok");
169     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, type=>'paletted');
170     ok($im_b, "but same height ok");
171
172     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
173            "check the error message");
174   }
175 }
176
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
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
204 sub 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";
211   ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
212       $comment);
213 }
214