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 #
   4 # BEGIN {
   5 #   chdir 't' if -d 't';
   6 #   @INC = '../lib';
   7 # }
   8 #
   9 # Its primary purpose is to clear @INC so core tests don't pick up
  10 # modules from an installed Perl.
  11 #
  12 # t/TEST and t/harness will invoke each test script with
  13 #      perl -MTestInit[=arg,arg,..] some/test.t
  14 # You may "use TestInit" in the test # programs but it is not required.
  15 #
  16 # TestInit will completely empty the current @INC and replace it with
  17 # new entries based on the args:
  18 #
  19 #    U2T: adds ../../lib and ../../t;
  20 #    U1:  adds ../lib;
  21 #    T:   adds lib  and chdir's to the top-level directory.
  22 #
  23 # In the absence of any of the above options, it chdir's to
  24 #  t/ or cpan/Foo-Bar/ etc as appropriate and correspondingly
  25 #  sets @INC to (../lib) or ( ../../lib, ../../t)
  26 #
  27 # In addition,
  28 #
  29 #   A:   converts any added @INC entries to absolute paths;
  30 #   NC:  unsets $ENV{PERL_CORE};
  31 #   DOT: unconditionally appends '.' to @INC.
  32 #
  33 # Any trailing '.' in @INC present on entry will be preserved.
  34 #
  35 # P.S. This documentation is not in POD format in order to avoid
  36 # problems when there are fundamental bugs in perl.
  37
  38 package TestInit;
  39
  40 $VERSION = 1.04;
  41
  42 # Let tests know they're running in the perl core.  Useful for modules
  43 # which live dual lives on CPAN.
  44 # Don't interfere with the taintedness of %ENV, this could perturbate tests.
  45 # This feels like a better solution than the original, from
  46 # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2003-07/msg00154.html
  47 $ENV{PERL_CORE} = $^X;
  48
  49 $0 =~ s/\.dp$//; # for the test.deparse make target
  50
  51 my $add_dot = (@INC && $INC[-1] eq '.'); # preserve existing,
  52
  53 sub import {
  54     my $self = shift;
  55     my @up_2_t = ('../../lib', '../../t');
  56     my ($abs, $chdir, $setopt);
  57     foreach (@_) {
  58         if ($_ eq 'U2T') {
  59             @INC = @up_2_t;
  60             $setopt = 1;
  61         } elsif ($_ eq 'U1') {
  62             @INC = '../lib';
  63             $setopt = 1;
  64         } elsif ($_ eq 'NC') {
  65             delete $ENV{PERL_CORE}
  66         } elsif ($_ eq 'A') {
  67             $abs = 1;
  68         } elsif ($_ eq 'T') {
  69             $chdir = '..'
  70                 unless -f 't/TEST' && -f 'MANIFEST' && -d 'lib' && -d 'ext';
  71             @INC = 'lib';
  72             $setopt = 1;
  73         } elsif ($_ eq 'DOT') {
  74             $add_dot = 1;
  75         } else {
  76             die "Unknown option '$_'";
  77         }
  78     }
  79
  80     # Need to default. This behaviour is consistent with previous behaviour,
  81     # as the equivalent of this code used to be run at the top level, hence
  82     # would happen (unconditionally) before import() was called.
  83     unless ($setopt) {
  84         if (-f 't/TEST' && -f 'MANIFEST' && -d 'lib' && -d 'ext') {
  85             # We're being run from the top level. Try to change directory, and
  86             # set things up correctly. This is a 90% solution, but for
  87             # hand-running tests, that's good enough
  88             if ($0 =~ s!^((?:ext|dist|cpan)[\\/][^\\/]+)[\\/](.*\.t)$!$2!) {
  89                 # Looks like a test in ext.
  90                 $chdir = $1;
  91                 @INC = @up_2_t;
  92                 $setopt = 1;
  93                 $^X =~ s!^\.([\\/])!..$1..$1!;
  94             } else {
  95                 $chdir = 't';
  96                 @INC = '../lib';
  97                 $setopt = $0 =~ m!^lib/!;
  98             }
  99         } else {
 100             # (likely) we're being run by t/TEST or t/harness, and we're a test
 101             # in t/
 102             if (defined &DynaLoader::boot_DynaLoader) {
 103                 @INC = '../lib';
 104             }
 105             else {
 106                 # miniperl/minitest
 107                 # t/TEST does not supply -I../lib, so buildcustomize.pl is
 108                 # not automatically included.
 109                 unshift @INC, '../lib';
 110                 do "../lib/buildcustomize.pl";
 111             }
 112         }
 113     }
 114
 115     if (defined $chdir) {
 116         chdir $chdir or die "Can't chdir '$chdir': $!";
 117     }
 118
 119     if ($abs) {
 120         require File::Spec::Functions;
 121         # Forcibly untaint this.
 122         @INC = map { $_ = File::Spec::Functions::rel2abs($_); /(.*)/; $1 } @INC;
 123         $^X = File::Spec::Functions::rel2abs($^X);
 124     }
 125
 126     if ($setopt) {
 127         my $sep;
 128         if ($^O eq 'VMS') {
 129             $sep = '|';
 130         } elsif ($^O eq 'MSWin32') {
 131             $sep = ';';
 132         } else {
 133             $sep = ':';
 134         }
 135
 136         my $lib = join $sep, @INC;
 137         if (exists $ENV{PERL5LIB}) {
 138             $ENV{PERL5LIB} = $lib . substr $ENV{PERL5LIB}, 0, 0;
 139         } else {
 140             $ENV{PERL5LIB} = $lib;
 141         }
 142     }
 143
 144     push @INC, '.' if $add_dot;
 145 }
 146
 147 1;