1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
#!perl -w
use Imager qw(:all);
use strict;
use Test::More tests=>46;
use Imager::Test qw(is_color4 is_image);
init_log("testout/t108tga.log",1);
my $img = create_test_image();
my $base_diff = 0;
write_test($img, "testout/t108_24bit.tga", 0, 0, "");
write_test($img, "testout/t108_24bit_rle.tga", 0, 1, "");
write_test($img, "testout/t108_15bit.tga", 1, 1, "");
write_test($img, "testout/t108_15bit_rle.tga", 1, 1, "");
# 'webmap' is noticably faster than the default
my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
translate=>'errdiff'});
write_test($im8, "testout/t108_8bit.tga", 0, 0, "");
write_test($im8, "testout/t108_8bit_rle.tga", 0, 1, "");
write_test($im8, "testout/t108_8_15bit.tga", 1, 0, "");
write_test($im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
# use a fixed palette so we get reproducible results for the compressed
# version
my @bit4 = map { NC($_) }
qw(605844 966600 0148b2 00f800 bf0a33 5e009e
2ead1b 0000f8 004b01 fd0000 0e1695 000002);
my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
make_colors=>'none' });
my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
make_colors=>'none',
translate=>'errdiff' });
write_test($im4, "testout/t108_4bit.tga", 0, 1, "");
write_test($im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
read_test("testout/t108_24bit.tga", $img);
read_test("testout/t108_8bit.tga", $im8);
read_test("testout/t108_4bit.tga", $im4);
read_test("testout/t108_1bit.tga", $im1);
# the following might have slight differences
$base_diff = i_img_diff($img, $im8) * 2;
print "# base difference $base_diff\n";
my $imoo = Imager->new;
ok($imoo->read(file=>'testout/t108_24bit.tga'),
"OO read image")
or print "# ",$imoo->errstr,"\n";
ok($imoo->write(file=>'testout/t108_oo.tga'),
"OO write image")
or print "# ",$imoo->errstr,"\n";
my ($type) = $imoo->tags(name=>'i_format');
is($type, 'tga', "check i_format tag");
# in 0.44 and earlier, reading an image with an idstring of 128 or more
# bytes would result in an allocation error, if the platform char type
# was signed
$imoo = Imager->new;
ok($imoo->read(file=>'testimg/longid.tga'), "read long id image");
my ($id) = $imoo->tags(name=>'tga_idstring');
is($id, "X" x 128, "check tga_idstring tag");
my ($bitspp) = $imoo->tags(name=>'tga_bitspp');
is($bitspp, 24, "check tga_bitspp tag");
my ($compressed) = $imoo->tags(name=>'compressed');
is($compressed, 1, "check compressed tag");
{ # check file limits are checked
my $limit_file = "testout/t108_24bit.tga";
ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
my $im = Imager->new;
ok(!$im->read(file=>$limit_file),
"should fail read due to size limits");
print "# ",$im->errstr,"\n";
like($im->errstr, qr/image width/, "check message");
ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
ok(!$im->read(file=>$limit_file),
"should fail read due to size limits");
print "# ",$im->errstr,"\n";
like($im->errstr, qr/image height/, "check message");
ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
ok($im->read(file=>$limit_file),
"should succeed - just inside width limit");
ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
ok($im->read(file=>$limit_file),
"should succeed - just inside height limit");
# 150 x 150 x 3 channel image uses 67500 bytes
ok(Imager->set_file_limits(reset=>1, bytes=>67499),
"set bytes limit 67499");
ok(!$im->read(file=>$limit_file),
"should fail - too many bytes");
print "# ",$im->errstr,"\n";
like($im->errstr, qr/storage size/, "check error message");
ok(Imager->set_file_limits(reset=>1, bytes=>67500),
"set bytes limit 67500");
ok($im->read(file=>$limit_file),
"should succeed - just inside bytes limit");
Imager->set_file_limits(reset=>1);
}
{ # Issue # 18397
# the issue is for 4 channel images to jpeg, but 2 channel images have
# a similar problem on tga
my $im = Imager->new(xsize=>100, ysize=>100, channels => 2);
my $data;
ok(!$im->write(data => \$data, type=>'tga'),
"check failure of writing a 2 channel image");
is($im->errstr, "Cannot store 2 channel image in targa format",
"check the error message");
}
{
ok(grep($_ eq 'tga', Imager->read_types), "check tga in read types");
ok(grep($_ eq 'tga', Imager->write_types), "check tga in write types");
}
{ # Issue #32926
# a sample image was read as all transparent
# it had bitsperpixel = 16 and atribute channel set to 1, so it
# should have an alpha channel.
# So we'll do what the gimp does and treat a zero value as opaque.
my $im = Imager->new;
ok($im->read(file => 'testimg/alpha16.tga'),
"read 16-bit/pixel alpha image");
my $c1 = $im->getpixel('x' => 0, 'y' => 0);
is_color4($c1, 0, 0, 0, 0, "check transparent pixel");
my $c2 = $im->getpixel('x' => 19, 'y' => 0);
is_color4($c2, 255, 0, 0, 255, "check opaque pixel");
# since this has an effect on writing too, write,it, read it, check it
my $data;
ok($im->write(data => \$data, type => 'tga', wierdpack => 1),
"write 16-bit/pixel w/alpha");
my $im2 = Imager->new;
ok($im2->read(data => $data), "read it back");
is_image($im, $im2, "check they match");
}
sub write_test {
my ($im, $filename, $wierdpack, $compress, $idstring) = @_;
local *FH;
if (open FH, "> $filename") {
binmode FH;
my $IO = Imager::io_new_fd(fileno(FH));
ok(Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring),
"write $filename")
or print "# ",Imager->_error_as_msg(),"\n";
undef $IO;
close FH;
} else {
fail("write $filename: open failed: $!");
}
}
sub read_test {
my ($filename, $im, %tags) = @_;
local *FH;
if (open FH, "< $filename") {
binmode FH;
my $IO = Imager::io_new_fd(fileno(FH));
my $im_read = Imager::i_readtga_wiol($IO,-1);
if ($im_read) {
my $diff = i_img_diff($im, $im_read);
cmp_ok($diff, '<=', $base_diff,
"check read image vs original");
} else {
fail("read $filename ".Imager->_error_as_msg());
}
undef $IO;
close FH;
} else {
fail("read $filename, open failure: $!");
}
}
sub create_test_image {
my $green = i_color_new(0,255,0,255);
my $blue = i_color_new(0,0,255,255);
my $red = i_color_new(255,0,0,255);
my $img = Imager::ImgRaw::new(150,150,3);
i_box_filled($img, 70, 25, 130, 125, $green);
i_box_filled($img, 20, 25, 80, 125, $blue);
i_arc($img, 75, 75, 30, 0, 361, $red);
i_conv($img, [0.1, 0.2, 0.4, 0.2, 0.1]);
return $img;
}
|
