This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix failure in Archive::Tar tests when perl is built
[perl5.git] / lib / File / Spec / Win32.pm
CommitLineData
270d1e39
GS
1package File::Spec::Win32;
2
cbc7acb0 3use strict;
07824bd1 4
b4296952 5use vars qw(@ISA $VERSION);
cbc7acb0 6require File::Spec::Unix;
b4296952 7
5b287435 8$VERSION = '1.5';
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
60598624
RGS
38sub rootdir () { '\\' }
39
40
cbc7acb0 41=item tmpdir
270d1e39 42
cbc7acb0
JD
43Returns a string representation of the first existing directory
44from the following list:
270d1e39 45
cbc7acb0
JD
46 $ENV{TMPDIR}
47 $ENV{TEMP}
48 $ENV{TMP}
dd9bbc5b 49 SYS:/temp
27da23d5 50 C:\system\temp
28747828 51 C:/temp
cbc7acb0
JD
52 /tmp
53 /
54
27da23d5
JH
55The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
56for Symbian (the File::Spec::Win32 is used also for those platforms).
dd9bbc5b
JH
57
58Since Perl 5.8.0, if running under taint mode, and if the environment
a384e9e1
RGS
59variables are tainted, they are not used.
60
cbc7acb0 61=cut
270d1e39 62
cbc7acb0
JD
63my $tmpdir;
64sub tmpdir {
65 return $tmpdir if defined $tmpdir;
60598624 66 $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
07824bd1 67 'SYS:/temp',
27da23d5 68 'C:\system\temp',
07824bd1
JH
69 'C:/temp',
70 '/tmp',
71 '/' );
cbc7acb0
JD
72}
73
46726cbe
CB
74sub case_tolerant {
75 return 1;
76}
77
cbc7acb0
JD
78sub file_name_is_absolute {
79 my ($self,$file) = @_;
1b1e14d3 80 return scalar($file =~ m{^([a-z]:)?[\\/]}is);
270d1e39
GS
81}
82
83=item catfile
84
85Concatenate one or more directory names and a filename to form a
86complete path ending with a filename
87
88=cut
89
90sub catfile {
cbc7acb0 91 my $self = shift;
02961b52 92 my $file = $self->canonpath(pop @_);
270d1e39
GS
93 return $file unless @_;
94 my $dir = $self->catdir(@_);
cbc7acb0 95 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
96 return $dir.$file;
97}
98
638113eb
JH
99sub catdir {
100 my $self = shift;
101 my @args = @_;
102 foreach (@args) {
103 tr[/][\\];
104 # append a backslash to each argument unless it has one there
105 $_ .= "\\" unless m{\\$};
106 }
107 return $self->canonpath(join('', @args));
108}
109
270d1e39 110sub path {
270d1e39
GS
111 my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
112 my @path = split(';',$path);
cbc7acb0
JD
113 foreach (@path) { $_ = '.' if $_ eq '' }
114 return @path;
270d1e39
GS
115}
116
117=item canonpath
118
119No physical check on the filesystem, but a logical cleanup of a
120path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
121On Win32 makes
122
123 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
124 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
125
126=cut
127
128sub canonpath {
0994714a 129 my ($self,$path) = @_;
cc23144f 130 my $orig_path = $path;
1b1e14d3 131 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 132 $path =~ s|/|\\|g;
ecf68df6
DR
133 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
134 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
135 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 136 $path =~ s|\\\Z(?!\n)||
e021ab8e
JH
137 unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
138 # xx1/xx2/xx3/../../xx -> xx1/xx
139 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
140 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
141 return $path if $path =~ m|^\.\.|; # skip relative paths
142 return $path unless $path =~ /\.\./; # too few .'s to cleanup
143 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
638113eb 144 $path =~ s{^\\\.\.$}{\\}; # \.. -> \
e021ab8e
JH
145 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
146
147 my ($vol,$dirs,$file) = $self->splitpath($path);
148 my @dirs = $self->splitdir($dirs);
149 my (@base_dirs, @path_dirs);
150 my $dest = \@base_dirs;
151 for my $dir (@dirs){
152 $dest = \@path_dirs if $dir eq $self->updir;
153 push @$dest, $dir;
154 }
155 # for each .. in @path_dirs pop one item from
156 # @base_dirs
157 while (my $dir = shift @path_dirs){
158 unless ($dir eq $self->updir){
159 unshift @path_dirs, $dir;
160 last;
cc23144f 161 }
e021ab8e
JH
162 pop @base_dirs;
163 }
164 $path = $self->catpath(
165 $vol,
166 $self->catdir(@base_dirs, @path_dirs),
167 $file
168 );
cbc7acb0 169 return $path;
270d1e39
GS
170}
171
c27914c9
BS
172=item splitpath
173
174 ($volume,$directories,$file) = File::Spec->splitpath( $path );
175 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
176
40d020d9 177Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
178the last file is a path unless the path ends in '\\', '\\.', '\\..'
179or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 180( $volume, $path, '' ).
c27914c9
BS
181
182Separators accepted are \ and /.
183
184Volumes can be drive letters or UNC sharenames (\\server\share).
185
0994714a 186The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
187(usually identical to) the original path.
188
189=cut
190
191sub splitpath {
192 my ($self,$path, $nofile) = @_;
193 my ($volume,$directory,$file) = ('','','');
194 if ( $nofile ) {
195 $path =~
0994714a 196 m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
c27914c9 197 (.*)
1b1e14d3 198 }xs;
c27914c9
BS
199 $volume = $1;
200 $directory = $2;
201 }
202 else {
203 $path =~
0994714a
GS
204 m{^ ( (?: [a-zA-Z]: |
205 (?:\\\\|//)[^\\/]+[\\/][^\\/]+
c27914c9
BS
206 )?
207 )
5b287435 208 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 209 (.*)
1b1e14d3 210 }xs;
c27914c9
BS
211 $volume = $1;
212 $directory = $2;
213 $file = $3;
214 }
215
216 return ($volume,$directory,$file);
217}
218
219
220=item splitdir
221
59605c55 222The opposite of L<catdir()|File::Spec/catdir()>.
c27914c9
BS
223
224 @dirs = File::Spec->splitdir( $directories );
225
226$directories must be only the directory portion of the path on systems
227that have the concept of a volume or that have path syntax that differentiates
228files from directories.
229
230Unlike just splitting the directories on the separator, leading empty and
231trailing directory entries can be returned, because these are significant
232on some OSs. So,
233
234 File::Spec->splitdir( "/a/b/c" );
235
236Yields:
237
238 ( '', 'a', 'b', '', 'c', '' )
239
240=cut
241
242sub splitdir {
243 my ($self,$directories) = @_ ;
244 #
245 # split() likes to forget about trailing null fields, so here we
246 # check to be sure that there will not be any before handling the
247 # simple case.
248 #
9c045eb2 249 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
250 return split( m|[\\/]|, $directories );
251 }
252 else {
253 #
254 # since there was a trailing separator, add a file name to the end,
255 # then do the split, then replace it with ''.
256 #
257 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
258 $directories[ $#directories ]= '' ;
259 return @directories ;
260 }
261}
262
263
264=item catpath
265
266Takes volume, directory and file portions and returns an entire path. Under
267Unix, $volume is ignored, and this is just like catfile(). On other OSs,
268the $volume become significant.
269
270=cut
271
272sub catpath {
273 my ($self,$volume,$directory,$file) = @_;
274
275 # If it's UNC, make sure the glue separator is there, reusing
276 # whatever separator is first in the $volume
277 $volume .= $1
9c045eb2 278 if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
1b1e14d3 279 $directory =~ m@^[^\\/]@s
c27914c9
BS
280 ) ;
281
282 $volume .= $directory ;
283
284 # If the volume is not just A:, make sure the glue separator is
285 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
286 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
287 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 288 $file =~ m@[^\\/]@
c27914c9
BS
289 ) {
290 $volume =~ m@([\\/])@ ;
291 my $sep = $1 ? $1 : '\\' ;
292 $volume .= $sep ;
293 }
294
295 $volume .= $file ;
296
297 return $volume ;
298}
299
300
c27914c9
BS
301sub abs2rel {
302 my($self,$path,$base) = @_;
0fab864c 303 $base = $self->_cwd() unless defined $base and length $base;
c27914c9 304
638113eb 305 for ($path, $base) { $_ = $self->canonpath($_) }
c27914c9 306
638113eb
JH
307 my ($path_volume) = $self->splitpath($path, 1);
308 my ($base_volume) = $self->splitpath($base, 1);
c27914c9 309
e021ab8e
JH
310 # Can't relativize across volumes
311 return $path unless $path_volume eq $base_volume;
c27914c9 312
638113eb
JH
313 for ($path, $base) { $_ = $self->rel2abs($_) }
314
315 my $path_directories = ($self->splitpath($path, 1))[1];
316 my $base_directories = ($self->splitpath($base, 1))[1];
317
c27914c9
BS
318 # Now, remove all leading components that are the same
319 my @pathchunks = $self->splitdir( $path_directories );
320 my @basechunks = $self->splitdir( $base_directories );
321
322 while ( @pathchunks &&
323 @basechunks &&
324 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
325 ) {
326 shift @pathchunks ;
327 shift @basechunks ;
328 }
329
e021ab8e 330 my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
c27914c9 331
e021ab8e 332 return $self->canonpath( $self->catpath('', $result_dirs, '') );
c27914c9
BS
333}
334
c27914c9 335
786b702f 336sub rel2abs {
c27914c9
BS
337 my ($self,$path,$base ) = @_;
338
c27914c9
BS
339 if ( ! $self->file_name_is_absolute( $path ) ) {
340
1d7cb664 341 if ( !defined( $base ) || $base eq '' ) {
5b287435
RGS
342 require Cwd ;
343 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
344 $base = $self->_cwd() unless defined $base ;
c27914c9 345 }
1d7cb664
GS
346 elsif ( ! $self->file_name_is_absolute( $base ) ) {
347 $base = $self->rel2abs( $base ) ;
348 }
c27914c9
BS
349 else {
350 $base = $self->canonpath( $base ) ;
351 }
352
9c045eb2
GS
353 my ( $path_directories, $path_file ) =
354 ($self->splitpath( $path, 1 ))[1,2] ;
c27914c9 355
9c045eb2 356 my ( $base_volume, $base_directories ) =
c27914c9
BS
357 $self->splitpath( $base, 1 ) ;
358
359 $path = $self->catpath(
360 $base_volume,
361 $self->catdir( $base_directories, $path_directories ),
362 $path_file
363 ) ;
364 }
365
366 return $self->canonpath( $path ) ;
367}
368
270d1e39
GS
369=back
370
dd9bbc5b
JH
371=head2 Note For File::Spec::Win32 Maintainers
372
373Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
374
99f36a73
RGS
375=head1 COPYRIGHT
376
377Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
378
379This program is free software; you can redistribute it and/or modify
380it under the same terms as Perl itself.
381
cbc7acb0
JD
382=head1 SEE ALSO
383
72f15715
T
384See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
385implementation of these methods, not the semantics.
270d1e39 386
cbc7acb0
JD
387=cut
388
3891;