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