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