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