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