[perl5.git] / lib / CPANPLUS / t / inc / conf.pl

### On VMS, the ENV is not reset after the program terminates.
### So reset it here explicitly
my ($old_env_path, $old_env_perl5lib);
BEGIN {
    use FindBin; 
    use File::Spec;
    
    ### paths to our own 'lib' and 'inc' dirs
    ### include them, relative from t/
    my @paths   = map { "$FindBin::Bin/$_" } qw[../lib inc];

    ### absolute'ify the paths in @INC;
    my @rel2abs = map { File::Spec->rel2abs( $_ ) }
                    grep { not File::Spec->file_name_is_absolute( $_ ) } @INC;
    
    ### use require to make devel::cover happy
    require lib;
    for ( @paths, @rel2abs ) { 
        my $l = 'lib'; 
        $l->import( $_ ) 
    }

    use Config;

    ### and add them to the environment, so shellouts get them
    $old_env_perl5lib = $ENV{'PERL5LIB'};
    $ENV{'PERL5LIB'}  = join ':', 
                        grep { defined } $ENV{'PERL5LIB'}, @paths, @rel2abs;
    
    ### add our own path to the front of $ENV{PATH}, so that cpanp-run-perl
    ### and friends get picked up
    $old_env_path = $ENV{PATH};
    $ENV{'PATH'}  = join $Config{'path_sep'}, 
                    grep { defined } "$FindBin::Bin/../bin", $ENV{'PATH'};

    ### Fix up the path to perl, as we're about to chdir
    ### but only under perlcore, or if the path contains delimiters,
    ### meaning it's relative, but not looked up in your $PATH
    $^X = File::Spec->rel2abs( $^X ) 
        if $ENV{PERL_CORE} or ( $^X =~ m|[/\\]| );

    ### chdir to our own test dir, so we know all files are relative 
    ### to this point, no matter whether run from perlcore tests or
    ### regular CPAN installs
    chdir "$FindBin::Bin" if -d "$FindBin::Bin"
}

BEGIN {
    use IPC::Cmd;
   
    ### Win32 has issues with redirecting FD's properly in IPC::Run:
    ### Can't redirect fd #4 on Win32 at IPC/Run.pm line 2801
    $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32';
    $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32';
}

### Use a $^O comparison, as depending on module at this time
### may cause weird errors/warnings
END {
    if ($^O eq 'VMS') {
        ### VMS environment variables modified by this test need to be put back
        ### path is "magic" on VMS, we can not tell if it really existed before
        ### this was run, because VMS will magically pretend that a PATH
        ### environment variable exists set to the current working directory
        $ENV{PATH} = $old_path;

        if (defined $old_perl5lib) {
            $ENV{PERL5LIB} = $old_perl5lib;
        } else {
            delete $ENV{PERL5LIB};
        }
    }
}

use strict;
use CPANPLUS::Configure;
use CPANPLUS::Error ();

use File::Path      qw[rmtree];
use FileHandle;
use File::Basename  qw[basename];

{   ### Force the ignoring of .po files for L::M::S
    $INC{'Locale::Maketext::Lexicon.pm'} = __FILE__;
    $Locale::Maketext::Lexicon::VERSION = 0;
}

my $Env = 'PERL5_CPANPLUS_TEST_VERBOSE';

# prereq has to be in our package file && core!
use constant TEST_CONF_PREREQ           => 'Cwd';   
use constant TEST_CONF_MODULE           => 'Foo::Bar::EU::NOXS';
use constant TEST_CONF_AUTHOR           => 'EUNOXS';
use constant TEST_CONF_INST_MODULE      => 'Foo::Bar';
use constant TEST_CONF_INVALID_MODULE   => 'fnurk';
use constant TEST_CONF_MIRROR_DIR       => 'dummy-localmirror';
use constant TEST_CONF_CPAN_DIR         => 'dummy-CPAN';

### we might need this Some Day when we're installing into
### our own sandbox. see t/20.t for details
# use constant TEST_INSTALL_DIR       => do {
#     my $dir = File::Spec->rel2abs( 'dummy-perl' );
# 
#     ### clean up paths if we are on win32    
#     ### dirs with spaces will be.. bad :(
#     $^O eq 'MSWin32'
#         ? Win32::GetShortPathName( $dir )
#         : $dir;
# };        

