Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

file 142 lines (124 sloc) 4.555 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
#!perl -w
use strict;
use Imager qw(:all :handy);
use Test::More tests => 27;
use Imager::Test qw(test_colorf_gpix is_fcolor1 is_fcolor3);

-d "testout" or mkdir "testout";

Imager::init("log"=>'testout/t67convert.log');

my $imbase = Imager::ImgRaw::new(200,300,3);

# first a basic test, make sure the basic things happen ok
# make a 1 channel image from the above (black) image
# but with 1 as the 'extra' value
SKIP:
{
  my $im_white = i_convert($imbase, [ [ 0, 0, 0, 1 ] ]);
  skip("convert to white failed", 3)
    unless ok($im_white, "convert to white");

  my ($w, $h, $ch) = i_img_info($im_white);

  # the output image should now have one channel
  is($ch, 1, "one channel image now");
  # should have the same width and height
  ok($w == 200 && $h == 300, "check converted size is the same");

  # should be a white image now, let's check
  my $c = Imager::i_get_pixel($im_white, 20, 20);
  my @c = $c->rgba;
  print "# @c\n";
  is($c[0], 255, "check image is white");
}

# test the highlevel interface
# currently this requires visual inspection of the output files
my $im = Imager->new;
SKIP:
{
  skip("could not load scale.ppm", 3)
    unless $im->read(file=>'testimg/scale.ppm');
  my $out = $im->convert(preset=>'gray');
  ok($out, "convert preset gray");
  ok($out->write(file=>'testout/t67_gray.ppm', type=>'pnm'),
    "save grey image");
  $out = $im->convert(preset=>'blue');
  ok($out, "convert preset blue");

  ok($out->write(file=>'testout/t67_blue.ppm', type=>'pnm'),
     "save blue image");
}

# test against 16-bit/sample images
{
 SKIP:
  {
    my $imbase16 = Imager::i_img_16_new(200, 200, 3);

    my $im16targ = i_convert($imbase16, [ [ 0, 0, 0, 1 ],
[ 0, 0, 0, 0 ],
[ 0, 0, 0, 0 ] ]);
    ok($im16targ, "convert 16/bit sample image")
      or skip("could not convert 16-bit image", 2);

    # image should still be 16-bit
    is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");

    # make sure that it's roughly red
    test_colorf_gpix($im16targ, 0, 0, NCF(1, 0, 0), 0.001, "image roughly red");
  }
 SKIP:
  {
    my $imbase16 = Imager->new(xsize => 10, ysize => 10, bits => 16);
    ok($imbase16->setpixel
       (x => 5, y => 2, color => Imager::Color::Float->new(0.1, 0.2, 0.3)),
       "set a sample pixel");
    my $c1 = $imbase16->getpixel(x => 5, y => 2, type => "float");
    is_fcolor3($c1, 0.1, 0.2, 0.3, "check it was set")
      or print "#", join(",", $c1->rgba), "\n";
    
    my $targ16 = $imbase16->convert(matrix => [ [ 0.05, 0.15, 0.01, 0.5 ] ]);
    ok($targ16, "convert another 16/bit sample image")
      or skip("could not convert", 3);
    is($targ16->getchannels, 1, "convert should be 1 channel");
    is($targ16->bits, 16, "and 16-bits");
    my $c = $targ16->getpixel(x => 5, y => 2, type => "float");
    is_fcolor1($c, 0.538, 1/32768, "check grey value");
  }
}

# test against palette based images
my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
my $black = NC(0, 0, 0);
my $blackindex = Imager::i_addcolors($impal, $black);
ok($blackindex, "add black to paletted");
for my $y (0..299) {
  Imager::i_ppal($impal, 0, $y, ($blackindex) x 200);
}

SKIP:
{
  my $impalout = i_convert($impal, [ [ 0, 0, 0, 0 ],
[ 0, 0, 0, 1 ],
[ 0, 0, 0, 0 ] ]);
  skip("could not convert paletted", 3)
    unless ok($impalout, "convert paletted");
  is(Imager::i_img_type($impalout), 1, "image still paletted");
  is(Imager::i_colorcount($impalout), 1, "still only one colour");
  my $c = Imager::i_getcolors($impalout, $blackindex);
  ok($c, "get color from palette");
  my @ch = $c->rgba;
  print "# @ch\n";
  ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0,
     "colour is as expected");
}

{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
  # methods that return a new image should warn in void context
  my $warning;
  local $SIG{__WARN__} =
    sub {
      $warning = "@_";
      my $printed = $warning;
      $printed =~ s/\n$//;
      $printed =~ s/\n/\n\#/g;
      print "# ",$printed, "\n";
    };
  my $img = Imager->new(xsize=>10, ysize=>10);
  $img->convert(preset=>"grey");
  cmp_ok($warning, '=~', 'void', "correct warning");
  cmp_ok($warning, '=~', 't67convert\\.t', "correct file");
}

{ # http://rt.cpan.org/NoAuth/Bug.html?id=28492
  # convert() doesn't preserve image sample size
  my $im = Imager->new(xsize => 20, ysize => 20, channels => 3,
bits => 'double');
  is($im->bits, 'double', 'check source bits');
  my $conv = $im->convert(preset => 'grey');
  is($conv->bits, 'double', 'make sure result has extra bits');
}
Something went wrong with that request. Please try again.