TestInit.pm

   1 # This is a replacement for the old BEGIN preamble which heads (or
   2 # should head) up every core test program to prepare it for running.
   3 # Now instead of:
   4 #
   5 # BEGIN {
   6 #   chdir 't' if -d 't';
   7 #   @INC = '../lib';
   8 # }
   9 #
  10 # Its primary purpose is to clear @INC so core tests don't pick up
  11 # modules from an installed Perl.
  12 #
  13 # t/TEST will use -MTestInit.  You may "use TestInit" in the test
  14 # programs but it is not required.
  15 #
  16 # P.S. This documentation is not in POD format in order to avoid
  17 # problems when there are fundamental bugs in perl.
  18
  19 package TestInit;
  20
  21 $VERSION = 1.04;
  22
  23 # Let tests know they're running in the perl core.  Useful for modules
  24 # which live dual lives on CPAN.
  25 # Don't interfere with the taintedness of %ENV, this could perturbate tests.
  26 # This feels like a better solution than the original, from
  27 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2003-07/msg00154.html
  28 $ENV{PERL_CORE} = $^X;
  29
  30 $0 =~ s/\.dp$//; # for the test.deparse make target
  31
  32 sub import {
  33     my $self = shift;
  34     my @up_2_t = ('../../lib', '../../t');
  35     my ($abs, $chdir, $setopt);
  36     foreach (@_) {
  37         if ($_ eq 'U2T') {
  38             @INC = @up_2_t;
  39             $setopt = 1;
  40         } elsif ($_ eq 'U1') {
  41             @INC = '../lib';
  42             $setopt = 1;
  43         } elsif ($_ eq 'NC') {
  44             delete $ENV{PERL_CORE}
  45         } elsif ($_ eq 'A') {
  46             $abs = 1;
  47         } elsif ($_ eq 'T') {
  48             $chdir = '..'
  49                 unless -f 't/TEST' && -f 'MANIFEST' && -d 'lib' && -d 'ext';
  50             @INC = 'lib';
  51             $setopt = 1;
  52         } else {
  53             die "Unknown option '$_'";
  54         }
  55     }
  56
  57     # Need to default. This behaviour is consistent with previous behaviour,
  58     # as the equivalent of this code used to be run at the top level, hence
  59     # would happen (unconditionally) before import() was called.
  60     unless ($setopt) {
  61         if (-f 't/TEST' && -f 'MANIFEST' && -d 'lib' && -d 'ext') {
  62             # We're being run from the top level. Try to change directory, and
  63             # set things up correctly. This is a 90% solution, but for
  64             # hand-running tests, that's good enough
  65             if ($0 =~ s!^((?:ext|dist|cpan)[\\/][^\\/]+)[\\/](.*\.t)$!$2!) {
  66                 # Looks like a test in ext.
  67                 $chdir = $1;
  68                 @INC = @up_2_t;
  69                 $setopt = 1;
  70                 $^X =~ s!^\.([\\/])!..$1..$1!;
  71             } else {
  72                 $chdir = 't';
  73                 @INC = '../lib';
  74                 $setopt = $0 =~ m!^lib/!;
  75             }
  76         } else {
  77             # (likely) we're being run by t/TEST or t/harness, and we're a test
  78             # in t/
  79             @INC = '../lib';
  80         }
  81     }
  82
  83     if (defined $chdir) {
  84         chdir $chdir or die "Can't chdir '$chdir': $!";
  85     }
  86
  87     if ($abs) {
  88         require File::Spec::Functions;
  89         # Forcibly untaint this.
  90         @INC = map { $_ = File::Spec::Functions::rel2abs($_); /(.*)/; $1 } @INC;
  91         $^X = File::Spec::Functions::rel2abs($^X);
  92     }
  93
  94     if ($setopt) {
  95         my $sep;
  96         if ($^O eq 'VMS') {
  97             $sep = '|';
  98         } elsif ($^O eq 'MSWin32') {
  99             $sep = ';';
 100         } else {
 101             $sep = ':';
 102         }
 103
 104         my $lib = join $sep, @INC;
 105         if (exists $ENV{PERL5LIB}) {
 106             $ENV{PERL5LIB} = $lib . substr $ENV{PERL5LIB}, 0, 0;
 107         } else {
 108             $ENV{PERL5LIB} = $lib;
 109         }
 110     }
 111
 112     push @INC, '.' unless ${^TAINT};
 113 }
 114
 115 1;