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