t/t40scale.t

   1 #!perl -w
   2 use strict;
   3 use lib 't';
   4 use Test::More tests => 68;
   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 {
  30   # check for a warning when scale() is called in void context
  31   my $warning;
  32   local $SIG{__WARN__} =
  33     sub {
  34       $warning = "@_";
  35       my $printed = $warning;
  36       $printed =~ s/\n$//;
  37       $printed =~ s/\n/\n\#/g;
  38       print "# ",$printed, "\n";
  39     };
  40   $img->scale(scalefactor=>0.25);
  41   cmp_ok($warning, '=~', qr/void/, "check warning");
  42   cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
  43   $warning = '';
  44   $img->scaleX(scalefactor=>0.25);
  45   cmp_ok($warning, '=~', qr/void/, "check warning");
  46   cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
  47   $warning = '';
  48   $img->scaleY(scalefactor=>0.25);
  49   cmp_ok($warning, '=~', qr/void/, "check warning");
  50   cmp_ok($warning, '=~', qr/t40scale\.t/, "check filename");
  51 }
  52 { # https://rt.cpan.org/Ticket/Display.html?id=7467
  53   # segfault in Imager 0.43
  54   # make sure scale() doesn't let us make an image zero pixels high or wide
  55   # it does this by making the given axis as least 1 pixel high
  56   my $out = $img->scale(scalefactor=>0.00001);
  57   is($out->getwidth, 1, "min scale width");
  58   is($out->getheight, 1, "min scale height");
  59
  60   $out = $img->scale(scalefactor=>0.00001, qtype => 'preview');
  61   is($out->getwidth, 1, "min scale width (preview)");
  62   is($out->getheight, 1, "min scale height (preview)");
  63 }
  64
  65 { # error handling - NULL image
  66   my $im = Imager->new;
  67   ok(!$im->scale(scalefactor => 0.5), "try to scale empty image");
  68   is($im->errstr, "empty input image", "check error message");
  69
  70   # scaleX/scaleY
  71   ok(!$im->scaleX(scalefactor => 0.5), "try to scaleX empty image");
  72   is($im->errstr, "empty input image", "check error message");
  73   ok(!$im->scaleY(scalefactor => 0.5), "try to scaleY empty image");
  74   is($im->errstr, "empty input image", "check error message");
  75 }
  76
  77 { # invalid qtype value
  78   my $im = Imager->new(xsize => 100, ysize => 100);
  79   ok(!$im->scale(scalefactor => 0.5, qtype=>'unknown'), "unknown qtype");
  80   is($im->errstr, "invalid value for qtype parameter", "check error message");
  81
  82   # invalid type value
  83   ok(!$im->scale(xpixels => 10, ypixels=>50, type=>"unknown"), "unknown type");
  84   is($im->errstr, "invalid value for type parameter", "check error message");
  85 }
  86
  87 SKIP:
  88 { # Image::Math::Constrain support
  89   eval "require Image::Math::Constrain;";
  90   $@ and skip "optional module Image::Math::Constrain not installed", 3;
  91   my $constrain = Image::Math::Constrain->new(20, 100);
  92   my $im = Imager->new(xsize => 160, ysize => 96);
  93   my $result = $im->scale(constrain => $constrain);
  94   ok($result, "successful scale with Image::Math::Constrain");
  95   is($result->getwidth, 20, "check result width");
  96   is($result->getheight, 12, "check result height");
  97 }
  98
  99 { # scale size checks
 100   my $im = Imager->new(xsize => 160, ysize => 96); # some random size
 101
 102   scale_test($im, 'scale', 80, 48, "48 x 48 def type",
 103              xpixels => 48, ypixels => 48);
 104   scale_test($im, 'scale', 80, 48, "48 x 48 max type",
 105              xpixels => 48, ypixels => 48, type => 'max');
 106   scale_test($im, 'scale', 80, 48, "80 x 80 min type",
 107              xpixels => 80, ypixels => 80, type => 'min');
 108   scale_test($im, 'scale', 80, 48, "no scale parameters (default to 0.5 scalefactor)");
 109   scale_test($im, 'scale', 120, 72, "0.75 scalefactor",
 110              scalefactor => 0.75);
 111   scale_test($im, 'scale', 80, 48, "80 width",
 112              xpixels => 80);
 113   scale_test($im, 'scale', 120, 72, "72 height",
 114              ypixels => 72);
 115
 116   # scaleX
 117   scale_test($im, 'scaleX', 80, 96, "defaults");
 118   scale_test($im, 'scaleX', 40, 96, "0.25 scalefactor",
 119              scalefactor => 0.25);
 120   scale_test($im, 'scaleX', 120, 96, "pixels 120",
 121              pixels => 120);
 122
 123   # scaleY
 124   scale_test($im, 'scaleY', 160, 48, "defaults");
 125   scale_test($im, 'scaleY', 160, 192, "2.0 scalefactor",
 126              scalefactor => 2.0);
 127   scale_test($im, 'scaleY', 160, 144, "pixels 144",
 128              pixels => 144);
 129 }
 130
 131 sub scale_test {
 132   my ($in, $method, $exp_width, $exp_height, $note, @parms) = @_;
 133
 134   print "# $note: @parms\n";
 135  SKIP:
 136   {
 137     my $scaled = $in->$method(@parms);
 138     ok($scaled, "$method $note")
 139       or skip("failed to scale", 2);
 140     is($scaled->getwidth, $exp_width, "check width");
 141     is($scaled->getheight, $exp_height, "check height");
 142   }
 143 }