t/t15color.t

   1 # Before `make install' is performed this script should be runnable with
   2 # `make test'. After `make install' it should work as `perl test.pl'
   3
   4 ######################### We start with some black magic to print on failure.
   5
   6 # Change 1..1 below to 1..last_test_to_print .
   7 # (It may become useful if the test is moved to ./t subdirectory.)
   8
   9 BEGIN { $| = 1; print "1..42\n"; }
  10 END {print "not ok 1\n" unless $loaded;}
  11 use Imager;
  12 $loaded = 1;
  13 print "ok 1\n";
  14
  15 init_log("testout/t15color.log",1);
  16
  17 my $c1 = Imager::Color->new(100, 150, 200, 250);
  18 print test_col($c1, 100, 150, 200, 250) ? "ok 2\n" : "not ok 2\n";
  19 my $c2 = Imager::Color->new(100, 150, 200);
  20 print test_col($c2, 100, 150, 200, 255) ? "ok 3\n" : "not ok 3\n";
  21 my $c3 = Imager::Color->new("#6496C8");
  22 print test_col($c3, 100, 150, 200, 255) ? "ok 4\n" : "not ok 4\n";
  23 # crashes in Imager-0.38pre8 and earlier
  24 my @foo;
  25 for (1..1000) {
  26   push(@foo, Imager::Color->new("#FFFFFF"));
  27 }
  28 my $fail;
  29 for (@foo) {
  30   Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
  31   Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
  32   test_col($_, 128, 128, 128, 128) or ++$fail;
  33 }
  34 $fail and print "not ";
  35 print "ok 5\n";
  36
  37 # test the new OO methods
  38 color_ok(6, 100, 150, 200, 255, Imager::Color->new(r=>100, g=>150, b=>200));
  39 color_ok(7, 101, 151, 201, 255,
  40          Imager::Color->new(red=>101, green=>151, blue=>201));
  41 color_ok(8, 102, 255, 255, 255, Imager::Color->new(grey=>102));
  42 color_ok(9, 103, 255, 255, 255, Imager::Color->new(gray=>103));
  43 if (-e '/usr/lib/X11/rgb.txt') {
  44   color_ok(10, 0, 0, 255, 255, Imager::Color->new(xname=>'blue'));
  45 }
  46 else {
  47   print "ok 10 # skip - no X rgb.txt found\n";
  48 }
  49 color_ok(11, 255, 250, 250, 255,
  50          Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal'));
  51 color_ok(12, 255, 255, 255, 255, Imager::Color->new(h=>0, 's'=>0, 'v'=>1.0));
  52 color_ok(13, 255, 0, 0, 255, Imager::Color->new(h=>0, 's'=>1, v=>1));
  53 color_ok(14, 128, 129, 130, 255, Imager::Color->new(web=>'#808182'));
  54 color_ok(15, 0x11, 0x22, 0x33, 255, Imager::Color->new(web=>'#123'));
  55 color_ok(16, 255, 150, 121, 255, Imager::Color->new(rgb=>[ 255, 150, 121 ]));
  56 color_ok(17, 255, 150, 121, 128,
  57          Imager::Color->new(rgba=>[ 255, 150, 121, 128 ]));
  58 color_ok(18, 255, 0, 0, 255, Imager::Color->new(hsv=>[ 0, 1, 1 ]));
  59 color_ok(19, 129, 130, 131, 134,
  60          Imager::Color->new(channel0=>129, channel1=>130, channel2=>131,
  61                             channel3=>134));
  62 color_ok(20, 129, 130, 131, 134,
  63          Imager::Color->new(c0=>129, c1=>130, c2=>131, c3=>134));
  64 color_ok(21, 200, 201, 203, 204,
  65          Imager::Color->new(channels=>[ 200, 201, 203, 204 ]));
  66 color_ok(22, 255, 250, 250, 255,
  67          Imager::Color->new(name=>'snow', palette=>'testimg/test_gimp_pal'));
  68
  69 # test the internal HSV <=> RGB conversions
  70 # these values were generated using the GIMP
  71 # all but hue is 0..360, saturation and value from 0 to 1
  72 # rgb from 0 to 255
  73 my @hsv_vs_rgb =
  74   (
  75    { hsv => [ 0, 0.2, 0.1 ], rgb=> [ 25, 20, 20 ] },
  76    { hsv => [ 0, 0.5, 1.0 ], rgb => [ 255, 127, 127 ] },
  77    { hsv => [ 100, 0.5, 1.0 ], rgb => [ 170, 255, 127 ] },
  78    { hsv => [ 100, 1.0, 1.0 ], rgb=> [ 85, 255, 0 ] },
  79    { hsv => [ 335, 0.5, 0.5 ], rgb=> [127, 63, 90 ] },
  80   );
  81
  82 use Imager::Color::Float;
  83 my $test_num = 23;
  84 my $index = 0;
  85 for my $entry (@hsv_vs_rgb) {
  86   print "# color index $index\n";
  87   my $hsv = $entry->{hsv};
  88   my $rgb = $entry->{rgb};
  89   my $fhsvo = Imager::Color::Float->new($hsv->[0]/360.0, $hsv->[1], $hsv->[2]);
  90   my $fc = Imager::Color::Float::i_hsv_to_rgb($fhsvo);
  91   fcolor_close_enough($test_num++, $rgb->[0]/255, $rgb->[1]/255,
  92                       $rgb->[2]/255, $fc);
  93   my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
  94   fcolor_close_enough($test_num++, $hsv->[0]/360.0, $hsv->[1], $hsv->[2],
  95                       $fc2);
  96
  97   my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255,
  98                                 $hsv->[2] * 255);
  99   my $c = Imager::Color::i_hsv_to_rgb($hsvo);
 100   color_close_enough($test_num++, @$rgb, $c);
 101   my $c2 = Imager::Color::i_rgb_to_hsv($c);
 102   color_close_enough_hsv($test_num++, $hsv->[0]*255/360.0, $hsv->[1] * 255,
 103                      $hsv->[2] * 255, $c2);
 104   ++$index;
 105 }
 106
 107
 108
 109 sub test_col {
 110   my ($c, $r, $g, $b, $a) = @_;
 111   unless ($c) {
 112     print "# $Imager::ERRSTR\n";
 113     return 0;
 114   }
 115   my ($cr, $cg, $cb, $ca) = $c->rgba;
 116   return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
 117 }
 118
 119 sub color_close_enough {
 120   my ($test_num, $r, $g, $b, $c) = @_;
 121
 122   my ($cr, $cg, $cb) = $c->rgba;
 123   if (abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5) {
 124     print "ok $test_num # ($cr, $cg, $cb) <=> ($r, $g, $b)\n";
 125   }
 126   else {
 127     print "not ok $test_num # ($cr, $cg, $cb) <=> ($r, $g, $b)\n";
 128   }
 129 }
 130
 131 sub color_close_enough_hsv {
 132   my ($test_num, $h, $s, $v, $c) = @_;
 133
 134   my ($ch, $cs, $cv) = $c->rgba;
 135   if ($ch < 5 && $h > 250) {
 136     $ch += 255;
 137   }
 138   elsif ($ch > 250 && $h < 5) {
 139     $h += 255;
 140   }
 141   if (abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5) {
 142     print "ok $test_num # ($ch, $cs, $cv) <=> ($h, $s, $v)\n";
 143   }
 144   else {
 145     print "not ok $test_num # ($ch, $cs, $cv) <=> ($h, $s, $v)\n";
 146   }
 147 }
 148
 149 sub fcolor_close_enough {
 150   my ($test_num, $r, $g, $b, $c) = @_;
 151
 152   my ($cr, $cg, $cb) = $c->rgba;
 153   if (abs($cr-$r) <= 0.01 && abs($cg-$g) <= 0.01 && abs($cb-$b) <= 0.01) {
 154     print "ok $test_num\n";
 155   }
 156   else {
 157     print "not ok $test_num # ($cr, $cg, $cb) <=> ($r, $g, $b)\n";
 158   }
 159 }
 160
 161 sub color_ok {
 162   my ($test_num, $r, $g, $b, $a, $c) = @_;
 163
 164   if (test_col($c, $r, $g, $b, $a)) {
 165     print "ok $test_num\n";
 166   }
 167   else {
 168     print "not ok $test_num\n"
 169   }
 170 }
 171