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