t/t022double.t

   1 #!perl -w
   2 use strict;
   3 BEGIN { $| = 1; print "1..29\n"; }
   4 my $loaded;
   5 END {print "not ok 1\n" unless $loaded;}
   6 use Imager qw(:all :handy);
   7 #use Data::Dumper;
   8 $loaded = 1;
   9 print "ok 1\n";
  10 init_log("testout/t022double.log", 1);
  11
  12 use Imager::Color::Float;
  13
  14 my $im_g = Imager::i_img_double_new(100, 101, 1);
  15
  16 ok(2, Imager::i_img_getchannels($im_g) == 1,
  17    "1 channel image channel count mismatch");
  18 ok(3, Imager::i_img_getmask($im_g) & 1, "1 channel image bad mask");
  19 ok(4, Imager::i_img_virtual($im_g) == 0,
  20   "1 channel image thinks it is virtual");
  21 my $double_bits = length(pack("d", 1)) * 8;
  22 ok(5, Imager::i_img_bits($im_g) == $double_bits,
  23    "1 channel image has bits != $double_bits");
  24 ok(6, Imager::i_img_type($im_g) == 0, "1 channel image isn't direct");
  25
  26 my @ginfo = i_img_info($im_g);
  27 ok(7, $ginfo[0] == 100, "1 channel image width incorrect");
  28 ok(8, $ginfo[1] == 101, "1 channel image height incorrect");
  29
  30 undef $im_g;
  31
  32 my $im_rgb = Imager::i_img_double_new(100, 101, 3);
  33
  34 ok(9, Imager::i_img_getchannels($im_rgb) == 3,
  35    "3 channel image channel count mismatch");
  36 ok(10, (Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image bad mask");
  37 ok(11, Imager::i_img_bits($im_rgb) == $double_bits,
  38   "3 channel image has bits != $double_bits");
  39 ok(12, Imager::i_img_type($im_rgb) == 0, "3 channel image isn't direct");
  40
  41 my $redf = NCF(1, 0, 0);
  42 my $greenf = NCF(0, 1, 0);
  43 my $bluef = NCF(0, 0, 1);
  44
  45 # fill with red
  46 for my $y (0..101) {
  47   Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
  48 }
  49 print "ok 13\n";
  50 # basic sanity
  51 test_colorf_gpix(14, $im_rgb, 0,  0,   $redf);
  52 test_colorf_gpix(16, $im_rgb, 99, 0,   $redf);
  53 test_colorf_gpix(18, $im_rgb, 0,  100, $redf);
  54 test_colorf_gpix(20, $im_rgb, 99, 100, $redf);
  55 test_colorf_glin(22, $im_rgb, 0,  0,   ($redf) x 100);
  56 test_colorf_glin(24, $im_rgb, 0,  100, ($redf) x 100);
  57
  58 Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
  59 test_colorf_glin(26, $im_rgb, 0, 1,
  60                  ($redf) x 20, ($greenf) x 60, ($redf) x 20);
  61
  62 # basic OO tests
  63 my $oo16img = Imager->new(xsize=>200, ysize=>201, bits=>16)
  64   or print "not ";
  65 print "ok 28\n";
  66 $oo16img->bits == 16 or print "not ";
  67 print "ok 29\n";
  68
  69
  70 sub NCF {
  71   return Imager::Color::Float->new(@_);
  72 }
  73
  74 sub test_colorf_gpix {
  75   my ($test_base, $im, $x, $y, $expected) = @_;
  76   my $c = Imager::i_gpixf($im, $x, $y);
  77   $c or print "not ";
  78   print "ok ",$test_base++,"\n";
  79   colorf_cmp($c, $expected) == 0 or print "not ";
  80   print "ok ",$test_base++,"\n";
  81 }
  82
  83 sub test_colorf_glin {
  84   my ($test_base, $im, $x, $y, @pels) = @_;
  85
  86   my @got = Imager::i_glinf($im, $x, $x+@pels, $y);
  87   @got == @pels or print "not ";
  88   print "ok ",$test_base++,"\n";
  89   grep(colorf_cmp($pels[$_], $got[$_]), 0..$#got) and print "not ";
  90   print "ok ",$test_base++,"\n";
  91 }
  92
  93 sub colorf_cmp {
  94   my ($c1, $c2) = @_;
  95   my @s1 = map { int($_*65535.99) } $c1->rgba;
  96   my @s2 = map { int($_*65535.99) } $c2->rgba;
  97
  98   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
  99   return $s1[0] <=> $s2[0]
 100     || $s1[1] <=> $s2[1]
 101       || $s1[2] <=> $s2[2];
 102 }
 103
 104 sub ok {
 105   my ($test_num, $ok, $comment) = @_;
 106
 107   if ($ok) {
 108     print "ok $test_num\n";
 109   }
 110   else {
 111     print "not ok $test_num # $comment\n";
 112   }
 113 }