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