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