t/t022double.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 97;
   4
   5 BEGIN { use_ok(Imager => qw(:all :handy)) }
   6 require "t/testtools.pl";
   7
   8 init_log("testout/t022double.log", 1);
   9
  10 use Imager::Test qw(image_bounds_checks);
  11
  12 use Imager::Color::Float;
  13
  14 my $im_g = Imager::i_img_double_new(100, 101, 1);
  15
  16 ok(Imager::i_img_getchannels($im_g) == 1,
  17    "1 channel image channel count mismatch");
  18 ok(Imager::i_img_getmask($im_g) & 1, "1 channel image bad mask");
  19 ok(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 print "# $double_bits double bits\n";
  23 ok(Imager::i_img_bits($im_g) == $double_bits,
  24    "1 channel image has bits != $double_bits");
  25 ok(Imager::i_img_type($im_g) == 0, "1 channel image isn't direct");
  26
  27 my @ginfo = i_img_info($im_g);
  28 ok($ginfo[0] == 100, "1 channel image width incorrect");
  29 ok($ginfo[1] == 101, "1 channel image height incorrect");
  30
  31 undef $im_g;
  32
  33 my $im_rgb = Imager::i_img_double_new(100, 101, 3);
  34
  35 ok(Imager::i_img_getchannels($im_rgb) == 3,
  36    "3 channel image channel count mismatch");
  37 ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image bad mask");
  38 ok(Imager::i_img_bits($im_rgb) == $double_bits,
  39   "3 channel image has bits != $double_bits");
  40 ok(Imager::i_img_type($im_rgb) == 0, "3 channel image isn't direct");
  41
  42 my $redf = NCF(1, 0, 0);
  43 my $greenf = NCF(0, 1, 0);
  44 my $bluef = NCF(0, 0, 1);
  45
  46 # fill with red
  47 for my $y (0..101) {
  48   Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
  49 }
  50
  51 # basic sanity
  52 test_colorf_gpix($im_rgb, 0,  0,   $redf);
  53 test_colorf_gpix($im_rgb, 99, 0,   $redf);
  54 test_colorf_gpix($im_rgb, 0,  100, $redf);
  55 test_colorf_gpix($im_rgb, 99, 100, $redf);
  56 test_colorf_glin($im_rgb, 0,  0,   ($redf) x 100);
  57 test_colorf_glin($im_rgb, 0,  100, ($redf) x 100);
  58
  59 Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
  60 test_colorf_glin($im_rgb, 0, 1,
  61                  ($redf) x 20, ($greenf) x 60, ($redf) x 20);
  62
  63 # basic OO tests
  64 my $ooimg = Imager->new(xsize=>200, ysize=>201, bits=>'double');
  65 ok($ooimg, "couldn't make double image");
  66 is($ooimg->bits, 'double', "oo didn't give double image");
  67
  68 # check that the image is copied correctly
  69 my $oocopy = $ooimg->copy;
  70 is($oocopy->bits, 'double', "oo copy didn't give double image");
  71
  72 ok(!Imager->new(xsize=>0, ysize=>1, bits=>'double'),
  73     "fail making 0 width image");
  74 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
  75        "and correct message");
  76 ok(!Imager->new(xsize=>1, ysize=>0, bits=>'double'),
  77     "fail making 0 height image");
  78 cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
  79        "and correct message");
  80 ok(!Imager->new(xsize=>-1, ysize=>1, bits=>'double'),
  81     "fail making -ve width 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 height 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', channels=>0),
  89     "fail making 0 channel image");
  90 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
  91        "and correct message");
  92 ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>5),
  93     "fail making 5 channel image");
  94 cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
  95        "and correct message");
  96
  97 {
  98   # https://rt.cpan.org/Ticket/Display.html?id=8213
  99   # check for handling of memory allocation of very large images
 100   # only test this on 32-bit machines - on a 64-bit machine it may
 101   # result in trying to allocate 4Gb of memory, which is unfriendly at
 102   # least and may result in running out of memory, causing a different
 103   # type of exit
 104   use Config;
 105   SKIP:
 106   {
 107     $Config{intsize} == 4
 108       or skip "don't want to allocate 4Gb", 8;
 109     my $uint_range = 256 ** $Config{intsize};
 110     my $dbl_size = $Config{doublesize} || 8;
 111     my $dim1 = int(sqrt($uint_range/$dbl_size))+1;
 112
 113     my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>'double');
 114     is($im_b, undef, "integer overflow check - 1 channel");
 115
 116     $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>'double');
 117     ok($im_b, "but same width ok");
 118     $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>'double');
 119     ok($im_b, "but same height ok");
 120     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 121            "check the error message");
 122
 123     # do a similar test with a 3 channel image, so we're sure we catch
 124     # the same case where the third dimension causes the overflow
 125     my $dim3 = int(sqrt($uint_range / 3 / $dbl_size))+1;
 126
 127     $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>'double');
 128     is($im_b, undef, "integer overflow check - 3 channel");
 129
 130     $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, bits=>'double');
 131     ok($im_b, "but same width ok");
 132     $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, bits=>'double');
 133     ok($im_b, "but same height ok");
 134
 135     cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
 136            "check the error message");
 137   }
 138 }
 139
 140 { # check the channel mask function
 141
 142   my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
 143
 144   mask_tests($im);
 145 }
 146
 147 { # bounds checking
 148   my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
 149   image_bounds_checks($im);
 150 }