lib/Imager/Test.pm

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