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