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