lib/CPANPLUS/t/inc/conf.pl

   1 ### On VMS, the ENV is not reset after the program terminates.
   2 ### So reset it here explicitly
   3 my ($old_env_path, $old_env_perl5lib);
   4 BEGIN {
   5     use FindBin;
   6     use File::Spec;
   7
   8     ### paths to our own 'lib' and 'inc' dirs
   9     ### include them, relative from t/
  10     my @paths   = map { "$FindBin::Bin/$_" } qw[../lib inc];
  11
  12     ### absolute'ify the paths in @INC;
  13     my @rel2abs = map { File::Spec->rel2abs( $_ ) }
  14                     grep { not File::Spec->file_name_is_absolute( $_ ) } @INC;
  15
  16     ### use require to make devel::cover happy
  17     require lib;
  18     for ( @paths, @rel2abs ) {
  19         my $l = 'lib';
  20         $l->import( $_ )
  21     }
  22
  23     use Config;
  24
  25     ### and add them to the environment, so shellouts get them
  26     $old_env_perl5lib = $ENV{'PERL5LIB'};
  27     $ENV{'PERL5LIB'}  = join ':',
  28                         grep { defined } $ENV{'PERL5LIB'}, @paths, @rel2abs;
  29
  30     ### add our own path to the front of $ENV{PATH}, so that cpanp-run-perl
  31     ### and friends get picked up
  32     $old_env_path = $ENV{PATH};
  33     $ENV{'PATH'}  = join $Config{'path_sep'},
  34                     grep { defined } "$FindBin::Bin/../bin", $ENV{'PATH'};
  35
  36     ### Fix up the path to perl, as we're about to chdir
  37     ### but only under perlcore, or if the path contains delimiters,
  38     ### meaning it's relative, but not looked up in your $PATH
  39     $^X = File::Spec->rel2abs( $^X )
  40         if $ENV{PERL_CORE} or ( $^X =~ m|[/\\]| );
  41
  42     ### chdir to our own test dir, so we know all files are relative
  43     ### to this point, no matter whether run from perlcore tests or
  44     ### regular CPAN installs
  45     chdir "$FindBin::Bin" if -d "$FindBin::Bin"
  46 }
  47
  48 BEGIN {
  49     use IPC::Cmd;
  50
  51     ### Win32 has issues with redirecting FD's properly in IPC::Run:
  52     ### Can't redirect fd #4 on Win32 at IPC/Run.pm line 2801
  53     $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32';
  54     $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32';
  55 }
  56
  57 ### Use a $^O comparison, as depending on module at this time
  58 ### may cause weird errors/warnings
  59 END {
  60     if ($^O eq 'VMS') {
  61         ### VMS environment variables modified by this test need to be put back
  62         ### path is "magic" on VMS, we can not tell if it really existed before
  63         ### this was run, because VMS will magically pretend that a PATH
  64         ### environment variable exists set to the current working directory
  65         $ENV{PATH} = $old_path;
  66
  67         if (defined $old_perl5lib) {
  68             $ENV{PERL5LIB} = $old_perl5lib;
  69         } else {
  70             delete $ENV{PERL5LIB};
  71         }
  72     }
  73 }
  74
  75 use strict;
  76 use CPANPLUS::Configure;
  77 use CPANPLUS::Error ();
  78
  79 use File::Path      qw[rmtree];
  80 use FileHandle;
  81 use File::Basename  qw[basename];
  82
  83 {   ### Force the ignoring of .po files for L::M::S
  84     $INC{'Locale::Maketext::Lexicon.pm'} = __FILE__;
  85     $Locale::Maketext::Lexicon::VERSION = 0;
  86 }
  87
  88 my $Env = 'PERL5_CPANPLUS_TEST_VERBOSE';
  89
  90 # prereq has to be in our package file && core!
  91 use constant TEST_CONF_PREREQ           => 'Cwd';
  92 use constant TEST_CONF_MODULE           => 'Foo::Bar::EU::NOXS';
  93 use constant TEST_CONF_AUTHOR           => 'EUNOXS';
  94 use constant TEST_CONF_INST_MODULE      => 'Foo::Bar';
  95 use constant TEST_CONF_INVALID_MODULE   => 'fnurk';
  96 use constant TEST_CONF_MIRROR_DIR       => 'dummy-localmirror';
  97 use constant TEST_CONF_CPAN_DIR         => 'dummy-CPAN';
  98
  99 ### we might need this Some Day when we're installing into
 100 ### our own sandbox. see t/20.t for details
 101 # use constant TEST_INSTALL_DIR       => do {
 102 #     my $dir = File::Spec->rel2abs( 'dummy-perl' );
 103 #
 104 #     ### clean up paths if we are on win32
 105 #     ### dirs with spaces will be.. bad :(
 106 #     $^O eq 'MSWin32'
 107 #         ? Win32::GetShortPathName( $dir )
 108 #         : $dir;
 109 # };
 110
 111 # use constant TEST_INSTALL_DIR_LIB
 112 #     => File::Spec->catdir( TEST_INSTALL_DIR, 'lib' );
 113 # use constant TEST_INSTALL_DIR_BIN
 114 #     => File::Spec->catdir( TEST_INSTALL_DIR, 'bin' );
 115 # use constant TEST_INSTALL_DIR_MAN1
 116 #     => File::Spec->catdir( TEST_INSTALL_DIR, 'man', 'man1' );
 117 # use constant TEST_INSTALL_DIR_MAN3
 118 #     => File::Spec->catdir( TEST_INSTALL_DIR, 'man', 'man3' );
 119 # use constant TEST_INSTALL_DIR_ARCH
 120 #     => File::Spec->catdir( TEST_INSTALL_DIR, 'arch' );
 121 #
 122 # use constant TEST_INSTALL_EU_MM_FLAGS =>
 123 #     ' INSTALLDIRS=site' .
 124 #     ' INSTALLSITELIB='     . TEST_INSTALL_DIR_LIB .
 125 #     ' INSTALLSITEARCH='    . TEST_INSTALL_DIR_ARCH .    # .packlist
 126 #     ' INSTALLARCHLIB='     . TEST_INSTALL_DIR_ARCH .    # perllocal.pod
 127 #     ' INSTALLSITEBIN='     . TEST_INSTALL_DIR_BIN .
 128 #     ' INSTALLSCRIPT='      . TEST_INSTALL_DIR_BIN .
 129 #     ' INSTALLSITEMAN1DIR=' . TEST_INSTALL_DIR_MAN1 .
 130 #     ' INSTALLSITEMAN3DIR=' . TEST_INSTALL_DIR_MAN3;
 131
 132
 133 sub gimme_conf {
 134
 135     ### don't load any other configs than the heuristic one
 136     ### during tests. They might hold broken/incorrect data
 137     ### for our test suite. Bug [perl #43629] showed this.
 138     my $conf = CPANPLUS::Configure->new( load_configs => 0 );
 139     $conf->set_conf( hosts  => [ {
 140                         path        => File::Spec->rel2abs(TEST_CONF_CPAN_DIR),
 141                         scheme      => 'file',
 142                     } ],
 143     );
 144     $conf->set_conf( base       => 'dummy-cpanplus' );
 145     $conf->set_conf( dist_type  => '' );
 146     $conf->set_conf( signature  => 0 );
 147     $conf->set_conf( verbose    => 1 ) if $ENV{ $Env };
 148
 149     ### never use a pager in the test suite
 150     $conf->set_program( pager   => '' );
 151
 152     ### dmq tells us that we should run with /nologo
 153     ### if using nmake, as it's very noise otherwise.
 154     {   my $make = $conf->get_program('make');
 155         if( $make and basename($make) =~ /^nmake/i and
 156             $make !~ m|/nologo|
 157         ) {
 158             $make .= ' /nologo';
 159             $conf->set_program( make => $make );
 160         }
 161     }
 162
 163     _clean_test_dir( [
 164         $conf->get_conf('base'),
 165         TEST_CONF_MIRROR_DIR,
 166 #         TEST_INSTALL_DIR_LIB,
 167 #         TEST_INSTALL_DIR_BIN,
 168 #         TEST_INSTALL_DIR_MAN1,
 169 #         TEST_INSTALL_DIR_MAN3,
 170     ], (  $ENV{PERL_CORE} ? 0 : 1 ) );
 171
 172     return $conf;
 173 };
 174
 175 {
 176     my $fh;
 177     my $file = ".".basename($0).".output";
 178     sub output_handle {
 179         return $fh if $fh;
 180
 181         $fh = FileHandle->new(">$file")
 182                     or warn "Could not open output file '$file': $!";
 183
 184         $fh->autoflush(1);
 185         return $fh;
 186     }
 187
 188     sub output_file { return $file }
 189
 190
 191
 192     ### redirect output from msg() and error() output to file
 193     unless( $ENV{$Env} ) {
 194
 195         print "# To run tests in verbose mode, set ".
 196               "\$ENV{$Env} = 1\n" unless $ENV{PERL_CORE};
 197
 198         1 while unlink $file;   # just in case
 199
 200         $CPANPLUS::Error::ERROR_FH  =
 201         $CPANPLUS::Error::ERROR_FH  = output_handle();
 202
 203         $CPANPLUS::Error::MSG_FH    =
 204         $CPANPLUS::Error::MSG_FH    = output_handle();
 205
 206     }
 207 }
 208
 209
 210 ### clean these files if we're under perl core
 211 END {
 212     if ( $ENV{PERL_CORE} ) {
 213         close output_handle(); 1 while unlink output_file();
 214
 215         _clean_test_dir( [
 216             gimme_conf->get_conf('base'),
 217             TEST_CONF_MIRROR_DIR,
 218     #         TEST_INSTALL_DIR_LIB,
 219     #         TEST_INSTALL_DIR_BIN,
 220     #         TEST_INSTALL_DIR_MAN1,
 221     #         TEST_INSTALL_DIR_MAN3,
 222         ], 0 ); # DO NOT be verbose under perl core -- makes tests fail
 223     }
 224 }
 225
 226 ### whenever we start a new script, we want to clean out our
 227 ### old files from the test '.cpanplus' dir..
 228 sub _clean_test_dir {
 229     my $dirs    = shift || [];
 230     my $verbose = shift || 0;
 231
 232     for my $dir ( @$dirs ) {
 233
 234         ### no point if it doesn't exist;
 235         next unless -d $dir;
 236
 237         my $dh;
 238         opendir $dh, $dir or die "Could not open basedir '$dir': $!";
 239         while( my $file = readdir $dh ) {
 240             next if $file =~ /^\./;  # skip dot files
 241
 242             my $path = File::Spec->catfile( $dir, $file );
 243
 244             ### John Malmberg reports yet another VMS issue:
 245             ### A directory name on VMS in VMS format ends with .dir
 246             ### when it is referenced as a file.
 247             ### In UNIX format traditionally PERL on VMS does not remove the
 248             ### '.dir', however the VMS C library conversion routines do remove
 249             ### the '.dir' and the VMS C library routines can not handle the
 250             ### '.dir' being present on UNIX format filenames.
 251             ### So code doing the fixup has on VMS has to be able to handle both
 252             ### UNIX format names and VMS format names.
 253             ### XXX See http://www.xray.mpe.mpg.de/
 254             ### mailing-lists/perl5-porters/2007-10/msg00064.html
 255             ### for details -- the below regex could use some touchups
 256             ### according to John. M.
 257             $file =~ s/\.dir//i if $^O eq 'VMS';
 258
 259             my $dirpath = File::Spec->catdir( $dir, $file );
 260
 261             ### directory, rmtree it
 262             if( -d $path ) {
 263                 print "# Deleting directory '$path'\n" if $verbose;
 264                 eval { rmtree( $path ) };
 265                 warn "Could not delete '$path' while cleaning up '$dir'" if $@;
 266
 267             ### regular file
 268             } else {
 269                 print "# Deleting file '$path'\n" if $verbose;
 270                 1 while unlink $path;
 271             }
 272         }
 273
 274         close $dh;
 275     }
 276
 277     return 1;
 278 }
 279 1;