t/t022double.t

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