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'
5 ######################### We start with some black magic to print on failure.
7 # Change 1..1 below to 1..last_test_to_print .
8 # (It may become useful if the test is moved to ./t subdirectory.)
10 use Test::More tests => 70;
13 use Imager::Test qw(is_fcolor4);
15 -d "testout" or mkdir "testout";
17 Imager->open_log(log => "testout/t15color.log");
19 my $c1 = Imager::Color->new(100, 150, 200, 250);
20 ok(test_col($c1, 100, 150, 200, 250), 'simple 4-arg');
21 my $c2 = Imager::Color->new(100, 150, 200);
22 ok(test_col($c2, 100, 150, 200, 255), 'simple 3-arg');
23 my $c3 = Imager::Color->new("#6496C8");
24 ok(test_col($c3, 100, 150, 200, 255), 'web color');
25 # crashes in Imager-0.38pre8 and earlier
28 push(@foo, Imager::Color->new("#FFFFFF"));
32 Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
33 Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
34 test_col($_, 128, 128, 128, 128) or ++$fail;
36 ok(!$fail, 'consitency check');
38 # test the new OO methods
39 color_ok('r g b',, 100, 150, 200, 255, Imager::Color->new(r=>100, g=>150, b=>200));
40 color_ok('red green blue', 101, 151, 201, 255,
41 Imager::Color->new(red=>101, green=>151, blue=>201));
42 color_ok('grey', 102, 255, 255, 255, Imager::Color->new(grey=>102));
43 color_ok('gray', 103, 255, 255, 255, Imager::Color->new(gray=>103));
46 skip "no X rgb.txt found", 1
47 unless grep -r, Imager::Color::_test_x_palettes();
48 color_ok('xname', 0, 0, 255, 255, Imager::Color->new(xname=>'blue'));
50 color_ok('gimp', 255, 250, 250, 255,
51 Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal'));
52 color_ok('h s v', 255, 255, 255, 255, Imager::Color->new(h=>0, 's'=>0, 'v'=>1.0));
53 color_ok('h s v again', 255, 0, 0, 255, Imager::Color->new(h=>0, 's'=>1, v=>1));
54 color_ok('web 6 digit', 128, 129, 130, 255, Imager::Color->new(web=>'#808182'));
55 color_ok('web 3 digit', 0x11, 0x22, 0x33, 255, Imager::Color->new(web=>'#123'));
56 color_ok('rgb arrayref', 255, 150, 121, 255, Imager::Color->new(rgb=>[ 255, 150, 121 ]));
57 color_ok('rgba arrayref', 255, 150, 121, 128,
58 Imager::Color->new(rgba=>[ 255, 150, 121, 128 ]));
59 color_ok('hsv arrayref', 255, 0, 0, 255, Imager::Color->new(hsv=>[ 0, 1, 1 ]));
60 color_ok('channel0-3', 129, 130, 131, 134,
61 Imager::Color->new(channel0=>129, channel1=>130, channel2=>131,
63 color_ok('c0-3', 129, 130, 131, 134,
64 Imager::Color->new(c0=>129, c1=>130, c2=>131, c3=>134));
65 color_ok('channels arrayref', 200, 201, 203, 204,
66 Imager::Color->new(channels=>[ 200, 201, 203, 204 ]));
67 color_ok('name', 255, 250, 250, 255,
68 Imager::Color->new(name=>'snow', palette=>'testimg/test_gimp_pal'));
70 # test the internal HSV <=> RGB conversions
71 # these values were generated using the GIMP
72 # all but hue is 0..360, saturation and value from 0 to 1
76 { hsv => [ 0, 0.2, 0.1 ], rgb=> [ 25, 20, 20 ] },
77 { hsv => [ 0, 0.5, 1.0 ], rgb => [ 255, 127, 127 ] },
78 { hsv => [ 100, 0.5, 1.0 ], rgb => [ 170, 255, 127 ] },
79 { hsv => [ 100, 1.0, 1.0 ], rgb=> [ 85, 255, 0 ] },
80 { hsv => [ 335, 0.5, 0.5 ], rgb=> [127, 63, 90 ] },
83 use Imager::Color::Float;
86 for my $entry (@hsv_vs_rgb) {
87 print "# color index $index\n";
88 my $hsv = $entry->{hsv};
89 my $rgb = $entry->{rgb};
90 my $fhsvo = Imager::Color::Float->new($hsv->[0]/360.0, $hsv->[1], $hsv->[2]);
91 my $fc = Imager::Color::Float::i_hsv_to_rgb($fhsvo);
92 fcolor_close_enough("i_hsv_to_rgbf $index", $rgb->[0]/255, $rgb->[1]/255,
94 my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
95 fcolor_close_enough("i_rgbf_to_hsv $index", $hsv->[0]/360.0, $hsv->[1], $hsv->[2],
98 my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255,
100 my $c = Imager::Color::i_hsv_to_rgb($hsvo);
101 color_close_enough("i_hsv_to_rgb $index", @$rgb, $c);
102 my $c2 = Imager::Color::i_rgb_to_hsv($c);
103 color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255,
104 $hsv->[2] * 255, $c2);
108 # check the built-ins table
109 color_ok('builtin black', 0, 0, 0, 255,
110 Imager::Color->new(builtin=>'black'));
113 my $c1 = Imager::Color->new(255, 255, 255, 0);
114 my $c2 = Imager::Color->new(255, 255, 255, 255);
115 ok(!$c1->equals(other=>$c2), "not equal no ignore alpha");
116 ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)),
117 "equal with ignore alpha");
118 ok($c1->equals(other=>$c1), "equal to itself");
121 { # http://rt.cpan.org/NoAuth/Bug.html?id=13143
122 # Imager::Color->new(color_name) warning if HOME environment variable not set
125 local $SIG{__WARN__} = sub { push @warnings, "@_" };
127 # presumably no-one will name a color like this.
128 my $c1 = Imager::Color->new(gimp=>"ABCDEFGHIJKLMNOP");
129 is(@warnings, 0, "Should be no warnings")
130 or do { print "# $_" for @warnings };
134 # float color from hex triple
135 my $f3white = Imager::Color::Float->new("#FFFFFF");
136 is_fcolor4($f3white, 1.0, 1.0, 1.0, 1.0, "check color #FFFFFF");
137 my $f3black = Imager::Color::Float->new("#000000");
138 is_fcolor4($f3black, 0, 0, 0, 1.0, "check color #000000");
139 my $f3grey = Imager::Color::Float->new("#808080");
140 is_fcolor4($f3grey, 0x80/0xff, 0x80/0xff, 0x80/0xff, 1.0, "check color #808080");
142 my $f4white = Imager::Color::Float->new("#FFFFFF80");
143 is_fcolor4($f4white, 1.0, 1.0, 1.0, 0x80/0xff, "check color #FFFFFF80");
147 # fail to make a color
148 ok(!Imager::Color::Float->new("-unknown-"), "try to make float color -unknown-");
153 my $c = Imager::Color::Float->new(0, 0, 0);
154 is_fcolor4($c, 0, 0, 0, 1.0, "check simple init of float color");
155 ok($c->set(1.0, 0.5, 0.25, 1.0), "set() the color");
156 is_fcolor4($c, 1.0, 0.5, 0.25, 1.0, "check after set");
158 ok(!$c->set("-unknown-"), "set to unknown");
163 my $c = Imager::Color->new(255, 0, 0);
164 my($h,$s,$v) = $c->hsv;
166 is($s,1,'red saturation');
167 is($v,1,'red value');
169 $c = Imager::Color->new(0, 255, 0);
170 ($h,$s,$v) = $c->hsv;
171 is($h,120,'green hue');
172 is($s,1,'green saturation');
173 is($v,1,'green value');
175 $c = Imager::Color->new(0, 0, 255);
176 ($h,$s,$v) = $c->hsv;
177 is($h,240,'blue hue');
178 is($s,1,'blue saturation');
179 is($v,1,'blue value');
181 $c = Imager::Color->new(255, 255, 255);
182 ($h,$s,$v) = $c->hsv;
183 is($h,0,'white hue');
184 is($s,0,'white saturation');
185 is($v,1,'white value');
187 $c = Imager::Color->new(0, 0, 0);
188 ($h,$s,$v) = $c->hsv;
189 is($h,0,'black hue');
190 is($s,0,'black saturation');
191 is($v,0,'black value');
195 my ($c, $r, $g, $b, $a) = @_;
197 print "# $Imager::ERRSTR\n";
200 my ($cr, $cg, $cb, $ca) = $c->rgba;
201 return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
204 sub color_close_enough {
205 my ($name, $r, $g, $b, $c) = @_;
207 my ($cr, $cg, $cb) = $c->rgba;
208 ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5,
209 "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
212 sub color_close_enough_hsv {
213 my ($name, $h, $s, $v, $c) = @_;
215 my ($ch, $cs, $cv) = $c->rgba;
216 if ($ch < 5 && $h > 250) {
219 elsif ($ch > 250 && $h < 5) {
222 ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5,
223 "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)");
226 sub fcolor_close_enough {
227 my ($name, $r, $g, $b, $c) = @_;
229 my ($cr, $cg, $cb) = $c->rgba;
230 ok(abs($cr-$r) <= 0.01 && abs($cg-$g) <= 0.01 && abs($cb-$b) <= 0.01,
231 "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
235 my ($name, $r, $g, $b, $a, $c) = @_;
237 unless (ok(test_col($c, $r, $g, $b, $a), $name)) {
238 print "# ($r,$g,$b,$a) != (".join(",", $c ? $c->rgba: ()).")\n";