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