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