t/t67convert.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:all :handy);
   4 use lib 't';
   5 use Test::More tests=>19;
   6
   7 Imager::init("log"=>'testout/t67convert.log');
   8
   9 my $imbase = Imager::ImgRaw::new(200,300,3);
  10
  11 # first a basic test, make sure the basic things happen ok
  12 # make a 1 channel image from the above (black) image
  13 # but with 1 as the 'extra' value
  14 my $imnew = Imager::i_img_new();
  15 SKIP:
  16 {
  17   skip("convert to white failed", 3)
  18     unless ok(i_convert($imnew, $imbase, [ [ 0, 0, 0, 1 ] ]), "convert to white");
  19
  20   my ($w, $h, $ch) = i_img_info($imnew);
  21
  22   # the output image should now have one channel
  23   is($ch, 1, "one channel image now");
  24   # should have the same width and height
  25   ok($w == 200 && $h == 300, "check converted size is the same");
  26
  27   # should be a white image now, let's check
  28   my $c = Imager::i_get_pixel($imnew, 20, 20);
  29   my @c = $c->rgba;
  30   print "# @c\n";
  31   is($c[0], 255, "check image is white");
  32 }
  33
  34 # test the highlevel interface
  35 # currently this requires visual inspection of the output files
  36 my $im = Imager->new;
  37 SKIP:
  38 {
  39   skip("could not load scale.ppm", 3)
  40     unless $im->read(file=>'testimg/scale.ppm');
  41   my $out = $im->convert(preset=>'gray');
  42   ok($out, "convert preset gray");
  43   ok($out->write(file=>'testout/t67_gray.ppm', type=>'pnm'),
  44     "save grey image");
  45   $out = $im->convert(preset=>'blue');
  46   ok($out, "convert preset blue");
  47
  48   ok($out->write(file=>'testout/t67_blue.ppm', type=>'pnm'),
  49      "save blue image");
  50 }
  51
  52 # test against 16-bit/sample images
  53 my $im16targ = Imager::i_img_16_new(200, 300, 3);
  54 SKIP:
  55 {
  56   skip("could not convert 16-bit image", 2)
  57     unless ok(i_convert($im16targ, $imbase, [ [ 0, 0, 0, 1 ],
  58                                               [ 0, 0, 0, 0 ],
  59                                               [ 0, 0, 0, 0 ] ]),
  60               "convert 16/bit sample image");
  61   # image should still be 16-bit
  62   is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");
  63   # make sure that it's roughly red
  64   my $c = Imager::i_gpixf($im16targ, 0, 0);
  65   my @ch = $c->rgba;
  66   ok(abs($ch[0] - 1) <= 0.0001 && abs($ch[1]) <= 0.0001 && abs($ch[2]) <= 0.0001,
  67      "image roughly red");
  68 }
  69
  70 # test against palette based images
  71 my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
  72 my $black = NC(0, 0, 0);
  73 my $blackindex = Imager::i_addcolors($impal, $black);
  74 ok($blackindex, "add black to paletted");
  75 for my $y (0..299) {
  76   Imager::i_ppal($impal, 0, $y, ($black) x 200);
  77 }
  78 my $impalout = Imager::i_img_pal_new(200, 300, 3, 256);
  79 SKIP:
  80 {
  81   skip("could not convert paletted", 3)
  82     unless ok(i_convert($impalout, $impal, [ [ 0, 0, 0, 0 ],
  83                                    [ 0, 0, 0, 1 ],
  84                                    [ 0, 0, 0, 0 ] ]),
  85              "convert paletted");
  86   is(Imager::i_img_type($impalout), 1, "image still paletted");
  87   is(Imager::i_colorcount($impalout), 1, "still only one colour");
  88   my $c = Imager::i_getcolors($impalout, $blackindex);
  89   ok($c, "get color from palette");
  90   my @ch = $c->rgba;
  91   print "# @ch\n";
  92   ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0,
  93      "colour is as expected");
  94 }
  95
  96 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
  97   my $warning;
  98   local $SIG{__WARN__} =
  99     sub {
 100       $warning = "@_";
 101       my $printed = $warning;
 102       $printed =~ s/\n$//;
 103       $printed =~ s/\n/\n\#/g;
 104       print "# ",$printed, "\n";
 105     };
 106   my $img = Imager->new(xsize=>10, ysize=>10);
 107   $img->convert(preset=>"grey");
 108   cmp_ok($warning, '=~', 'void', "correct warning");
 109   cmp_ok($warning, '=~', 't67convert\\.t', "correct file");
 110 }