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