convert scale.c to scale.im so we have 8 bit/sample and double/sample
[imager.git] / t / t40scale.t
1 #!perl -w
2 use strict;
3 use lib 't';
4 use Test::More tests => 223;
5
6 BEGIN { use_ok(Imager=>':all') }
7
8 require "t/testtools.pl";
9
10 Imager::init('log'=>'testout/t40scale.log');
11 my $img=Imager->new();
12
13 ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'),
14    "load test image") or print "# ",$img->errstr,"\n";
15
16 my $scaleimg=$img->scale(scalefactor=>0.25)
17   or print "# ",$img->errstr,"\n";
18 ok($scaleimg, "scale it (good mode)");
19
20 ok($scaleimg->write(file=>'testout/t40scale1.ppm',type=>'pnm'),
21    "save scaled image") or print "# ",$img->errstr,"\n";
22
23 $scaleimg=$img->scale(scalefactor=>0.25,qtype=>'preview');
24 ok($scaleimg, "scale it (preview)") or print "# ",$img->errstr,"\n";
25
26 ok($scaleimg->write(file=>'testout/t40scale2.ppm',type=>'pnm'),
27    "write preview scaled image")  or print "# ",$img->errstr,"\n";
28
29 $scaleimg = $img->scale(scalefactor => 0.25, qtype => 'mixing');
30 ok($scaleimg, "scale it (mixing)") or print "# ", $img->errstr, "\n";
31 ok($scaleimg->write(file=>'testout/t40scale3.ppm', type=>'pnm'),
32    "write mixing scaled image") or print "# ", $img->errstr, "\n";
33
34 { # double image scaling with mixing, since it has code to handle it
35   my $dimg = Imager->new(xsize => $img->getwidth, ysize => $img->getheight,
36                          channels => $img->getchannels,
37                          bits => 'double');
38   ok($dimg, "create double/sample image");
39   $dimg->paste(src => $img);
40   $scaleimg = $dimg->scale(scalefactor => 0.25, qtype => 'mixing');
41   ok($scaleimg, "scale it (mixing, double)");
42   ok($scaleimg->write(file => 'testout/t40mixdbl.ppm', type => 'pnm'),
43      "write double/mixing scaled image");
44   is($scaleimg->bits, 'double', "got the right image type as output");
45
46   # hscale only, mixing
47   $scaleimg = $dimg->scale(xscalefactor => 0.33, yscalefactor => 1.0,
48                            qtype => 'mixing');
49   ok($scaleimg, "scale it (hscale, mixing, double)");
50   is($scaleimg->getheight, $dimg->getheight, "same height");
51   ok($scaleimg->write(file => 'testout/t40hscdmix.ppm', type => 'pnm'),
52      "save it");
53
54   # vscale only, mixing
55   $scaleimg = $dimg->scale(xscalefactor => 1.0, yscalefactor => 0.33,
56                            qtype => 'mixing');
57   ok($scaleimg, "scale it (vscale, mixing, double)");
58   is($scaleimg->getwidth, $dimg->getwidth, "same width");
59   ok($scaleimg->write(file => 'testout/t40vscdmix.ppm', type => 'pnm'),
60      "save it");
61 }
62
63 {
64   # check for a warning when scale() is called in void context
65   my $warning;
66   local $SIG{__WARN__} = 
67     sub { 
68       $warning = "@_";
69       my $printed = $warning;
70       $printed =~ s/\n$//;
71       $printed =~ s/\n/\n\#/g; 
72       print "# ",$printed, "\n";
73     };
74   $img->scale(scalefactor=>0.25);
75   cmp_ok($warning, '=~', qr/void/, "check warning");
76   cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
77   $warning = '';
78   $img->scaleX(scalefactor=>0.25);
79   cmp_ok($warning, '=~', qr/void/, "check warning");
80   cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
81   $warning = '';
82   $img->scaleY(scalefactor=>0.25);
83   cmp_ok($warning, '=~', qr/void/, "check warning");
84   cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
85 }
86 { # https://rt.cpan.org/Ticket/Display.html?id=7467
87   # segfault in Imager 0.43
88   # make sure scale() doesn't let us make an image zero pixels high or wide
89   # it does this by making the given axis as least 1 pixel high
90   my $out = $img->scale(scalefactor=>0.00001);
91   is($out->getwidth, 1, "min scale width");
92   is($out->getheight, 1, "min scale height");
93
94   $out = $img->scale(scalefactor=>0.00001, qtype => 'preview');
95   is($out->getwidth, 1, "min scale width (preview)");
96   is($out->getheight, 1, "min scale height (preview)");
97
98   $out = $img->scale(scalefactor=>0.00001, qtype => 'mixing');
99   is($out->getwidth, 1, "min scale width (mixing)");
100   is($out->getheight, 1, "min scale height (mixing)");
101 }
102
103 { # error handling - NULL image
104   my $im = Imager->new;
105   ok(!$im->scale(scalefactor => 0.5), "try to scale empty image");
106   is($im->errstr, "empty input image", "check error message");
107
108   # scaleX/scaleY
109   ok(!$im->scaleX(scalefactor => 0.5), "try to scaleX empty image");
110   is($im->errstr, "empty input image", "check error message");
111   ok(!$im->scaleY(scalefactor => 0.5), "try to scaleY empty image");
112   is($im->errstr, "empty input image", "check error message");
113 }
114
115 { # invalid qtype value
116   my $im = Imager->new(xsize => 100, ysize => 100);
117   ok(!$im->scale(scalefactor => 0.5, qtype=>'unknown'), "unknown qtype");
118   is($im->errstr, "invalid value for qtype parameter", "check error message");
119   
120   # invalid type value
121   ok(!$im->scale(xpixels => 10, ypixels=>50, type=>"unknown"), "unknown type");
122   is($im->errstr, "invalid value for type parameter", "check error message");
123 }
124
125 SKIP:
126 { # Image::Math::Constrain support
127   eval "require Image::Math::Constrain;";
128   $@ and skip "optional module Image::Math::Constrain not installed", 3;
129   my $constrain = Image::Math::Constrain->new(20, 100);
130   my $im = Imager->new(xsize => 160, ysize => 96);
131   my $result = $im->scale(constrain => $constrain);
132   ok($result, "successful scale with Image::Math::Constrain");
133   is($result->getwidth, 20, "check result width");
134   is($result->getheight, 12, "check result height");
135 }
136
137 { # scale size checks
138   my $im = Imager->new(xsize => 160, ysize => 96); # some random size
139
140   scale_test($im, 'scale', 80, 48, "48 x 48 def type",
141              xpixels => 48, ypixels => 48);
142   scale_test($im, 'scale', 80, 48, "48 x 48 max type",
143              xpixels => 48, ypixels => 48, type => 'max');
144   scale_test($im, 'scale', 80, 48, "80 x 80 min type",
145              xpixels => 80, ypixels => 80, type => 'min');
146   scale_test($im, 'scale', 80, 48, "no scale parameters (default to 0.5 scalefactor)");
147   scale_test($im, 'scale', 120, 72, "0.75 scalefactor",
148              scalefactor => 0.75);
149   scale_test($im, 'scale', 80, 48, "80 width",
150              xpixels => 80);
151   scale_test($im, 'scale', 120, 72, "72 height",
152              ypixels => 72);
153
154   # new scaling parameters in 0.54
155   scale_test($im, 'scale', 80, 48, "xscale 0.5",
156              xscalefactor => 0.5);
157   scale_test($im, 'scale', 80, 48, "yscale 0.5",
158              yscalefactor => 0.5);
159   scale_test($im, 'scale', 40, 48, "xscale 0.25 yscale 0.5",
160              xscalefactor => 0.25, yscalefactor => 0.5);
161   scale_test($im, 'scale', 160, 48, "xscale 1.0 yscale 0.5",
162              xscalefactor => 1.0, yscalefactor => 0.5);
163   scale_test($im, 'scale', 160, 48, "xpixels 160 ypixels 48 type nonprop",
164              xpixels => 160, ypixels => 48, type => 'nonprop');
165   scale_test($im, 'scale', 160, 96, "xpixels 160 ypixels 96",
166              xpixels => 160, ypixels => 96);
167   scale_test($im, 'scale', 80, 96, "xpixels 80 ypixels 96 type nonprop",
168              xpixels => 80, ypixels => 96, type => 'nonprop');
169
170   # scaleX
171   scale_test($im, 'scaleX', 80, 96, "defaults");
172   scale_test($im, 'scaleX', 40, 96, "0.25 scalefactor",
173              scalefactor => 0.25);
174   scale_test($im, 'scaleX', 120, 96, "pixels 120",
175              pixels => 120);
176
177   # scaleY
178   scale_test($im, 'scaleY', 160, 48, "defaults");
179   scale_test($im, 'scaleY', 160, 192, "2.0 scalefactor",
180              scalefactor => 2.0);
181   scale_test($im, 'scaleY', 160, 144, "pixels 144",
182              pixels => 144);
183 }
184
185 sub scale_test {
186   my ($in, $method, $exp_width, $exp_height, $note, @parms) = @_;
187
188   print "# $note: @parms\n";
189   for my $qtype (qw(normal preview mixing)) {
190   SKIP:
191     {
192       my $scaled = $in->$method(@parms, qtype => $qtype);
193       ok($scaled, "$method $note qtype $qtype")
194         or skip("failed to scale", 2);
195       is($scaled->getwidth, $exp_width, "check width");
196       is($scaled->getheight, $exp_height, "check height");
197     }
198   }
199 }