This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Get C++ compiles going on Solaris again.
[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
c7e4122e 8$VERSION = '3.2501';
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
efa159bc
RU
80=item case_tolerant
81
82MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
83indicating the case significance when comparing file specifications.
84Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
85See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
86Default: 1
87
88=cut
89
90sub case_tolerant () {
91 eval { require Win32API::File; } or return 1;
a7f43cfc 92 my $drive = shift || "C:";
efa159bc
RU
93 my $osFsType = "\0"x256;
94 my $osVolName = "\0"x256;
95 my $ouFsFlags = 0;
96 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
97 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
98 else { return 1; }
46726cbe
CB
99}
100
efa159bc
RU
101=item file_name_is_absolute
102
103As of right now, this returns 2 if the path is absolute with a
104volume, 1 if it's absolute with no volume, 0 otherwise.
105
106=cut
107
cbc7acb0 108sub file_name_is_absolute {
c1e8580e 109
cbc7acb0 110 my ($self,$file) = @_;
c1e8580e
SP
111
112 if ($file =~ m{^($VOL_RX)}o) {
113 my $vol = $1;
114 return ($vol =~ m{^$UNC_RX}o ? 2
115 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
116 : 0);
117 }
118 return $file =~ m{^[\\/]} ? 1 : 0;
270d1e39
GS
119}
120
121=item catfile
122
123Concatenate one or more directory names and a filename to form a
124complete path ending with a filename
125
126=cut
127
128sub catfile {
cbc7acb0 129 my $self = shift;
02961b52 130 my $file = $self->canonpath(pop @_);
270d1e39
GS
131 return $file unless @_;
132 my $dir = $self->catdir(@_);
cbc7acb0 133 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
134 return $dir.$file;
135}
136
638113eb
JH
137sub catdir {
138 my $self = shift;
139 my @args = @_;
140 foreach (@args) {
141 tr[/][\\];
142 # append a backslash to each argument unless it has one there
143 $_ .= "\\" unless m{\\$};
144 }
145 return $self->canonpath(join('', @args));
146}
147
270d1e39 148sub path {
092026cf
SH
149 my @path = split(';', $ENV{PATH});
150 s/"//g for @path;
151 @path = grep length, @path;
152 unshift(@path, ".");
cbc7acb0 153 return @path;
270d1e39
GS
154}
155
156=item canonpath
157
158No physical check on the filesystem, but a logical cleanup of a
159path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
160On Win32 makes
161
162 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
163 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
164
165=cut
166
167sub canonpath {
0994714a 168 my ($self,$path) = @_;
9596c75c 169
1b1e14d3 170 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 171 $path =~ s|/|\\|g;
ecf68df6
DR
172 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
173 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
174 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 175 $path =~ s|\\\Z(?!\n)||
e021ab8e
JH
176 unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
177 # xx1/xx2/xx3/../../xx -> xx1/xx
178 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
179 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
180 return $path if $path =~ m|^\.\.|; # skip relative paths
181 return $path unless $path =~ /\.\./; # too few .'s to cleanup
182 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
638113eb 183 $path =~ s{^\\\.\.$}{\\}; # \.. -> \
e021ab8e
JH
184 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
185
9596c75c 186 return $self->_collapse($path);
270d1e39
GS
187}
188
c27914c9
BS
189=item splitpath
190
191 ($volume,$directories,$file) = File::Spec->splitpath( $path );
192 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
193
40d020d9 194Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
195the last file is a path unless the path ends in '\\', '\\.', '\\..'
196or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 197( $volume, $path, '' ).
c27914c9
BS
198
199Separators accepted are \ and /.
200
201Volumes can be drive letters or UNC sharenames (\\server\share).
202
0994714a 203The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
204(usually identical to) the original path.
205
206=cut
207
208sub splitpath {
209 my ($self,$path, $nofile) = @_;
210 my ($volume,$directory,$file) = ('','','');
211 if ( $nofile ) {
212 $path =~
110c90cc 213 m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9
BS
214 $volume = $1;
215 $directory = $2;
216 }
217 else {
218 $path =~
110c90cc 219 m{^ ( $VOL_RX ? )
5b287435 220 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 221 (.*)
110c90cc 222 }sox;
c27914c9
BS
223 $volume = $1;
224 $directory = $2;
225 $file = $3;
226 }
227
228 return ($volume,$directory,$file);
229}
230
231
232=item splitdir
233
59605c55 234The opposite of L<catdir()|File::Spec/catdir()>.
c27914c9
BS
235
236 @dirs = File::Spec->splitdir( $directories );
237
238$directories must be only the directory portion of the path on systems
239that have the concept of a volume or that have path syntax that differentiates
240files from directories.
241
242Unlike just splitting the directories on the separator, leading empty and
243trailing directory entries can be returned, because these are significant
244on some OSs. So,
245
246 File::Spec->splitdir( "/a/b/c" );
247
248Yields:
249
250 ( '', 'a', 'b', '', 'c', '' )
251
252=cut
253
254sub splitdir {
255 my ($self,$directories) = @_ ;
256 #
257 # split() likes to forget about trailing null fields, so here we
258 # check to be sure that there will not be any before handling the
259 # simple case.
260 #
9c045eb2 261 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
262 return split( m|[\\/]|, $directories );
263 }
264 else {
265 #
266 # since there was a trailing separator, add a file name to the end,
267 # then do the split, then replace it with ''.
268 #
269 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
270 $directories[ $#directories ]= '' ;
271 return @directories ;
272 }
273}
274
275
276=item catpath
277
278Takes volume, directory and file portions and returns an entire path. Under
279Unix, $volume is ignored, and this is just like catfile(). On other OSs,
280the $volume become significant.
281
282=cut
283
284sub catpath {
285 my ($self,$volume,$directory,$file) = @_;
286
287 # If it's UNC, make sure the glue separator is there, reusing
288 # whatever separator is first in the $volume
9596c75c
RGS
289 my $v;
290 $volume .= $v
291 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3 292 $directory =~ m@^[^\\/]@s
c27914c9
BS
293 ) ;
294
295 $volume .= $directory ;
296
297 # If the volume is not just A:, make sure the glue separator is
298 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
299 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
300 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 301 $file =~ m@[^\\/]@
c27914c9
BS
302 ) {
303 $volume =~ m@([\\/])@ ;
304 my $sep = $1 ? $1 : '\\' ;
305 $volume .= $sep ;
306 }
307
308 $volume .= $file ;
309
310 return $volume ;
311}
312
9d5071ba
SP
313sub _same {
314 lc($_[1]) eq lc($_[2]);
c27914c9
BS
315}
316
786b702f 317sub rel2abs {
c27914c9
BS
318 my ($self,$path,$base ) = @_;
319
110c90cc
SP
320 my $is_abs = $self->file_name_is_absolute($path);
321
322 # Check for volume (should probably document the '2' thing...)
323 return $self->canonpath( $path ) if $is_abs == 2;
324
325 if ($is_abs) {
326 # It's missing a volume, add one
327 my $vol = ($self->splitpath( $self->_cwd() ))[0];
328 return $self->canonpath( $vol . $path );
329 }
330
331 if ( !defined( $base ) || $base eq '' ) {
332 require Cwd ;
333 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
334 $base = $self->_cwd() unless defined $base ;
c27914c9 335 }
110c90cc
SP
336 elsif ( ! $self->file_name_is_absolute( $base ) ) {
337 $base = $self->rel2abs( $base ) ;
338 }
339 else {
340 $base = $self->canonpath( $base ) ;
341 }
342
343 my ( $path_directories, $path_file ) =
344 ($self->splitpath( $path, 1 ))[1,2] ;
345
346 my ( $base_volume, $base_directories ) =
347 $self->splitpath( $base, 1 ) ;
348
349 $path = $self->catpath(
350 $base_volume,
351 $self->catdir( $base_directories, $path_directories ),
352 $path_file
353 ) ;
c27914c9
BS
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
99f36a73
RGS
364=head1 COPYRIGHT
365
efa159bc 366Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
99f36a73
RGS
367
368This program is free software; you can redistribute it and/or modify
369it under the same terms as Perl itself.
370
cbc7acb0
JD
371=head1 SEE ALSO
372
72f15715
T
373See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
374implementation of these methods, not the semantics.
270d1e39 375
cbc7acb0
JD
376=cut
377
3781;