lib/Imager/Test.pm

   1 package Imager::Test;
   2 use strict;
   3 use Test::Builder;
   4 require Exporter;
   5 use vars qw(@ISA @EXPORT_OK $VERSION);
   6
   7 $VERSION = "1.000";
   8
   9 @ISA = qw(Exporter);
  10 @EXPORT_OK =
  11   qw(
  12      diff_text_with_nul
  13      test_image_raw
  14      test_image_16
  15      test_image
  16      test_image_double
  17      is_color1
  18      is_color3
  19      is_color4
  20      is_color_close3
  21      is_fcolor1
  22      is_fcolor3
  23      is_fcolor4
  24      color_cmp
  25      is_image
  26      is_imaged
  27      is_image_similar
  28      isnt_image
  29      image_bounds_checks
  30      mask_tests
  31      test_colorf_gpix
  32      test_color_gpix
  33      test_colorf_glin);
  34
  35 sub diff_text_with_nul {
  36   my ($desc, $text1, $text2, @params) = @_;
  37
  38   my $builder = Test::Builder->new;
  39
  40   print "# $desc\n";
  41   my $imbase = Imager->new(xsize => 100, ysize => 100);
  42   my $imcopy = Imager->new(xsize => 100, ysize => 100);
  43
  44   $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20,
  45                                string => $text1,
  46                                @params), "$desc - draw text1");
  47   $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20,
  48                                string => $text2,
  49                                @params), "$desc - draw text2");
  50   $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0,
  51                      "$desc - check result different");
  52 }
  53
  54 sub is_color3($$$$$) {
  55   my ($color, $red, $green, $blue, $comment) = @_;
  56
  57   my $builder = Test::Builder->new;
  58
  59   unless (defined $color) {
  60     $builder->ok(0, $comment);
  61     $builder->diag("color is undef");
  62     return;
  63   }
  64   unless ($color->can('rgba')) {
  65     $builder->ok(0, $comment);
  66     $builder->diag("color is not a color object");
  67     return;
  68   }
  69
  70   my ($cr, $cg, $cb) = $color->rgba;
  71   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
  72     print <<END_DIAG;
  73 Color mismatch:
  74   Red: $red vs $cr
  75 Green: $green vs $cg
  76  Blue: $blue vs $cb
  77 END_DIAG
  78     return;
  79   }
  80
  81   return 1;
  82 }
  83
  84 sub is_color_close3($$$$$$) {
  85   my ($color, $red, $green, $blue, $tolerance, $comment) = @_;
  86
  87   my $builder = Test::Builder->new;
  88
  89   unless (defined $color) {
  90     $builder->ok(0, $comment);
  91     $builder->diag("color is undef");
  92     return;
  93   }
  94   unless ($color->can('rgba')) {
  95     $builder->ok(0, $comment);
  96     $builder->diag("color is not a color object");
  97     return;
  98   }
  99
 100   my ($cr, $cg, $cb) = $color->rgba;
 101   unless ($builder->ok(abs($cr - $red) <= $tolerance
 102                        && abs($cg - $green) <= $tolerance
 103                        && abs($cb - $blue) <= $tolerance, $comment)) {
 104     $builder->diag(<<END_DIAG);
 105 Color out of tolerance ($tolerance):
 106   Red: expected $red vs received $cr
 107 Green: expected $green vs received $cg
 108  Blue: expected $blue vs received $cb
 109 END_DIAG
 110     return;
 111   }
 112
 113   return 1;
 114 }
 115
 116 sub is_color4($$$$$$) {
 117   my ($color, $red, $green, $blue, $alpha, $comment) = @_;
 118
 119   my $builder = Test::Builder->new;
 120
 121   unless (defined $color) {
 122     $builder->ok(0, $comment);
 123     $builder->diag("color is undef");
 124     return;
 125   }
 126   unless ($color->can('rgba')) {
 127     $builder->ok(0, $comment);
 128     $builder->diag("color is not a color object");
 129     return;
 130   }
 131
 132   my ($cr, $cg, $cb, $ca) = $color->rgba;
 133   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue
 134                        && $ca == $alpha, $comment)) {
 135     $builder->diag(<<END_DIAG);
 136 Color mismatch:
 137   Red: $cr vs $red
 138 Green: $cg vs $green
 139  Blue: $cb vs $blue
 140 Alpha: $ca vs $alpha
 141 END_DIAG
 142     return;
 143   }
 144
 145   return 1;
 146 }
 147
 148 sub is_fcolor4($$$$$$;$) {
 149   my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_;
 150   my ($comment, $mindiff);
 151   if (defined $comment_or_undef) {
 152     ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
 153   }
 154   else {
 155     ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
 156   }
 157
 158   my $builder = Test::Builder->new;
 159
 160   unless (defined $color) {
 161     $builder->ok(0, $comment);
 162     $builder->diag("color is undef");
 163     return;
 164   }
 165   unless ($color->can('rgba')) {
 166     $builder->ok(0, $comment);
 167     $builder->diag("color is not a color object");
 168     return;
 169   }
 170
 171   my ($cr, $cg, $cb, $ca) = $color->rgba;
 172   unless ($builder->ok(abs($cr - $red) <= $mindiff
 173                        && abs($cg - $green) <= $mindiff
 174                        && abs($cb - $blue) <= $mindiff
 175                        && abs($ca - $alpha) <= $mindiff, $comment)) {
 176     $builder->diag(<<END_DIAG);
 177 Color mismatch:
 178   Red: $cr vs $red
 179 Green: $cg vs $green
 180  Blue: $cb vs $blue
 181 Alpha: $ca vs $alpha
 182 END_DIAG
 183     return;
 184   }
 185
 186   return 1;
 187 }
 188
 189 sub is_fcolor1($$$;$) {
 190   my ($color, $grey, $comment_or_diff, $comment_or_undef) = @_;
 191   my ($comment, $mindiff);
 192   if (defined $comment_or_undef) {
 193     ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
 194   }
 195   else {
 196     ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
 197   }
 198
 199   my $builder = Test::Builder->new;
 200
 201   unless (defined $color) {
 202     $builder->ok(0, $comment);
 203     $builder->diag("color is undef");
 204     return;
 205   }
 206   unless ($color->can('rgba')) {
 207     $builder->ok(0, $comment);
 208     $builder->diag("color is not a color object");
 209     return;
 210   }
 211
 212   my ($cgrey) = $color->rgba;
 213   unless ($builder->ok(abs($cgrey - $grey) <= $mindiff, $comment)) {
 214     print <<END_DIAG;
 215 Color mismatch:
 216   Gray: $cgrey vs $grey
 217 END_DIAG
 218     return;
 219   }
 220
 221   return 1;
 222 }
 223
 224 sub is_fcolor3($$$$$;$) {
 225   my ($color, $red, $green, $blue, $comment_or_diff, $comment_or_undef) = @_;
 226   my ($comment, $mindiff);
 227   if (defined $comment_or_undef) {
 228     ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
 229   }
 230   else {
 231     ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
 232   }
 233
 234   my $builder = Test::Builder->new;
 235
 236   unless (defined $color) {
 237     $builder->ok(0, $comment);
 238     $builder->diag("color is undef");
 239     return;
 240   }
 241   unless ($color->can('rgba')) {
 242     $builder->ok(0, $comment);
 243     $builder->diag("color is not a color object");
 244     return;
 245   }
 246
 247   my ($cr, $cg, $cb) = $color->rgba;
 248   unless ($builder->ok(abs($cr - $red) <= $mindiff
 249                        && abs($cg - $green) <= $mindiff
 250                        && abs($cb - $blue) <= $mindiff, $comment)) {
 251     $builder->diag(<<END_DIAG);
 252 Color mismatch:
 253   Red: $cr vs $red
 254 Green: $cg vs $green
 255  Blue: $cb vs $blue
 256 END_DIAG
 257     return;
 258   }
 259
 260   return 1;
 261 }
 262
 263 sub is_color1($$$) {
 264   my ($color, $grey, $comment) = @_;
 265
 266   my $builder = Test::Builder->new;
 267
 268   unless (defined $color) {
 269     $builder->ok(0, $comment);
 270     $builder->diag("color is undef");
 271     return;
 272   }
 273   unless ($color->can('rgba')) {
 274     $builder->ok(0, $comment);
 275     $builder->diag("color is not a color object");
 276     return;
 277   }
 278
 279   my ($cgrey) = $color->rgba;
 280   unless ($builder->ok($cgrey == $grey, $comment)) {
 281     $builder->diag(<<END_DIAG);
 282 Color mismatch:
 283   Grey: $grey vs $cgrey
 284 END_DIAG
 285     return;
 286   }
 287
 288   return 1;
 289 }
 290
 291 sub test_image_raw {
 292   my $green=Imager::i_color_new(0,255,0,255);
 293   my $blue=Imager::i_color_new(0,0,255,255);
 294   my $red=Imager::i_color_new(255,0,0,255);
 295
 296   my $img=Imager::ImgRaw::new(150,150,3);
 297
 298   Imager::i_box_filled($img,70,25,130,125,$green);
 299   Imager::i_box_filled($img,20,25,80,125,$blue);
 300   Imager::i_arc($img,75,75,30,0,361,$red);
 301   Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
 302
 303   $img;
 304 }
 305
 306 sub test_image {
 307   my $green = Imager::Color->new(0, 255, 0, 255);
 308   my $blue  = Imager::Color->new(0, 0, 255, 255);
 309   my $red   = Imager::Color->new(255, 0, 0, 255);
 310   my $img = Imager->new(xsize => 150, ysize => 150);
 311   $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
 312   $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
 313   $img->arc(x => 75, y => 75, r => 30, color => $red);
 314   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
 315
 316   $img;
 317 }
 318
 319 sub test_image_16 {
 320   my $green = Imager::Color->new(0, 255, 0, 255);
 321   my $blue  = Imager::Color->new(0, 0, 255, 255);
 322   my $red   = Imager::Color->new(255, 0, 0, 255);
 323   my $img = Imager->new(xsize => 150, ysize => 150, bits => 16);
 324   $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
 325   $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
 326   $img->arc(x => 75, y => 75, r => 30, color => $red);
 327   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
 328
 329   $img;
 330 }
 331
 332 sub test_image_double {
 333   my $green = Imager::Color->new(0, 255, 0, 255);
 334   my $blue  = Imager::Color->new(0, 0, 255, 255);
 335   my $red   = Imager::Color->new(255, 0, 0, 255);
 336   my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double');
 337   $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
 338   $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
 339   $img->arc(x => 75, y => 75, r => 30, color => $red);
 340   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
 341
 342   $img;
 343 }
 344
 345 sub _low_image_diff_check {
 346   my ($left, $right, $comment) = @_;
 347
 348   my $builder = Test::Builder->new;
 349
 350   unless (defined $left) {
 351     $builder->ok(0, $comment);
 352     $builder->diag("left is undef");
 353     return;
 354   }
 355   unless (defined $right) {
 356     $builder->ok(0, $comment);
 357     $builder->diag("right is undef");
 358     return;
 359   }
 360   unless ($left->{IMG}) {
 361     $builder->ok(0, $comment);
 362     $builder->diag("left image has no low level object");
 363     return;
 364   }
 365   unless ($right->{IMG}) {
 366     $builder->ok(0, $comment);
 367     $builder->diag("right image has no low level object");
 368     return;
 369   }
 370   unless ($left->getwidth == $right->getwidth) {
 371     $builder->ok(0, $comment);
 372     $builder->diag("left width " . $left->getwidth . " vs right width "
 373                    . $right->getwidth);
 374     return;
 375   }
 376   unless ($left->getheight == $right->getheight) {
 377     $builder->ok(0, $comment);
 378     $builder->diag("left height " . $left->getheight . " vs right height "
 379                    . $right->getheight);
 380     return;
 381   }
 382   unless ($left->getchannels == $right->getchannels) {
 383     $builder->ok(0, $comment);
 384     $builder->diag("left channels " . $left->getchannels . " vs right channels "
 385                    . $right->getchannels);
 386     return;
 387   }
 388
 389   return 1;
 390 }
 391
 392 sub is_image_similar($$$$) {
 393   my ($left, $right, $limit, $comment) = @_;
 394
 395   {
 396     local $Test::Builder::Level = $Test::Builder::Level + 1;
 397
 398     _low_image_diff_check($left, $right, $comment)
 399       or return;
 400   }
 401
 402   my $builder = Test::Builder->new;
 403
 404   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
 405   if ($diff > $limit) {
 406     $builder->ok(0, $comment);
 407     $builder->diag("image data difference > $limit - $diff");
 408
 409     if ($limit == 0) {
 410       # find the first mismatch
 411       PIXELS:
 412       for my $y (0 .. $left->getheight()-1) {
 413         for my $x (0.. $left->getwidth()-1) {
 414           my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
 415           my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
 416           if ("@lsamples" ne "@rsamples") {
 417             $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
 418             last PIXELS;
 419           }
 420         }
 421       }
 422     }
 423
 424     return;
 425   }
 426
 427   return $builder->ok(1, $comment);
 428 }
 429
 430 sub is_image($$$) {
 431   my ($left, $right, $comment) = @_;
 432
 433   local $Test::Builder::Level = $Test::Builder::Level + 1;
 434
 435   return is_image_similar($left, $right, 0, $comment);
 436 }
 437
 438 sub is_imaged($$$) {
 439   my ($left, $right, $comment) = @_;
 440
 441   {
 442     local $Test::Builder::Level = $Test::Builder::Level + 1;
 443
 444     _low_image_diff_check($left, $right, $comment)
 445       or return;
 446   }
 447
 448   my $builder = Test::Builder->new;
 449
 450   my $diff = Imager::i_img_diffd($left->{IMG}, $right->{IMG});
 451   if ($diff > 0) {
 452     $builder->ok(0, $comment);
 453     $builder->diag("image data difference: $diff");
 454
 455     # find the first mismatch
 456   PIXELS:
 457     for my $y (0 .. $left->getheight()-1) {
 458       for my $x (0.. $left->getwidth()-1) {
 459         my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
 460         my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
 461         if ("@lsamples" ne "@rsamples") {
 462           $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
 463           last PIXELS;
 464         }
 465       }
 466     }
 467
 468     return;
 469   }
 470
 471   return $builder->ok(1, $comment);
 472 }
 473
 474 sub isnt_image {
 475   my ($left, $right, $comment) = @_;
 476
 477   my $builder = Test::Builder->new;
 478
 479   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
 480
 481   return $builder->ok($diff, "$comment");
 482 }
 483
 484 sub image_bounds_checks {
 485   my $im = shift;
 486
 487   my $builder = Test::Builder->new;
 488
 489   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
 490   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
 491   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
 492   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
 493   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
 494   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
 495   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
 496   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
 497   my $black = Imager::Color->new(0, 0, 0);
 498   require Imager::Color::Float;
 499   my $blackf = Imager::Color::Float->new(0, 0, 0);
 500   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
 501   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
 502   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
 503   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
 504   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
 505   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
 506   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
 507   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
 508 }
 509
 510 sub test_colorf_gpix {
 511   my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
 512
 513   my $builder = Test::Builder->new;
 514
 515   defined $comment or $comment = '';
 516
 517   my $c = Imager::i_gpixf($im, $x, $y);
 518   unless ($c) {
 519     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
 520     return;
 521   }
 522   unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,
 523              "$comment - got right color ($x, $y)")) {
 524     my @c = $c->rgba;
 525     my @exp = $expected->rgba;
 526     $builder->diag(<<EOS);
 527 # got: ($c[0], $c[1], $c[2])
 528 # expected: ($exp[0], $exp[1], $exp[2])
 529 EOS
 530   }
 531   1;
 532 }
 533
 534 sub test_color_gpix {
 535   my ($im, $x, $y, $expected, $comment) = @_;
 536
 537   my $builder = Test::Builder->new;
 538
 539   defined $comment or $comment = '';
 540   my $c = Imager::i_get_pixel($im, $x, $y);
 541   unless ($c) {
 542     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
 543     return;
 544   }
 545   unless ($builder->ok(color_cmp($c, $expected) == 0,
 546      "got right color ($x, $y)")) {
 547     my @c = $c->rgba;
 548     my @exp = $expected->rgba;
 549     $builder->diag(<<EOS);
 550 # got: ($c[0], $c[1], $c[2])
 551 # expected: ($exp[0], $exp[1], $exp[2])
 552 EOS
 553     return;
 554   }
 555
 556   return 1;
 557 }
 558
 559 sub test_colorf_glin {
 560   my ($im, $x, $y, $pels, $comment) = @_;
 561
 562   my $builder = Test::Builder->new;
 563
 564   my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
 565   @got == @$pels
 566     or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
 567
 568   return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
 569      "$comment - check colors ($x, $y)");
 570 }
 571
 572 sub colorf_cmp {
 573   my ($c1, $c2, $epsilon) = @_;
 574
 575   defined $epsilon or $epsilon = 0;
 576
 577   my @s1 = $c1->rgba;
 578   my @s2 = $c2->rgba;
 579
 580   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
 581   return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
 582     || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
 583       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
 584 }
 585
 586 sub color_cmp {
 587   my ($c1, $c2) = @_;
 588
 589   my @s1 = $c1->rgba;
 590   my @s2 = $c2->rgba;
 591
 592   return $s1[0] <=> $s2[0]
 593     || $s1[1] <=> $s2[1]
 594       || $s1[2] <=> $s2[2];
 595 }
 596
 597 # these test the action of the channel mask on the image supplied
 598 # which should be an OO image.
 599 sub mask_tests {
 600   my ($im, $epsilon) = @_;
 601
 602   my $builder = Test::Builder->new;
 603
 604   defined $epsilon or $epsilon = 0;
 605
 606   # we want to check all four of ppix() and plin(), ppix() and plinf()
 607   # basic test procedure:
 608   #   first using default/all 1s mask, set to white
 609   #   make sure we got white
 610   #   set mask to skip a channel, set to grey
 611   #   make sure only the right channels set
 612
 613   print "# channel mask tests\n";
 614   # 8-bit color tests
 615   my $white = Imager::NC(255, 255, 255);
 616   my $grey = Imager::NC(128, 128, 128);
 617   my $white_grey = Imager::NC(128, 255, 128);
 618
 619   print "# with ppix\n";
 620   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 621   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
 622   test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
 623   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 624   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
 625   test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
 626
 627   print "# with plin\n";
 628   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 629   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
 630      "set to white all channels");
 631   test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
 632   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 633   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
 634      "set to grey, no channel 2");
 635   test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
 636
 637   # float color tests
 638   my $whitef = Imager::NCF(1.0, 1.0, 1.0);
 639   my $greyf = Imager::NCF(0.5, 0.5, 0.5);
 640   my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
 641
 642   print "# with ppixf\n";
 643   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 644   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
 645   test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
 646   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 647   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
 648   test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
 649
 650   print "# with plinf\n";
 651   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 652   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
 653      "set to white all channels");
 654   test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
 655   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 656   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
 657      "set to grey, no channel 2");
 658   test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
 659
 660 }
 661
 662 1;
 663
 664 __END__
 665
 666 =head1 NAME
 667
 668 Imager::Test - common functions used in testing Imager
 669
 670 =head1 SYNOPSIS
 671
 672   use Imager::Test 'diff_text_with_nul';
 673   diff_text_with_nul($test_name, $text1, $text2, @string_options);
 674
 675 =head1 DESCRIPTION
 676
 677 This is a repository of functions used in testing Imager.
 678
 679 Some functions will only be useful in testing Imager itself, while
 680 others should be useful in testing modules that use Imager.
 681
 682 No functions are exported by default.
 683
 684 =head1 FUNCTIONS
 685
 686 =head2 Test functions
 687
 688 =for stopwords OO
 689
 690 =over
 691
 692 =item is_color1($color, $grey, $comment)
 693
 694 Tests if the first channel of $color matches $grey.
 695
 696 =item is_color3($color, $red, $green, $blue, $comment)
 697
 698 Tests if $color matches the given ($red, $green, $blue)
 699
 700 =item is_color4($color, $red, $green, $blue, $alpha, $comment)
 701
 702 Tests if $color matches the given ($red, $green, $blue, $alpha)
 703
 704 =item is_fcolor1($fcolor, $grey, $comment)
 705
 706 =item is_fcolor1($fcolor, $grey, $epsilon, $comment)
 707
 708 Tests if $fcolor's first channel is within $epsilon of ($grey).  For
 709 the first form $epsilon is taken as 0.001.
 710
 711 =item is_fcolor3($fcolor, $red, $green, $blue, $comment)
 712
 713 =item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
 714
 715 Tests if $fcolor's channels are within $epsilon of ($red, $green,
 716 $blue).  For the first form $epsilon is taken as 0.001.
 717
 718 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
 719
 720 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
 721
 722 Tests if $fcolor's channels are within $epsilon of ($red, $green,
 723 $blue, $alpha).  For the first form $epsilon is taken as 0.001.
 724
 725 =item is_image($im1, $im2, $comment)
 726
 727 Tests if the 2 images have the same content.  Both images must be
 728 defined, have the same width, height, channels and the same color in
 729 each pixel.  The color comparison is done at 8-bits per pixel.  The
 730 color representation such as direct vs paletted, bits per sample are
 731 not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
 732
 733 =item is_imaged($im, $im2, $comment)
 734
 735 Tests if the two images have the same content at the double/sample
 736 level.
 737
 738 =item is_image_similar($im1, $im2, $maxdiff, $comment)
 739
 740 Tests if the 2 images have similar content.  Both images must be
 741 defined, have the same width, height and channels.  The cum of the
 742 squares of the differences of each sample are calculated and must be
 743 less than or equal to I<$maxdiff> for the test to pass.  The color
 744 comparison is done at 8-bits per pixel.  The color representation such
 745 as direct vs paletted, bits per sample are not checked.
 746
 747 =item isnt_image($im1, $im2, $comment)
 748
 749 Tests that the two images are different.  For regressions tests where
 750 something (like text output of "0") produced no change, but should
 751 have produced a change.
 752
 753 =item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
 754
 755 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 756 it to the floating point color $expected, with a tolerance of epsilon.
 757
 758 =item test_color_gpix($im, $x, $y, $expected, $comment)
 759
 760 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 761 it to the floating point color $expected.
 762
 763 =item test_colorf_glin($im, $x, $y, $pels, $comment)
 764
 765 Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
 766 low level image $im and compares them against @$pels.
 767
 768 =item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
 769
 770 Tests if $color's first three channels are within $tolerance of ($red,
 771 $green, $blue).
 772
 773 =back
 774
 775 =head2 Test suite functions
 776
 777 Functions that perform one or more tests, typically used to test
 778 various parts of Imager's implementation.
 779
 780 =over
 781
 782 =item image_bounds_checks($im)
 783
 784 Attempts to write to various pixel positions outside the edge of the
 785 image to ensure that it fails in those locations.
 786
 787 Any new image type should pass these tests.  Does 16 separate tests.
 788
 789 =item mask_tests($im, $epsilon)
 790
 791 Perform a standard set of mask tests on the OO image $im.  Does 24
 792 separate tests.
 793
 794 =item diff_text_with_nul($test_name, $text1, $text2, @options)
 795
 796 Creates 2 test images and writes $text1 to the first image and $text2
 797 to the second image with the string() method.  Each call adds 3
 798 C<ok>/C<not ok> to the output of the test script.
 799
 800 Extra options that should be supplied include the font and either a
 801 color or channel parameter.
 802
 803 This was explicitly created for regression tests on #21770.
 804
 805 =back
 806
 807 =head2 Helper functions
 808
 809 =over
 810
 811 =item test_image_raw()
 812
 813 Returns a 150x150x3 Imager::ImgRaw test image.
 814
 815 =item test_image()
 816
 817 Returns a 150x150x3 8-bit/sample OO test image.
 818
 819 =item test_image_16()
 820
 821 Returns a 150x150x3 16-bit/sample OO test image.
 822
 823 =item test_image_double()
 824
 825 Returns a 150x150x3 double/sample OO test image.
 826
 827 =item color_cmp($c1, $c2)
 828
 829 Performs an ordering of 3-channel colors (like <=>).
 830
 831 =item colorf_cmp($c1, $c2)
 832
 833 Performs an ordering of 3-channel floating point colors (like <=>).
 834
 835 =back
 836
 837 =head1 AUTHOR
 838
 839 Tony Cook <tony@develop-help.com>
 840
 841 =cut