- start of external Imager API access:
[imager.git] / t / t022double.t
1 #!perl -w
2 use strict;
3 use lib 't';
4 use Test::More tests => 81;
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 is($oocopy->bits, '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 { # check the channel mask function
140   
141   my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
142
143   mask_tests($im);
144 }
145
146