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