t/test.pm

   1 # (X)Emacs mode: -*- cperl -*-
   2
   3 package test;
   4
   5 =head1 NAME
   6
   7 test - tools for helping in test suites (not including running externalprograms).
   8
   9 =head1 SYNOPSIS
  10
  11   use FindBin               1.42 qw( $Bin );
  12   use Test                  1.13 qw( ok plan );
  13
  14   BEGIN { unshift @INC, $Bin };
  15
  16   use test                  qw(   evcheck runcheck );
  17
  18   BEGIN {
  19     plan tests  => 3,
  20          todo   => [],
  21          ;
  22   }
  23
  24   ok evcheck(sub {
  25                open my $fh, '>', 'foo';
  26                print $fh "$_\n"
  27                  for 'Bulgaria', 'Cholet';
  28                close $fh;
  29              }, 'write foo'), 1, 'write foo';
  30
  31   save_output('stderr', *STDERR{IO});
  32   warn 'Hello, Mum!';
  33   print restore_output('stderr');
  34
  35 =head1 DESCRIPTION
  36
  37 This package provides some variables, and sets up an environment, for test
  38 scripts, such as those used in F<t/>.
  39
  40 This package does not including running external programs; that is provided by
  41 C<test2.pm>.  This is so that suites not needing that can include only
  42 test.pm, and so not require the presence of C<IPC::Run>.
  43
  44 Setting up the environment includes:
  45
  46 =over 4
  47
  48 =item Prepending F<blib/script> onto the path
  49
  50 =item Pushing the module F<lib/> dir onto the @INC var
  51
  52 For internal C<use> calls.
  53
  54 =item Changing directory to a temporary directory
  55
  56 To avoid cluttering the local dir, and/or allowing the local directory
  57 structure to affect matters.
  58
  59 =item Cleaning up the temporary directory afterwards
  60
  61 Unless TEST_DEBUG is set in the environment.
  62
  63 =back
  64
  65 =cut
  66
  67 # ----------------------------------------------------------------------------
  68
  69 # Pragmas -----------------------------
  70
  71 use 5.00503;
  72 use strict;
  73 use vars qw( @EXPORT_OK );
  74
  75 # Inheritance -------------------------
  76
  77 use base qw( Exporter );
  78
  79 =head2 EXPORTS
  80
  81 The following symbols are exported upon request:
  82
  83 =over 4
  84
  85 =item compare
  86
  87 =item evcheck
  88
  89 =item save_output
  90
  91 =item restore_output
  92
  93 =item tmpnam
  94
  95 =item tempdir
  96
  97 =item find_exec
  98
  99 =back
 100
 101 =cut
 102
 103 @EXPORT_OK = qw( compare evcheck
 104                  save_output restore_output tempdir tmpnam );
 105
 106 # Utility -----------------------------
 107
 108 use Carp                          qw( carp croak );
 109 use Cwd                      2.01 qw( cwd );
 110 use Env                           qw( PATH );
 111 use Fatal                    1.02 qw( close open seek sysopen unlink );
 112 use Fcntl                    1.03 qw( :DEFAULT );
 113 use File::Basename                qw( basename );
 114 use File::Compare          1.1002 qw( );
 115 use File::Path             1.0401 qw( mkpath rmtree );
 116 use File::Spec                0.6 qw( );
 117 use FindBin                  1.42 qw( $Bin );
 118 use POSIX                    1.02 qw( );
 119 use Test                    1.122 qw( ok skip );
 120
 121 # ----------------------------------------------------------------------------
 122
 123 sub rel2abs {
 124   if ( File::Spec->file_name_is_absolute($_[0]) ) {
 125     return $_[0];
 126   } else {
 127     return File::Spec->catdir(cwd, $_[0]);
 128   }
 129 }
 130
 131 sub min {
 132   croak "Can't min over 0 args!\n"
 133     unless @_;
 134   my $min = $_[0];
 135   for (@_[1..$#_]) {
 136     $min = $_
 137       if $_ < $min;
 138   }
 139
 140   return $min;
 141 }
 142
 143 # -------------------------------------
 144 # PACKAGE CONSTANTS
 145 # -------------------------------------
 146
 147 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
 148
 149 sub find_exec {
 150   my ($exec) = @_;
 151
 152   for (split /:/, $PATH) {
 153     my $try = File::Spec->catfile($_, $exec);
 154     return rel2abs($try)
 155       if -x $try;
 156   }
 157   return;
 158 }
 159
 160 # -------------------------------------
 161 # PACKAGE ACTIONS
 162 # -------------------------------------
 163
 164 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
 165
 166 $_ = rel2abs($_)
 167   for @INC;
 168
 169 my $tmpdn = tempdir();
 170 $| = 1;
 171
 172 mkpath $tmpdn;
 173 die "Couldn't create temp dir: $tmpdn: $!\n"
 174   unless -r $tmpdn and -w $tmpdn and -x $tmpdn and -o $tmpdn and -d $tmpdn;
 175
 176 #@INC = map rel2abs($_), @INC;
 177 chdir $tmpdn;
 178
 179 # -------------------------------------
 180 # PACKAGE FUNCTIONS
 181 # -------------------------------------
 182
 183 =head2 evcheck
 184
 185 Eval code, return status
 186
 187 =over 4
 188
 189 =item ARGUMENTS
 190
 191 =over 4
 192
 193 =item code
 194
 195 Coderef to eval
 196
 197 =item name
 198
 199 Name to use in error messages
 200
 201 =back
 202
 203 =item RETURNS
 204
 205 =over 4
 206
 207 =item okay
 208
 209 1 if eval was okay, 0 if not.
 210
 211 =back
 212
 213 =back
 214
 215 =cut
 216
 217 sub evcheck {
 218   my ($code, $name) = @_;
 219
 220   my $ok = 0;
 221
 222   eval {
 223     &$code;
 224     $ok = 1;
 225   }; if ( $@ ) {
 226     carp "Code $name failed: $@\n"
 227       if $ENV{TEST_DEBUG};
 228     $ok = 0;
 229   }
 230
 231   return $ok;
 232 }
 233
 234 # -------------------------------------
 235
 236 =head2 save_output
 237
 238 Redirect a filehandle to temporary storage for later examination.
 239
 240 =over 4
 241
 242 =item ARGUMENTS
 243
 244 =over 4
 245
 246 =item name
 247
 248 Name to store as (used in L<restore_output>)
 249
 250 =item filehandle
 251
 252 The filehandle to save
 253
 254 =back
 255
 256 =cut
 257
 258 # Map from names to saved filehandles.
 259
 260 # Values are arrayrefs, being filehandle that was saved (to restore), the
 261 # filehandle being printed to in the meantime, and the original filehandle.
 262 # This may be treated as a stack; to allow multiple saves... push & pop this
 263 # stack.
 264
 265 my %grabs;
 266
 267 sub save_output {
 268   croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
 269     unless @_ == 2;
 270   my ($name, $filehandle) = @_;
 271
 272   my $tmpfh  = do { local *F; *F; };
 273   my $savefh = do { local *F; *F; };
 274
 275   (undef, $tmpfh) = test::tmpnam();
 276   select((select($tmpfh), $| = 1)[0]);
 277
 278   open $savefh, '>&' . fileno $filehandle
 279     or die "can't dup $name: $!";
 280   open $filehandle, '>&' . fileno $tmpfh
 281     or die "can't open $name to tempfile: $!";
 282
 283   push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
 284 }
 285
 286 # -------------------------------------
 287
 288 =head2 restore_output
 289
 290 Restore a saved filehandle to its original state, return the saved output.
 291
 292 =over 4
 293
 294 =item ARGUMENTS
 295
 296 =over 4
 297
 298 =item name
 299
 300 Name of the filehandle to restore (as passed to L<save_output>).
 301
 302 =back
 303
 304 =item RETURNS
 305
 306 =over 4
 307
 308 =item saved_string
 309
 310 A single string being the output saved.
 311
 312 =back
 313
 314 =cut
 315
 316 sub restore_output {
 317   my ($name) = @_;
 318
 319   croak "$name has not been saved\n"
 320     unless exists $grabs{$name};
 321   croak "All saved instances of $name have been restored\n"
 322     unless @{$grabs{$name}};
 323   my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3;
 324
 325   close $origfh
 326     or die "cannot close $name opened to tempfile: $!";
 327   open  $origfh, '>&' . fileno $savefh
 328     or die "cannot dup $name back again: $!";
 329   select((select($origfh), $| = 1)[0]);
 330
 331   seek $tmpfh, 0, 0;
 332   local $/ = undef;
 333   my $string = <$tmpfh>;
 334   close $tmpfh;
 335
 336   return $string;
 337 }
 338
 339 sub _test_save_restore_output {
 340   warn "to stderr 1\n";
 341   save_output("stderr", *STDERR{IO});
 342   warn "Hello, Mum!";
 343   print 'SAVED:->:', restore_output("stderr"), ":<-\n";
 344   warn "to stderr 2\n";
 345 }
 346
 347 # -------------------------------------
 348
 349 =head2 tmpnam
 350
 351 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
 352 if TEST_DEBUG has SAVE in the value.
 353
 354 =over 4
 355
 356 =item ARGUMENTS
 357
 358 =over 4
 359
 360 =item name
 361
 362 I<Optional>.  If defined, a name by which to refer to the tmpfile in user
 363 messages.
 364
 365 =back
 366
 367 =item RETURNS
 368
 369 =over 4
 370
 371 =item filename
 372
 373 Name of temporary file.
 374
 375 =item fh
 376
 377 Open filehandle to temp file, in r/w mode.  Only created & returned in list
 378 context.
 379
 380 =back
 381
 382 =back
 383
 384 =cut
 385
 386 my @tmpfns;
 387
 388 BEGIN {
 389   my $savewarn = $SIG{__WARN__};
 390   # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
 391   local $SIG{__WARN__} =
 392     sub {
 393       $savewarn->(@_)
 394         if defined $savewarn                        and
 395            UNIVERSAL::isa($savewarn,'CODE')         and
 396            $_[0] !~ /^Subroutine tmpnam redefined/;
 397     };
 398
 399   *tmpnam = sub {
 400     my $tmpnam = POSIX::tmpnam;
 401
 402     if (@_) {
 403       push @tmpfns, [ $tmpnam, $_[0] ];
 404     } else {
 405       push @tmpfns, $tmpnam;
 406     }
 407
 408     if (wantarray) {
 409       sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
 410       return $tmpnam, $tmpfh;
 411     } else {
 412       return $tmpnam;
 413     }
 414   }
 415 }
 416
 417 END {
 418   if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 419     for (@tmpfns) {
 420       if ( ref $_ ) {
 421         printf "Used temp file: %s (%s)\n", @$_;
 422       } else {
 423         print "Used temp file: $_\n";
 424       }
 425     }
 426   } else {
 427     unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
 428       if @tmpfns;
 429   }
 430 }
 431
 432 # -------------------------------------
 433
 434 =head2 tempdir
 435
 436 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
 437 if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
 438
 439 =over 4
 440
 441 =item ARGUMENTS
 442
 443 I<None>
 444
 445 =item RETURNS
 446
 447 =over 4
 448
 449 =item name
 450
 451 Name of temporary dir.
 452
 453 =back
 454
 455 =back
 456
 457 =cut
 458
 459 my @tmpdirs;
 460 sub tempdir {
 461   my $tempdir = POSIX::tmpnam;
 462   mkdir $tempdir, 0700
 463     or die "Failed to create temporary directory $tempdir: $!\n";
 464
 465   if (@_) {
 466     push @tmpdirs, [ $tempdir, $_[0] ];
 467   } else {
 468     push @tmpdirs, $tempdir;
 469   }
 470
 471   return $tempdir;
 472 }
 473
 474 END {
 475   for (@tmpdirs) {
 476     if ( ref $_ ) {
 477       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 478         printf "Used temp dir: %s (%s)\n", @$_;
 479       } else {
 480         # Solaris gets narky about removing the pwd.
 481         chdir File::Spec->rootdir;
 482         rmtree $_->[0];
 483       }
 484     } else {
 485       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 486         print "Used temp dir: $_\n";
 487       } else {
 488         # Solaris gets narky about removing the pwd.
 489         chdir File::Spec->rootdir;
 490         rmtree $_;
 491       }
 492     }
 493   }
 494 }
 495
 496 # -------------------------------------
 497
 498 =head2 compare
 499
 500   compare(+{ fn1 => $fn1, fn2 => $fn2, gzip => 1 });
 501
 502 This performs one test.
 503
 504 =over 4
 505
 506 =item ARGUMENTS
 507
 508 A single argument is taken, considered as a hash ref, with the following keys:
 509
 510 In TEST_DEBUG mode, if the files do not compare equal, outputs file info on
 511 STDERR.
 512
 513 =over 4
 514
 515 =item fn1
 516
 517 B<Mandatory>  File to compare
 518
 519 =item fn2
 520
 521 B<Mandatory>  File to compare
 522
 523 =item name
 524
 525 B<Mandatory>  Test name
 526
 527 =item sort
 528
 529 B<Optional> sort files prior to comparison.  Requires the C<sort> command to
 530 be on C<$PATH> (else skips).
 531
 532 =item gunzip
 533
 534 B<Optional> gunzip files prior to comparison.  Requires the C<gzip> command to
 535 be on C<$PATH> (else skips).  gzip occurs prior to any sort.
 536
 537 =item untar
 538
 539 B<Optional> untar files prior to comparison.  Requires the C<tar> command to
 540 be on C<$PATH> (else skips).  any gzip occurs prior to any tar.  Tar files are
 541 considered equal if they each contain the same filenames & each file contained
 542 is equal.  If the sort flag is present, each file is sorted prior to comparison.
 543
 544 =back
 545
 546 =back
 547
 548 =cut
 549
 550 # return codes and old-style call semantics left for backwards compatibility
 551 BEGIN {
 552   my $savewarn = $SIG{__WARN__};
 553   # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
 554   local $SIG{__WARN__} =
 555     sub {
 556       $savewarn->(@_)
 557         if defined $savewarn                        and
 558            UNIVERSAL::isa($savewarn,'CODE')         and
 559            $_[0] !~ /^Subroutine compare redefined/;
 560     };
 561
 562   *compare = sub {
 563     my ($fn1, $fn2, $sort) = @_;
 564     my ($gzip, $tar, $name);
 565     my $notest = 1;
 566
 567     if ( @_ == 1 and UNIVERSAL::isa($_[0], 'HASH') ) {
 568       ($fn1, $fn2, $name, $sort, $gzip, $tar, $notest) =
 569         @{$_[0]}{qw( fn1 fn2 name sort gunzip untar notest )};
 570       my @missing = grep ! defined $_[0]->{$_}, qw( fn1 fn2 name );
 571       carp "Missing mandatory key(s): " . join(', ', @missing) . "\n"
 572         if @missing;
 573     }
 574
 575     my ($name1, $name2) = ($fn1, $fn2);
 576
 577     for ( grep ! defined, $fn1, $fn2 ) {
 578       carp 'Usage: compare({fn1 => $fn1, fn2 => $fn2, name => "some name"})' ."\n"
 579           if $ENV{TEST_DEBUG};
 580       ok 0, 1, $name
 581         unless $notest;
 582       return -8;
 583     }
 584
 585     {
 586       my $err = 0;
 587
 588       for (0..1) {
 589         my $fn = ($name1, $name2)[$_];
 590         if ( ! -e $fn ) {
 591           carp "Does not exist: $fn\n"
 592             if $ENV{TEST_DEBUG};
 593           $err |= 2 ** $_;
 594         } elsif ( ! -r $fn ) {
 595           carp "Cannot read: $fn\n"
 596             if $ENV{TEST_DEBUG};
 597           $err |= 2 ** $_;
 598         }
 599       }
 600
 601       if ( $err ) {
 602         ok 0, 1, $name
 603           unless $notest;
 604         return -$err;
 605       }
 606     }
 607
 608     if ( $gzip ) {
 609       unless ( find_exec('gzip') ) {
 610         print "ok # Skip gzip not found in path\n";
 611         return -16;
 612       }
 613
 614       my $tmp1 = tmpnam;
 615       my $tmp2 = tmpnam;
 616       system "gzip $fn1 -cd > $tmp1"
 617         and croak "gzip $fn1 failed: $?\n";
 618       system "gzip $fn2 -cd > $tmp2"
 619         and croak "gzip $fn2 failed: $?\n";
 620       ($fn1, $fn2) = ($tmp1, $tmp2);
 621     }
 622
 623     if ( $tar ) {
 624       unless ( find_exec('tar') ) {
 625         print "ok # Skip tar not found in path\n";
 626         return -16;
 627       }
 628
 629       local $/ = "\n";
 630       chomp (my @list1 = sort qx( tar tf $fn1 ));
 631       croak "tar tf $fn1 failed with wait status: $?\n"
 632         if $?;
 633       chomp(my @list2 = sort qx( tar tf $fn2 ));
 634       croak "tar tf $fn2 failed with wait status: $?\n"
 635         if $?;
 636
 637       if ( @list2 > @list1 ) {
 638         carp
 639           sprintf("More files (%d) in $name2 than $name1 (%d)\n",
 640                   scalar @list2, scalar @list1)
 641           if $ENV{TEST_DEBUG};
 642         ok @list1, @list2, $name
 643           unless $notest;
 644         return 0;
 645       } elsif ( @list1 > @list2 ) {
 646         carp
 647           sprintf("More files (%d) in $name1 than $name2 (%d)\n",
 648                   scalar @list1, scalar @list2)
 649           if $ENV{TEST_DEBUG};
 650         ok @list1, @list2, $name
 651           unless $notest;
 652         return 0;
 653       }
 654
 655       for (my $i = 0; $i < @list1; $i++) {
 656         if ( $list1[$i] lt $list2[$i] ) {
 657           carp "File $list1[$i] is present in $name1 but not $name2\n"
 658             if $ENV{TEST_DEBUG};
 659           ok $list1[$i], $list2[$i], $name
 660             unless $notest;
 661           return 0;
 662         } elsif ( $list1[$i] gt $list2[$i] ) {
 663           carp "File $list2[$i] is present in $name2 but not $name1\n"
 664             if $ENV{TEST_DEBUG};
 665           ok $list2[$i], $list1[$i], $name
 666             unless $notest;
 667           return 0;
 668         }
 669       }
 670
 671       for my $fn (@list1) {
 672         my $tmp1 = tmpnam;
 673         my $tmp2 = tmpnam;
 674         system "tar -xf $fn1 -O $fn > $tmp1"
 675           and croak "tar -xf $fn1 -O $fn failed: $?\n";
 676         system "tar -xf $fn2 -O $fn > $tmp2"
 677           and croak "tar -xf $fn2 -O $fn failed: $?\n";
 678         my $ok = compare({ fn1    => $tmp1,
 679                            fn2    => $tmp2,
 680                            sort   => $sort,
 681                            notest => 1,
 682                            name   =>
 683                              qq'Subcheck file "$fn" for compare $name1, $name2',
 684                          });
 685         unless ( $ok >= 1 ) {
 686           carp qq'Difference found testing file "$fn" in tars $name1 ($tmp1), $name2 ($tmp2)\n'
 687             if $ENV{TEST_DEBUG};
 688           ok 0, 1, $name
 689             unless $notest;
 690           return 0;
 691         }
 692       }
 693
 694       ok 1, 1, $name
 695         unless $notest;
 696       return 1;
 697     }
 698
 699     if ( $sort ) {
 700       unless ( find_exec('sort') ) {
 701         print "ok # Skip sort not found in path\n";
 702         return -16;
 703       }
 704
 705       my $tmp1 = tmpnam;
 706       my $tmp2 = tmpnam;
 707       system sort => $fn1, -o => $tmp1
 708         and croak "Sort $fn1 failed: $?\n";
 709       system sort => $fn2, -o => $tmp2
 710         and croak "Sort $fn2 failed: $?\n";
 711       ($fn1, $fn2) = ($tmp1, $tmp2);
 712     }
 713
 714     unless ( File::Compare::compare($fn1, $fn2) ) {
 715       ok 1, 1, $name
 716         unless $notest;
 717       return 1;
 718     }
 719
 720     if ( $ENV{TEST_DEBUG} ) {
 721       my $pid = fork;
 722       die "Fork failed: $!\n"
 723         unless defined $pid;
 724
 725       if ( $pid ) { # Parent
 726         my $waitpid = waitpid($pid, 0);
 727         die "Waitpid got: $waitpid (expected $pid)\n"
 728           unless $waitpid == $pid;
 729       } else { # Child
 730         open *STDOUT{IO}, ">&" . fileno STDERR;
 731         # Uniquify file names
 732         my @args = keys %{+{ map {;$_=>1} $name1, $name2, $fn1, $fn2 }};
 733         exec qw(ls -l), @args;
 734       }
 735
 736       my $fh1 = IO::File->new($fn1, O_RDONLY)
 737         or die "Couldn't open $fn1: $!\n";
 738       my $fh2 = IO::File->new($fn2, O_RDONLY)
 739         or die "Couldn't open $fn2: $!\n";
 740
 741       local $/ = "\n";
 742
 743       my $found = 0;
 744       while ( ! $found and my $line1 = <$fh1> ) {
 745         my $line2 = <$fh2>;
 746         if ( ! defined $line2 ) {
 747           print STDERR "$fn2 ended at line: $.\n";
 748           $found = 1;
 749         } elsif ( $line2 ne $line1 ) {
 750           my $maxlength = max(map length($_), $line1, $line2);
 751           my $minlength = min(map length($_), $line1, $line2);
 752
 753           my @diffchars = grep(substr($line1, $_, 1) ne substr($line2, $_, 1),
 754                                0..$minlength-1);
 755           my $diff = ' ' x $minlength;
 756           substr($diff, $_, 1) = '|'
 757             for @diffchars;
 758
 759           my @extrachars, map((length($line1) > length($line2) ? '^' : 'v'),
 760                               $minlength..$maxlength-1);
 761
 762           $diff = join '', $diff, @extrachars;
 763
 764           my $diff_count  = @diffchars;
 765           my $extra_count = @extrachars;
 766
 767           print STDERR <<"END";
 768 Difference at line $. ($diff_count characters differ) (top line is $extra_count chars longer):
 769 $name1:
 770 -->$line1<--
 771    $diff
 772 -->$line2<--
 773 $name2:
 774 Differing characters at positions @{[join ',',@diffchars]} (zero-based)
 775 END
 776           $found = 1;
 777         }
 778       }
 779
 780       if ( ! $found ) {
 781         my $line2 = <$fh2>;
 782         if ( defined $line2 ) {
 783           print STDERR "$name1 ended before line: $.\n";
 784         } else {
 785           print STDERR "Difference between $name1, $name2 not found!\n";
 786         }
 787       }
 788
 789       close $fh1;
 790       close $fh2;
 791     }
 792
 793     ok 0, 1, $name
 794       unless $notest;
 795     return 0;
 796   }
 797 }
 798
 799 # -------------------------------------
 800
 801 =head2 find_exec
 802
 803 =over 4
 804
 805 =item ARGUMENTS
 806
 807 =over 4
 808
 809 =item proggie
 810
 811 The name of the program
 812
 813 =back
 814
 815 =item RETURNS
 816
 817 =over 4
 818
 819 =item path
 820
 821 The path to the first executable file with the given name on C<$PATH>.  Or
 822 nothing, if no such file exists.
 823
 824 =back
 825
 826 =back
 827
 828 =cut
 829
 830 # defined further up to use in constants
 831
 832 # ----------------------------------------------------------------------------
 833
 834 =head1 EXAMPLES
 835
 836 Z<>
 837
 838 =head1 BUGS
 839
 840 Z<>
 841
 842 =head1 REPORTING BUGS
 843
 844 Email the author.
 845
 846 =head1 AUTHOR
 847
 848 Martyn J. Pearce C<fluffy@cpan.org>
 849
 850 =head1 COPYRIGHT
 851
 852 Copyright (c) 2001, 2002, 2004 Martyn J. Pearce.  This program is free
 853 software; you can redistribute it and/or modify it under the same terms as
 854 Perl itself.
 855
 856 =head1 SEE ALSO
 857
 858 Z<>
 859
 860 =cut
 861
 862 1; # keep require happy.
 863
 864 __END__