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