This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid runtime module loading in File::Spec
[perl5.git] / dist / PathTools / lib / File / Spec / Win32.pm
CommitLineData
270d1e39
GS
1package File::Spec::Win32;
2
cbc7acb0 3use strict;
07824bd1 4
a3371546 5use Cwd ();
cbc7acb0 6require File::Spec::Unix;
b4296952 7
1a58b39a 8our $VERSION = '3.69';
4f642d62 9$VERSION =~ tr/_//d;
b4296952 10
1a58b39a 11our @ISA = qw(File::Spec::Unix);
cbc7acb0 12
110c90cc
SP
13# Some regexes we use for path splitting
14my $DRIVE_RX = '[a-zA-Z]:';
15my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
16my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
17
18
270d1e39
GS
19=head1 NAME
20
21File::Spec::Win32 - methods for Win32 file specs
22
23=head1 SYNOPSIS
24
cbc7acb0 25 require File::Spec::Win32; # Done internally by File::Spec if needed
270d1e39
GS
26
27=head1 DESCRIPTION
28
29See File::Spec::Unix for a documentation of the methods provided
30there. This package overrides the implementation of these methods, not
31the semantics.
32
bbc7dcd2 33=over 4
270d1e39 34
cbc7acb0 35=item devnull
270d1e39 36
cbc7acb0 37Returns a string representation of the null device.
270d1e39 38
cbc7acb0 39=cut
270d1e39 40
cbc7acb0
JD
41sub devnull {
42 return "nul";
43}
270d1e39 44
486bcc50 45sub rootdir { '\\' }
60598624
RGS
46
47
cbc7acb0 48=item tmpdir
270d1e39 49
cbc7acb0
JD
50Returns a string representation of the first existing directory
51from the following list:
270d1e39 52
cbc7acb0
JD
53 $ENV{TMPDIR}
54 $ENV{TEMP}
55 $ENV{TMP}
dd9bbc5b 56 SYS:/temp
27da23d5 57 C:\system\temp
28747828 58 C:/temp
cbc7acb0
JD
59 /tmp
60 /
61
27da23d5
JH
62The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
63for Symbian (the File::Spec::Win32 is used also for those platforms).
dd9bbc5b 64
1d0806cf 65If running under taint mode, and if the environment
a384e9e1
RGS
66variables are tainted, they are not used.
67
cbc7acb0 68=cut
270d1e39 69
cbc7acb0 70sub tmpdir {
82730d4c 71 my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP));
cbc7acb0 72 return $tmpdir if defined $tmpdir;
9d5071ba 73 $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
07824bd1 74 'SYS:/temp',
27da23d5 75 'C:\system\temp',
07824bd1
JH
76 'C:/temp',
77 '/tmp',
78 '/' );
82730d4c 79 $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP));
cbc7acb0
JD
80}
81
efa159bc
RU
82=item case_tolerant
83
84MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
85indicating the case significance when comparing file specifications.
86Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
87See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
88Default: 1
89
90=cut
91
486bcc50 92sub case_tolerant {
8901ddee
TC
93 eval {
94 local @INC = @INC;
95 pop @INC if $INC[-1] eq '.';
96 require Win32API::File;
97 } or return 1;
a7f43cfc 98 my $drive = shift || "C:";
efa159bc
RU
99 my $osFsType = "\0"x256;
100 my $osVolName = "\0"x256;
101 my $ouFsFlags = 0;
102 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
103 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
104 else { return 1; }
46726cbe
CB
105}
106
efa159bc
RU
107=item file_name_is_absolute
108
109As of right now, this returns 2 if the path is absolute with a
110volume, 1 if it's absolute with no volume, 0 otherwise.
111
112=cut
113
cbc7acb0 114sub file_name_is_absolute {
c1e8580e 115
cbc7acb0 116 my ($self,$file) = @_;
c1e8580e
SP
117
118 if ($file =~ m{^($VOL_RX)}o) {
119 my $vol = $1;
120 return ($vol =~ m{^$UNC_RX}o ? 2
121 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
122 : 0);
123 }
124 return $file =~ m{^[\\/]} ? 1 : 0;
270d1e39
GS
125}
126
127=item catfile
128
129Concatenate one or more directory names and a filename to form a
130complete path ending with a filename
131
132=cut
133
134sub catfile {
bf7c0a3d
SP
135 shift;
136
137 # Legacy / compatibility support
138 #
139 shift, return _canon_cat( "/", @_ )
140 if $_[0] eq "";
141
795ee885
SP
142 # Compatibility with File::Spec <= 3.26:
143 # catfile('A:', 'foo') should return 'A:\foo'.
144 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
145 if $_[0] =~ m{^$DRIVE_RX\z}o;
146
bf7c0a3d 147 return _canon_cat( @_ );
270d1e39
GS
148}
149
638113eb 150sub catdir {
bf7c0a3d
SP
151 shift;
152
153 # Legacy / compatibility support
154 #
155 return ""
156 unless @_;
157 shift, return _canon_cat( "/", @_ )
158 if $_[0] eq "";
159
795ee885
SP
160 # Compatibility with File::Spec <= 3.26:
161 # catdir('A:', 'foo') should return 'A:\foo'.
162 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
163 if $_[0] =~ m{^$DRIVE_RX\z}o;
164
bf7c0a3d 165 return _canon_cat( @_ );
638113eb
JH
166}
167
270d1e39 168sub path {
092026cf
SH
169 my @path = split(';', $ENV{PATH});
170 s/"//g for @path;
171 @path = grep length, @path;
172 unshift(@path, ".");
cbc7acb0 173 return @path;
270d1e39
GS
174}
175
176=item canonpath
177
178No physical check on the filesystem, but a logical cleanup of a
179path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
180On Win32 makes
181
182 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
183 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
184
185=cut
186
187sub canonpath {
bf7c0a3d
SP
188 # Legacy / compatibility support
189 #
190 return $_[1] if !defined($_[1]) or $_[1] eq '';
191 return _canon_cat( $_[1] );
270d1e39
GS
192}
193
c27914c9
BS
194=item splitpath
195
555bd962
BG
196 ($volume,$directories,$file) = File::Spec->splitpath( $path );
197 ($volume,$directories,$file) = File::Spec->splitpath( $path,
198 $no_file );
c27914c9 199
40d020d9 200Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
201the last file is a path unless the path ends in '\\', '\\.', '\\..'
202or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 203( $volume, $path, '' ).
c27914c9
BS
204
205Separators accepted are \ and /.
206
207Volumes can be drive letters or UNC sharenames (\\server\share).
208
0994714a 209The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
210(usually identical to) the original path.
211
212=cut
213
214sub splitpath {
215 my ($self,$path, $nofile) = @_;
216 my ($volume,$directory,$file) = ('','','');
217 if ( $nofile ) {
218 $path =~
110c90cc 219 m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9
BS
220 $volume = $1;
221 $directory = $2;
222 }
223 else {
224 $path =~
110c90cc 225 m{^ ( $VOL_RX ? )
5b287435 226 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 227 (.*)
110c90cc 228 }sox;
c27914c9
BS
229 $volume = $1;
230 $directory = $2;
231 $file = $3;
232 }
233
234 return ($volume,$directory,$file);
235}
236
237
238=item splitdir
239
b60bb9a0 240The opposite of L<catdir()|File::Spec/catdir>.
c27914c9
BS
241
242 @dirs = File::Spec->splitdir( $directories );
243
244$directories must be only the directory portion of the path on systems
245that have the concept of a volume or that have path syntax that differentiates
246files from directories.
247
248Unlike just splitting the directories on the separator, leading empty and
249trailing directory entries can be returned, because these are significant
250on some OSs. So,
251
252 File::Spec->splitdir( "/a/b/c" );
253
254Yields:
255
256 ( '', 'a', 'b', '', 'c', '' )
257
258=cut
259
260sub splitdir {
261 my ($self,$directories) = @_ ;
262 #
263 # split() likes to forget about trailing null fields, so here we
264 # check to be sure that there will not be any before handling the
265 # simple case.
266 #
9c045eb2 267 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
268 return split( m|[\\/]|, $directories );
269 }
270 else {
271 #
272 # since there was a trailing separator, add a file name to the end,
273 # then do the split, then replace it with ''.
274 #
275 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
276 $directories[ $#directories ]= '' ;
277 return @directories ;
278 }
279}
280
281
282=item catpath
283
284Takes volume, directory and file portions and returns an entire path. Under
285Unix, $volume is ignored, and this is just like catfile(). On other OSs,
286the $volume become significant.
287
288=cut
289
290sub catpath {
291 my ($self,$volume,$directory,$file) = @_;
292
293 # If it's UNC, make sure the glue separator is there, reusing
294 # whatever separator is first in the $volume
9596c75c
RGS
295 my $v;
296 $volume .= $v
297 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3 298 $directory =~ m@^[^\\/]@s
c27914c9
BS
299 ) ;
300
301 $volume .= $directory ;
302
303 # If the volume is not just A:, make sure the glue separator is
304 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
305 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
306 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 307 $file =~ m@[^\\/]@
c27914c9
BS
308 ) {
309 $volume =~ m@([\\/])@ ;
310 my $sep = $1 ? $1 : '\\' ;
311 $volume .= $sep ;
312 }
313
314 $volume .= $file ;
315
316 return $volume ;
317}
318
9d5071ba
SP
319sub _same {
320 lc($_[1]) eq lc($_[2]);
c27914c9
BS
321}
322
786b702f 323sub rel2abs {
c27914c9
BS
324 my ($self,$path,$base ) = @_;
325
110c90cc
SP
326 my $is_abs = $self->file_name_is_absolute($path);
327
328 # Check for volume (should probably document the '2' thing...)
329 return $self->canonpath( $path ) if $is_abs == 2;
330
331 if ($is_abs) {
332 # It's missing a volume, add one
a3371546 333 my $vol = ($self->splitpath( Cwd::getcwd() ))[0];
110c90cc
SP
334 return $self->canonpath( $vol . $path );
335 }
336
337 if ( !defined( $base ) || $base eq '' ) {
110c90cc 338 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
a3371546 339 $base = Cwd::getcwd() unless defined $base ;
c27914c9 340 }
110c90cc
SP
341 elsif ( ! $self->file_name_is_absolute( $base ) ) {
342 $base = $self->rel2abs( $base ) ;
343 }
344 else {
345 $base = $self->canonpath( $base ) ;
346 }
347
348 my ( $path_directories, $path_file ) =
349 ($self->splitpath( $path, 1 ))[1,2] ;
350
351 my ( $base_volume, $base_directories ) =
352 $self->splitpath( $base, 1 ) ;
353
354 $path = $self->catpath(
355 $base_volume,
356 $self->catdir( $base_directories, $path_directories ),
357 $path_file
358 ) ;
c27914c9
BS
359
360 return $self->canonpath( $path ) ;
361}
362
270d1e39
GS
363=back
364
dd9bbc5b
JH
365=head2 Note For File::Spec::Win32 Maintainers
366
367Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
368
99f36a73
RGS
369=head1 COPYRIGHT
370
efa159bc 371Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
99f36a73
RGS
372
373This program is free software; you can redistribute it and/or modify
374it under the same terms as Perl itself.
375
cbc7acb0
JD
376=head1 SEE ALSO
377
72f15715
T
378See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
379implementation of these methods, not the semantics.
270d1e39 380
cbc7acb0
JD
381=cut
382
bf7c0a3d 383
486bcc50 384sub _canon_cat # @path -> path
bf7c0a3d 385{
486bcc50
NC
386 my ($first, @rest) = @_;
387
bf7c0a3d
SP
388 my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
389 ? ucfirst( $1 ).( $2 ? "\\" : "" )
390 : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
391 (?: [\\/] ([^\\/]+) )?
392 [\\/]? }{}xs # UNC volume
393 ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
394 : $first =~ s{ \A [\\/] }{}x # root dir
395 ? "\\"
396 : "";
486bcc50 397 my $path = join "\\", $first, @rest;
bf7c0a3d
SP
398
399 $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
400
401 # xx/././yy --> xx/yy
402 $path =~ s{(?:
403 (?:\A|\\) # at begin or after a slash
404 \.
405 (?:\\\.)* # and more
406 (?:\\|\z) # at end or followed by slash
407 )+ # performance boost -- I do not know why
408 }{\\}gx;
409
410 # XXX I do not know whether more dots are supported by the OS supporting
411 # this ... annotation (NetWare or symbian but not MSWin32).
412 # Then .... could easily become ../../.. etc:
413 # Replace \.\.\. by (\.\.\.+) and substitute with
414 # { $1 . ".." . "\\.." x (length($2)-2) }gex
415 # ... --> ../..
416 $path =~ s{ (\A|\\) # at begin or after a slash
417 \.\.\.
418 (?=\\|\z) # at end or followed by slash
419 }{$1..\\..}gx;
420 # xx\yy\..\zz --> xx\zz
421 while ( $path =~ s{(?:
422 (?:\A|\\) # at begin or after a slash
423 [^\\]+ # rip this 'yy' off
424 \\\.\.
425 (?<!\A\.\.\\\.\.) # do *not* replace ^..\..
426 (?<!\\\.\.\\\.\.) # do *not* replace \..\..
427 (?:\\|\z) # at end or followed by slash
428 )+ # performance boost -- I do not know why
429 }{\\}sx ) {}
430
431 $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
432 $path =~ s#\\\z##; # xx\ --> xx
433
434 if ( $volume =~ m#\\\z# )
435 { # <vol>\.. --> <vol>\
436 $path =~ s{ \A # at begin
437 \.\.
438 (?:\\\.\.)* # and more
439 (?:\\|\z) # at end or followed by slash
440 }{}x;
441
442 return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
443 if $path eq ""
444 and $volume =~ m#\A(\\\\.*)\\\z#s;
445 }
446 return $path ne "" || $volume ? $volume.$path : ".";
447}
448
cbc7acb0 4491;