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