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