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 $epsilon = Imager::i_img_epsilonf();
 440   if (@_ > 3) {
 441     ($epsilon) = splice @_, 2, 1;
 442   }
 443
 444   my ($left, $right, $comment) = @_;
 445
 446   {
 447     local $Test::Builder::Level = $Test::Builder::Level + 1;
 448
 449     _low_image_diff_check($left, $right, $comment)
 450       or return;
 451   }
 452
 453   my $builder = Test::Builder->new;
 454
 455   my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment);
 456   if (!$same) {
 457     $builder->ok(0, $comment);
 458     $builder->diag("images different");
 459
 460     # find the first mismatch
 461   PIXELS:
 462     for my $y (0 .. $left->getheight()-1) {
 463       for my $x (0.. $left->getwidth()-1) {
 464         my @lsamples = $left->getsamples(x => $x, y => $y, width => 1, type => "float");
 465         my @rsamples = $right->getsamples(x => $x, y => $y, width => 1, type => "float");
 466         if ("@lsamples" ne "@rsamples") {
 467           $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
 468           last PIXELS;
 469         }
 470       }
 471     }
 472
 473     return;
 474   }
 475
 476   return $builder->ok(1, $comment);
 477 }
 478
 479 sub isnt_image {
 480   my ($left, $right, $comment) = @_;
 481
 482   my $builder = Test::Builder->new;
 483
 484   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
 485
 486   return $builder->ok($diff, "$comment");
 487 }
 488
 489 sub image_bounds_checks {
 490   my $im = shift;
 491
 492   my $builder = Test::Builder->new;
 493
 494   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
 495   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
 496   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
 497   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
 498   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
 499   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
 500   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
 501   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
 502   my $black = Imager::Color->new(0, 0, 0);
 503   require Imager::Color::Float;
 504   my $blackf = Imager::Color::Float->new(0, 0, 0);
 505   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
 506   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
 507   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
 508   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
 509   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
 510   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
 511   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
 512   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
 513 }
 514
 515 sub test_colorf_gpix {
 516   my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
 517
 518   my $builder = Test::Builder->new;
 519
 520   defined $comment or $comment = '';
 521
 522   my $c = Imager::i_gpixf($im, $x, $y);
 523   unless ($c) {
 524     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
 525     return;
 526   }
 527   unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,
 528              "$comment - got right color ($x, $y)")) {
 529     my @c = $c->rgba;
 530     my @exp = $expected->rgba;
 531     $builder->diag(<<EOS);
 532 # got: ($c[0], $c[1], $c[2])
 533 # expected: ($exp[0], $exp[1], $exp[2])
 534 EOS
 535   }
 536   1;
 537 }
 538
 539 sub test_color_gpix {
 540   my ($im, $x, $y, $expected, $comment) = @_;
 541
 542   my $builder = Test::Builder->new;
 543
 544   defined $comment or $comment = '';
 545   my $c = Imager::i_get_pixel($im, $x, $y);
 546   unless ($c) {
 547     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
 548     return;
 549   }
 550   unless ($builder->ok(color_cmp($c, $expected) == 0,
 551      "got right color ($x, $y)")) {
 552     my @c = $c->rgba;
 553     my @exp = $expected->rgba;
 554     $builder->diag(<<EOS);
 555 # got: ($c[0], $c[1], $c[2])
 556 # expected: ($exp[0], $exp[1], $exp[2])
 557 EOS
 558     return;
 559   }
 560
 561   return 1;
 562 }
 563
 564 sub test_colorf_glin {
 565   my ($im, $x, $y, $pels, $comment) = @_;
 566
 567   my $builder = Test::Builder->new;
 568
 569   my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
 570   @got == @$pels
 571     or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
 572
 573   return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
 574      "$comment - check colors ($x, $y)");
 575 }
 576
 577 sub colorf_cmp {
 578   my ($c1, $c2, $epsilon) = @_;
 579
 580   defined $epsilon or $epsilon = 0;
 581
 582   my @s1 = $c1->rgba;
 583   my @s2 = $c2->rgba;
 584
 585   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
 586   return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
 587     || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
 588       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
 589 }
 590
 591 sub color_cmp {
 592   my ($c1, $c2) = @_;
 593
 594   my @s1 = $c1->rgba;
 595   my @s2 = $c2->rgba;
 596
 597   return $s1[0] <=> $s2[0]
 598     || $s1[1] <=> $s2[1]
 599       || $s1[2] <=> $s2[2];
 600 }
 601
 602 # these test the action of the channel mask on the image supplied
 603 # which should be an OO image.
 604 sub mask_tests {
 605   my ($im, $epsilon) = @_;
 606
 607   my $builder = Test::Builder->new;
 608
 609   defined $epsilon or $epsilon = 0;
 610
 611   # we want to check all four of ppix() and plin(), ppix() and plinf()
 612   # basic test procedure:
 613   #   first using default/all 1s mask, set to white
 614   #   make sure we got white
 615   #   set mask to skip a channel, set to grey
 616   #   make sure only the right channels set
 617
 618   print "# channel mask tests\n";
 619   # 8-bit color tests
 620   my $white = Imager::NC(255, 255, 255);
 621   my $grey = Imager::NC(128, 128, 128);
 622   my $white_grey = Imager::NC(128, 255, 128);
 623
 624   print "# with ppix\n";
 625   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 626   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
 627   test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
 628   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 629   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
 630   test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
 631
 632   print "# with plin\n";
 633   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 634   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
 635      "set to white all channels");
 636   test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
 637   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 638   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
 639      "set to grey, no channel 2");
 640   test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
 641
 642   # float color tests
 643   my $whitef = Imager::NCF(1.0, 1.0, 1.0);
 644   my $greyf = Imager::NCF(0.5, 0.5, 0.5);
 645   my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
 646
 647   print "# with ppixf\n";
 648   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 649   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
 650   test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
 651   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 652   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
 653   test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
 654
 655   print "# with plinf\n";
 656   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 657   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
 658      "set to white all channels");
 659   test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
 660   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 661   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
 662      "set to grey, no channel 2");
 663   test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
 664
 665 }
 666
 667 1;
 668
 669 __END__
 670
 671 =head1 NAME
 672
 673 Imager::Test - common functions used in testing Imager
 674
 675 =head1 SYNOPSIS
 676
 677   use Imager::Test 'diff_text_with_nul';
 678   diff_text_with_nul($test_name, $text1, $text2, @string_options);
 679
 680 =head1 DESCRIPTION
 681
 682 This is a repository of functions used in testing Imager.
 683
 684 Some functions will only be useful in testing Imager itself, while
 685 others should be useful in testing modules that use Imager.
 686
 687 No functions are exported by default.
 688
 689 =head1 FUNCTIONS
 690
 691 =head2 Test functions
 692
 693 =for stopwords OO
 694
 695 =over
 696
 697 =item is_color1($color, $grey, $comment)
 698
 699 Tests if the first channel of $color matches $grey.
 700
 701 =item is_color3($color, $red, $green, $blue, $comment)
 702
 703 Tests if $color matches the given ($red, $green, $blue)
 704
 705 =item is_color4($color, $red, $green, $blue, $alpha, $comment)
 706
 707 Tests if $color matches the given ($red, $green, $blue, $alpha)
 708
 709 =item is_fcolor1($fcolor, $grey, $comment)
 710
 711 =item is_fcolor1($fcolor, $grey, $epsilon, $comment)
 712
 713 Tests if $fcolor's first channel is within $epsilon of ($grey).  For
 714 the first form $epsilon is taken as 0.001.
 715
 716 =item is_fcolor3($fcolor, $red, $green, $blue, $comment)
 717
 718 =item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
 719
 720 Tests if $fcolor's channels are within $epsilon of ($red, $green,
 721 $blue).  For the first form $epsilon is taken as 0.001.
 722
 723 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
 724
 725 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
 726
 727 Tests if $fcolor's channels are within $epsilon of ($red, $green,
 728 $blue, $alpha).  For the first form $epsilon is taken as 0.001.
 729
 730 =item is_image($im1, $im2, $comment)
 731
 732 Tests if the 2 images have the same content.  Both images must be
 733 defined, have the same width, height, channels and the same color in
 734 each pixel.  The color comparison is done at 8-bits per pixel.  The
 735 color representation such as direct vs paletted, bits per sample are
 736 not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
 737
 738 =item is_imaged($im, $im2, $comment)
 739
 740 =item is_imaged($im, $im2, $epsilon, $comment)
 741
 742 Tests if the two images have the same content at the double/sample
 743 level.  C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
 744 four.
 745
 746 =item is_image_similar($im1, $im2, $maxdiff, $comment)
 747
 748 Tests if the 2 images have similar content.  Both images must be
 749 defined, have the same width, height and channels.  The cum of the
 750 squares of the differences of each sample are calculated and must be
 751 less than or equal to I<$maxdiff> for the test to pass.  The color
 752 comparison is done at 8-bits per pixel.  The color representation such
 753 as direct vs paletted, bits per sample are not checked.
 754
 755 =item isnt_image($im1, $im2, $comment)
 756
 757 Tests that the two images are different.  For regressions tests where
 758 something (like text output of "0") produced no change, but should
 759 have produced a change.
 760
 761 =item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
 762
 763 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 764 it to the floating point color $expected, with a tolerance of epsilon.
 765
 766 =item test_color_gpix($im, $x, $y, $expected, $comment)
 767
 768 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 769 it to the floating point color $expected.
 770
 771 =item test_colorf_glin($im, $x, $y, $pels, $comment)
 772
 773 Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
 774 low level image $im and compares them against @$pels.
 775
 776 =item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
 777
 778 Tests if $color's first three channels are within $tolerance of ($red,
 779 $green, $blue).
 780
 781 =back
 782
 783 =head2 Test suite functions
 784
 785 Functions that perform one or more tests, typically used to test
 786 various parts of Imager's implementation.
 787
 788 =over
 789
 790 =item image_bounds_checks($im)
 791
 792 Attempts to write to various pixel positions outside the edge of the
 793 image to ensure that it fails in those locations.
 794
 795 Any new image type should pass these tests.  Does 16 separate tests.
 796
 797 =item mask_tests($im, $epsilon)
 798
 799 Perform a standard set of mask tests on the OO image $im.  Does 24
 800 separate tests.
 801
 802 =item diff_text_with_nul($test_name, $text1, $text2, @options)
 803
 804 Creates 2 test images and writes $text1 to the first image and $text2
 805 to the second image with the string() method.  Each call adds 3
 806 C<ok>/C<not ok> to the output of the test script.
 807
 808 Extra options that should be supplied include the font and either a
 809 color or channel parameter.
 810
 811 This was explicitly created for regression tests on #21770.
 812
 813 =back
 814
 815 =head2 Helper functions
 816
 817 =over
 818
 819 =item test_image_raw()
 820
 821 Returns a 150x150x3 Imager::ImgRaw test image.
 822
 823 =item test_image()
 824
 825 Returns a 150x150x3 8-bit/sample OO test image.
 826
 827 =item test_image_16()
 828
 829 Returns a 150x150x3 16-bit/sample OO test image.
 830
 831 =item test_image_double()
 832
 833 Returns a 150x150x3 double/sample OO test image.
 834
 835 =item color_cmp($c1, $c2)
 836
 837 Performs an ordering of 3-channel colors (like <=>).
 838
 839 =item colorf_cmp($c1, $c2)
 840
 841 Performs an ordering of 3-channel floating point colors (like <=>).
 842
 843 =back
 844
 845 =head1 AUTHOR
 846
 847 Tony Cook <tony@develop-help.com>
 848
 849 =cut