Imager::Color set_internal is now simpler
[imager.git] / t / 100-base / 020-color.t
1 #!perl -w
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
10 use Test::More;
11
12 use Imager;
13 use Imager::Test qw(is_fcolor3 is_fcolor4 is_color4);
14
15 -d "testout" or mkdir "testout";
16
17 Imager->open_log(log => "testout/t15color.log");
18
19 my $c1 = Imager::Color->new(100, 150, 200, 250);
20 is_color4($c1, 100, 150, 200, 250, 'simple 4-arg');
21 my $c2 = Imager::Color->new(100, 150, 200);
22 is_color4($c2, 100, 150, 200, 255, 'simple 3-arg');
23 my $c3 = Imager::Color->new("#6496C8");
24 is_color4($c3, 100, 150, 200, 255, 'web color');
25 # crashes in Imager-0.38pre8 and earlier
26 my @foo;
27 for (1..1000) {
28   push(@foo, Imager::Color->new("#FFFFFF"));
29 }
30 my $fail;
31 for (@foo) {
32   Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
33   Imager::Color::set_internal($_, 128, 129, 130, 131) == $_ or ++$fail;
34   test_col($_, 128, 129, 130, 131) or ++$fail;
35 }
36 ok(!$fail, 'consitency check');
37
38 # test the new OO methods
39 SKIP:
40 {
41   skip "no X rgb.txt found", 1 
42     unless grep -r, Imager::Color::_test_x_palettes();
43   is_color4(Imager::Color->new(xname=>'blue'), 0, 0, 255, 255, 'xname');
44 }
45
46 my @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
145 for 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);
148 }
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
154 my @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
163 use Imager::Color::Float;
164 my $test_num = 23;
165 my $index = 0;
166 for 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);
172   is_fcolor3($fc, $rgb->[0]/255, $rgb->[1]/255, $rgb->[2]/255, 0.01,
173              "i_hsv_to_rgbf $index");
174   my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
175   is_fcolor3($fc2, $hsv->[0]/360.0, $hsv->[1], $hsv->[2], "i_rgbf_to_hsv $index");
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);
180   color_close_enough("i_hsv_to_rgb $index", @$rgb, $c);
181   my $c2 = Imager::Color::i_rgb_to_hsv($c);
182   color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255, 
183                      $hsv->[2] * 255, $c2);
184   ++$index;
185 }
186
187 # check the built-ins table
188 is_color4(Imager::Color->new(builtin=>'black'), 0, 0, 0, 255, 'builtin black');
189
190 {
191   my $c1 = Imager::Color->new(255, 255, 255, 0);
192   my $c2 = Imager::Color->new(255, 255, 255, 255);
193   ok(!$c1->equals(other=>$c2), "not equal no ignore alpha");
194   ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)), 
195       "equal with ignore alpha");
196   ok($c1->equals(other=>$c1), "equal to itself");
197 }
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 }
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
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
272 done_testing();
273
274 sub test_col {
275   my ($c, $r, $g, $b, $a) = @_;
276   unless ($c) {
277     print "# $Imager::ERRSTR\n";
278     return 0;
279   }
280   my ($cr, $cg, $cb, $ca) = $c->rgba;
281   return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
282 }
283
284 sub color_close_enough {
285   my ($name, $r, $g, $b, $c) = @_;
286
287   my ($cr, $cg, $cb) = $c->rgba;
288   ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5,
289     "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
290 }
291
292 sub color_close_enough_hsv {
293   my ($name, $h, $s, $v, $c) = @_;
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   }
302   ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5,
303     "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)");
304 }
305