]>
Commit | Line | Data |
---|---|---|
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 | ||
d5fb1fdf | 10 | use Test::More tests => 70; |
b7d25d0e | 11 | |
34c03f04 TC |
12 | use Imager; |
13 | use Imager::Test qw(is_fcolor4); | |
02d1d628 | 14 | |
40e78f96 TC |
15 | -d "testout" or mkdir "testout"; |
16 | ||
e1a42e19 | 17 | Imager->open_log(log => "testout/t15color.log"); |
02d1d628 AMH |
18 | |
19 | my $c1 = Imager::Color->new(100, 150, 200, 250); | |
b7d25d0e | 20 | ok(test_col($c1, 100, 150, 200, 250), 'simple 4-arg'); |
02d1d628 | 21 | my $c2 = Imager::Color->new(100, 150, 200); |
b7d25d0e | 22 | ok(test_col($c2, 100, 150, 200, 255), 'simple 3-arg'); |
02d1d628 | 23 | my $c3 = Imager::Color->new("#6496C8"); |
b7d25d0e | 24 | ok(test_col($c3, 100, 150, 200, 255), 'web color'); |
0999c453 TC |
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, 128, 128, 128) == $_ or ++$fail; | |
27c85c8d | 34 | test_col($_, 128, 128, 128, 128) or ++$fail; |
0999c453 | 35 | } |
b7d25d0e | 36 | ok(!$fail, 'consitency check'); |
02d1d628 | 37 | |
faa9b3e7 | 38 | # test the new OO methods |
b7d25d0e TC |
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, | |
faa9b3e7 | 41 | Imager::Color->new(red=>101, green=>151, blue=>201)); |
b7d25d0e TC |
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)); | |
44 | SKIP: | |
45 | { | |
d034a178 TC |
46 | skip "no X rgb.txt found", 1 |
47 | unless grep -r, Imager::Color::_test_x_palettes(); | |
b7d25d0e | 48 | color_ok('xname', 0, 0, 255, 255, Imager::Color->new(xname=>'blue')); |
faa9b3e7 | 49 | } |
b7d25d0e | 50 | color_ok('gimp', 255, 250, 250, 255, |
faa9b3e7 | 51 | Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal')); |
b7d25d0e TC |
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, | |
faa9b3e7 | 58 | Imager::Color->new(rgba=>[ 255, 150, 121, 128 ])); |
b7d25d0e TC |
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, | |
faa9b3e7 TC |
61 | Imager::Color->new(channel0=>129, channel1=>130, channel2=>131, |
62 | channel3=>134)); | |
b7d25d0e | 63 | color_ok('c0-3', 129, 130, 131, 134, |
faa9b3e7 | 64 | Imager::Color->new(c0=>129, c1=>130, c2=>131, c3=>134)); |
b7d25d0e | 65 | color_ok('channels arrayref', 200, 201, 203, 204, |
faa9b3e7 | 66 | Imager::Color->new(channels=>[ 200, 201, 203, 204 ])); |
b7d25d0e | 67 | color_ok('name', 255, 250, 250, 255, |
faa9b3e7 | 68 | Imager::Color->new(name=>'snow', palette=>'testimg/test_gimp_pal')); |
efdc2568 TC |
69 | |
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 | |
73 | # rgb from 0 to 255 | |
74 | my @hsv_vs_rgb = | |
75 | ( | |
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 ] }, | |
81 | ); | |
82 | ||
83 | use Imager::Color::Float; | |
84 | my $test_num = 23; | |
85 | my $index = 0; | |
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); | |
b7d25d0e | 92 | fcolor_close_enough("i_hsv_to_rgbf $index", $rgb->[0]/255, $rgb->[1]/255, |
efdc2568 TC |
93 | $rgb->[2]/255, $fc); |
94 | my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc); | |
b7d25d0e | 95 | fcolor_close_enough("i_rgbf_to_hsv $index", $hsv->[0]/360.0, $hsv->[1], $hsv->[2], |
efdc2568 TC |
96 | $fc2); |
97 | ||
98 | my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255, | |
99 | $hsv->[2] * 255); | |
100 | my $c = Imager::Color::i_hsv_to_rgb($hsvo); | |
b7d25d0e | 101 | color_close_enough("i_hsv_to_rgb $index", @$rgb, $c); |
efdc2568 | 102 | my $c2 = Imager::Color::i_rgb_to_hsv($c); |
b7d25d0e | 103 | color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255, |
efdc2568 TC |
104 | $hsv->[2] * 255, $c2); |
105 | ++$index; | |
106 | } | |
107 | ||
1c00d65b | 108 | # check the built-ins table |
b7d25d0e | 109 | color_ok('builtin black', 0, 0, 0, 255, |
1c00d65b | 110 | Imager::Color->new(builtin=>'black')); |
5f8cbeac | 111 | |
0d3b936e TC |
112 | { |
113 | my $c1 = Imager::Color->new(255, 255, 255, 0); | |
114 | my $c2 = Imager::Color->new(255, 255, 255, 255); | |
b7d25d0e TC |
115 | ok(!$c1->equals(other=>$c2), "not equal no ignore alpha"); |
116 | ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)), | |
0d3b936e | 117 | "equal with ignore alpha"); |
b7d25d0e | 118 | ok($c1->equals(other=>$c1), "equal to itself"); |
0d3b936e | 119 | } |
3d782fde TC |
120 | |
121 | { # http://rt.cpan.org/NoAuth/Bug.html?id=13143 | |
122 | # Imager::Color->new(color_name) warning if HOME environment variable not set | |
123 | local $ENV{HOME}; | |
124 | my @warnings; | |
125 | local $SIG{__WARN__} = sub { push @warnings, "@_" }; | |
126 | ||
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 }; | |
131 | } | |
34c03f04 TC |
132 | |
133 | { | |
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"); | |
141 | ||
142 | my $f4white = Imager::Color::Float->new("#FFFFFF80"); | |
143 | is_fcolor4($f4white, 1.0, 1.0, 1.0, 0x80/0xff, "check color #FFFFFF80"); | |
144 | } | |
145 | ||
146 | { | |
147 | # fail to make a color | |
148 | ok(!Imager::Color::Float->new("-unknown-"), "try to make float color -unknown-"); | |
149 | } | |
150 | ||
151 | { | |
152 | # set after creation | |
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"); | |
157 | ||
158 | ok(!$c->set("-unknown-"), "set to unknown"); | |
159 | } | |
160 | ||
d5fb1fdf PG |
161 | { |
162 | # test ->hsv | |
163 | my $c = Imager::Color->new(255, 0, 0); | |
164 | my($h,$s,$v) = $c->hsv; | |
165 | is($h,0,'red hue'); | |
166 | is($s,1,'red saturation'); | |
167 | is($v,1,'red value'); | |
168 | ||
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'); | |
174 | ||
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'); | |
180 | ||
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'); | |
186 | ||
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'); | |
192 | } | |
193 | ||
02d1d628 AMH |
194 | sub test_col { |
195 | my ($c, $r, $g, $b, $a) = @_; | |
faa9b3e7 TC |
196 | unless ($c) { |
197 | print "# $Imager::ERRSTR\n"; | |
198 | return 0; | |
199 | } | |
02d1d628 AMH |
200 | my ($cr, $cg, $cb, $ca) = $c->rgba; |
201 | return $r == $cr && $g == $cg && $b == $cb && $a == $ca; | |
202 | } | |
203 | ||
efdc2568 | 204 | sub color_close_enough { |
b7d25d0e | 205 | my ($name, $r, $g, $b, $c) = @_; |
efdc2568 TC |
206 | |
207 | my ($cr, $cg, $cb) = $c->rgba; | |
b7d25d0e TC |
208 | ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5, |
209 | "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)"); | |
efdc2568 TC |
210 | } |
211 | ||
212 | sub color_close_enough_hsv { | |
b7d25d0e | 213 | my ($name, $h, $s, $v, $c) = @_; |
efdc2568 TC |
214 | |
215 | my ($ch, $cs, $cv) = $c->rgba; | |
216 | if ($ch < 5 && $h > 250) { | |
217 | $ch += 255; | |
218 | } | |
219 | elsif ($ch > 250 && $h < 5) { | |
220 | $h += 255; | |
221 | } | |
b7d25d0e TC |
222 | ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5, |
223 | "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)"); | |
efdc2568 TC |
224 | } |
225 | ||
226 | sub fcolor_close_enough { | |
b7d25d0e | 227 | my ($name, $r, $g, $b, $c) = @_; |
efdc2568 TC |
228 | |
229 | my ($cr, $cg, $cb) = $c->rgba; | |
b7d25d0e TC |
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)"); | |
efdc2568 TC |
232 | } |
233 | ||
faa9b3e7 | 234 | sub color_ok { |
b7d25d0e | 235 | my ($name, $r, $g, $b, $a, $c) = @_; |
faa9b3e7 | 236 | |
b7d25d0e | 237 | unless (ok(test_col($c, $r, $g, $b, $a), $name)) { |
1c00d65b | 238 | print "# ($r,$g,$b,$a) != (".join(",", $c ? $c->rgba: ()).")\n"; |
faa9b3e7 TC |
239 | } |
240 | } | |
02d1d628 | 241 |