view release on metacpan or  search on metacpan

lib/Imager/Test.pm  view on Meta::CPAN

  my $builder = Test::Builder->new;
  
  my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
  @got == @$pels
    or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
  
  return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
     "$comment - check colors ($x, $y)");
}

sub colorf_cmp {
  my ($c1, $c2, $epsilon) = @_;

  defined $epsilon or $epsilon = 0;

  my @s1 = $c1->rgba;
  my @s2 = $c2->rgba;

  # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
  return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0] 
    || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
      || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
}

sub color_cmp {
  my ($c1, $c2) = @_;

  my @s1 = $c1->rgba;
  my @s2 = $c2->rgba;

  return $s1[0] <=> $s2[0] 
    || $s1[1] <=> $s2[1]
      || $s1[2] <=> $s2[2];
}

# these test the action of the channel mask on the image supplied
# which should be an OO image.
sub mask_tests {
  my ($im, $epsilon) = @_;

  no if $] >= 5.014, warnings => 'Imager::channelmask';
  my $builder = Test::Builder->new;

  defined $epsilon or $epsilon = 0;

  # we want to check all four of ppix() and plin(), ppix() and plinf()
  # basic test procedure:
  #   first using default/all 1s mask, set to white
  #   make sure we got white
  #   set mask to skip a channel, set to grey
  #   make sure only the right channels set

  print "# channel mask tests\n";
  # 8-bit color tests
  my $white = Imager::NC(255, 255, 255);
  my $grey = Imager::NC(128, 128, 128);
  my $white_grey = Imager::NC(128, 255, 128);

  print "# with ppix\n";
  $builder->ok($im->setmask(mask=>~0), "set to default mask");
  $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
  test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
  $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
  test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");

  print "# with plin\n";
  $builder->ok($im->setmask(mask=>~0), "set to default mask");
  $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]), 
     "set to white all channels");
  test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
  $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]), 
     "set to grey, no channel 2");
  test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");

  # float color tests
  my $whitef = Imager::NCF(1.0, 1.0, 1.0);
  my $greyf = Imager::NCF(0.5, 0.5, 0.5);
  my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);

  print "# with ppixf\n";
  $builder->ok($im->setmask(mask=>~0), "set to default mask");
  $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
  test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
  $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
  test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");

  print "# with plinf\n";
  $builder->ok($im->setmask(mask=>~0), "set to default mask");
  $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]), 
     "set to white all channels");
  test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
  $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]), 
     "set to grey, no channel 2");
  test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");

}

sub std_font_test_count {
  return 21;
}

sub std_font_tests {
  my ($opts) = @_;

  my $font = $opts->{font}
    or carp "Missing font parameter";

  my $name_font = $opts->{glyph_name_font} || $font;

  my $has_chars = $opts->{has_chars} || [ 1, '', 1 ];

  my $glyph_names = $opts->{glyph_names} || [ "A", undef, "A" ];

 SKIP:
  { # check magic is handled correctly
    # https://rt.cpan.org/Ticket/Display.html?id=83438
    skip("no native UTF8 support in this version of perl", 11) 
      unless $] >= 5.006;
    skip("overloading handling of magic is broken in this version of perl", 11)
      unless $] >= 5.008;
    Imager->log("utf8 magic tests\n");
    my $over = bless {}, "Imager::Test::OverUtf8";
    my $text = "A".chr(0x2010)."A";
    my $white = Imager::Color->new("#FFF");
    my $base_draw = Imager->new(xsize => 80, ysize => 20);
    ok($base_draw->string(font => $font,
			  text => $text,
			  x => 2,
			  y => 18,
			  size => 15,
			  color => $white,
			  aa => 1),
       "magic: make a base image");
    my $test_draw = Imager->new(xsize => 80, ysize => 20);
    ok($test_draw->string(font => $font,
			  text => $over,
			  x => 2,
			  y => 18,
			  size => 15,
			  color => $white,
			  aa => 1),
       "magic: draw with overload");
    is_image($base_draw, $test_draw, "check they match");
    if ($opts->{files}) {
      $test_draw->write(file => "testout/utf8tdr.ppm");
      $base_draw->write(file => "testout/utf8bdr.ppm");
    }

    my $base_cp = Imager->new(xsize => 80, ysize => 20);
    $base_cp->box(filled => 1, color => "#808080");
    my $test_cp = $base_cp->copy;