1 package File::Spec::Win32;
5 use vars qw(@ISA $VERSION);
6 require File::Spec::Unix;
10 @ISA = qw(File::Spec::Unix);
12 # Some regexes we use for path splitting
13 my $DRIVE_RX = '[a-zA-Z]:';
14 my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
15 my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
20 File::Spec::Win32 - methods for Win32 file specs
24 require File::Spec::Win32; # Done internally by File::Spec if needed
28 See File::Spec::Unix for a documentation of the methods provided
29 there. This package overrides the implementation of these methods, not
36 Returns a string representation of the null device.
44 sub rootdir () { '\\' }
49 Returns a string representation of the first existing directory
50 from the following list:
61 The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
62 for Symbian (the File::Spec::Win32 is used also for those platforms).
64 Since Perl 5.8.0, if running under taint mode, and if the environment
65 variables are tainted, they are not used.
71 return $tmpdir if defined $tmpdir;
72 $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
82 MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
83 indicating the case significance when comparing file specifications.
84 Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
85 See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
90 sub case_tolerant () {
91 eval { require Win32API::File; } or return 1;
92 my $drive = shift || "C:";
93 my $osFsType = "\0"x256;
94 my $osVolName = "\0"x256;
96 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
97 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
101 =item file_name_is_absolute
103 As of right now, this returns 2 if the path is absolute with a
104 volume, 1 if it's absolute with no volume, 0 otherwise.
108 sub file_name_is_absolute {
110 my ($self,$file) = @_;
112 if ($file =~ m{^($VOL_RX)}o) {
114 return ($vol =~ m{^$UNC_RX}o ? 2
115 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
118 return $file =~ m{^[\\/]} ? 1 : 0;
123 Concatenate one or more directory names and a filename to form a
124 complete path ending with a filename
130 my $file = $self->canonpath(pop @_);
131 return $file unless @_;
132 my $dir = $self->catdir(@_);
133 $dir .= "\\" unless substr($dir,-1) eq "\\";
142 # append a backslash to each argument unless it has one there
143 $_ .= "\\" unless m{\\$};
145 return $self->canonpath(join('', @args));
149 my @path = split(';', $ENV{PATH});
151 @path = grep length, @path;
158 No physical check on the filesystem, but a logical cleanup of a
159 path. On UNIX eliminated successive slashes and successive "/.".
162 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
163 dir1\dir2\dir3\...\dir4 -> \dir\dir4
168 my ($self,$path) = @_;
170 $path =~ s/^([a-z]:)/\u$1/s;
172 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
173 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
174 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
175 $path =~ s|\\\Z(?!\n)||
176 unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
177 # xx1/xx2/xx3/../../xx -> xx1/xx
178 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
179 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
180 return $path if $path =~ m|^\.\.|; # skip relative paths
181 return $path unless $path =~ /\.\./; # too few .'s to cleanup
182 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
183 $path =~ s{^\\\.\.$}{\\}; # \.. -> \
184 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
186 return $self->_collapse($path);
191 ($volume,$directories,$file) = File::Spec->splitpath( $path );
192 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
194 Splits a path into volume, directory, and filename portions. Assumes that
195 the last file is a path unless the path ends in '\\', '\\.', '\\..'
196 or $no_file is true. On Win32 this means that $no_file true makes this return
197 ( $volume, $path, '' ).
199 Separators accepted are \ and /.
201 Volumes can be drive letters or UNC sharenames (\\server\share).
203 The results can be passed to L</catpath> to get back a path equivalent to
204 (usually identical to) the original path.
209 my ($self,$path, $nofile) = @_;
210 my ($volume,$directory,$file) = ('','','');
213 m{^ ( $VOL_RX ? ) (.*) }sox;
220 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
228 return ($volume,$directory,$file);
234 The opposite of L<catdir()|File::Spec/catdir()>.
236 @dirs = File::Spec->splitdir( $directories );
238 $directories must be only the directory portion of the path on systems
239 that have the concept of a volume or that have path syntax that differentiates
240 files from directories.
242 Unlike just splitting the directories on the separator, leading empty and
243 trailing directory entries can be returned, because these are significant
246 File::Spec->splitdir( "/a/b/c" );
250 ( '', 'a', 'b', '', 'c', '' )
255 my ($self,$directories) = @_ ;
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
261 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
262 return split( m|[\\/]|, $directories );
266 # since there was a trailing separator, add a file name to the end,
267 # then do the split, then replace it with ''.
269 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
270 $directories[ $#directories ]= '' ;
271 return @directories ;
278 Takes volume, directory and file portions and returns an entire path. Under
279 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
280 the $volume become significant.
285 my ($self,$volume,$directory,$file) = @_;
287 # If it's UNC, make sure the glue separator is there, reusing
288 # whatever separator is first in the $volume
291 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
292 $directory =~ m@^[^\\/]@s
295 $volume .= $directory ;
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.
299 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
300 $volume =~ m@[^\\/]\Z(?!\n)@ &&
303 $volume =~ m@([\\/])@ ;
304 my $sep = $1 ? $1 : '\\' ;
314 lc($_[1]) eq lc($_[2]);
318 my ($self,$path,$base ) = @_;
320 my $is_abs = $self->file_name_is_absolute($path);
322 # Check for volume (should probably document the '2' thing...)
323 return $self->canonpath( $path ) if $is_abs == 2;
326 # It's missing a volume, add one
327 my $vol = ($self->splitpath( $self->_cwd() ))[0];
328 return $self->canonpath( $vol . $path );
331 if ( !defined( $base ) || $base eq '' ) {
333 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
334 $base = $self->_cwd() unless defined $base ;
336 elsif ( ! $self->file_name_is_absolute( $base ) ) {
337 $base = $self->rel2abs( $base ) ;
340 $base = $self->canonpath( $base ) ;
343 my ( $path_directories, $path_file ) =
344 ($self->splitpath( $path, 1 ))[1,2] ;
346 my ( $base_volume, $base_directories ) =
347 $self->splitpath( $base, 1 ) ;
349 $path = $self->catpath(
351 $self->catdir( $base_directories, $path_directories ),
355 return $self->canonpath( $path ) ;
360 =head2 Note For File::Spec::Win32 Maintainers
362 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
366 Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
368 This program is free software; you can redistribute it and/or modify
369 it under the same terms as Perl itself.
373 See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
374 implementation of these methods, not the semantics.