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
|
#!perl -w
use strict;
use Test::More tests => 34;
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
use lib qw(blib/lib blib/arch);
BEGIN { use_ok('Imager', ':all') }
init_log("testout/t102png.log",1);
i_has_format("png") && print "# has png\n";
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]);
my $timg = Imager::ImgRaw::new(20, 20, 4);
my $trans = i_color_new(255, 0, 0, 127);
i_box_filled($timg, 0, 0, 20, 20, $green);
i_box_filled($timg, 2, 2, 18, 18, $trans);
if (!i_has_format("png")) {
SKIP:
{
my $im = Imager->new;
ok(!$im->read(file=>"testimg/palette.png"), "should fail to read png");
cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
$im = Imager->new(xsize=>2, ysize=>2);
ok(!$im->write(file=>"testout/nopng.png"), "should fail to write png");
cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
ok(!grep($_ eq 'png', Imager->read_types), "check png not in read types");
ok(!grep($_ eq 'png', Imager->write_types), "check png not in write types");
skip("no png support", 27);
}
} else {
Imager::i_tags_add($img, "i_xres", 0, "300", 0);
Imager::i_tags_add($img, "i_yres", 0, undef, 200);
# the following confuses the GIMP
#Imager::i_tags_add($img, "i_aspect_only", 0, undef, 1);
open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
binmode(FH);
my $IO = Imager::io_new_fd(fileno(FH));
ok(i_writepng_wiol($img, $IO), "write");
close(FH);
open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
my $cmpimg = i_readpng_wiol($IO, -1);
close(FH);
ok($cmpimg, "read png");
print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
my %tags = map { Imager::i_tags_get($cmpimg, $_) }
0..Imager::i_tags_count($cmpimg) - 1;
ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
is($tags{i_format}, "png", "i_format: $tags{i_format}");
open FH, "> testout/t102_trans.png"
or die "Cannot open testout/t102_trans.png: $!";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
ok(i_writepng_wiol($timg, $IO), "write tranparent");
close FH;
open FH,"testout/t102_trans.png"
or die "cannot open testout/t102_trans.png\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
$cmpimg = i_readpng_wiol($IO, -1);
ok($cmpimg, "read transparent");
close(FH);
print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
# REGRESSION TEST
# png.c 1.1 would produce an incorrect image when loading images with
# less than 8 bits/pixel with a transparent palette entry
open FH, "< testimg/palette.png"
or die "cannot open testimg/palette.png: $!\n";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
# 1.1 may segfault here (it does with libefence)
my $pimg = i_readpng_wiol($IO,-1);
ok($pimg, "read transparent paletted image");
close FH;
open FH, "< testimg/palette_out.png"
or die "cannot open testimg/palette_out.png: $!\n";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
my $poimg = i_readpng_wiol($IO, -1);
ok($poimg, "read palette_out image");
close FH;
if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
print <<EOS;
# this tests a bug in Imager's png.c v1.1
# if also tickles a bug in libpng before 1.0.5, so you may need to
# upgrade libpng
EOS
}
{ # check file limits are checked
my $limit_file = "testout/t102.png";
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);
}
{ # check if the read_multi fallback works
my @imgs = Imager->read_multi(file => 'testout/t102.png');
is(@imgs, 1, "check the image was loaded");
is(i_img_diff($img, $imgs[0]), 0, "check image matches");
# check the write_multi fallback
ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
@imgs),
'test write_multi() callback');
# check that we fail if we actually write 2
ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
@imgs, @imgs),
'test write_multi() callback failure');
}
{
ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
}
}
|
