t/t022double.t

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