# use constant TEST_INSTALL_DIR_LIB 
#     => File::Spec->catdir( TEST_INSTALL_DIR, 'lib' );
# use constant TEST_INSTALL_DIR_BIN 
#     => File::Spec->catdir( TEST_INSTALL_DIR, 'bin' );
# use constant TEST_INSTALL_DIR_MAN1 
#     => File::Spec->catdir( TEST_INSTALL_DIR, 'man', 'man1' );
# use constant TEST_INSTALL_DIR_MAN3
#     => File::Spec->catdir( TEST_INSTALL_DIR, 'man', 'man3' );
# use constant TEST_INSTALL_DIR_ARCH
#     => File::Spec->catdir( TEST_INSTALL_DIR, 'arch' );
# 
# use constant TEST_INSTALL_EU_MM_FLAGS =>
#     ' INSTALLDIRS=site' .
#     ' INSTALLSITELIB='     . TEST_INSTALL_DIR_LIB .
#     ' INSTALLSITEARCH='    . TEST_INSTALL_DIR_ARCH .    # .packlist
#     ' INSTALLARCHLIB='     . TEST_INSTALL_DIR_ARCH .    # perllocal.pod
#     ' INSTALLSITEBIN='     . TEST_INSTALL_DIR_BIN .
#     ' INSTALLSCRIPT='      . TEST_INSTALL_DIR_BIN .
#     ' INSTALLSITEMAN1DIR=' . TEST_INSTALL_DIR_MAN1 .
#     ' INSTALLSITEMAN3DIR=' . TEST_INSTALL_DIR_MAN3;


sub gimme_conf { 

    ### don't load any other configs than the heuristic one
    ### during tests. They might hold broken/incorrect data
    ### for our test suite. Bug [perl #43629] showed this.
    my $conf = CPANPLUS::Configure->new( load_configs => 0 );
    $conf->set_conf( hosts  => [ { 
                        path        => File::Spec->rel2abs(TEST_CONF_CPAN_DIR),
                        scheme      => 'file',
                    } ],      
    );
    $conf->set_conf( base       => 'dummy-cpanplus' );
    $conf->set_conf( dist_type  => '' );
    $conf->set_conf( signature  => 0 );
    $conf->set_conf( verbose    => 1 ) if $ENV{ $Env };
    
    ### never use a pager in the test suite
    $conf->set_program( pager   => '' );

    ### dmq tells us that we should run with /nologo
    ### if using nmake, as it's very noise otherwise.
    {   my $make = $conf->get_program('make');
        if( $make and basename($make) =~ /^nmake/i and
            $make !~ m|/nologo|
        ) {
            $make .= ' /nologo';
            $conf->set_program( make => $make );
        }
    }
    
    _clean_test_dir( [
        $conf->get_conf('base'),     
        TEST_CONF_MIRROR_DIR,
#         TEST_INSTALL_DIR_LIB,
#         TEST_INSTALL_DIR_BIN,
#         TEST_INSTALL_DIR_MAN1, 
#         TEST_INSTALL_DIR_MAN3,
    ], (  $ENV{PERL_CORE} ? 0 : 1 ) );
        
    return $conf;
};

{
    my $fh;
    my $file = ".".basename($0).".output";
    sub output_handle {
        return $fh if $fh;
        
        $fh = FileHandle->new(">$file")
                    or warn "Could not open output file '$file': $!";
       
        $fh->autoflush(1);
        return $fh;
    }
    
    sub output_file { return $file }
    
    
    ### redirect output from msg() and error() output to file
    unless( $ENV{$Env} ) {
    
        print "# To run tests in verbose mode, set ".
              "\$ENV{$Env} = 1\n" unless $ENV{PERL_CORE};
    
        1 while unlink $file;   # just in case
    
        $CPANPLUS::Error::ERROR_FH  =
        $CPANPLUS::Error::ERROR_FH  = output_handle();
        
        $CPANPLUS::Error::MSG_FH    =
        $CPANPLUS::Error::MSG_FH    = output_handle();
        
    }        
}


### clean these files if we're under perl core
END { 
    if ( $ENV{PERL_CORE} ) {
        close output_handle(); 1 while unlink output_file();

        _clean_test_dir( [
            gimme_conf->get_conf('base'),   
            TEST_CONF_MIRROR_DIR,
    #         TEST_INSTALL_DIR_LIB,
    #         TEST_INSTALL_DIR_BIN,
    #         TEST_INSTALL_DIR_MAN1, 
    #         TEST_INSTALL_DIR_MAN3,
        ], 0 ); # DO NOT be verbose under perl core -- makes tests fail
    }
}

