Various changes:
[imager.git] / t / t15color.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
3d782fde 10use Test::More tests => 47;
b7d25d0e
TC
11
12BEGIN { use_ok('Imager'); };
02d1d628
AMH
13
14init_log("testout/t15color.log",1);
15
16my $c1 = Imager::Color->new(100, 150, 200, 250);
b7d25d0e 17ok(test_col($c1, 100, 150, 200, 250), 'simple 4-arg');
02d1d628 18my $c2 = Imager::Color->new(100, 150, 200);
b7d25d0e 19ok(test_col($c2, 100, 150, 200, 255), 'simple 3-arg');
02d1d628 20my $c3 = Imager::Color->new("#6496C8");
b7d25d0e 21ok(test_col($c3, 100, 150, 200, 255), 'web color');
0999c453
TC
22# crashes in Imager-0.38pre8 and earlier
23my @foo;
24for (1..1000) {
25 push(@foo, Imager::Color->new("#FFFFFF"));
26}
27my $fail;
28for (@foo) {
29 Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
30 Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
27c85c8d 31 test_col($_, 128, 128, 128, 128) or ++$fail;
0999c453 32}
b7d25d0e 33ok(!$fail, 'consitency check');
02d1d628 34
faa9b3e7 35# test the new OO methods
b7d25d0e
TC
36color_ok('r g b',, 100, 150, 200, 255, Imager::Color->new(r=>100, g=>150, b=>200));
37color_ok('red green blue', 101, 151, 201, 255,
faa9b3e7 38 Imager::Color->new(red=>101, green=>151, blue=>201));
b7d25d0e
TC
39color_ok('grey', 102, 255, 255, 255, Imager::Color->new(grey=>102));
40color_ok('gray', 103, 255, 255, 255, Imager::Color->new(gray=>103));
41SKIP:
42{
43 skip "no X rgb.txt found", 1 unless -e '/usr/lib/X11/rgb.txt';
44 color_ok('xname', 0, 0, 255, 255, Imager::Color->new(xname=>'blue'));
faa9b3e7 45}
b7d25d0e 46color_ok('gimp', 255, 250, 250, 255,
faa9b3e7 47 Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal'));
b7d25d0e
TC
48color_ok('h s v', 255, 255, 255, 255, Imager::Color->new(h=>0, 's'=>0, 'v'=>1.0));
49color_ok('h s v again', 255, 0, 0, 255, Imager::Color->new(h=>0, 's'=>1, v=>1));
50color_ok('web 6 digit', 128, 129, 130, 255, Imager::Color->new(web=>'#808182'));
51color_ok('web 3 digit', 0x11, 0x22, 0x33, 255, Imager::Color->new(web=>'#123'));
52color_ok('rgb arrayref', 255, 150, 121, 255, Imager::Color->new(rgb=>[ 255, 150, 121 ]));
53color_ok('rgba arrayref', 255, 150, 121, 128,
faa9b3e7 54 Imager::Color->new(rgba=>[ 255, 150, 121, 128 ]));
b7d25d0e
TC
55color_ok('hsv arrayref', 255, 0, 0, 255, Imager::Color->new(hsv=>[ 0, 1, 1 ]));
56color_ok('channel0-3', 129, 130, 131, 134,
faa9b3e7
TC
57 Imager::Color->new(channel0=>129, channel1=>130, channel2=>131,
58 channel3=>134));
b7d25d0e 59color_ok('c0-3', 129, 130, 131, 134,
faa9b3e7 60 Imager::Color->new(c0=>129, c1=>130, c2=>131, c3=>134));
b7d25d0e 61color_ok('channels arrayref', 200, 201, 203, 204,
faa9b3e7 62 Imager::Color->new(channels=>[ 200, 201, 203, 204 ]));
b7d25d0e 63color_ok('name', 255, 250, 250, 255,
faa9b3e7 64 Imager::Color->new(name=>'snow', palette=>'testimg/test_gimp_pal'));
efdc2568
TC
65
66# test the internal HSV <=> RGB conversions
67# these values were generated using the GIMP
68# all but hue is 0..360, saturation and value from 0 to 1
69# rgb from 0 to 255
70my @hsv_vs_rgb =
71 (
72 { hsv => [ 0, 0.2, 0.1 ], rgb=> [ 25, 20, 20 ] },
73 { hsv => [ 0, 0.5, 1.0 ], rgb => [ 255, 127, 127 ] },
74 { hsv => [ 100, 0.5, 1.0 ], rgb => [ 170, 255, 127 ] },
75 { hsv => [ 100, 1.0, 1.0 ], rgb=> [ 85, 255, 0 ] },
76 { hsv => [ 335, 0.5, 0.5 ], rgb=> [127, 63, 90 ] },
77 );
78
79use Imager::Color::Float;
80my $test_num = 23;
81my $index = 0;
82for my $entry (@hsv_vs_rgb) {
83 print "# color index $index\n";
84 my $hsv = $entry->{hsv};
85 my $rgb = $entry->{rgb};
86 my $fhsvo = Imager::Color::Float->new($hsv->[0]/360.0, $hsv->[1], $hsv->[2]);
87 my $fc = Imager::Color::Float::i_hsv_to_rgb($fhsvo);
b7d25d0e 88 fcolor_close_enough("i_hsv_to_rgbf $index", $rgb->[0]/255, $rgb->[1]/255,
efdc2568
TC
89 $rgb->[2]/255, $fc);
90 my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
b7d25d0e 91 fcolor_close_enough("i_rgbf_to_hsv $index", $hsv->[0]/360.0, $hsv->[1], $hsv->[2],
efdc2568
TC
92 $fc2);
93
94 my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255,
95 $hsv->[2] * 255);
96 my $c = Imager::Color::i_hsv_to_rgb($hsvo);
b7d25d0e 97 color_close_enough("i_hsv_to_rgb $index", @$rgb, $c);
efdc2568 98 my $c2 = Imager::Color::i_rgb_to_hsv($c);
b7d25d0e 99 color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255,
efdc2568
TC
100 $hsv->[2] * 255, $c2);
101 ++$index;
102}
103
1c00d65b 104# check the built-ins table
b7d25d0e 105color_ok('builtin black', 0, 0, 0, 255,
1c00d65b 106 Imager::Color->new(builtin=>'black'));
5f8cbeac 107
0d3b936e
TC
108{
109 my $c1 = Imager::Color->new(255, 255, 255, 0);
110 my $c2 = Imager::Color->new(255, 255, 255, 255);
b7d25d0e
TC
111 ok(!$c1->equals(other=>$c2), "not equal no ignore alpha");
112 ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)),
0d3b936e 113 "equal with ignore alpha");
b7d25d0e 114 ok($c1->equals(other=>$c1), "equal to itself");
0d3b936e 115}
3d782fde
TC
116
117{ # http://rt.cpan.org/NoAuth/Bug.html?id=13143
118 # Imager::Color->new(color_name) warning if HOME environment variable not set
119 local $ENV{HOME};
120 my @warnings;
121 local $SIG{__WARN__} = sub { push @warnings, "@_" };
122
123 # presumably no-one will name a color like this.
124 my $c1 = Imager::Color->new(gimp=>"ABCDEFGHIJKLMNOP");
125 is(@warnings, 0, "Should be no warnings")
126 or do { print "# $_" for @warnings };
127}
efdc2568 128
02d1d628
AMH
129sub test_col {
130 my ($c, $r, $g, $b, $a) = @_;
faa9b3e7
TC
131 unless ($c) {
132 print "# $Imager::ERRSTR\n";
133 return 0;
134 }
02d1d628
AMH
135 my ($cr, $cg, $cb, $ca) = $c->rgba;
136 return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
137}
138
efdc2568 139sub color_close_enough {
b7d25d0e 140 my ($name, $r, $g, $b, $c) = @_;
efdc2568
TC
141
142 my ($cr, $cg, $cb) = $c->rgba;
b7d25d0e
TC
143 ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5,
144 "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
efdc2568
TC
145}
146
147sub color_close_enough_hsv {
b7d25d0e 148 my ($name, $h, $s, $v, $c) = @_;
efdc2568
TC
149
150 my ($ch, $cs, $cv) = $c->rgba;
151 if ($ch < 5 && $h > 250) {
152 $ch += 255;
153 }
154 elsif ($ch > 250 && $h < 5) {
155 $h += 255;
156 }
b7d25d0e
TC
157 ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5,
158 "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)");
efdc2568
TC
159}
160
161sub fcolor_close_enough {
b7d25d0e 162 my ($name, $r, $g, $b, $c) = @_;
efdc2568
TC
163
164 my ($cr, $cg, $cb) = $c->rgba;
b7d25d0e
TC
165 ok(abs($cr-$r) <= 0.01 && abs($cg-$g) <= 0.01 && abs($cb-$b) <= 0.01,
166 "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
efdc2568
TC
167}
168
faa9b3e7 169sub color_ok {
b7d25d0e 170 my ($name, $r, $g, $b, $a, $c) = @_;
faa9b3e7 171
b7d25d0e 172 unless (ok(test_col($c, $r, $g, $b, $a), $name)) {
1c00d65b 173 print "# ($r,$g,$b,$a) != (".join(",", $c ? $c->rgba: ()).")\n";
faa9b3e7
TC
174 }
175}
02d1d628 176