1 package File::Spec::Win32;
6 require File::Spec::Unix;
11 our @ISA = qw(File::Spec::Unix);
13 # Some regexes we use for path splitting
14 my $DRIVE_RX = '[a-zA-Z]:';
15 my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
16 my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
21 File::Spec::Win32 - methods for Win32 file specs
25 require File::Spec::Win32; # Done internally by File::Spec if needed
29 See File::Spec::Unix for a documentation of the methods provided
30 there. This package overrides the implementation of these methods, not
37 Returns a string representation of the null device.
50 Returns a string representation of the first existing directory
51 from the following list:
62 The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
63 for Symbian (the File::Spec::Win32 is used also for those platforms).
65 If running under taint mode, and if the environment
66 variables are tainted, they are not used.
71 my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP));
72 return $tmpdir if defined $tmpdir;
73 $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
79 $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP));
84 MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
85 indicating the case significance when comparing file specifications.
86 Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
87 See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
95 pop @INC if $INC[-1] eq '.';
96 require Win32API::File;
98 my $drive = shift || "C:";
99 my $osFsType = "\0"x256;
100 my $osVolName = "\0"x256;
102 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
103 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
107 =item file_name_is_absolute
109 As of right now, this returns 2 if the path is absolute with a
110 volume, 1 if it's absolute with no volume, 0 otherwise.
114 sub file_name_is_absolute {
116 my ($self,$file) = @_;
118 if ($file =~ m{^($VOL_RX)}o) {
120 return ($vol =~ m{^$UNC_RX}o ? 2
121 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
124 return $file =~ m{^[\\/]} ? 1 : 0;
129 Concatenate one or more directory names and a filename to form a
130 complete path ending with a filename
137 # Legacy / compatibility support
139 shift, return _canon_cat( "/", @_ )
142 # Compatibility with File::Spec <= 3.26:
143 # catfile('A:', 'foo') should return 'A:\foo'.
144 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
145 if $_[0] =~ m{^$DRIVE_RX\z}o;
147 return _canon_cat( @_ );
153 # Legacy / compatibility support
157 shift, return _canon_cat( "/", @_ )
160 # Compatibility with File::Spec <= 3.26:
161 # catdir('A:', 'foo') should return 'A:\foo'.
162 return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
163 if $_[0] =~ m{^$DRIVE_RX\z}o;
165 return _canon_cat( @_ );
169 my @path = split(';', $ENV{PATH});
171 @path = grep length, @path;
178 No physical check on the filesystem, but a logical cleanup of a
179 path. On UNIX eliminated successive slashes and successive "/.".
182 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
183 dir1\dir2\dir3\...\dir4 -> \dir\dir4
188 # Legacy / compatibility support
190 return $_[1] if !defined($_[1]) or $_[1] eq '';
191 return _canon_cat( $_[1] );
196 ($volume,$directories,$file) = File::Spec->splitpath( $path );
197 ($volume,$directories,$file) = File::Spec->splitpath( $path,
200 Splits a path into volume, directory, and filename portions. Assumes that
201 the last file is a path unless the path ends in '\\', '\\.', '\\..'
202 or $no_file is true. On Win32 this means that $no_file true makes this return
203 ( $volume, $path, '' ).
205 Separators accepted are \ and /.
207 Volumes can be drive letters or UNC sharenames (\\server\share).
209 The results can be passed to L</catpath> to get back a path equivalent to
210 (usually identical to) the original path.
215 my ($self,$path, $nofile) = @_;
216 my ($volume,$directory,$file) = ('','','');
219 m{^ ( $VOL_RX ? ) (.*) }sox;
226 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
234 return ($volume,$directory,$file);
240 The opposite of L<catdir()|File::Spec/catdir>.
242 @dirs = File::Spec->splitdir( $directories );
244 $directories must be only the directory portion of the path on systems
245 that have the concept of a volume or that have path syntax that differentiates
246 files from directories.
248 Unlike just splitting the directories on the separator, leading empty and
249 trailing directory entries can be returned, because these are significant
252 File::Spec->splitdir( "/a/b/c" );
256 ( '', 'a', 'b', '', 'c', '' )
261 my ($self,$directories) = @_ ;
263 # split() likes to forget about trailing null fields, so here we
264 # check to be sure that there will not be any before handling the
267 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
268 return split( m|[\\/]|, $directories );
272 # since there was a trailing separator, add a file name to the end,
273 # then do the split, then replace it with ''.
275 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
276 $directories[ $#directories ]= '' ;
277 return @directories ;
284 Takes volume, directory and file portions and returns an entire path. Under
285 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
286 the $volume become significant.
291 my ($self,$volume,$directory,$file) = @_;
293 # If it's UNC, make sure the glue separator is there, reusing
294 # whatever separator is first in the $volume
297 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
298 $directory =~ m@^[^\\/]@s
301 $volume .= $directory ;
303 # If the volume is not just A:, make sure the glue separator is
304 # there, reusing whatever separator is first in the $volume if possible.
305 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
306 $volume =~ m@[^\\/]\Z(?!\n)@ &&
309 $volume =~ m@([\\/])@ ;
310 my $sep = $1 ? $1 : '\\' ;
320 lc($_[1]) eq lc($_[2]);
324 my ($self,$path,$base ) = @_;
326 my $is_abs = $self->file_name_is_absolute($path);
328 # Check for volume (should probably document the '2' thing...)
329 return $self->canonpath( $path ) if $is_abs == 2;
332 # It's missing a volume, add one
333 my $vol = ($self->splitpath( Cwd::getcwd() ))[0];
334 return $self->canonpath( $vol . $path );
337 if ( !defined( $base ) || $base eq '' ) {
338 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
339 $base = Cwd::getcwd() unless defined $base ;
341 elsif ( ! $self->file_name_is_absolute( $base ) ) {
342 $base = $self->rel2abs( $base ) ;
345 $base = $self->canonpath( $base ) ;
348 my ( $path_directories, $path_file ) =
349 ($self->splitpath( $path, 1 ))[1,2] ;
351 my ( $base_volume, $base_directories ) =
352 $self->splitpath( $base, 1 ) ;
354 $path = $self->catpath(
356 $self->catdir( $base_directories, $path_directories ),
360 return $self->canonpath( $path ) ;
365 =head2 Note For File::Spec::Win32 Maintainers
367 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
371 Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
373 This program is free software; you can redistribute it and/or modify
374 it under the same terms as Perl itself.
378 See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
379 implementation of these methods, not the semantics.
384 sub _canon_cat # @path -> path
386 my ($first, @rest) = @_;
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
397 my $path = join "\\", $first, @rest;
399 $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
401 # xx/././yy --> xx/yy
403 (?:\A|\\) # at begin or after a slash
406 (?:\\|\z) # at end or followed by slash
407 )+ # performance boost -- I do not know why
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
416 $path =~ s{ (\A|\\) # at begin or after a slash
418 (?=\\|\z) # at end or followed by slash
420 # xx\yy\..\zz --> xx\zz
421 while ( $path =~ s{(?:
422 (?:\A|\\) # at begin or after a slash
423 [^\\]+ # rip this 'yy' off
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
431 $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
432 $path =~ s#\\\z##; # xx\ --> xx
434 if ( $volume =~ m#\\\z# )
435 { # <vol>\.. --> <vol>\
436 $path =~ s{ \A # at begin
438 (?:\\\.\.)* # and more
439 (?:\\|\z) # at end or followed by slash
442 return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
444 and $volume =~ m#\A(\\\\.*)\\\z#s;
446 return $path ne "" || $volume ? $volume.$path : ".";