### whenever we start a new script, we want to clean out our
### old files from the test '.cpanplus' dir..
sub _clean_test_dir {
    my $dirs    = shift || [];
    my $verbose = shift || 0;

    for my $dir ( @$dirs ) {

        ### no point if it doesn't exist;
        next unless -d $dir;

        my $dh;
        opendir $dh, $dir or die "Could not open basedir '$dir': $!";
        while( my $file = readdir $dh ) { 
            next if $file =~ /^\./;  # skip dot files
            
            my $path = File::Spec->catfile( $dir, $file );
            
            ### John Malmberg reports yet another VMS issue:
            ### A directory name on VMS in VMS format ends with .dir 
            ### when it is referenced as a file.
            ### In UNIX format traditionally PERL on VMS does not remove the
            ### '.dir', however the VMS C library conversion routines do remove
            ### the '.dir' and the VMS C library routines can not handle the
            ### '.dir' being present on UNIX format filenames.
            ### So code doing the fixup has on VMS has to be able to handle both
            ### UNIX format names and VMS format names. 
            ### XXX See http://www.xray.mpe.mpg.de/
            ### mailing-lists/perl5-porters/2007-10/msg00064.html
            ### for details -- the below regex could use some touchups
            ### according to John. M.            
            $file =~ s/\.dir//i if $^O eq 'VMS';
            
            my $dirpath = File::Spec->catdir( $dir, $file );
            
            ### directory, rmtree it
            if( -d $path ) {
                print "# Deleting directory '$path'\n" if $verbose;
                eval { rmtree( $path ) };
                warn "Could not delete '$path' while cleaning up '$dir'" if $@;
           
            ### regular file
            } else {
                print "# Deleting file '$path'\n" if $verbose;
                1 while unlink $path;
            }            
        }       
    
        close $dh;
    }
    
    return 1;
}
1;
Commit	Line	Data
5bc5f6dc RGS	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);
6aaee015 RGS	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
5bc5f6dc RGS	26	$old_env_perl5lib = $ENV{'PERL5LIB'};
5bc5f6dc RGS	27	$ENV{'PERL5LIB'} = join ':',
6aaee015 RGS	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
5bc5f6dc RGS	32	$old_env_path = $ENV{PATH};
5bc5f6dc RGS	33	$ENV{'PATH'} = join $Config{'path_sep'},
6aaee015 RGS	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
5bc5f6dc RGS	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
6aaee015 RGS	75	use strict;
6aaee015 RGS	76	use CPANPLUS::Configure;
983ffab6	77	use CPANPLUS::Error ();
6aaee015 RGS	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
5bc5f6dc RGS	88	my $Env = 'PERL5_CPANPLUS_TEST_VERBOSE';
5bc5f6dc RGS	89
6aaee015 RGS	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';
5bc5f6dc	93	use constant TEST_CONF_AUTHOR => 'EUNOXS';
6aaee015 RGS	94	use constant TEST_CONF_INST_MODULE => 'Foo::Bar';
6aaee015 RGS	95	use constant TEST_CONF_INVALID_MODULE => 'fnurk';
494f1016	96	use constant TEST_CONF_MIRROR_DIR => 'dummy-localmirror';
5bc5f6dc	97	use constant TEST_CONF_CPAN_DIR => 'dummy-CPAN';
6aaee015 RGS	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 {
d0baa00e SP	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 );
6aaee015	139	$conf->set_conf( hosts => [ {
5bc5f6dc	140	path => File::Spec->rel2abs(TEST_CONF_CPAN_DIR),
6aaee015 RGS	141	scheme => 'file',
	142	} ],
	143	);
	144	$conf->set_conf( base => 'dummy-cpanplus' );
	145	$conf->set_conf( dist_type => '' );
	146	$conf->set_conf( signature => 0 );
5bc5f6dc RGS	147	$conf->set_conf( verbose => 1 ) if $ENV{ $Env };
	148
	149	### never use a pager in the test suite
	150	$conf->set_program( pager => '' );
6aaee015	151
622d31ac JB	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
6aaee015 RGS	163	_clean_test_dir( [
6aaee015 RGS	164	$conf->get_conf('base'),
494f1016	165	TEST_CONF_MIRROR_DIR,
6aaee015 RGS	166	# TEST_INSTALL_DIR_LIB,
	167	# TEST_INSTALL_DIR_BIN,
	168	# TEST_INSTALL_DIR_MAN1,
	169	# TEST_INSTALL_DIR_MAN3,
53873a16	170	], ( $ENV{PERL_CORE} ? 0 : 1 ) );
6aaee015 RGS	171
	172	return $conf;
	173	};
	174
494f1016 JB	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	}
6aaee015	187
494f1016	188	sub output_file { return $file }
983ffab6 JB	189
983ffab6 JB	190
5bc5f6dc	191
983ffab6	192	### redirect output from msg() and error() output to file
5bc5f6dc	193	unless( $ENV{$Env} ) {
983ffab6 JB	194
983ffab6 JB	195	print "# To run tests in verbose mode, set ".
5bc5f6dc	196	"\$ENV{$Env} = 1\n" unless $ENV{PERL_CORE};
983ffab6	197
5bc5f6dc	198	1 while unlink $file; # just in case
983ffab6 JB	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	}
6aaee015 RGS	207	}
6aaee015 RGS	208
494f1016 JB	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,
53873a16	222	], 0 ); # DO NOT be verbose under perl core -- makes tests fail
494f1016 JB	223	}
	224	}
	225
6aaee015 RGS	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
53873a16 RGS	234	### no point if it doesn't exist;
	235	next unless -d $dir;
	236
6aaee015 RGS	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
5bc5f6dc RGS	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
6aaee015 RGS	261	### directory, rmtree it
6aaee015 RGS	262	if( -d $path ) {
53873a16	263	print "# Deleting directory '$path'\n" if $verbose;
6aaee015 RGS	264	eval { rmtree( $path ) };
	265	warn "Could not delete '$path' while cleaning up '$dir'" if $@;
	266
	267	### regular file
	268	} else {
983ffab6	269	print "# Deleting file '$path'\n" if $verbose;
6aaee015 RGS	270	1 while unlink $path;
	271	}
	272	}
	273
	274	close $dh;
	275	}
	276
	277	return 1;
	278	}
	279	1;