develooper Front page | perl.perl5.porters | Postings from October 2003

[PATCH 5.8.2 @21574] make tests relocatable

Thread Next
From:
Ilya Zakharevich
Date:
October 31, 2003 01:49
Subject:
[PATCH 5.8.2 @21574] make tests relocatable
Message ID:
20031031094825.GA27776@math.berkeley.edu
Running the following script in the root of Perl distribution will fix most of
the tests in ./t to be relocatable.  All it does is replace

  @INC = '../lib';	# and some clones thereof

by

  @INC = '../lib' unless \$ENV{PERLTEST_KEEP_INC};

The patch which follows the script updates the tests tools for a run from a
different directory.

Few tests need some manual interaction.  [Also: the logic to run tainted tests
needs some minor update too to enable PERL5LIB support if one wants to test
uninstalled Perl.]

Enjoy,
Ilya

#!/usr/bin/perl -w
# sub {} was generated
# pfind -debug t /\.t$/ "=~ s,^(\s*\@INC\s*=\s*((qw)?\(\s*)?'?(\.\s+)?../lib(\s+\.)?'?(\s*\)?)\s*);\s*$,$1 unless \$ENV{PERLTEST_KEEP_INC};\n,"

use strict;
use File::Find 'find';
my $bak = '.bak';

my ($InterActiveProc, $Line_Found);

sub prt { 
  print "$File::Find::name\n";
}

sub do_rename {
  my ($from, $to) = @_;
  print STDERR "rename `$File::Find::dir/$from'\t===> `$File::Find::dir/$to'\n";
  rename $from, $to
    or warn("Cannot rename: $!\n"), return 0;
}

sub setup_bak {
  my ($file,$bak) = @_;
  return unless -e "$file$bak";
  my ($prefix,$count,$i) = ("", $bak, 0);
  unless ($bak =~ /^\w+\d+$/) {
    ($prefix,$count) = ($bak, 0);
  }
  $count++, $i++ while $i < 1000 and -e "$file$prefix$count";
  die "Cannot find backup name for '$file'\n" if $i >= 1000;
  die "Exiting...\n" unless do_rename "$file$bak", "$file$prefix$count";
}

find sub {
  my $name = $File::Find::name;
  my $dir  = $File::Find::dir;
  my $was = $_;
  my ($line, $found);

  
  my ($dev,$inode,$Mode) = CORE::stat($_);
  return unless	do {	/\.t$/		}  ;
  return unless -f _ and -r _ and -T _;
  (print STDERR "$name is not writable\n"), return unless -w _;
  {
    my $FileName = $_;
    my $found = 0;
    $FileName =~ s|^(\s)|./$1|; 
    my $openfile = $FileName;
    $openfile =~ s/(\s)$/$1\0/;
    open(FILE, "< $openfile") or die "cannot open '$name': $!";
    local $_;
    $InterActiveProc = \&dummy_inter;  # no interaction in the following loop
    1 while defined ($_ = <FILE>) and not ($found =  s,^(\s*\@INC\s*=\s*((qw)?\(\s*)?'?(\.\s+)?../lib(\s+\.)?'?(\s*\)?)\s*);\s*$,$1 unless \$ENV{PERLTEST_KEEP_INC};\n,);
    if ( $found ) { 
      close FILE or die "cannot close '$name' for write: $!"; 
      setup_bak($FileName, $bak);
      File::Copy::syscopy $FileName, "$FileName$bak"
	or die "cannot copy '$name' to '$name$bak': $!";
      open (FILE, "< $FileName$bak");
      open(OUTPUT, "+< $openfile") and truncate OUTPUT, 0
	or die "cannot open '$name' for write: $!";
      
      $InterActiveProc = \&real_inter; # now real interaction
      while (<FILE>) {  s,^(\s*\@INC\s*=\s*((qw)?\(\s*)?'?(\.\s+)?../lib(\s+\.)?'?(\s*\)?)\s*);\s*$,$1 unless \$ENV{PERLTEST_KEEP_INC};\n,; print OUTPUT; }
      close OUTPUT or die "cannot close $name: $!";
      ;
      $FileName .= $bak;
    }
    $Line_Found = $line if $found;
    close FILE or die "cannot close '$name': $!";
    return unless $found;
  }
  ;
    ;
  prt;
}, 't';

__END__

--- ./t/TEST-pre	Fri Sep  5 15:04:12 2003
+++ ./t/TEST	Fri Oct 31 01:12:18 2003
@@ -89,11 +89,16 @@ sub _quote_args {
     return $argstring;
 }
 
+sub in_test_dir ($) {
+    return shift unless $ENV{PERLTEST_DIR};
+    File::Spec->catdir($ENV{PERLTEST_DIR}, shift);
+}
+
 unless (@ARGV) {
     foreach my $dir (qw(base comp cmd run io op uni)) {
-        _find_tests($dir);
+        _find_tests(in_test_dir $dir);
     }
-    _find_tests("lib") unless $core;
+    _find_tests(in_test_dir "lib") unless $core;
     my $mani = File::Spec->catfile($updir, "MANIFEST");
     if (open(MANI, $mani)) {
         while (<MANI>) { # similar code in t/harness
@@ -112,9 +117,9 @@ unless (@ARGV) {
         warn "$0: cannot open $mani: $!\n";
     }
     unless ($core) {
-	_find_tests('pod');
-	_find_tests('x2p');
-	_find_tests('japh') if $torture;
+	_find_tests(in_test_dir 'pod');
+	_find_tests(in_test_dir 'x2p');
+	_find_tests(in_test_dir 'japh') if $torture;
     }
 }
 
--- ./t/TestInit.pm-pre	Wed Aug 13 23:52:38 2003
+++ ./t/TestInit.pm	Fri Oct 31 01:17:32 2003
@@ -18,7 +18,7 @@ package TestInit;
 $VERSION = 1.01;
 
 chdir 't' if -d 't';
-@INC = '../lib';
+@INC = '../lib' unless $ENV{PERLTEST_KEEP_INC};
 
 # Don't interfere with the taintedness of %ENV, this could perturbate tests
 $ENV{PERL_CORE} = 1 unless ${^TAINT};

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About