cpan/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 $Config{'path_sep'},
  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     if ( $ENV{PERL_CORE} ) {
  34       $ENV{'PATH'}  = join $Config{'path_sep'},
  35                     grep { defined } "$FindBin::Bin/../../../utils", $ENV{'PATH'};
  36     }
  37     else {
  38       $ENV{'PATH'}  = join $Config{'path_sep'},
  39                     grep { defined } "$FindBin::Bin/../bin", $ENV{'PATH'};
  40     }
  41
  42     ### Fix up the path to perl, as we're about to chdir
  43     ### but only under perlcore, or if the path contains delimiters,
  44     ### meaning it's relative, but not looked up in your $PATH
  45     $^X = File::Spec->rel2abs( $^X )
  46         if $ENV{PERL_CORE} or ( $^X =~ m|[/\\]| );
  47
  48     ### chdir to our own test dir, so we know all files are relative
  49     ### to this point, no matter whether run from perlcore tests or
  50     ### regular CPAN installs
  51     chdir "$FindBin::Bin" if -d "$FindBin::Bin"
  52 }
  53
  54 BEGIN {
  55     use IPC::Cmd;
  56
  57     ### Win32 has issues with redirecting FD's properly in IPC::Run:
  58     ### Can't redirect fd #4 on Win32 at IPC/Run.pm line 2801
  59     $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32';
  60     $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32';
  61 }
  62
  63 ### Use a $^O comparison, as depending on module at this time
  64 ### may cause weird errors/warnings
  65 END {
  66     if ($^O eq 'VMS') {
  67         ### VMS environment variables modified by this test need to be put back
  68         ### path is "magic" on VMS, we can not tell if it really existed before
  69         ### this was run, because VMS will magically pretend that a PATH
  70         ### environment variable exists set to the current working directory
  71         $ENV{PATH} = $old_env_path;
  72
  73         if (defined $old_env_perl5lib) {
  74             $ENV{PERL5LIB} = $old_env_perl5lib;
  75         } else {
  76             delete $ENV{PERL5LIB};
  77         }
  78     }
  79 }
  80
  81 use strict;
  82 use CPANPLUS::Configure;
  83 use CPANPLUS::Error ();
  84
  85 use File::Path      qw[rmtree];
  86 use FileHandle;
  87 use File::Basename  qw[basename];
  88
  89 {   ### Force the ignoring of .po files for L::M::S
  90     $INC{'Locale::Maketext::Lexicon.pm'} = __FILE__;
  91     $Locale::Maketext::Lexicon::VERSION = 0;
  92 }
  93
  94 my $Env = 'PERL5_CPANPLUS_TEST_VERBOSE';
  95
  96 # prereq has to be in our package file && core!
  97 use constant TEST_CONF_PREREQ           => 'Cwd';
  98 use constant TEST_CONF_MODULE           => 'Foo::Bar::EU::NOXS';
  99 use constant TEST_CONF_MODULE_SUB       => 'Foo::Bar::EU::NOXS::Sub';
 100 use constant TEST_CONF_AUTHOR           => 'EUNOXS';
 101 use constant TEST_CONF_INST_MODULE      => 'Foo::Bar';
 102 use constant TEST_CONF_INVALID_MODULE   => 'fnurk';
 103 use constant TEST_CONF_MIRROR_DIR       => 'dummy-localmirror';
 104 use constant TEST_CONF_CPAN_DIR         => 'dummy-CPAN';
 105 use constant TEST_CONF_CPANPLUS_DIR     => 'dummy-cpanplus';
 106 use constant TEST_CONF_INSTALL_DIR      => File::Spec->rel2abs(
 107                                                 File::Spec->catdir(
 108                                                     TEST_CONF_CPANPLUS_DIR,
 109                                                     'install'
 110                                                 )
 111                                             );
 112
 113 sub dummy_cpan_dir {
 114     ### VMS needs this in directory format for rel2abs
 115     my $test_dir = $^O eq 'VMS'
 116                     ? File::Spec->catdir(TEST_CONF_CPAN_DIR)
 117                     : TEST_CONF_CPAN_DIR;
 118
 119     ### Convert to an absolute file specification
 120     my $abs_test_dir = File::Spec->rel2abs($test_dir);
 121
 122     ### According to John M: the hosts path needs to be in UNIX format.
 123     ### File::Spec::Unix->rel2abs does not work at all on VMS
 124     $abs_test_dir    = VMS::Filespec::unixify( $abs_test_dir ) if $^O eq 'VMS';
 125
 126     return $abs_test_dir;
 127 }
 128
 129 sub gimme_conf {
 130
 131     ### don't load any other configs than the heuristic one
 132     ### during tests. They might hold broken/incorrect data
 133     ### for our test suite. Bug [perl #43629] showed this.
 134     my $conf = CPANPLUS::Configure->new( load_configs => 0 );
 135
 136     my $dummy_cpan = dummy_cpan_dir();
 137
 138     $conf->set_conf( hosts  => [ {
 139                         path        => $dummy_cpan,
 140                         scheme      => 'file',
 141                     } ],
 142     );
 143     $conf->set_conf( base       => File::Spec->rel2abs(TEST_CONF_CPANPLUS_DIR));
 144     $conf->set_conf( dist_type  => '' );
 145     $conf->set_conf( signature  => 0 );
 146     $conf->set_conf( verbose    => 1 ) if $ENV{ $Env };
 147
 148     ### never use a pager in the test suite
 149     $conf->set_program( pager   => '' );
 150
 151     ### dmq tells us that we should run with /nologo
 152     ### if using nmake, as it's very noisy otherwise.
 153     {   my $make = $conf->get_program('make');
 154         if( $make and basename($make) =~ /^nmake/i ) {
 155             $conf->set_conf( makeflags => '/nologo' );
 156         }
 157     }
 158
 159     ### CPANPLUS::Config checks 3 specific scenarios first
 160     ### when looking for cpanp-run-perl: parallel to cpanp,
 161     ### parallel to CPANPLUS.pm, or installed into a custom
 162     ### prefix like /tmp/foo. Only *THEN* does it check the
 163     ### the path.
 164     ### If the perl core is extracted to a directory that has
 165     ### cpanp-run-perl installed the same amount of 'uplevels'
 166     ### as the /tmp/foo prefix, we'll pull in the wrong script
 167     ### by accident.
 168     ### Since we set the path to cpanp-run-perl explicitily
 169     ### at the top of this script, it's best to update the config
 170     ### ourselves with a path lookup, rather than rely on its
 171     ### heuristics. Thanks to David Wheeler, Josh Jore and Vincent
 172     ### Pit for helping to track this down.
 173     if( $ENV{PERL_CORE} ) {
 174         $conf->set_program( "perlwrapper" => IPC::Cmd::can_run('cpanp-run-perl') );
 175     }
 176
 177     $conf->set_conf( source_engine =>  $ENV{CPANPLUS_SOURCE_ENGINE} )
 178         if $ENV{CPANPLUS_SOURCE_ENGINE};
 179
 180     _clean_test_dir( [
 181         $conf->get_conf('base'),
 182         TEST_CONF_MIRROR_DIR,
 183 #         TEST_INSTALL_DIR_LIB,
 184 #         TEST_INSTALL_DIR_BIN,
 185 #         TEST_INSTALL_DIR_MAN1,
 186 #         TEST_INSTALL_DIR_MAN3,
 187     ], (  $ENV{PERL_CORE} ? 0 : 1 ) );
 188
 189     return $conf;
 190 };
 191
 192 {
 193     my $fh;
 194     my $file = ".".basename($0).".output";
 195     sub output_handle {
 196         return $fh if $fh;
 197
 198         $fh = FileHandle->new(">$file")
 199                     or warn "Could not open output file '$file': $!";
 200
 201         $fh->autoflush(1);
 202         return $fh;
 203     }
 204
 205     sub output_file { return $file }
 206
 207
 208
 209     ### redirect output from msg() and error() output to file
 210     unless( $ENV{$Env} ) {
 211
 212         print "# To run tests in verbose mode, set ".
 213               "\$ENV{$Env} = 1\n" unless $ENV{PERL_CORE};
 214
 215         1 while unlink $file;   # just in case
 216
 217         $CPANPLUS::Error::ERROR_FH  =
 218         $CPANPLUS::Error::ERROR_FH  = output_handle();
 219
 220         $CPANPLUS::Error::MSG_FH    =
 221         $CPANPLUS::Error::MSG_FH    = output_handle();
 222
 223     }
 224 }
 225
 226
 227 ### clean these files if we're under perl core
 228 END {
 229     if ( $ENV{PERL_CORE} ) {
 230         close output_handle(); 1 while unlink output_file();
 231
 232         _clean_test_dir( [
 233             gimme_conf->get_conf('base'),
 234             TEST_CONF_MIRROR_DIR,
 235     #         TEST_INSTALL_DIR_LIB,
 236     #         TEST_INSTALL_DIR_BIN,
 237     #         TEST_INSTALL_DIR_MAN1,
 238     #         TEST_INSTALL_DIR_MAN3,
 239         ], 0 ); # DO NOT be verbose under perl core -- makes tests fail
 240     }
 241 }
 242
 243 ### whenever we start a new script, we want to clean out our
 244 ### old files from the test '.cpanplus' dir..
 245 sub _clean_test_dir {
 246     my $dirs    = shift || [];
 247     my $verbose = shift || 0;
 248
 249     for my $dir ( @$dirs ) {
 250
 251         ### no point if it doesn't exist;
 252         next unless -d $dir;
 253
 254         my $dh;
 255         opendir $dh, $dir or die "Could not open basedir '$dir': $!";
 256         while( my $file = readdir $dh ) {
 257             next if $file =~ /^\./;  # skip dot files
 258
 259             my $path = File::Spec->catfile( $dir, $file );
 260
 261             ### directory, rmtree it
 262             if( -d $path ) {
 263
 264                 ### John Malmberg reports yet another VMS issue:
 265                 ### A directory name on VMS in VMS format ends with .dir
 266                 ### when it is referenced as a file.
 267                 ### In UNIX format traditionally PERL on VMS does not remove the
 268                 ### '.dir', however the VMS C library conversion routines do
 269                 ### remove the '.dir' and the VMS C library routines can not
 270                 ### handle the '.dir' being present on UNIX format filenames.
 271                 ### So code doing the fixup has on VMS has to be able to handle
 272                 ### both UNIX format names and VMS format names.
 273
 274                 ### XXX See http://www.xray.mpe.mpg.de/
 275                 ### mailing-lists/perl5-porters/2007-10/msg00064.html
 276                 ### for details -- the below regex could use some touchups
 277                 ### according to John. M.
 278                 $file =~ s/\.dir$//i if $^O eq 'VMS';
 279
 280                 my $dirpath = File::Spec->catdir( $dir, $file );
 281
 282                 print "# Deleting directory '$dirpath'\n" if $verbose;
 283                 eval { rmtree( $dirpath ) };
 284                 warn "Could not delete '$dirpath' while cleaning up '$dir'"
 285                     if $@;
 286
 287             ### regular file
 288             } else {
 289                 print "# Deleting file '$path'\n" if $verbose;
 290                 1 while unlink $path;
 291             }
 292         }
 293
 294         close $dh;
 295     }
 296
 297     return 1;
 298 }
 299 1;