1package File::Spec::Win32; 2 3use strict; 4 5use Cwd (); 6require File::Spec::Unix; 7 8our $VERSION = '3.75'; 9$VERSION =~ tr/_//d; 10 11our @ISA = qw(File::Spec::Unix); 12 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 19=head1 NAME 20 21File::Spec::Win32 - methods for Win32 file specs 22 23=head1 SYNOPSIS 24 25 require File::Spec::Win32; # Done internally by File::Spec if needed 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 33=over 4 34 35=item devnull 36 37Returns a string representation of the null device. 38 39=cut 40 41sub devnull { 42 return "nul"; 43} 44 45sub rootdir { '\\' } 46 47 48=item tmpdir 49 50Returns a string representation of the first existing directory 51from the following list: 52 53 $ENV{TMPDIR} 54 $ENV{TEMP} 55 $ENV{TMP} 56 SYS:/temp 57 C:\system\temp 58 C:/temp 59 /tmp 60 / 61 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). 64 65If running under taint mode, and if the environment 66variables are tainted, they are not used. 67 68=cut 69 70sub tmpdir { 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) ), 74 'SYS:/temp', 75 'C:\system\temp', 76 'C:/temp', 77 '/tmp', 78 '/' ); 79 $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP)); 80} 81 82=item case_tolerant 83 84MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, 85indicating the case significance when comparing file specifications. 86Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem. 87See http://cygwin.com/ml/cygwin/2007-07/msg00891.html 88Default: 1 89 90=cut 91 92sub case_tolerant { 93 eval { 94 local @INC = @INC; 95 pop @INC if $INC[-1] eq '.'; 96 require Win32API::File; 97 } or return 1; 98 my $drive = shift || "C:"; 99 my $osFsType = "\0"x256; 100 my $osVolName = "\0"x256; 101 my $ouFsFlags = 0; 102 Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); 103 if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } 104 else { return 1; } 105} 106 107=item file_name_is_absolute 108 109As of right now, this returns 2 if the path is absolute with a 110volume, 1 if it's absolute with no volume, 0 otherwise. 111 112=cut 113 114sub file_name_is_absolute { 115 116 my ($self,$file) = @_; 117 118 if ($file =~ m{^($VOL_RX)}o) { 119 my $vol = $1; 120 return ($vol =~ m{^$UNC_RX}o ? 2 121 : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 122 : 0); 123 } 124 return $file =~ m{^[\\/]} ? 1 : 0; 125} 126 127=item catfile 128 129Concatenate one or more directory names and a filename to form a 130complete path ending with a filename 131 132=cut 133 134sub catfile { 135 shift; 136 137 # Legacy / compatibility support 138 # 139 shift, return _canon_cat( "/", @_ ) 140 if $_[0] eq ""; 141 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; 146 147 return _canon_cat( @_ ); 148} 149 150sub catdir { 151 shift; 152 153 # Legacy / compatibility support 154 # 155 return "" 156 unless @_; 157 shift, return _canon_cat( "/", @_ ) 158 if $_[0] eq ""; 159 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; 164 165 return _canon_cat( @_ ); 166} 167 168sub path { 169 my @path = split(';', $ENV{PATH}); 170 s/"//g for @path; 171 @path = grep length, @path; 172 unshift(@path, "."); 173 return @path; 174} 175 176=item canonpath 177 178No physical check on the filesystem, but a logical cleanup of a 179path. On UNIX eliminated successive slashes and successive "/.". 180On Win32 makes 181 182 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even 183 dir1\dir2\dir3\...\dir4 -> \dir\dir4 184 185=cut 186 187sub canonpath { 188 # Legacy / compatibility support 189 # 190 return $_[1] if !defined($_[1]) or $_[1] eq ''; 191 return _canon_cat( $_[1] ); 192} 193 194=item splitpath 195 196 ($volume,$directories,$file) = File::Spec->splitpath( $path ); 197 ($volume,$directories,$file) = File::Spec->splitpath( $path, 198 $no_file ); 199 200Splits a path into volume, directory, and filename portions. Assumes that 201the last file is a path unless the path ends in '\\', '\\.', '\\..' 202or $no_file is true. On Win32 this means that $no_file true makes this return 203( $volume, $path, '' ). 204 205Separators accepted are \ and /. 206 207Volumes can be drive letters or UNC sharenames (\\server\share). 208 209The results can be passed to L</catpath> to get back a path equivalent to 210(usually identical to) the original path. 211 212=cut 213 214sub splitpath { 215 my ($self,$path, $nofile) = @_; 216 my ($volume,$directory,$file) = ('','',''); 217 if ( $nofile ) { 218 $path =~ 219 m{^ ( $VOL_RX ? ) (.*) }sox; 220 $volume = $1; 221 $directory = $2; 222 } 223 else { 224 $path =~ 225 m{^ ( $VOL_RX ? ) 226 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) 227 (.*) 228 }sox; 229 $volume = $1; 230 $directory = $2; 231 $file = $3; 232 } 233 234 return ($volume,$directory,$file); 235} 236 237 238=item splitdir 239 240The opposite of L<catdir()|File::Spec/catdir>. 241 242 @dirs = File::Spec->splitdir( $directories ); 243 244$directories must be only the directory portion of the path on systems 245that have the concept of a volume or that have path syntax that differentiates 246files from directories. 247 248Unlike just splitting the directories on the separator, leading empty and 249trailing directory entries can be returned, because these are significant 250on some OSs. So, 251 252 File::Spec->splitdir( "/a/b/c" ); 253 254Yields: 255 256 ( '', 'a', 'b', '', 'c', '' ) 257 258=cut 259 260sub splitdir { 261 my ($self,$directories) = @_ ; 262 # 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 265 # simple case. 266 # 267 if ( $directories !~ m|[\\/]\Z(?!\n)| ) { 268 return split( m|[\\/]|, $directories ); 269 } 270 else { 271 # 272 # since there was a trailing separator, add a file name to the end, 273 # then do the split, then replace it with ''. 274 # 275 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; 276 $directories[ $#directories ]= '' ; 277 return @directories ; 278 } 279} 280 281 282=item catpath 283 284Takes volume, directory and file portions and returns an entire path. Under 285Unix, $volume is ignored, and this is just like catfile(). On other OSs, 286the $volume become significant. 287 288=cut 289 290sub catpath { 291 my ($self,$volume,$directory,$file) = @_; 292 293 # If it's UNC, make sure the glue separator is there, reusing 294 # whatever separator is first in the $volume 295 my $v; 296 $volume .= $v 297 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && 298 $directory =~ m@^[^\\/]@s 299 ) ; 300 301 $volume .= $directory ; 302 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)@ && 307 $file =~ m@[^\\/]@ 308 ) { 309 $volume =~ m@([\\/])@ ; 310 my $sep = $1 ? $1 : '\\' ; 311 $volume .= $sep ; 312 } 313 314 $volume .= $file ; 315 316 return $volume ; 317} 318 319sub _same { 320 lc($_[1]) eq lc($_[2]); 321} 322 323sub rel2abs { 324 my ($self,$path,$base ) = @_; 325 326 my $is_abs = $self->file_name_is_absolute($path); 327 328 # Check for volume (should probably document the '2' thing...) 329 return $self->canonpath( $path ) if $is_abs == 2; 330 331 if ($is_abs) { 332 # It's missing a volume, add one 333 my $vol = ($self->splitpath( Cwd::getcwd() ))[0]; 334 return $self->canonpath( $vol . $path ); 335 } 336 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 ; 340 } 341 elsif ( ! $self->file_name_is_absolute( $base ) ) { 342 $base = $self->rel2abs( $base ) ; 343 } 344 else { 345 $base = $self->canonpath( $base ) ; 346 } 347 348 my ( $path_directories, $path_file ) = 349 ($self->splitpath( $path, 1 ))[1,2] ; 350 351 my ( $base_volume, $base_directories ) = 352 $self->splitpath( $base, 1 ) ; 353 354 $path = $self->catpath( 355 $base_volume, 356 $self->catdir( $base_directories, $path_directories ), 357 $path_file 358 ) ; 359 360 return $self->canonpath( $path ) ; 361} 362 363=back 364 365=head2 Note For File::Spec::Win32 Maintainers 366 367Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. 368 369=head1 COPYRIGHT 370 371Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. 372 373This program is free software; you can redistribute it and/or modify 374it under the same terms as Perl itself. 375 376=head1 SEE ALSO 377 378See L<File::Spec> and L<File::Spec::Unix>. This package overrides the 379implementation of these methods, not the semantics. 380 381=cut 382 383 384sub _canon_cat # @path -> path 385{ 386 my ($first, @rest) = @_; 387 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 395 ? "\\" 396 : ""; 397 my $path = join "\\", $first, @rest; 398 399 $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy 400 401 # xx/././yy --> xx/yy 402 $path =~ s{(?: 403 (?:\A|\\) # at begin or after a slash 404 \. 405 (?:\\\.)* # and more 406 (?:\\|\z) # at end or followed by slash 407 )+ # performance boost -- I do not know why 408 }{\\}gx; 409 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 415 # ... --> ../.. 416 $path =~ s{ (\A|\\) # at begin or after a slash 417 \.\.\. 418 (?=\\|\z) # at end or followed by slash 419 }{$1..\\..}gx; 420 # xx\yy\..\zz --> xx\zz 421 while ( $path =~ s{(?: 422 (?:\A|\\) # at begin or after a slash 423 [^\\]+ # rip this 'yy' off 424 \\\.\. 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 429 }{\\}sx ) {} 430 431 $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root 432 $path =~ s#\\\z##; # xx\ --> xx 433 434 if ( $volume =~ m#\\\z# ) 435 { # <vol>\.. --> <vol>\ 436 $path =~ s{ \A # at begin 437 \.\. 438 (?:\\\.\.)* # and more 439 (?:\\|\z) # at end or followed by slash 440 }{}x; 441 442 return $1 # \\HOST\SHARE\ --> \\HOST\SHARE 443 if $path eq "" 444 and $volume =~ m#\A(\\\\.*)\\\z#s; 445 } 446 return $path ne "" || $volume ? $volume.$path : "."; 447} 448 4491; 450