t/t021sixteen.t

   1 #!perl -w
   2 use strict;
   3 BEGIN { $| = 1; print "1..51\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/t021sixteen.log", 1);
  11 require "t/testtools.pl";
  12
  13 use Imager::Color::Float;
  14
  15 my $im_g = Imager::i_img_16_new(100, 101, 1);
  16
  17 print Imager::i_img_getchannels($im_g) == 1
  18   ? "ok 2\n" : "not ok 2 # 1 channel image channel count mismatch\n";
  19 print Imager::i_img_getmask($im_g) & 1
  20   ? "ok 3\n" : "not ok 3 # 1 channel image bad mask\n";
  21 print Imager::i_img_virtual($im_g)
  22   ? "not ok 4 # 1 channel image thinks it is virtual\n" : "ok 4\n";
  23 print Imager::i_img_bits($im_g) == 16
  24   ? "ok 5\n" : "not ok 5 # 1 channel image has bits != 16\n";
  25 print Imager::i_img_type($im_g) == 0 # direct
  26   ? "ok 6\n" : "not ok 6 # 1 channel image isn't direct\n";
  27
  28 my @ginfo = i_img_info($im_g);
  29 print $ginfo[0] == 100
  30   ? "ok 7\n" : "not ok 7 # 1 channel image width incorrect\n";
  31 print $ginfo[1] == 101
  32   ? "ok 8\n" : "not ok 8 # 1 channel image height incorrect\n";
  33
  34 undef $im_g;
  35
  36 my $im_rgb = Imager::i_img_16_new(100, 101, 3);
  37
  38 print Imager::i_img_getchannels($im_rgb) == 3
  39   ? "ok 9\n" : "not ok 9 # 3 channel image channel count mismatch\n";
  40 print +(Imager::i_img_getmask($im_rgb) & 7) == 7
  41   ? "ok 10\n" : "not ok 10 # 3 channel image bad mask\n";
  42 print Imager::i_img_bits($im_rgb) == 16
  43   ? "ok 11\n" : "not ok 11 # 3 channel image has bits != 16\n";
  44 print Imager::i_img_type($im_rgb) == 0 # direct
  45   ? "ok 12\n" : "not ok 12 # 3 channel image isn't direct\n";
  46
  47 my $redf = NCF(1, 0, 0);
  48 my $greenf = NCF(0, 1, 0);
  49 my $bluef = NCF(0, 0, 1);
  50
  51 # fill with red
  52 for my $y (0..101) {
  53   Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
  54 }
  55 print "ok 13\n";
  56 # basic sanity
  57 test_colorf_gpix(14, $im_rgb, 0,  0,   $redf);
  58 test_colorf_gpix(16, $im_rgb, 99, 0,   $redf);
  59 test_colorf_gpix(18, $im_rgb, 0,  100, $redf);
  60 test_colorf_gpix(20, $im_rgb, 99, 100, $redf);
  61 test_colorf_glin(22, $im_rgb, 0,  0,   ($redf) x 100);
  62 test_colorf_glin(24, $im_rgb, 0,  100, ($redf) x 100);
  63
  64 Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
  65 test_colorf_glin(26, $im_rgb, 0, 1,
  66                  ($redf) x 20, ($greenf) x 60, ($redf) x 20);
  67
  68 # basic OO tests
  69 my $oo16img = Imager->new(xsize=>200, ysize=>201, bits=>16)
  70   or print "not ";
  71 print "ok 28\n";
  72 $oo16img->bits == 16 or print "not ";
  73 print "ok 29\n";
  74
  75 my $num = 30;
  76 # make sure of error handling
  77 okn($num++, !Imager->new(xsize=>0, ysize=>1, bits=>16),
  78     "fail to create a 0 pixel wide image");
  79 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
  80        "and correct error message");
  81
  82 okn($num++, !Imager->new(xsize=>1, ysize=>0, bits=>16),
  83     "fail to create a 0 pixel high image");
  84 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
  85        "and correct error message");
  86
  87 okn($num++, !Imager->new(xsize=>-1, ysize=>1, bits=>16),
  88     "fail to create a negative width image");
  89 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
  90        "and correct error message");
  91
  92 okn($num++, !Imager->new(xsize=>1, ysize=>-1, bits=>16),
  93     "fail to create a negative height image");
  94 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
  95        "and correct error message");
  96
  97 okn($num++, !Imager->new(xsize=>-1, ysize=>-1, bits=>16),
  98     "fail to create a negative width/height image");
  99 matchn($num++, Imager->errstr, qr/Image sizes must be positive/,
 100        "and correct error message");
 101
 102 okn($num++, !Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>0),
 103     "fail to create a zero channel image");
 104 matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
 105        "and correct error message");
 106 okn($num++, !Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>5),
 107     "fail to create a five channel image");
 108 matchn($num++, Imager->errstr, qr/channels must be between 1 and 4/,
 109        "and correct error message");
 110
 111 {
 112   # https://rt.cpan.org/Ticket/Display.html?id=8213
 113   # check for handling of memory allocation of very large images
 114   # only test this on 32-bit machines - on a 64-bit machine it may
 115   # result in trying to allocate 4Gb of memory, which is unfriendly at
 116   # least and may result in running out of memory, causing a different
 117   # type of exit
 118   use Config;
 119   if ($Config{intsize} == 4) {
 120     my $uint_range = 256 ** $Config{intsize};
 121     print "# range $uint_range\n";
 122     my $dim1 = int(sqrt($uint_range/2))+1;
 123
 124     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>16);
 125     isn($num++, $im_b, undef, "integer overflow check - 1 channel");
 126
 127     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>16);
 128     okn($num++, $im_b, "but same width ok");
 129     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>16);
 130     okn($num++, $im_b, "but same height ok");
 131     matchn($num++, Imager->errstr, qr/integer overflow/,
 132            "check the error message");
 133
 134     # do a similar test with a 3 channel image, so we're sure we catch
 135     # the same case where the third dimension causes the overflow
 136     my $dim3 = int(sqrt($uint_range / 3 / 2))+1;
 137
 138     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>16);
 139     isn($num++, $im_b, undef, "integer overflow check - 3 channel");
 140
 141     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, bits=>16);
 142     okn($num++, $im_b, "but same width ok");
 143     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, bits=>16);
 144     okn($num++, $im_b, "but same height ok");
 145
 146     matchn($num++, Imager->errstr, qr/integer overflow/,
 147            "check the error message");
 148   }
 149   else {
 150     skipn($num, 8, "don't want to allocate 4Gb");
 151     $num += 8;
 152   }
 153 }
 154
 155 sub NCF {
 156   return Imager::Color::Float->new(@_);
 157 }
 158
 159 sub test_colorf_gpix {
 160   my ($test_base, $im, $x, $y, $expected) = @_;
 161   my $c = Imager::i_gpixf($im, $x, $y);
 162   $c or print "not ";
 163   print "ok ",$test_base++,"\n";
 164   colorf_cmp($c, $expected) == 0 or print "not ";
 165   print "ok ",$test_base++,"\n";
 166 }
 167
 168 sub test_colorf_glin {
 169   my ($test_base, $im, $x, $y, @pels) = @_;
 170
 171   my @got = Imager::i_glinf($im, $x, $x+@pels, $y);
 172   @got == @pels or print "not ";
 173   print "ok ",$test_base++,"\n";
 174   grep(colorf_cmp($pels[$_], $got[$_]), 0..$#got) and print "not ";
 175   print "ok ",$test_base++,"\n";
 176 }
 177
 178 sub colorf_cmp {
 179   my ($c1, $c2) = @_;
 180   my @s1 = map { int($_*65535.99) } $c1->rgba;
 181   my @s2 = map { int($_*65535.99) } $c2->rgba;
 182
 183   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
 184   return $s1[0] <=> $s2[0]
 185     || $s1[1] <=> $s2[1]
 186       || $s1[2] <=> $s2[2];
 187 }