t/t022double.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 136;
   4 BEGIN { use_ok(Imager => qw(:all :handy)) }
   5
   6 use Imager::Test qw(test_image is_image is_color3);
   7
   8 -d "testout" or mkdir "testout";
   9
  10 Imager->open_log(log => "testout/t022double.log");
  11
  12 use Imager::Test qw(image_bounds_checks test_colorf_gpix test_colorf_glin mask_tests);
  13
  14 use Imager::Color::Float;
  15
  16 my $im_g = Imager::i_img_double_new(100, 101, 1);
  17
  18 ok(Imager::i_img_getchannels($im_g) == 1,
  19    "1 channel image channel count mismatch");
  20 ok(Imager::i_img_getmask($im_g) & 1, "1 channel image bad mask");
  21 ok(Imager::i_img_virtual($im_g) == 0,
  22   "1 channel image thinks it is virtual");
  23 my $double_bits = length(pack("d", 1)) * 8;
  24 print "# $double_bits double bits\n";
  25 ok(Imager::i_img_bits($im_g) == $double_bits,
  26    "1 channel image has bits != $double_bits");
  27 ok(Imager::i_img_type($im_g) == 0, "1 channel image isn't direct");
  28
  29 my @ginfo = i_img_info($im_g);
  30 ok($ginfo[0] == 100, "1 channel image width incorrect");
  31 ok($ginfo[1] == 101, "1 channel image height incorrect");
  32
  33 undef $im_g;
  34
  35 my $im_rgb = Imager::i_img_double_new(100, 101, 3);
  36
  37 ok(Imager::i_img_getchannels($im_rgb) == 3,
  38    "3 channel image channel count mismatch");
  39 ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image bad mask");
  40 ok(Imager::i_img_bits($im_rgb) == $double_bits,
  41   "3 channel image has bits != $double_bits");
  42 ok(Imager::i_img_type($im_rgb) == 0, "3 channel image isn't direct");
  43
  44 my $redf = NCF(1, 0, 0);
  45 my $greenf = NCF(0, 1, 0);
  46 my $bluef = NCF(0, 0, 1);
  47
  48 # fill with red
  49 for my $y (0..101) {
  50   Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
  51 }
  52
  53 # basic sanity
  54 test_colorf_gpix($im_rgb, 0,  0,   $redf);
  55 test_colorf_gpix($im_rgb, 99, 0,   $redf);
  56 test_colorf_gpix($im_rgb, 0,  100, $redf);
  57 test_colorf_gpix($im_rgb, 99, 100, $redf);
  58 test_colorf_glin($im_rgb, 0,  0,   [ ($redf) x 100 ], 'sanity glin @0');
  59 test_colorf_glin($im_rgb, 0,  100, [ ($redf) x 100 ], 'sanity glin @100');
  60
  61 Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
  62 test_colorf_glin($im_rgb, 0, 1,
  63                  [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
  64                  'check after write');
  65
  66 # basic OO tests
  67 my $ooimg = Imager->new(xsize=>200, ysize=>201, bits=>'double');
  68 ok($ooimg, "couldn't make double image");
  69 is($ooimg->bits, 'double', "oo didn't give double image");
  70 ok(!$ooimg->is_bilevel, 'not monochrome');
  71
  72 # check that the image is copied correctly
  73 my $oocopy = $ooimg->copy;
  74 is($oocopy->bits, 'double', "oo copy didn't give double image");
  75
  76 ok(!Imager->new(xsize=>0, ysize=>1, bits=>'double'),
  77     "fail making 0 width image");
  78 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
  79        "and correct message");
  80 ok(!Imager->new(xsize=>1, ysize=>0, bits=>'double'),
  81     "fail making 0 height image");
  82 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
  83        "and correct message");
  84 ok(!Imager->new(xsize=>-1, ysize=>1, bits=>'double'),
  85     "fail making -ve width image");
  86 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
  87        "and correct message");
  88 ok(!Imager->new(xsize=>1, ysize=>-1, bits=>'double'),
  89     "fail making -ve height image");
  90 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
  91        "and correct message");
  92 ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>0),
  93     "fail making 0 channel image");
  94 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
  95        "and correct message");
  96 ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>5),
  97     "fail making 5 channel image");
  98 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
  99        "and correct message");
 100
 101 {
 102   # https://rt.cpan.org/Ticket/Display.html?id=8213
 103   # check for handling of memory allocation of very large images
 104   # only test this on 32-bit machines - on a 64-bit machine it may
 105   # result in trying to allocate 4Gb of memory, which is unfriendly at
 106   # least and may result in running out of memory, causing a different
 107   # type of exit
 108   use Config;
 109   SKIP:
 110   {
 111     $Config{ptrsize} == 4
 112       or skip "don't want to allocate 4Gb", 8;
 113     my $uint_range = 256 ** $Config{intsize};
 114     my $dbl_size = $Config{doublesize} || 8;
 115     my $dim1 = int(sqrt($uint_range/$dbl_size))+1;
 116
 117     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>'double');
 118     is($im_b, undef, "integer overflow check - 1 channel");
 119
 120     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>'double');
 121     ok($im_b, "but same width ok");
 122     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>'double');
 123     ok($im_b, "but same height ok");
 124     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 125            "check the error message");
 126
 127     # do a similar test with a 3 channel image, so we're sure we catch
 128     # the same case where the third dimension causes the overflow
 129     my $dim3 = int(sqrt($uint_range / 3 / $dbl_size))+1;
 130
 131     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>'double');
 132     is($im_b, undef, "integer overflow check - 3 channel");
 133
 134     $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, bits=>'double');
 135     ok($im_b, "but same width ok");
 136     $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, bits=>'double');
 137     ok($im_b, "but same height ok");
 138
 139     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 140            "check the error message");
 141   }
 142 }
 143
 144 { # check the channel mask function
 145
 146   my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
 147
 148   mask_tests($im);
 149 }
 150
 151 { # bounds checking
 152   my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
 153   image_bounds_checks($im);
 154 }
 155
 156
 157 { # convert to rgb double
 158   my $im = test_image();
 159   my $imdb = $im->to_rgb_double;
 160   print "# check conversion to double\n";
 161   is($imdb->bits, "double", "check bits");
 162   is_image($im, $imdb, "check image data matches");
 163 }
 164
 165 { # empty image handling
 166   my $im = Imager->new;
 167   ok($im, "make empty image");
 168   ok(!$im->to_rgb_double, "convert empty image to double");
 169   is($im->errstr, "to_rgb_double: empty input image", "check message");
 170 }
 171
 172 my $psamp_outside_error = "Image position outside of image";
 173 { # psamp
 174   print "# psamp\n";
 175   my $imraw = Imager::i_img_double_new(10, 10, 3);
 176   {
 177     is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
 178        "i_psamp def channels, 3 samples");
 179     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 180               "check color written");
 181     Imager::i_img_setmask($imraw, 5);
 182     is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
 183        "i_psamp def channels, 3 samples, masked");
 184     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
 185               "check color written");
 186     is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
 187        "i_psamp channels listed, 3 samples, masked");
 188     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
 189               "check color written");
 190     Imager::i_img_setmask($imraw, ~0);
 191     is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
 192        "i_psamp channels [0, 1], 4 samples");
 193     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 194               "check first color written");
 195     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 196               "check second color written");
 197     is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
 198        "write a full row");
 199     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 200               [ (128, 63, 32) x 10 ],
 201               "check full row");
 202     is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
 203                        [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
 204        6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
 205   }
 206   { # errors we catch
 207     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
 208        undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
 209     is(_get_error(), "No channel 3 in this image",
 210        "check error message");
 211     is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
 212        undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
 213     is(_get_error(), "No channel -1 in this image",
 214        "check error message");
 215     is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 216        "negative y");
 217     is(_get_error(), $psamp_outside_error, "check error message");
 218     is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
 219        "y overflow");
 220     is(_get_error(), $psamp_outside_error, "check error message");
 221     is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 222        "negative x");
 223     is(_get_error(), $psamp_outside_error, "check error message");
 224     is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 225        "x overflow");
 226     is(_get_error(), $psamp_outside_error, "check error message");
 227   }
 228   print "# end psamp tests\n";
 229 }
 230
 231 { # psampf
 232   print "# psampf\n";
 233   my $imraw = Imager::i_img_double_new(10, 10, 3);
 234   {
 235     is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
 236        "i_psampf def channels, 3 samples");
 237     is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
 238               "check color written");
 239     Imager::i_img_setmask($imraw, 5);
 240     is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
 241        "i_psampf def channels, 3 samples, masked");
 242     is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
 243               "check color written");
 244     is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
 245        "i_psampf channels listed, 3 samples, masked");
 246     is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
 247               "check color written");
 248     Imager::i_img_setmask($imraw, ~0);
 249     is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
 250        "i_psampf channels [0, 1], 4 samples");
 251     is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
 252               "check first color written");
 253     is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
 254               "check second color written");
 255     is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
 256        "write a full row");
 257     is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
 258               [ (128, 64, 32) x 10 ],
 259               "check full row");
 260     is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
 261                         [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
 262        6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
 263   }
 264   { # errors we catch
 265     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
 266        undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
 267     is(_get_error(), "No channel 3 in this image",
 268        "check error message");
 269     is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
 270        undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
 271     is(_get_error(), "No channel -1 in this image",
 272        "check error message");
 273     is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
 274        "negative y");
 275     is(_get_error(), $psamp_outside_error, "check error message");
 276     is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
 277        "y overflow");
 278     is(_get_error(), $psamp_outside_error, "check error message");
 279     is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
 280        "negative x");
 281     is(_get_error(), $psamp_outside_error, "check error message");
 282     is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
 283        "x overflow");
 284     is(_get_error(), $psamp_outside_error, "check error message");
 285   }
 286   print "# end psampf tests\n";
 287 }
 288
 289 Imager->close_log;
 290
 291 unless ($ENV{IMAGER_KEEP_FILES}) {
 292   unlink "testout/t022double.log";
 293 }
 294
 295 sub _get_error {
 296   my @errors = Imager::i_errors();
 297   return join(": ", map $_->[0], @errors);
 298 }