| 1 | #!/usr/bin/perl |
| 2 | use 5.008009; |
| 3 | use strict; |
| 4 | use warnings; |
| 5 | |
| 6 | use Convert::Color::RGB8; |
| 7 | use Test::More tests => 7 * ($ENV{RELEASE_TESTING} ? 4096 : 512); |
| 8 | |
| 9 | use constant EPSILON => $ENV{RELEASE_TESTING} ? 1e-11 : 2e-4; |
| 10 | my @spaces = qw/XYZ LUV LCh HUSL HUSLp/; |
| 11 | |
| 12 | sub isf { |
| 13 | my ($xx, $yy, $name) = @_; |
| 14 | for (0 .. 2) { |
| 15 | my ($x, $y) = ($xx->[$_], $yy->[$_]); |
| 16 | do { diag "$x != $y"; return fail $name } if abs ($x - $y) > EPSILON; |
| 17 | } |
| 18 | pass $name; |
| 19 | } |
| 20 | |
| 21 | my @tests; |
| 22 | |
| 23 | if ($ENV{RELEASE_TESTING}) { |
| 24 | require JSON::MaybeXS; |
| 25 | open my $fh, '<', 't/snapshot-rev4.json'; |
| 26 | my $snapshot = join '', <$fh>; |
| 27 | |
| 28 | my %tests = %{JSON::MaybeXS::decode_json $snapshot}; |
| 29 | @tests = map { [$_, $tests{$_}] } sort keys %tests; |
| 30 | } else { |
| 31 | open my $fh, '<', 't/snapshot-rev4.csv'; |
| 32 | <$fh>; |
| 33 | |
| 34 | while (<$fh>) { |
| 35 | my ($color, @good) = split ','; |
| 36 | my %test; |
| 37 | $test{rgb} = [Convert::Color::RGB8->new($color)->rgb]; |
| 38 | $test{lc $spaces[$_]} = [@good[$_ * 3 .. $_ * 3 + 2]] for 0 .. $#spaces; |
| 39 | push @tests, ["#$color", \%test] |
| 40 | } |
| 41 | } |
| 42 | |
| 43 | for my $test (@tests) { |
| 44 | my ($color, $data) = @$test; |
| 45 | my $col = Convert::Color::RGB8->new(substr $color, 1); |
| 46 | isf $col->convert_to(lc), $data->{lc()}, "convert $color to $_" for @spaces; |
| 47 | isf [$col->convert_to(lc)->rgb], $data->{rgb}, "convert $color to $_ and back" for qw/HUSL HUSLp/; |
| 48 | } |