1 package File::Spec::Win32;
5 use vars qw(@ISA $VERSION);
6 require File::Spec::Unix;
9 $VERSION = eval $VERSION;
11 @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 Since Perl 5.8.0, if running under taint mode, and if the environment
66 variables are tainted, they are not used.
72 return $tmpdir if defined $tmpdir;
73 $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
83 MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
84 indicating the case significance when comparing file specifications.
85 Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
86 See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
92 eval { require Win32API::File; } or return 1;
93 my $drive = shift || "C:";
94 my $osFsType = "\0"x256;
95 my $osVolName = "\0"x256;
97 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
98 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
102 =item file_name_is_absolute
104 As of right now, this returns 2 if the path is absolute with a
105 volume, 1 if it's absolute with no volume, 0 otherwise.
109 sub file_name_is_absolute {
111 my ($self,$file) = @_;
113 if ($file =~ m{^($VOL_RX)}o) {
115 return ($vol =~ m{^$UNC_RX}o ? 2
116 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
119 return $file =~ m{^[\\/]} ? 1 : 0;
124 Concatenate one or more directory names and a filename to form a
125 complete path ending with a filename
132 # Legacy / compatibility support
134 shift, return _canon_cat( "/", @_ )
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;
142 return _canon_cat( @_ );
148 # Legacy / compatibility support
152 shift, return _canon_cat( "/", @_ )
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;
160 return _canon_cat( @_ );
164 my @path = split(';', $ENV{PATH});
166 @path = grep length, @path;
173 No physical check on the filesystem, but a logical cleanup of a
174 path. On UNIX eliminated successive slashes and successive "/.".
177 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
178 dir1\dir2\dir3\...\dir4 -> \dir\dir4
183 # Legacy / compatibility support
185 return $_[1] if !defined($_[1]) or $_[1] eq '';
186 return _canon_cat( $_[1] );
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.
379 sub _canon_cat # @path -> path
381 my ($first, @rest) = @_;
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
392 my $path = join "\\", $first, @rest;
394 $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
396 # xx/././yy --> xx/yy
398 (?:\A|\\) # at begin or after a slash
401 (?:\\|\z) # at end or followed by slash
402 )+ # performance boost -- I do not know why
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
411 $path =~ s{ (\A|\\) # at begin or after a slash
413 (?=\\|\z) # at end or followed by slash
415 # xx\yy\..\zz --> xx\zz
416 while ( $path =~ s{(?:
417 (?:\A|\\) # at begin or after a slash
418 [^\\]+ # rip this 'yy' off
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
426 $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
427 $path =~ s#\\\z##; # xx\ --> xx
429 if ( $volume =~ m#\\\z# )
430 { # <vol>\.. --> <vol>\
431 $path =~ s{ \A # at begin
433 (?:\\\.\.)* # and more
434 (?:\\|\z) # at end or followed by slash
437 return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
439 and $volume =~ m#\A(\\\\.*)\\\z#s;
441 return $path ne "" || $volume ? $volume.$path : ".";