t/t40scale.t

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