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);
   6 @ISA = qw(Exporter);
   7 @EXPORT_OK = qw(diff_text_with_nul
   8                 test_image_raw test_image_16 test_image test_image_double
   9                 is_color3 is_color1 is_color4 is_color_close3
  10                 is_fcolor4
  11                 is_image is_image_similar
  12                 image_bounds_checks mask_tests
  13                 test_colorf_gpix test_color_gpix test_colorf_glin);
  14
  15 sub diff_text_with_nul {
  16   my ($desc, $text1, $text2, @params) = @_;
  17
  18   my $builder = Test::Builder->new;
  19
  20   print "# $desc\n";
  21   my $imbase = Imager->new(xsize => 100, ysize => 100);
  22   my $imcopy = Imager->new(xsize => 100, ysize => 100);
  23
  24   $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20,
  25                                string => $text1,
  26                                @params), "$desc - draw text1");
  27   $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20,
  28                                string => $text2,
  29                                @params), "$desc - draw text2");
  30   $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0,
  31                      "$desc - check result different");
  32 }
  33
  34 sub is_color3($$$$$) {
  35   my ($color, $red, $green, $blue, $comment) = @_;
  36
  37   my $builder = Test::Builder->new;
  38
  39   unless (defined $color) {
  40     $builder->ok(0, $comment);
  41     $builder->diag("color is undef");
  42     return;
  43   }
  44   unless ($color->can('rgba')) {
  45     $builder->ok(0, $comment);
  46     $builder->diag("color is not a color object");
  47     return;
  48   }
  49
  50   my ($cr, $cg, $cb) = $color->rgba;
  51   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
  52     $builder->diag(<<END_DIAG);
  53 Color mismatch:
  54   Red: $red vs $cr
  55 Green: $green vs $cg
  56  Blue: $blue vs $cb
  57 END_DIAG
  58     return;
  59   }
  60
  61   return 1;
  62 }
  63
  64 sub is_color_close3($$$$$$) {
  65   my ($color, $red, $green, $blue, $tolerance, $comment) = @_;
  66
  67   my $builder = Test::Builder->new;
  68
  69   unless (defined $color) {
  70     $builder->ok(0, $comment);
  71     $builder->diag("color is undef");
  72     return;
  73   }
  74   unless ($color->can('rgba')) {
  75     $builder->ok(0, $comment);
  76     $builder->diag("color is not a color object");
  77     return;
  78   }
  79
  80   my ($cr, $cg, $cb) = $color->rgba;
  81   unless ($builder->ok(abs($cr - $red) <= $tolerance
  82                        && abs($cg - $green) <= $tolerance
  83                        && abs($cb - $blue) <= $tolerance, $comment)) {
  84     $builder->diag(<<END_DIAG);
  85 Color out of tolerance ($tolerance):
  86   Red: expected $red vs received $cr
  87 Green: expected $green vs received $cg
  88  Blue: expected $blue vs received $cb
  89 END_DIAG
  90     return;
  91   }
  92
  93   return 1;
  94 }
  95
  96 sub is_color4($$$$$$) {
  97   my ($color, $red, $green, $blue, $alpha, $comment) = @_;
  98
  99   my $builder = Test::Builder->new;
 100
 101   unless (defined $color) {
 102     $builder->ok(0, $comment);
 103     $builder->diag("color is undef");
 104     return;
 105   }
 106   unless ($color->can('rgba')) {
 107     $builder->ok(0, $comment);
 108     $builder->diag("color is not a color object");
 109     return;
 110   }
 111
 112   my ($cr, $cg, $cb, $ca) = $color->rgba;
 113   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue
 114                        && $ca == $alpha, $comment)) {
 115     $builder->diag(<<END_DIAG);
 116 Color mismatch:
 117   Red: $red vs $cr
 118 Green: $green vs $cg
 119  Blue: $blue vs $cb
 120 Alpha: $alpha vs $ca
 121 END_DIAG
 122     return;
 123   }
 124
 125   return 1;
 126 }
 127
 128 sub is_fcolor4($$$$$$;$) {
 129   my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_;
 130   my ($comment, $mindiff);
 131   if (defined $comment_or_undef) {
 132     ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
 133   }
 134   else {
 135     ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
 136   }
 137
 138   my $builder = Test::Builder->new;
 139
 140   unless (defined $color) {
 141     $builder->ok(0, $comment);
 142     $builder->diag("color is undef");
 143     return;
 144   }
 145   unless ($color->can('rgba')) {
 146     $builder->ok(0, $comment);
 147     $builder->diag("color is not a color object");
 148     return;
 149   }
 150
 151   my ($cr, $cg, $cb, $ca) = $color->rgba;
 152   unless ($builder->ok(abs($cr - $red) <= $mindiff
 153                        && abs($cg - $green) <= $mindiff
 154                        && abs($cb - $blue) <= $mindiff
 155                        && abs($ca - $alpha) <= $mindiff, $comment)) {
 156     $builder->diag(<<END_DIAG);
 157 Color mismatch:
 158   Red: $red vs $cr
 159 Green: $green vs $cg
 160  Blue: $blue vs $cb
 161 Alpha: $alpha vs $ca
 162 END_DIAG
 163     return;
 164   }
 165
 166   return 1;
 167 }
 168
 169 sub is_color1($$$) {
 170   my ($color, $grey, $comment) = @_;
 171
 172   my $builder = Test::Builder->new;
 173
 174   unless (defined $color) {
 175     $builder->ok(0, $comment);
 176     $builder->diag("color is undef");
 177     return;
 178   }
 179   unless ($color->can('rgba')) {
 180     $builder->ok(0, $comment);
 181     $builder->diag("color is not a color object");
 182     return;
 183   }
 184
 185   my ($cgrey) = $color->rgba;
 186   unless ($builder->ok($cgrey == $grey, $comment)) {
 187     $builder->diag(<<END_DIAG);
 188 Color mismatch:
 189   Grey: $grey vs $cgrey
 190 END_DIAG
 191     return;
 192   }
 193
 194   return 1;
 195 }
 196
 197 sub test_image_raw {
 198   my $green=Imager::i_color_new(0,255,0,255);
 199   my $blue=Imager::i_color_new(0,0,255,255);
 200   my $red=Imager::i_color_new(255,0,0,255);
 201
 202   my $img=Imager::ImgRaw::new(150,150,3);
 203
 204   Imager::i_box_filled($img,70,25,130,125,$green);
 205   Imager::i_box_filled($img,20,25,80,125,$blue);
 206   Imager::i_arc($img,75,75,30,0,361,$red);
 207   Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
 208
 209   $img;
 210 }
 211
 212 sub test_image {
 213   my $green = Imager::Color->new(0, 255, 0, 255);
 214   my $blue  = Imager::Color->new(0, 0, 255, 255);
 215   my $red   = Imager::Color->new(255, 0, 0, 255);
 216   my $img = Imager->new(xsize => 150, ysize => 150);
 217   $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
 218   $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
 219   $img->arc(x => 75, y => 75, r => 30, color => $red);
 220   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
 221
 222   $img;
 223 }
 224
 225 sub test_image_16 {
 226   my $green = Imager::Color->new(0, 255, 0, 255);
 227   my $blue  = Imager::Color->new(0, 0, 255, 255);
 228   my $red   = Imager::Color->new(255, 0, 0, 255);
 229   my $img = Imager->new(xsize => 150, ysize => 150, bits => 16);
 230   $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
 231   $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
 232   $img->arc(x => 75, y => 75, r => 30, color => $red);
 233   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
 234
 235   $img;
 236 }
 237
 238 sub test_image_double {
 239   my $green = Imager::Color->new(0, 255, 0, 255);
 240   my $blue  = Imager::Color->new(0, 0, 255, 255);
 241   my $red   = Imager::Color->new(255, 0, 0, 255);
 242   my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double');
 243   $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
 244   $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
 245   $img->arc(x => 75, y => 75, r => 30, color => $red);
 246   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
 247
 248   $img;
 249 }
 250
 251 sub is_image_similar($$$$) {
 252   my ($left, $right, $limit, $comment) = @_;
 253
 254   my $builder = Test::Builder->new;
 255
 256   unless (defined $left) {
 257     $builder->ok(0, $comment);
 258     $builder->diag("left is undef");
 259     return;
 260   }
 261   unless (defined $right) {
 262     $builder->ok(0, $comment);
 263     $builder->diag("right is undef");
 264     return;
 265   }
 266   unless ($left->{IMG}) {
 267     $builder->ok(0, $comment);
 268     $builder->diag("left image has no low level object");
 269     return;
 270   }
 271   unless ($right->{IMG}) {
 272     $builder->ok(0, $comment);
 273     $builder->diag("right image has no low level object");
 274     return;
 275   }
 276   unless ($left->getwidth == $right->getwidth) {
 277     $builder->ok(0, $comment);
 278     $builder->diag("left width " . $left->getwidth . " vs right width "
 279                    . $right->getwidth);
 280     return;
 281   }
 282   unless ($left->getheight == $right->getheight) {
 283     $builder->ok(0, $comment);
 284     $builder->diag("left height " . $left->getheight . " vs right height "
 285                    . $right->getheight);
 286     return;
 287   }
 288   unless ($left->getchannels == $right->getchannels) {
 289     $builder->ok(0, $comment);
 290     $builder->diag("left channels " . $left->getchannels . " vs right channels "
 291                    . $right->getchannels);
 292     return;
 293   }
 294   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
 295   if ($diff > $limit) {
 296     $builder->ok(0, $comment);
 297     $builder->diag("image data difference > $limit - $diff");
 298
 299     if ($limit == 0) {
 300       # find the first mismatch
 301       CHECK:
 302       for my $y (0 .. $left->getheight()-1) {
 303         for my $x (0.. $left->getwidth()-1) {
 304           my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
 305           my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
 306           if ("@lsamples" ne "@rsamples") {
 307             $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
 308             last CHECK;
 309           }
 310         }
 311       }
 312     }
 313
 314     return;
 315   }
 316
 317   return $builder->ok(1, $comment);
 318 }
 319
 320 sub is_image($$$) {
 321   my ($left, $right, $comment) = @_;
 322
 323   local $Test::Builder::Level = $Test::Builder::Level + 1;
 324
 325   return is_image_similar($left, $right, 0, $comment);
 326 }
 327
 328 sub image_bounds_checks {
 329   my $im = shift;
 330
 331   my $builder = Test::Builder->new;
 332
 333   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
 334   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
 335   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
 336   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
 337   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
 338   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
 339   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
 340   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
 341   my $black = Imager::Color->new(0, 0, 0);
 342   require Imager::Color::Float;
 343   my $blackf = Imager::Color::Float->new(0, 0, 0);
 344   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
 345   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
 346   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
 347   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
 348   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
 349   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
 350   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
 351   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
 352 }
 353
 354 sub test_colorf_gpix {
 355   my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
 356
 357   my $builder = Test::Builder->new;
 358
 359   defined $comment or $comment = '';
 360
 361   my $c = Imager::i_gpixf($im, $x, $y);
 362   unless ($c) {
 363     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
 364     return;
 365   }
 366   unless ($builder->ok(_colorf_cmp($c, $expected, $epsilon) == 0,
 367              "$comment - got right color ($x, $y)")) {
 368     print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
 369     print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
 370     return;
 371   }
 372   1;
 373 }
 374
 375 sub test_color_gpix {
 376   my ($im, $x, $y, $expected, $comment) = @_;
 377
 378   my $builder = Test::Builder->new;
 379
 380   defined $comment or $comment = '';
 381   my $c = Imager::i_get_pixel($im, $x, $y);
 382   unless ($c) {
 383     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
 384     return;
 385   }
 386   unless ($builder->ok(_color_cmp($c, $expected) == 0,
 387      "got right color ($x, $y)")) {
 388     print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
 389     print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
 390     return;
 391   }
 392
 393   return 1;
 394 }
 395
 396 sub test_colorf_glin {
 397   my ($im, $x, $y, $pels, $comment) = @_;
 398
 399   my $builder = Test::Builder->new;
 400
 401   my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
 402   @got == @$pels
 403     or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
 404
 405   return $builder->ok(!grep(_colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
 406      "$comment - check colors ($x, $y)");
 407 }
 408
 409 sub _colorf_cmp {
 410   my ($c1, $c2, $epsilon) = @_;
 411
 412   defined $epsilon or $epsilon = 0;
 413
 414   my @s1 = $c1->rgba;
 415   my @s2 = $c2->rgba;
 416
 417   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
 418   return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
 419     || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
 420       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
 421 }
 422
 423 sub _color_cmp {
 424   my ($c1, $c2) = @_;
 425
 426   my @s1 = $c1->rgba;
 427   my @s2 = $c2->rgba;
 428
 429   return $s1[0] <=> $s2[0]
 430     || $s1[1] <=> $s2[1]
 431       || $s1[2] <=> $s2[2];
 432 }
 433
 434 # these test the action of the channel mask on the image supplied
 435 # which should be an OO image.
 436 sub mask_tests {
 437   my ($im, $epsilon) = @_;
 438
 439   my $builder = Test::Builder->new;
 440
 441   defined $epsilon or $epsilon = 0;
 442
 443   # we want to check all four of ppix() and plin(), ppix() and plinf()
 444   # basic test procedure:
 445   #   first using default/all 1s mask, set to white
 446   #   make sure we got white
 447   #   set mask to skip a channel, set to grey
 448   #   make sure only the right channels set
 449
 450   print "# channel mask tests\n";
 451   # 8-bit color tests
 452   my $white = Imager::NC(255, 255, 255);
 453   my $grey = Imager::NC(128, 128, 128);
 454   my $white_grey = Imager::NC(128, 255, 128);
 455
 456   print "# with ppix\n";
 457   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 458   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
 459   test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
 460   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 461   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
 462   test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
 463
 464   print "# with plin\n";
 465   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 466   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
 467      "set to white all channels");
 468   test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
 469   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 470   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
 471      "set to grey, no channel 2");
 472   test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
 473
 474   # float color tests
 475   my $whitef = Imager::NCF(1.0, 1.0, 1.0);
 476   my $greyf = Imager::NCF(0.5, 0.5, 0.5);
 477   my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
 478
 479   print "# with ppixf\n";
 480   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 481   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
 482   test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
 483   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 484   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
 485   test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
 486
 487   print "# with plinf\n";
 488   $builder->ok($im->setmask(mask=>~0), "set to default mask");
 489   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
 490      "set to white all channels");
 491   test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
 492   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
 493   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
 494      "set to grey, no channel 2");
 495   test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
 496
 497 }
 498
 499 1;
 500
 501 __END__
 502
 503 =head1 NAME
 504
 505 Imager::Test - common functions used in testing Imager
 506
 507 =head1 SYNOPSIS
 508
 509   use Imager::Test 'diff_text_with_nul';
 510   diff_text_with_nul($test_name, $text1, $text2, @string_options);
 511
 512 =head1 DESCRIPTION
 513
 514 This is a repository of functions used in testing Imager.
 515
 516 Some functions will only be useful in testing Imager itself, while
 517 others should be useful in testing modules that use Imager.
 518
 519 No functions are exported by default.
 520
 521 =head1 FUNCTIONS
 522
 523 =over
 524
 525 =item is_color3($color, $red, $blue, $green, $comment)
 526
 527 Tests is $color matches the given ($red, $blue, $green)
 528
 529 =item is_image($im1, $im2, $comment)
 530
 531 Tests if the 2 images have the same content.  Both images must be
 532 defined, have the same width, height, channels and the same color in
 533 each pixel.  The color comparison is done at 8-bits per pixel.  The
 534 color representation such as direct vs paletted, bits per sample are
 535 not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
 536
 537 =item is_image_similar($im1, $im2, $maxdiff, $comment)
 538
 539 Tests if the 2 images have similar content.  Both images must be
 540 defined, have the same width, height and channels.  The cum of the
 541 squares of the differences of each sample are calculated and must be
 542 less than or equal to I<$maxdiff> for the test to pass.  The color
 543 comparison is done at 8-bits per pixel.  The color representation such
 544 as direct vs paletted, bits per sample are not checked.
 545
 546 =item test_image_raw()
 547
 548 Returns a 150x150x3 Imager::ImgRaw test image.
 549
 550 =item test_image()
 551
 552 Returns a 150x150x3 8-bit/sample OO test image.
 553
 554 =item test_image_16()
 555
 556 Returns a 150x150x3 16-bit/sample OO test image.
 557
 558 =item test_image_double()
 559
 560 Returns a 150x150x3 double/sample OO test image.
 561
 562 =item diff_text_with_nul($test_name, $text1, $text2, @options)
 563
 564 Creates 2 test images and writes $text1 to the first image and $text2
 565 to the second image with the string() method.  Each call adds 3 ok/not
 566 ok to the output of the test script.
 567
 568 Extra options that should be supplied include the font and either a
 569 color or channel parameter.
 570
 571 This was explicitly created for regression tests on #21770.
 572
 573 =item image_bounds_checks($im)
 574
 575 Attempts to write to various pixel positions outside the edge of the
 576 image to ensure that it fails in those locations.
 577
 578 Any new image type should pass these tests.  Does 16 separate tests.
 579
 580 =item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
 581
 582 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 583 it to the floating point color $expected, with a tolerance of epsilon.
 584
 585 =item test_color_gpix($im, $x, $y, $expected, $comment)
 586
 587 Retrieves the pixel ($x,$y) from the low-level image $im and compares
 588 it to the floating point color $expected.
 589
 590 =item test_colorf_glin($im, $x, $y, $pels, $comment)
 591
 592 Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
 593 low level image $im and compares them against @$pels.
 594
 595 =item mask_tests($im, $epsilon)
 596
 597 Perform a standard set of mask tests on the OO image $im.
 598
 599 =back
 600
 601 =head1 AUTHOR
 602
 603 Tony Cook <tony@develop-help.com>
 604
 605 =cut