This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
return inode numbers as strings where necessary
[perl5.git] / dist / PathTools / lib / File / Spec / Win32.pm
CommitLineData
270d1e39
GS
1package File::Spec::Win32;
2
cbc7acb0 3use strict;
07824bd1 4
cbc7acb0 5require File::Spec::Unix;
b4296952 6
1a58b39a 7our $VERSION = '3.69';
4f642d62 8$VERSION =~ tr/_//d;
b4296952 9
1a58b39a 10our @ISA = qw(File::Spec::Unix);
cbc7acb0 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
486bcc50 44sub rootdir { '\\' }
60598624
RGS
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 63
1d0806cf 64If running under taint mode, and if the environment
a384e9e1
RGS
65variables are tainted, they are not used.
66
cbc7acb0 67=cut
270d1e39 68
cbc7acb0 69sub tmpdir {
82730d4c 70 my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP));
cbc7acb0 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 '/' );
82730d4c 78 $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP));
cbc7acb0
JD
79}
80
efa159bc
RU
81=item case_tolerant
82
83MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
84indicating the case significance when comparing file specifications.
85Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
86See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
87Default: 1
88
89=cut
90
486bcc50 91sub case_tolerant {
8901ddee
TC
92 eval {
93 local @INC = @INC;
94 pop @INC if $INC[-1] eq '.';
95 require Win32API::File;
96 } or return 1;
a7f43cfc 97 my $drive = shift || "C:";
efa159bc
RU
98 my $osFsType = "\0"x256;
99 my $osVolName = "\0"x256;
100 my $ouFsFlags = 0;
101 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
102 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
103 else { return 1; }
46726cbe
CB
104}
105
efa159bc
RU
106=item file_name_is_absolute
107
108As of right now, this returns 2 if the path is absolute with a
109volume, 1 if it's absolute with no volume, 0 otherwise.
110
111=cut
112
cbc7acb0 113sub file_name_is_absolute {
c1e8580e 114
cbc7acb0 115 my ($self,$file) = @_;
c1e8580e
SP
116
117 if ($file =~ m{^($VOL_RX)}o) {
118 my $vol = $1;
119 return ($vol =~ m{^$UNC_RX}o ? 2
120 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
121 : 0);
122 }
123 return $file =~ m{^[\\/]} ? 1 : 0;
270d1e39
GS
124}
125
126=item catfile
127
128Concatenate one or more directory names and a filename to form a
129complete path ending with a filename
130
131=cut
132
133sub catfile {
bf7c0a3d
SP
134 shift;
135
136 # Legacy / compatibility support
137 #
138 shift, return _canon_cat( "/", @_ )
139 if $_[0] eq "";
140
795ee885
SP
141 # Compatibility with File::Spec <= 3.26:
142 # catfile('A:', 'foo') should return 'A:\foo'.
143 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
144 if $_[0] =~ m{^$DRIVE_RX\z}o;
145
bf7c0a3d 146 return _canon_cat( @_ );
270d1e39
GS
147}
148
638113eb 149sub catdir {
bf7c0a3d
SP
150 shift;
151
152 # Legacy / compatibility support
153 #
154 return ""
155 unless @_;
156 shift, return _canon_cat( "/", @_ )
157 if $_[0] eq "";
158
795ee885
SP
159 # Compatibility with File::Spec <= 3.26:
160 # catdir('A:', 'foo') should return 'A:\foo'.
161 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
162 if $_[0] =~ m{^$DRIVE_RX\z}o;
163
bf7c0a3d 164 return _canon_cat( @_ );
638113eb
JH
165}
166
270d1e39 167sub path {
092026cf
SH
168 my @path = split(';', $ENV{PATH});
169 s/"//g for @path;
170 @path = grep length, @path;
171 unshift(@path, ".");
cbc7acb0 172 return @path;
270d1e39
GS
173}
174
175=item canonpath
176
177No physical check on the filesystem, but a logical cleanup of a
178path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
179On Win32 makes
180
181 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
182 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
183
184=cut
185
186sub canonpath {
bf7c0a3d
SP
187 # Legacy / compatibility support
188 #
189 return $_[1] if !defined($_[1]) or $_[1] eq '';
190 return _canon_cat( $_[1] );
270d1e39
GS
191}
192
c27914c9
BS
193=item splitpath
194
555bd962
BG
195 ($volume,$directories,$file) = File::Spec->splitpath( $path );
196 ($volume,$directories,$file) = File::Spec->splitpath( $path,
197 $no_file );
c27914c9 198
40d020d9 199Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
200the last file is a path unless the path ends in '\\', '\\.', '\\..'
201or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 202( $volume, $path, '' ).
c27914c9
BS
203
204Separators accepted are \ and /.
205
206Volumes can be drive letters or UNC sharenames (\\server\share).
207
0994714a 208The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
209(usually identical to) the original path.
210
211=cut
212
213sub splitpath {
214 my ($self,$path, $nofile) = @_;
215 my ($volume,$directory,$file) = ('','','');
216 if ( $nofile ) {
217 $path =~
110c90cc 218 m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9
BS
219 $volume = $1;
220 $directory = $2;
221 }
222 else {
223 $path =~
110c90cc 224 m{^ ( $VOL_RX ? )
5b287435 225 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 226 (.*)
110c90cc 227 }sox;
c27914c9
BS
228 $volume = $1;
229 $directory = $2;
230 $file = $3;
231 }
232
233 return ($volume,$directory,$file);
234}
235
236
237=item splitdir
238
b60bb9a0 239The opposite of L<catdir()|File::Spec/catdir>.
c27914c9
BS
240
241 @dirs = File::Spec->splitdir( $directories );
242
243$directories must be only the directory portion of the path on systems
244that have the concept of a volume or that have path syntax that differentiates
245files from directories.
246
247Unlike just splitting the directories on the separator, leading empty and
248trailing directory entries can be returned, because these are significant
249on some OSs. So,
250
251 File::Spec->splitdir( "/a/b/c" );
252
253Yields:
254
255 ( '', 'a', 'b', '', 'c', '' )
256
257=cut
258
259sub splitdir {
260 my ($self,$directories) = @_ ;
261 #
262 # split() likes to forget about trailing null fields, so here we
263 # check to be sure that there will not be any before handling the
264 # simple case.
265 #
9c045eb2 266 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
267 return split( m|[\\/]|, $directories );
268 }
269 else {
270 #
271 # since there was a trailing separator, add a file name to the end,
272 # then do the split, then replace it with ''.
273 #
274 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
275 $directories[ $#directories ]= '' ;
276 return @directories ;
277 }
278}
279
280
281=item catpath
282
283Takes volume, directory and file portions and returns an entire path. Under
284Unix, $volume is ignored, and this is just like catfile(). On other OSs,
285the $volume become significant.
286
287=cut
288
289sub catpath {
290 my ($self,$volume,$directory,$file) = @_;
291
292 # If it's UNC, make sure the glue separator is there, reusing
293 # whatever separator is first in the $volume
9596c75c
RGS
294 my $v;
295 $volume .= $v
296 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3 297 $directory =~ m@^[^\\/]@s
c27914c9
BS
298 ) ;
299
300 $volume .= $directory ;
301
302 # If the volume is not just A:, make sure the glue separator is
303 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
304 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
305 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 306 $file =~ m@[^\\/]@
c27914c9
BS
307 ) {
308 $volume =~ m@([\\/])@ ;
309 my $sep = $1 ? $1 : '\\' ;
310 $volume .= $sep ;
311 }
312
313 $volume .= $file ;
314
315 return $volume ;
316}
317
9d5071ba
SP
318sub _same {
319 lc($_[1]) eq lc($_[2]);
c27914c9
BS
320}
321
786b702f 322sub rel2abs {
c27914c9
BS
323 my ($self,$path,$base ) = @_;
324
110c90cc
SP
325 my $is_abs = $self->file_name_is_absolute($path);
326
327 # Check for volume (should probably document the '2' thing...)
328 return $self->canonpath( $path ) if $is_abs == 2;
329
330 if ($is_abs) {
331 # It's missing a volume, add one
332 my $vol = ($self->splitpath( $self->_cwd() ))[0];
333 return $self->canonpath( $vol . $path );
334 }
335
336 if ( !defined( $base ) || $base eq '' ) {
337 require Cwd ;
338 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
339 $base = $self->_cwd() 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;