This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PROPOSED PATCH lib/AutoLoader.t lib/AutoLoader.pm] Test and Improve unimport()
[perl5.git] / lib / File / Spec / Win32.pm
CommitLineData
270d1e39
GS
1package File::Spec::Win32;
2
cbc7acb0 3use strict;
c27914c9 4use Cwd;
b4296952 5use vars qw(@ISA $VERSION);
cbc7acb0 6require File::Spec::Unix;
b4296952 7
88d01e8d 8$VERSION = '1.3';
b4296952 9
cbc7acb0
JD
10@ISA = qw(File::Spec::Unix);
11
270d1e39
GS
12=head1 NAME
13
14File::Spec::Win32 - methods for Win32 file specs
15
16=head1 SYNOPSIS
17
cbc7acb0 18 require File::Spec::Win32; # Done internally by File::Spec if needed
270d1e39
GS
19
20=head1 DESCRIPTION
21
22See File::Spec::Unix for a documentation of the methods provided
23there. This package overrides the implementation of these methods, not
24the semantics.
25
bbc7dcd2 26=over 4
270d1e39 27
cbc7acb0 28=item devnull
270d1e39 29
cbc7acb0 30Returns a string representation of the null device.
270d1e39 31
cbc7acb0 32=cut
270d1e39 33
cbc7acb0
JD
34sub devnull {
35 return "nul";
36}
270d1e39 37
cbc7acb0 38=item tmpdir
270d1e39 39
cbc7acb0
JD
40Returns a string representation of the first existing directory
41from the following list:
270d1e39 42
cbc7acb0
JD
43 $ENV{TMPDIR}
44 $ENV{TEMP}
45 $ENV{TMP}
dd9bbc5b 46 SYS:/temp
28747828 47 C:/temp
cbc7acb0
JD
48 /tmp
49 /
50
dd9bbc5b
JH
51The SYS:/temp is preferred in Novell NetWare.
52
53Since Perl 5.8.0, if running under taint mode, and if the environment
a384e9e1
RGS
54variables are tainted, they are not used.
55
cbc7acb0 56=cut
270d1e39 57
cbc7acb0
JD
58my $tmpdir;
59sub tmpdir {
60 return $tmpdir if defined $tmpdir;
270d1e39 61 my $self = shift;
a384e9e1
RGS
62 my @dirlist = (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /));
63 {
64 no strict 'refs';
65 if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
66 require Scalar::Util;
67 @dirlist = grep { ! Scalar::Util::tainted $_ } @dirlist;
68 }
69 }
70 foreach (@dirlist) {
cbc7acb0
JD
71 next unless defined && -d;
72 $tmpdir = $_;
73 last;
270d1e39 74 }
cbc7acb0
JD
75 $tmpdir = '' unless defined $tmpdir;
76 $tmpdir = $self->canonpath($tmpdir);
77 return $tmpdir;
78}
79
46726cbe
CB
80sub case_tolerant {
81 return 1;
82}
83
cbc7acb0
JD
84sub file_name_is_absolute {
85 my ($self,$file) = @_;
1b1e14d3 86 return scalar($file =~ m{^([a-z]:)?[\\/]}is);
270d1e39
GS
87}
88
89=item catfile
90
91Concatenate one or more directory names and a filename to form a
92complete path ending with a filename
93
94=cut
95
96sub catfile {
cbc7acb0 97 my $self = shift;
02961b52 98 my $file = $self->canonpath(pop @_);
270d1e39
GS
99 return $file unless @_;
100 my $dir = $self->catdir(@_);
cbc7acb0 101 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
102 return $dir.$file;
103}
104
105sub path {
270d1e39
GS
106 my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
107 my @path = split(';',$path);
cbc7acb0
JD
108 foreach (@path) { $_ = '.' if $_ eq '' }
109 return @path;
270d1e39
GS
110}
111
112=item canonpath
113
114No physical check on the filesystem, but a logical cleanup of a
115path. On UNIX eliminated successive slashes and successive "/.".
116
117=cut
118
119sub canonpath {
0994714a 120 my ($self,$path) = @_;
1b1e14d3 121 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 122 $path =~ s|/|\\|g;
ecf68df6
DR
123 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
124 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
125 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 126 $path =~ s|\\\Z(?!\n)||
ecf68df6 127 unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx\ -> xx
cbc7acb0 128 return $path;
270d1e39
GS
129}
130
c27914c9
BS
131=item splitpath
132
133 ($volume,$directories,$file) = File::Spec->splitpath( $path );
134 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
135
136Splits a path in to volume, directory, and filename portions. Assumes that
137the last file is a path unless the path ends in '\\', '\\.', '\\..'
138or $no_file is true. On Win32 this means that $no_file true makes this return
139( $volume, $path, undef ).
140
141Separators accepted are \ and /.
142
143Volumes can be drive letters or UNC sharenames (\\server\share).
144
0994714a 145The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
146(usually identical to) the original path.
147
148=cut
149
150sub splitpath {
151 my ($self,$path, $nofile) = @_;
152 my ($volume,$directory,$file) = ('','','');
153 if ( $nofile ) {
154 $path =~
0994714a 155 m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
c27914c9 156 (.*)
1b1e14d3 157 }xs;
c27914c9
BS
158 $volume = $1;
159 $directory = $2;
160 }
161 else {
162 $path =~
0994714a
GS
163 m{^ ( (?: [a-zA-Z]: |
164 (?:\\\\|//)[^\\/]+[\\/][^\\/]+
c27914c9
BS
165 )?
166 )
9c045eb2 167 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 168 (.*)
1b1e14d3 169 }xs;
c27914c9
BS
170 $volume = $1;
171 $directory = $2;
172 $file = $3;
173 }
174
175 return ($volume,$directory,$file);
176}
177
178
179=item splitdir
180
59605c55 181The opposite of L<catdir()|File::Spec/catdir()>.
c27914c9
BS
182
183 @dirs = File::Spec->splitdir( $directories );
184
185$directories must be only the directory portion of the path on systems
186that have the concept of a volume or that have path syntax that differentiates
187files from directories.
188
189Unlike just splitting the directories on the separator, leading empty and
190trailing directory entries can be returned, because these are significant
191on some OSs. So,
192
193 File::Spec->splitdir( "/a/b/c" );
194
195Yields:
196
197 ( '', 'a', 'b', '', 'c', '' )
198
199=cut
200
201sub splitdir {
202 my ($self,$directories) = @_ ;
203 #
204 # split() likes to forget about trailing null fields, so here we
205 # check to be sure that there will not be any before handling the
206 # simple case.
207 #
9c045eb2 208 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
209 return split( m|[\\/]|, $directories );
210 }
211 else {
212 #
213 # since there was a trailing separator, add a file name to the end,
214 # then do the split, then replace it with ''.
215 #
216 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
217 $directories[ $#directories ]= '' ;
218 return @directories ;
219 }
220}
221
222
223=item catpath
224
225Takes volume, directory and file portions and returns an entire path. Under
226Unix, $volume is ignored, and this is just like catfile(). On other OSs,
227the $volume become significant.
228
229=cut
230
231sub catpath {
232 my ($self,$volume,$directory,$file) = @_;
233
234 # If it's UNC, make sure the glue separator is there, reusing
235 # whatever separator is first in the $volume
236 $volume .= $1
9c045eb2 237 if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
1b1e14d3 238 $directory =~ m@^[^\\/]@s
c27914c9
BS
239 ) ;
240
241 $volume .= $directory ;
242
243 # If the volume is not just A:, make sure the glue separator is
244 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
245 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
246 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 247 $file =~ m@[^\\/]@
c27914c9
BS
248 ) {
249 $volume =~ m@([\\/])@ ;
250 my $sep = $1 ? $1 : '\\' ;
251 $volume .= $sep ;
252 }
253
254 $volume .= $file ;
255
256 return $volume ;
257}
258
259
c27914c9
BS
260sub abs2rel {
261 my($self,$path,$base) = @_;
262
263 # Clean up $path
264 if ( ! $self->file_name_is_absolute( $path ) ) {
265 $path = $self->rel2abs( $path ) ;
266 }
267 else {
268 $path = $self->canonpath( $path ) ;
269 }
270
271 # Figure out the effective $base and clean it up.
9c1370fb 272 if ( !defined( $base ) || $base eq '' ) {
c27914c9
BS
273 $base = cwd() ;
274 }
9c1370fb
NK
275 elsif ( ! $self->file_name_is_absolute( $base ) ) {
276 $base = $self->rel2abs( $base ) ;
277 }
c27914c9
BS
278 else {
279 $base = $self->canonpath( $base ) ;
280 }
281
282 # Split up paths
9b1c7707 283 my ( undef, $path_directories, $path_file ) =
c27914c9
BS
284 $self->splitpath( $path, 1 ) ;
285
9c045eb2 286 my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
c27914c9
BS
287
288 # Now, remove all leading components that are the same
289 my @pathchunks = $self->splitdir( $path_directories );
290 my @basechunks = $self->splitdir( $base_directories );
291
292 while ( @pathchunks &&
293 @basechunks &&
294 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
295 ) {
296 shift @pathchunks ;
297 shift @basechunks ;
298 }
299
300 # No need to catdir, we know these are well formed.
301 $path_directories = CORE::join( '\\', @pathchunks );
302 $base_directories = CORE::join( '\\', @basechunks );
303
5cefc38b
GS
304 # $base_directories now contains the directories the resulting relative
305 # path must ascend out of before it can descend to $path_directory. So,
c27914c9 306 # replace all names with $parentDir
5cefc38b
GS
307
308 #FA Need to replace between backslashes...
309 $base_directories =~ s|[^\\]+|..|g ;
c27914c9
BS
310
311 # Glue the two together, using a separator if necessary, and preventing an
312 # empty result.
5cefc38b
GS
313
314 #FA Must check that new directories are not empty.
315 if ( $path_directories ne '' && $base_directories ne '' ) {
c27914c9
BS
316 $path_directories = "$base_directories\\$path_directories" ;
317 } else {
318 $path_directories = "$base_directories$path_directories" ;
319 }
320
321 return $self->canonpath(
9b1c7707 322 $self->catpath( "", $path_directories, $path_file )
c27914c9
BS
323 ) ;
324}
325
c27914c9 326
786b702f 327sub rel2abs {
c27914c9
BS
328 my ($self,$path,$base ) = @_;
329
c27914c9
BS
330 if ( ! $self->file_name_is_absolute( $path ) ) {
331
1d7cb664 332 if ( !defined( $base ) || $base eq '' ) {
c27914c9
BS
333 $base = cwd() ;
334 }
1d7cb664
GS
335 elsif ( ! $self->file_name_is_absolute( $base ) ) {
336 $base = $self->rel2abs( $base ) ;
337 }
c27914c9
BS
338 else {
339 $base = $self->canonpath( $base ) ;
340 }
341
9c045eb2
GS
342 my ( $path_directories, $path_file ) =
343 ($self->splitpath( $path, 1 ))[1,2] ;
c27914c9 344
9c045eb2 345 my ( $base_volume, $base_directories ) =
c27914c9
BS
346 $self->splitpath( $base, 1 ) ;
347
348 $path = $self->catpath(
349 $base_volume,
350 $self->catdir( $base_directories, $path_directories ),
351 $path_file
352 ) ;
353 }
354
355 return $self->canonpath( $path ) ;
356}
357
270d1e39
GS
358=back
359
dd9bbc5b
JH
360=head2 Note For File::Spec::Win32 Maintainers
361
362Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
363
cbc7acb0
JD
364=head1 SEE ALSO
365
366L<File::Spec>
270d1e39 367
cbc7acb0
JD
368=cut
369
3701;