t/t67convert.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:all :handy);
   4 use Test::More tests => 27;
   5 use Imager::Test qw(test_colorf_gpix is_fcolor1 is_fcolor3);
   6
   7 -d "testout" or mkdir "testout";
   8
   9 Imager::init("log"=>'testout/t67convert.log');
  10
  11 my $imbase = Imager::ImgRaw::new(200,300,3);
  12
  13 # first a basic test, make sure the basic things happen ok
  14 # make a 1 channel image from the above (black) image
  15 # but with 1 as the 'extra' value
  16 SKIP:
  17 {
  18   my $im_white = i_convert($imbase, [ [ 0, 0, 0, 1 ] ]);
  19   skip("convert to white failed", 3)
  20     unless ok($im_white, "convert to white");
  21
  22   my ($w, $h, $ch) = i_img_info($im_white);
  23
  24   # the output image should now have one channel
  25   is($ch, 1, "one channel image now");
  26   # should have the same width and height
  27   ok($w == 200 && $h == 300, "check converted size is the same");
  28
  29   # should be a white image now, let's check
  30   my $c = Imager::i_get_pixel($im_white, 20, 20);
  31   my @c = $c->rgba;
  32   print "# @c\n";
  33   is($c[0], 255, "check image is white");
  34 }
  35
  36 # test the highlevel interface
  37 # currently this requires visual inspection of the output files
  38 my $im = Imager->new;
  39 SKIP:
  40 {
  41   skip("could not load scale.ppm", 3)
  42     unless $im->read(file=>'testimg/scale.ppm');
  43   my $out = $im->convert(preset=>'gray');
  44   ok($out, "convert preset gray");
  45   ok($out->write(file=>'testout/t67_gray.ppm', type=>'pnm'),
  46     "save grey image");
  47   $out = $im->convert(preset=>'blue');
  48   ok($out, "convert preset blue");
  49
  50   ok($out->write(file=>'testout/t67_blue.ppm', type=>'pnm'),
  51      "save blue image");
  52 }
  53
  54 # test against 16-bit/sample images
  55 {
  56  SKIP:
  57   {
  58     my $imbase16 = Imager::i_img_16_new(200, 200, 3);
  59
  60     my $im16targ = i_convert($imbase16, [ [ 0, 0, 0, 1 ],
  61                                           [ 0, 0, 0, 0 ],
  62                                           [ 0, 0, 0, 0 ] ]);
  63     ok($im16targ, "convert 16/bit sample image")
  64       or skip("could not convert 16-bit image", 2);
  65
  66     # image should still be 16-bit
  67     is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");
  68
  69     # make sure that it's roughly red
  70     test_colorf_gpix($im16targ, 0, 0, NCF(1, 0, 0), 0.001, "image roughly red");
  71   }
  72  SKIP:
  73   {
  74     my $imbase16 = Imager->new(xsize => 10, ysize => 10, bits => 16);
  75     ok($imbase16->setpixel
  76        (x => 5, y => 2, color => Imager::Color::Float->new(0.1, 0.2, 0.3)),
  77        "set a sample pixel");
  78     my $c1 = $imbase16->getpixel(x => 5, y => 2, type => "float");
  79     is_fcolor3($c1, 0.1, 0.2, 0.3, "check it was set")
  80       or print "#", join(",", $c1->rgba), "\n";
  81
  82     my $targ16 = $imbase16->convert(matrix => [ [ 0.05, 0.15, 0.01, 0.5 ] ]);
  83     ok($targ16, "convert another 16/bit sample image")
  84       or skip("could not convert", 3);
  85     is($targ16->getchannels, 1, "convert should be 1 channel");
  86     is($targ16->bits, 16, "and 16-bits");
  87     my $c = $targ16->getpixel(x => 5, y => 2, type => "float");
  88     is_fcolor1($c, 0.538, 1/32768, "check grey value");
  89   }
  90 }
  91
  92 # test against palette based images
  93 my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
  94 my $black = NC(0, 0, 0);
  95 my $blackindex = Imager::i_addcolors($impal, $black);
  96 ok($blackindex, "add black to paletted");
  97 for my $y (0..299) {
  98   Imager::i_ppal($impal, 0, $y, ($blackindex) x 200);
  99 }
 100
 101 SKIP:
 102 {
 103   my $impalout = i_convert($impal, [ [ 0, 0, 0, 0 ],
 104                                      [ 0, 0, 0, 1 ],
 105                                      [ 0, 0, 0, 0 ] ]);
 106   skip("could not convert paletted", 3)
 107     unless ok($impalout, "convert paletted");
 108   is(Imager::i_img_type($impalout), 1, "image still paletted");
 109   is(Imager::i_colorcount($impalout), 1, "still only one colour");
 110   my $c = Imager::i_getcolors($impalout, $blackindex);
 111   ok($c, "get color from palette");
 112   my @ch = $c->rgba;
 113   print "# @ch\n";
 114   ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0,
 115      "colour is as expected");
 116 }
 117
 118 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
 119   # methods that return a new image should warn in void context
 120   my $warning;
 121   local $SIG{__WARN__} =
 122     sub {
 123       $warning = "@_";
 124       my $printed = $warning;
 125       $printed =~ s/\n$//;
 126       $printed =~ s/\n/\n\#/g;
 127       print "# ",$printed, "\n";
 128     };
 129   my $img = Imager->new(xsize=>10, ysize=>10);
 130   $img->convert(preset=>"grey");
 131   cmp_ok($warning, '=~', 'void', "correct warning");
 132   cmp_ok($warning, '=~', 't67convert\\.t', "correct file");
 133 }
 134
 135 { # http://rt.cpan.org/NoAuth/Bug.html?id=28492
 136   # convert() doesn't preserve image sample size
 137   my $im = Imager->new(xsize => 20, ysize => 20, channels => 3,
 138                        bits => 'double');
 139   is($im->bits, 'double', 'check source bits');
 140   my $conv = $im->convert(preset => 'grey');
 141   is($conv->bits, 'double', 'make sure result has extra bits');
 142 }