This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
speed up building with less disk IO pod moves+__END__+misc
[perl5.git] / dist / PathTools / 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
f4eedc6b 8$VERSION = '3.51';
3d2a0adf 9$VERSION =~ tr/_//;
b4296952 10
cbc7acb0
JD
11@ISA = qw(File::Spec::Unix);
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 {
efa159bc 93 eval { require Win32API::File; } or return 1;
a7f43cfc 94 my $drive = shift || "C:";
efa159bc
RU
95 my $osFsType = "\0"x256;
96 my $osVolName = "\0"x256;
97 my $ouFsFlags = 0;
98 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
99 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
100 else { return 1; }
46726cbe
CB
101}
102
efa159bc
RU
103=item file_name_is_absolute
104
105As of right now, this returns 2 if the path is absolute with a
106volume, 1 if it's absolute with no volume, 0 otherwise.
107
108=cut
109
cbc7acb0 110sub file_name_is_absolute {
c1e8580e 111
cbc7acb0 112 my ($self,$file) = @_;
c1e8580e
SP
113
114 if ($file =~ m{^($VOL_RX)}o) {
115 my $vol = $1;
116 return ($vol =~ m{^$UNC_RX}o ? 2
117 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
118 : 0);
119 }
120 return $file =~ m{^[\\/]} ? 1 : 0;
270d1e39
GS
121}
122
123=item catfile
124
125Concatenate one or more directory names and a filename to form a
126complete path ending with a filename
127
128=cut
129
130sub catfile {
bf7c0a3d
SP
131 shift;
132
133 # Legacy / compatibility support
134 #
135 shift, return _canon_cat( "/", @_ )
136 if $_[0] eq "";
137
795ee885
SP
138 # Compatibility with File::Spec <= 3.26:
139 # catfile('A:', 'foo') should return 'A:\foo'.
140 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
141 if $_[0] =~ m{^$DRIVE_RX\z}o;
142
bf7c0a3d 143 return _canon_cat( @_ );
270d1e39
GS
144}
145
638113eb 146sub catdir {
bf7c0a3d
SP
147 shift;
148
149 # Legacy / compatibility support
150 #
151 return ""
152 unless @_;
153 shift, return _canon_cat( "/", @_ )
154 if $_[0] eq "";
155
795ee885
SP
156 # Compatibility with File::Spec <= 3.26:
157 # catdir('A:', 'foo') should return 'A:\foo'.
158 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
159 if $_[0] =~ m{^$DRIVE_RX\z}o;
160
bf7c0a3d 161 return _canon_cat( @_ );
638113eb
JH
162}
163
270d1e39 164sub path {
092026cf
SH
165 my @path = split(';', $ENV{PATH});
166 s/"//g for @path;
167 @path = grep length, @path;
168 unshift(@path, ".");
cbc7acb0 169 return @path;
270d1e39
GS
170}
171
172=item canonpath
173
174No physical check on the filesystem, but a logical cleanup of a
175path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
176On Win32 makes
177
178 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
179 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
180
181=cut
182
183sub canonpath {
bf7c0a3d
SP
184 # Legacy / compatibility support
185 #
186 return $_[1] if !defined($_[1]) or $_[1] eq '';
187 return _canon_cat( $_[1] );
270d1e39
GS
188}
189
c27914c9
BS
190=item splitpath
191
555bd962
BG
192 ($volume,$directories,$file) = File::Spec->splitpath( $path );
193 ($volume,$directories,$file) = File::Spec->splitpath( $path,
194 $no_file );
c27914c9 195
40d020d9 196Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
197the last file is a path unless the path ends in '\\', '\\.', '\\..'
198or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 199( $volume, $path, '' ).
c27914c9
BS
200
201Separators accepted are \ and /.
202
203Volumes can be drive letters or UNC sharenames (\\server\share).
204
0994714a 205The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
206(usually identical to) the original path.
207
208=cut
209
210sub splitpath {
211 my ($self,$path, $nofile) = @_;
212 my ($volume,$directory,$file) = ('','','');
213 if ( $nofile ) {
214 $path =~
110c90cc 215 m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9
BS
216 $volume = $1;
217 $directory = $2;
218 }
219 else {
220 $path =~
110c90cc 221 m{^ ( $VOL_RX ? )
5b287435 222 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 223 (.*)
110c90cc 224 }sox;
c27914c9
BS
225 $volume = $1;
226 $directory = $2;
227 $file = $3;
228 }
229
230 return ($volume,$directory,$file);
231}
232
233
234=item splitdir
235
b60bb9a0 236The opposite of L<catdir()|File::Spec/catdir>.
c27914c9
BS
237
238 @dirs = File::Spec->splitdir( $directories );
239
240$directories must be only the directory portion of the path on systems
241that have the concept of a volume or that have path syntax that differentiates
242files from directories.
243
244Unlike just splitting the directories on the separator, leading empty and
245trailing directory entries can be returned, because these are significant
246on some OSs. So,
247
248 File::Spec->splitdir( "/a/b/c" );
249
250Yields:
251
252 ( '', 'a', 'b', '', 'c', '' )
253
254=cut
255
256sub splitdir {
257 my ($self,$directories) = @_ ;
258 #
259 # split() likes to forget about trailing null fields, so here we
260 # check to be sure that there will not be any before handling the
261 # simple case.
262 #
9c045eb2 263 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
264 return split( m|[\\/]|, $directories );
265 }
266 else {
267 #
268 # since there was a trailing separator, add a file name to the end,
269 # then do the split, then replace it with ''.
270 #
271 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
272 $directories[ $#directories ]= '' ;
273 return @directories ;
274 }
275}
276
277
278=item catpath
279
280Takes volume, directory and file portions and returns an entire path. Under
281Unix, $volume is ignored, and this is just like catfile(). On other OSs,
282the $volume become significant.
283
284=cut
285
286sub catpath {
287 my ($self,$volume,$directory,$file) = @_;
288
289 # If it's UNC, make sure the glue separator is there, reusing
290 # whatever separator is first in the $volume
9596c75c
RGS
291 my $v;
292 $volume .= $v
293 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3 294 $directory =~ m@^[^\\/]@s
c27914c9
BS
295 ) ;
296
297 $volume .= $directory ;
298
299 # If the volume is not just A:, make sure the glue separator is
300 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
301 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
302 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 303 $file =~ m@[^\\/]@
c27914c9
BS
304 ) {
305 $volume =~ m@([\\/])@ ;
306 my $sep = $1 ? $1 : '\\' ;
307 $volume .= $sep ;
308 }
309
310 $volume .= $file ;
311
312 return $volume ;
313}
314
9d5071ba
SP
315sub _same {
316 lc($_[1]) eq lc($_[2]);
c27914c9
BS
317}
318
786b702f 319sub rel2abs {
c27914c9
BS
320 my ($self,$path,$base ) = @_;
321
110c90cc
SP
322 my $is_abs = $self->file_name_is_absolute($path);
323
324 # Check for volume (should probably document the '2' thing...)
325 return $self->canonpath( $path ) if $is_abs == 2;
326
327 if ($is_abs) {
328 # It's missing a volume, add one
329 my $vol = ($self->splitpath( $self->_cwd() ))[0];
330 return $self->canonpath( $vol . $path );
331 }
332
333 if ( !defined( $base ) || $base eq '' ) {
334 require Cwd ;
335 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
336 $base = $self->_cwd() unless defined $base ;
c27914c9 337 }
110c90cc
SP
338 elsif ( ! $self->file_name_is_absolute( $base ) ) {
339 $base = $self->rel2abs( $base ) ;
340 }
341 else {
342 $base = $self->canonpath( $base ) ;
343 }
344
345 my ( $path_directories, $path_file ) =
346 ($self->splitpath( $path, 1 ))[1,2] ;
347
348 my ( $base_volume, $base_directories ) =
349 $self->splitpath( $base, 1 ) ;
350
351 $path = $self->catpath(
352 $base_volume,
353 $self->catdir( $base_directories, $path_directories ),
354 $path_file
355 ) ;
c27914c9
BS
356
357 return $self->canonpath( $path ) ;
358}
359
270d1e39
GS
360=back
361
dd9bbc5b
JH
362=head2 Note For File::Spec::Win32 Maintainers
363
364Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
365
99f36a73
RGS
366=head1 COPYRIGHT
367
efa159bc 368Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
99f36a73
RGS
369
370This program is free software; you can redistribute it and/or modify
371it under the same terms as Perl itself.
372
cbc7acb0
JD
373=head1 SEE ALSO
374
72f15715
T
375See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
376implementation of these methods, not the semantics.
270d1e39 377
cbc7acb0
JD
378=cut
379
bf7c0a3d 380
486bcc50 381sub _canon_cat # @path -> path
bf7c0a3d 382{
486bcc50
NC
383 my ($first, @rest) = @_;
384
bf7c0a3d
SP
385 my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
386 ? ucfirst( $1 ).( $2 ? "\\" : "" )
387 : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
388 (?: [\\/] ([^\\/]+) )?
389 [\\/]? }{}xs # UNC volume
390 ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
391 : $first =~ s{ \A [\\/] }{}x # root dir
392 ? "\\"
393 : "";
486bcc50 394 my $path = join "\\", $first, @rest;
bf7c0a3d
SP
395
396 $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
397
398 # xx/././yy --> xx/yy
399 $path =~ s{(?:
400 (?:\A|\\) # at begin or after a slash
401 \.
402 (?:\\\.)* # and more
403 (?:\\|\z) # at end or followed by slash
404 )+ # performance boost -- I do not know why
405 }{\\}gx;
406
407 # XXX I do not know whether more dots are supported by the OS supporting
408 # this ... annotation (NetWare or symbian but not MSWin32).
409 # Then .... could easily become ../../.. etc:
410 # Replace \.\.\. by (\.\.\.+) and substitute with
411 # { $1 . ".." . "\\.." x (length($2)-2) }gex
412 # ... --> ../..
413 $path =~ s{ (\A|\\) # at begin or after a slash
414 \.\.\.
415 (?=\\|\z) # at end or followed by slash
416 }{$1..\\..}gx;
417 # xx\yy\..\zz --> xx\zz
418 while ( $path =~ s{(?:
419 (?:\A|\\) # at begin or after a slash
420 [^\\]+ # rip this 'yy' off
421 \\\.\.
422 (?<!\A\.\.\\\.\.) # do *not* replace ^..\..
423 (?<!\\\.\.\\\.\.) # do *not* replace \..\..
424 (?:\\|\z) # at end or followed by slash
425 )+ # performance boost -- I do not know why
426 }{\\}sx ) {}
427
428 $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
429 $path =~ s#\\\z##; # xx\ --> xx
430
431 if ( $volume =~ m#\\\z# )
432 { # <vol>\.. --> <vol>\
433 $path =~ s{ \A # at begin
434 \.\.
435 (?:\\\.\.)* # and more
436 (?:\\|\z) # at end or followed by slash
437 }{}x;
438
439 return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
440 if $path eq ""
441 and $volume =~ m#\A(\\\\.*)\\\z#s;
442 }
443 return $path ne "" || $volume ? $volume.$path : ".";
444}
445
cbc7acb0 4461;