t/t40scale.t

   1 #!perl -w
   2 use strict;
   3 use lib 't';
   4 use Test::More tests => 16;
   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 }