t/t021sixteen.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 104;
   4
   5 BEGIN { use_ok(Imager=>qw(:all :handy)) }
   6
   7 init_log("testout/t021sixteen.log", 1);
   8
   9 use Imager::Color::Float;
  10 use Imager::Test qw(test_image is_image image_bounds_checks test_colorf_gpix
  11                     test_colorf_glin mask_tests is_color3);
  12
  13 my $im_g = Imager::i_img_16_new(100, 101, 1);
  14
  15 is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
  16 ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
  17 ok(!Imager::i_img_virtual($im_g), "shouldn't be marked virtual");
  18 is(Imager::i_img_bits($im_g), 16, "1 channel image has bits == 16");
  19 is(Imager::i_img_type($im_g), 0, "1 channel image isn't direct");
  20
  21 my @ginfo = i_img_info($im_g);
  22 is($ginfo[0], 100, "1 channel image width");
  23 is($ginfo[1], 101, "1 channel image height");
  24
  25 undef $im_g;
  26
  27 my $im_rgb = Imager::i_img_16_new(100, 101, 3);
  28
  29 is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
  30 ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image mask");
  31 is(Imager::i_img_bits($im_rgb), 16, "3 channel image bits");
  32 is(Imager::i_img_type($im_rgb), 0, "3 channel image type");
  33
  34 my $redf = NCF(1, 0, 0);
  35 my $greenf = NCF(0, 1, 0);
  36 my $bluef = NCF(0, 0, 1);
  37
  38 # fill with red
  39 for my $y (0..101) {
  40   Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
  41 }
  42 pass("fill with red");
  43 # basic sanity
  44 test_colorf_gpix($im_rgb, 0,  0,   $redf, 0, "top-left");
  45 test_colorf_gpix($im_rgb, 99, 0,   $redf, 0, "top-right");
  46 test_colorf_gpix($im_rgb, 0,  100, $redf, 0, "bottom left");
  47 test_colorf_gpix($im_rgb, 99, 100, $redf, 0, "bottom right");
  48 test_colorf_glin($im_rgb, 0,  0,   [ ($redf) x 100 ], "first line");
  49 test_colorf_glin($im_rgb, 0,  100, [ ($redf) x 100 ], "last line");
  50
  51 Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
  52 test_colorf_glin($im_rgb, 0, 1,
  53                  [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
  54                 "added some green in the middle");
  55 {
  56   my @samples;
  57   is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, 0 .. 2), 12,
  58      "i_gsamp_bits all channels - count")
  59     or print "# ", Imager->_error_as_msg(), "\n";
  60   is_deeply(\@samples, [ 65535, 0, 0,   65535, 0, 0,
  61                          0, 65535, 0,   0, 65535, 0 ],
  62             "check samples retrieved");
  63   @samples = ();
  64   is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, 0, 2), 8,
  65      "i_gsamp_bits some channels - count")
  66     or print "# ", Imager->_error_as_msg(), "\n";
  67   is_deeply(\@samples, [ 65535, 0,   65535, 0,
  68                          0, 0,       0, 0     ],
  69             "check samples retrieved");
  70   # fail gsamp
  71   is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, 0, 3), undef,
  72      "i_gsamp_bits fail bad channel");
  73   is(Imager->_error_as_msg(), 'No channel 3 in this image', 'check message');
  74
  75   is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 17, \@samples, 0, 0, 2), 8,
  76      "i_gsamp_bits succeed high bits");
  77   is($samples[0], 131071, "check correct with high bits");
  78
  79   # write some samples back
  80   my @wr_samples =
  81     (
  82      0, 0, 65535,
  83      65535, 0, 0,
  84      0, 65535, 0,
  85      65535, 65535, 0
  86     );
  87   is(Imager::i_psamp_bits($im_rgb, 18, 2, 16, [ 0 .. 2 ], \@wr_samples),
  88      12, "write 16-bit samples")
  89     or print "# ", Imager->_error_as_msg(), "\n";
  90   @samples = ();
  91   is(Imager::i_gsamp_bits($im_rgb, 18, 22, 2, 16, \@samples, 0, 0 .. 2), 12,
  92      "read them back")
  93     or print "# ", Imager->_error_as_msg(), "\n";
  94   is_deeply(\@samples, \@wr_samples, "check they match");
  95   my $c = Imager::i_get_pixel($im_rgb, 18, 2);
  96   is_color3($c, 0, 0, 255, "check it write to the right places");
  97 }
  98
  99 # basic OO tests
 100 my $oo16img = Imager->new(xsize=>200, ysize=>201, bits=>16);
 101 ok($oo16img, "make a 16-bit oo image");
 102 is($oo16img->bits,  16, "test bits");
 103 isnt($oo16img->is_bilevel, "should not be considered mono");
 104 # make sure of error handling
 105 ok(!Imager->new(xsize=>0, ysize=>1, bits=>16),
 106     "fail to create a 0 pixel wide image");
 107 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 108        "and correct error message");
 109
 110 ok(!Imager->new(xsize=>1, ysize=>0, bits=>16),
 111     "fail to create a 0 pixel high image");
 112 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 113        "and correct error message");
 114
 115 ok(!Imager->new(xsize=>-1, ysize=>1, bits=>16),
 116     "fail to create a negative width image");
 117 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 118        "and correct error message");
 119
 120 ok(!Imager->new(xsize=>1, ysize=>-1, bits=>16),
 121     "fail to create a negative height image");
 122 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 123        "and correct error message");
 124
 125 ok(!Imager->new(xsize=>-1, ysize=>-1, bits=>16),
 126     "fail to create a negative width/height image");
 127 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
 128        "and correct error message");
 129
 130 ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>0),
 131     "fail to create a zero channel image");
 132 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 133        "and correct error message");
 134 ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>5),
 135     "fail to create a five channel image");
 136 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
 137        "and correct error message");
 138
 139 {
 140   # https://rt.cpan.org/Ticket/Display.html?id=8213
 141   # check for handling of memory allocation of very large images
 142   # only test this on 32-bit machines - on a 64-bit machine it may
 143   # result in trying to allocate 4Gb of memory, which is unfriendly at
 144   # least and may result in running out of memory, causing a different
 145   # type of exit
 146  SKIP: {
 147     use Config;
 148     $Config{intsize} == 4
 149       or skip("don't want to allocate 4Gb", 8);
 150     my $uint_range = 256 ** $Config{intsize};
 151     print "# range $uint_range\n";
 152     my $dim1 = int(sqrt($uint_range/2))+1;
 153
 154     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>16);
 155     is($im_b, undef, "integer overflow check - 1 channel");
 156
 157     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>16);
 158     ok($im_b, "but same width ok");
 159     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>16);
 160     ok($im_b, "but same height ok");
 161     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 162            "check the error message");
 163
 164     # do a similar test with a 3 channel image, so we're sure we catch
 165     # the same case where the third dimension causes the overflow
 166     my $dim3 = int(sqrt($uint_range / 3 / 2))+1;
 167
 168     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>16);
 169     is($im_b, undef, "integer overflow check - 3 channel");
 170
 171     $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, bits=>16);
 172     ok($im_b, "but same width ok");
 173     $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, bits=>16);
 174     ok($im_b, "but same height ok");
 175
 176     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 177            "check the error message");
 178
 179     # check we can allocate a scanline, unlike double images the scanline
 180     # in the image itself is smaller than a line of i_fcolor
 181     # divide by 2 to get to int range, by 2 for 2 bytes/pixel, by 3 to
 182     # fit the image allocation in, but for the floats to overflow
 183     my $dim4 = $uint_range / 2 / 2 / 3;
 184     my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>1, bits=>16);
 185     is($im_o, undef, "integer overflow check - scanline");
 186     cmp_ok(Imager->errstr, '=~',
 187            qr/integer overflow calculating scanline allocation/,
 188            "check error message");
 189   }
 190 }
 191
 192 { # check the channel mask function
 193
 194   my $im = Imager->new(xsize => 10, ysize=>10, bits=>16);
 195
 196   mask_tests($im, 1.0/65535);
 197 }
 198
 199 { # convert to rgb16
 200   my $im = test_image();
 201   my $im16 = $im->to_rgb16;
 202   print "# check conversion to 16 bit\n";
 203   is($im16->bits, 16, "check bits");
 204   is_image($im, $im16, "check image data matches");
 205 }
 206
 207 { # bounds checks
 208   my $im = Imager->new(xsize => 10, ysize => 10, bits => 16);
 209   image_bounds_checks($im);
 210 }
 211
 212 {
 213   my $im = Imager->new(xsize => 10, ysize => 10, bits => 16, channels => 3);
 214   my @wr_samples = map int(rand 65536), 1..30;
 215   is($im->setsamples('y' => 1, data => \@wr_samples, type => '16bit'),
 216      30, "write 16-bit to OO image")
 217     or print "# ", $im->errstr, "\n";
 218   my @samples;
 219   is($im->getsamples(y => 1, target => \@samples, type => '16bit'),
 220      30, "read 16-bit from OO image")
 221     or print "# ", $im->errstr, "\n";
 222   is_deeply(\@wr_samples, \@samples, "check it matches");
 223 }