Imager::Color set_internal is now simpler
[imager.git] / t / 100-base / 020-color.t
CommitLineData
1c00d65b 1#!perl -w
02d1d628
AMH
2# Before `make install' is performed this script should be runnable with
3# `make test'. After `make install' it should work as `perl test.pl'
4
5######################### We start with some black magic to print on failure.
6
7# Change 1..1 below to 1..last_test_to_print .
8# (It may become useful if the test is moved to ./t subdirectory.)
9
b7346865 10use Test::More;
b7d25d0e 11
34c03f04 12use Imager;
c808d2b2 13use Imager::Test qw(is_fcolor3 is_fcolor4 is_color4);
02d1d628 14
40e78f96
TC
15-d "testout" or mkdir "testout";
16
e1a42e19 17Imager->open_log(log => "testout/t15color.log");
02d1d628
AMH
18
19my $c1 = Imager::Color->new(100, 150, 200, 250);
c808d2b2 20is_color4($c1, 100, 150, 200, 250, 'simple 4-arg');
02d1d628 21my $c2 = Imager::Color->new(100, 150, 200);
c808d2b2 22is_color4($c2, 100, 150, 200, 255, 'simple 3-arg');
02d1d628 23my $c3 = Imager::Color->new("#6496C8");
c808d2b2 24is_color4($c3, 100, 150, 200, 255, 'web color');
0999c453
TC
25# crashes in Imager-0.38pre8 and earlier
26my @foo;
27for (1..1000) {
28 push(@foo, Imager::Color->new("#FFFFFF"));
29}
30my $fail;
31for (@foo) {
32 Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
b7346865
TC
33 Imager::Color::set_internal($_, 128, 129, 130, 131) == $_ or ++$fail;
34 test_col($_, 128, 129, 130, 131) or ++$fail;
0999c453 35}
b7d25d0e 36ok(!$fail, 'consitency check');
02d1d628 37
faa9b3e7 38# test the new OO methods
b7d25d0e
TC
39SKIP:
40{
d034a178
TC
41 skip "no X rgb.txt found", 1
42 unless grep -r, Imager::Color::_test_x_palettes();
c808d2b2
TC
43 is_color4(Imager::Color->new(xname=>'blue'), 0, 0, 255, 255, 'xname');
44}
45
46my @oo_tests =
47 (
48 [
49 [ r=>100, g=>150, b=>200 ],
50 100, 150, 200, 255,
51 'r g b'
52 ],
53 [
54 [ red=>101, green=>151, blue=>201 ],
55 101, 151, 201, 255,
56 'red green blue'
57 ],
58 [
59 [ grey=>102 ],
60 102, 255, 255, 255,
61 'grey'
62 ],
63 [
64 [ gray=>103 ],
65 103, 255, 255, 255,
66 'gray'
67 ],
68 [
69 [ gimp=>'snow' , palette=>'testimg/test_gimp_pal' ],
70 255, 250, 250, 255,
71 'gimp'
72 ],
73 [
74 [ h=>0, 's'=>0, 'v'=>1.0 ],
75 255, 255, 255, 255,
76 'h s v'
77 ],
78 [
79 [ h=>0, 's'=>1, v=>1 ],
80 255, 0, 0, 255,
81 'h s v again'
82 ],
83 [
84 [ web=>'#808182' ],
85 128, 129, 130, 255,
86 'web 6 digit'
87 ],
88 [
89 [ web=>'#123' ],
90 0x11, 0x22, 0x33, 255,
91 'web 3 digit'
92 ],
93 [
94 [ rgb=>[ 255, 150, 121 ] ],
95 255, 150, 121, 255,
96 'rgb arrayref'
97 ],
98 [
99 [ rgba=>[ 255, 150, 121, 128 ] ],
100 255, 150, 121, 128,
101 'rgba arrayref'
102 ],
103 [
104 [ hsv=>[ 0, 1, 1 ] ],
105 255, 0, 0, 255,
106 'hsv arrayref'
107 ],
108 [
109 [ channel0=>129, channel1=>130, channel2=>131, channel3=>134 ],
110 129, 130, 131, 134,
111 'channel0-3'
112 ],
113 [
114 [ c0=>129, c1=>130, c2=>131, c3=>134 ],
115 129, 130, 131, 134,
116 'c0-3',
117 ],
118 [
119 [ channels=>[ 200, ] ],
120 200, 0, 0, 0,
121 'channels arrayref (1)'
122 ],
123 [
124 [ channels=>[ 200, 201 ] ],
125 200, 201, 0, 0,
126 'channels arrayref (2)'
127 ],
128 [
129 [ channels=>[ 200, 201, 203 ] ],
130 200, 201, 203, 0,
131 'channels arrayref (3)'
132 ],
133 [
134 [ channels=>[ 200, 201, 203, 204 ] ],
135 200, 201, 203, 204,
136 'channels arrayref (4)'
137 ],
138 [
139 [ name=>'snow', palette=>'testimg/test_gimp_pal' ],
140 255, 250, 250, 255,
141 'name'
142 ],
143 );
144
145for my $test (@oo_tests) {
146 my ($parms, $r, $g, $b, $a, $name) = @$test;
147 is_color4(Imager::Color->new(@$parms), $r, $g, $b, $a, $name);
faa9b3e7 148}
efdc2568
TC
149
150# test the internal HSV <=> RGB conversions
151# these values were generated using the GIMP
152# all but hue is 0..360, saturation and value from 0 to 1
153# rgb from 0 to 255
154my @hsv_vs_rgb =
155 (
156 { hsv => [ 0, 0.2, 0.1 ], rgb=> [ 25, 20, 20 ] },
157 { hsv => [ 0, 0.5, 1.0 ], rgb => [ 255, 127, 127 ] },
158 { hsv => [ 100, 0.5, 1.0 ], rgb => [ 170, 255, 127 ] },
159 { hsv => [ 100, 1.0, 1.0 ], rgb=> [ 85, 255, 0 ] },
160 { hsv => [ 335, 0.5, 0.5 ], rgb=> [127, 63, 90 ] },
161 );
162
163use Imager::Color::Float;
164my $test_num = 23;
165my $index = 0;
166for my $entry (@hsv_vs_rgb) {
167 print "# color index $index\n";
168 my $hsv = $entry->{hsv};
169 my $rgb = $entry->{rgb};
170 my $fhsvo = Imager::Color::Float->new($hsv->[0]/360.0, $hsv->[1], $hsv->[2]);
171 my $fc = Imager::Color::Float::i_hsv_to_rgb($fhsvo);
c808d2b2
TC
172 is_fcolor3($fc, $rgb->[0]/255, $rgb->[1]/255, $rgb->[2]/255, 0.01,
173 "i_hsv_to_rgbf $index");
efdc2568 174 my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
c808d2b2 175 is_fcolor3($fc2, $hsv->[0]/360.0, $hsv->[1], $hsv->[2], "i_rgbf_to_hsv $index");
efdc2568
TC
176
177 my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255,
178 $hsv->[2] * 255);
179 my $c = Imager::Color::i_hsv_to_rgb($hsvo);
b7d25d0e 180 color_close_enough("i_hsv_to_rgb $index", @$rgb, $c);
efdc2568 181 my $c2 = Imager::Color::i_rgb_to_hsv($c);
b7d25d0e 182 color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255,
efdc2568
TC
183 $hsv->[2] * 255, $c2);
184 ++$index;
185}
186
1c00d65b 187# check the built-ins table
c808d2b2 188is_color4(Imager::Color->new(builtin=>'black'), 0, 0, 0, 255, 'builtin black');
5f8cbeac 189
0d3b936e
TC
190{
191 my $c1 = Imager::Color->new(255, 255, 255, 0);
192 my $c2 = Imager::Color->new(255, 255, 255, 255);
b7d25d0e
TC
193 ok(!$c1->equals(other=>$c2), "not equal no ignore alpha");
194 ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)),
0d3b936e 195 "equal with ignore alpha");
b7d25d0e 196 ok($c1->equals(other=>$c1), "equal to itself");
0d3b936e 197}
3d782fde
TC
198
199{ # http://rt.cpan.org/NoAuth/Bug.html?id=13143
200 # Imager::Color->new(color_name) warning if HOME environment variable not set
201 local $ENV{HOME};
202 my @warnings;
203 local $SIG{__WARN__} = sub { push @warnings, "@_" };
204
205 # presumably no-one will name a color like this.
206 my $c1 = Imager::Color->new(gimp=>"ABCDEFGHIJKLMNOP");
207 is(@warnings, 0, "Should be no warnings")
208 or do { print "# $_" for @warnings };
209}
34c03f04
TC
210
211{
212 # float color from hex triple
213 my $f3white = Imager::Color::Float->new("#FFFFFF");
214 is_fcolor4($f3white, 1.0, 1.0, 1.0, 1.0, "check color #FFFFFF");
215 my $f3black = Imager::Color::Float->new("#000000");
216 is_fcolor4($f3black, 0, 0, 0, 1.0, "check color #000000");
217 my $f3grey = Imager::Color::Float->new("#808080");
218 is_fcolor4($f3grey, 0x80/0xff, 0x80/0xff, 0x80/0xff, 1.0, "check color #808080");
219
220 my $f4white = Imager::Color::Float->new("#FFFFFF80");
221 is_fcolor4($f4white, 1.0, 1.0, 1.0, 0x80/0xff, "check color #FFFFFF80");
222}
223
224{
225 # fail to make a color
226 ok(!Imager::Color::Float->new("-unknown-"), "try to make float color -unknown-");
227}
228
229{
230 # set after creation
231 my $c = Imager::Color::Float->new(0, 0, 0);
232 is_fcolor4($c, 0, 0, 0, 1.0, "check simple init of float color");
233 ok($c->set(1.0, 0.5, 0.25, 1.0), "set() the color");
234 is_fcolor4($c, 1.0, 0.5, 0.25, 1.0, "check after set");
235
236 ok(!$c->set("-unknown-"), "set to unknown");
237}
238
d5fb1fdf
PG
239{
240 # test ->hsv
241 my $c = Imager::Color->new(255, 0, 0);
242 my($h,$s,$v) = $c->hsv;
243 is($h,0,'red hue');
244 is($s,1,'red saturation');
245 is($v,1,'red value');
246
247 $c = Imager::Color->new(0, 255, 0);
248 ($h,$s,$v) = $c->hsv;
249 is($h,120,'green hue');
250 is($s,1,'green saturation');
251 is($v,1,'green value');
252
253 $c = Imager::Color->new(0, 0, 255);
254 ($h,$s,$v) = $c->hsv;
255 is($h,240,'blue hue');
256 is($s,1,'blue saturation');
257 is($v,1,'blue value');
258
259 $c = Imager::Color->new(255, 255, 255);
260 ($h,$s,$v) = $c->hsv;
261 is($h,0,'white hue');
262 is($s,0,'white saturation');
263 is($v,1,'white value');
264
265 $c = Imager::Color->new(0, 0, 0);
266 ($h,$s,$v) = $c->hsv;
267 is($h,0,'black hue');
268 is($s,0,'black saturation');
269 is($v,0,'black value');
270}
271
b7346865
TC
272done_testing();
273
02d1d628
AMH
274sub test_col {
275 my ($c, $r, $g, $b, $a) = @_;
faa9b3e7
TC
276 unless ($c) {
277 print "# $Imager::ERRSTR\n";
278 return 0;
279 }
02d1d628
AMH
280 my ($cr, $cg, $cb, $ca) = $c->rgba;
281 return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
282}
283
efdc2568 284sub color_close_enough {
b7d25d0e 285 my ($name, $r, $g, $b, $c) = @_;
efdc2568
TC
286
287 my ($cr, $cg, $cb) = $c->rgba;
b7d25d0e
TC
288 ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5,
289 "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
efdc2568
TC
290}
291
292sub color_close_enough_hsv {
b7d25d0e 293 my ($name, $h, $s, $v, $c) = @_;
efdc2568
TC
294
295 my ($ch, $cs, $cv) = $c->rgba;
296 if ($ch < 5 && $h > 250) {
297 $ch += 255;
298 }
299 elsif ($ch > 250 && $h < 5) {
300 $h += 255;
301 }
b7d25d0e
TC
302 ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5,
303 "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)");
efdc2568
TC
304}
305