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