t/t40scale.t

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