1package File::Spec::Win32; 2 3use strict; 4 5use vars qw(@ISA $VERSION); 6require File::Spec::Unix; 7 8$VERSION = '1.4'; 9 10@ISA = qw(File::Spec::Unix); 11 12=head1 NAME 13 14File::Spec::Win32 - methods for Win32 file specs 15 16=head1 SYNOPSIS 17 18 require File::Spec::Win32; # Done internally by File::Spec if needed 19 20=head1 DESCRIPTION 21 22See File::Spec::Unix for a documentation of the methods provided 23there. This package overrides the implementation of these methods, not 24the semantics. 25 26=over 4 27 28=item devnull 29 30Returns a string representation of the null device. 31 32=cut 33 34sub devnull { 35 return "nul"; 36} 37 38=item tmpdir 39 40Returns a string representation of the first existing directory 41from the following list: 42 43 $ENV{TMPDIR} 44 $ENV{TEMP} 45 $ENV{TMP} 46 SYS:/temp 47 C:/temp 48 /tmp 49 / 50 51The SYS:/temp is preferred in Novell NetWare (the File::Spec::Win32 52is used also for NetWare). 53 54Since Perl 5.8.0, if running under taint mode, and if the environment 55variables are tainted, they are not used. 56 57=cut 58 59my $tmpdir; 60sub tmpdir { 61 return $tmpdir if defined $tmpdir; 62 my $self = shift; 63 $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, 64 'SYS:/temp', 65 'C:/temp', 66 '/tmp', 67 '/' ); 68} 69 70sub case_tolerant { 71 return 1; 72} 73 74sub file_name_is_absolute { 75 my ($self,$file) = @_; 76 return scalar($file =~ m{^([a-z]:)?[\\/]}is); 77} 78 79=item catfile 80 81Concatenate one or more directory names and a filename to form a 82complete path ending with a filename 83 84=cut 85 86sub catfile { 87 my $self = shift; 88 my $file = $self->canonpath(pop @_); 89 return $file unless @_; 90 my $dir = $self->catdir(@_); 91 $dir .= "\\" unless substr($dir,-1) eq "\\"; 92 return $dir.$file; 93} 94 95sub catdir { 96 my $self = shift; 97 my @args = @_; 98 foreach (@args) { 99 tr[/][\\]; 100 # append a backslash to each argument unless it has one there 101 $_ .= "\\" unless m{\\$}; 102 } 103 return $self->canonpath(join('', @args)); 104} 105 106sub path { 107 my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; 108 my @path = split(';',$path); 109 foreach (@path) { $_ = '.' if $_ eq '' } 110 return @path; 111} 112 113=item canonpath 114 115No physical check on the filesystem, but a logical cleanup of a 116path. On UNIX eliminated successive slashes and successive "/.". 117On Win32 makes 118 119 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even 120 dir1\dir2\dir3\...\dir4 -> \dir\dir4 121 122=cut 123 124sub canonpath { 125 my ($self,$path) = @_; 126 my $orig_path = $path; 127 $path =~ s/^([a-z]:)/\u$1/s; 128 $path =~ s|/|\\|g; 129 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx 130 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx 131 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx 132 $path =~ s|\\\Z(?!\n)|| 133 unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx 134 # xx1/xx2/xx3/../../xx -> xx1/xx 135 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up 136 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up 137 return $path if $path =~ m|^\.\.|; # skip relative paths 138 return $path unless $path =~ /\.\./; # too few .'s to cleanup 139 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup 140 $path =~ s{^\\\.\.$}{\\}; # \.. -> \ 141 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx 142 143 my ($vol,$dirs,$file) = $self->splitpath($path); 144 my @dirs = $self->splitdir($dirs); 145 my (@base_dirs, @path_dirs); 146 my $dest = \@base_dirs; 147 for my $dir (@dirs){ 148 $dest = \@path_dirs if $dir eq $self->updir; 149 push @$dest, $dir; 150 } 151 # for each .. in @path_dirs pop one item from 152 # @base_dirs 153 while (my $dir = shift @path_dirs){ 154 unless ($dir eq $self->updir){ 155 unshift @path_dirs, $dir; 156 last; 157 } 158 pop @base_dirs; 159 } 160 $path = $self->catpath( 161 $vol, 162 $self->catdir(@base_dirs, @path_dirs), 163 $file 164 ); 165 return $path; 166} 167 168=item splitpath 169 170 ($volume,$directories,$file) = File::Spec->splitpath( $path ); 171 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); 172 173Splits a path into volume, directory, and filename portions. Assumes that 174the last file is a path unless the path ends in '\\', '\\.', '\\..' 175or $no_file is true. On Win32 this means that $no_file true makes this return 176( $volume, $path, '' ). 177 178Separators accepted are \ and /. 179 180Volumes can be drive letters or UNC sharenames (\\server\share). 181 182The results can be passed to L</catpath> to get back a path equivalent to 183(usually identical to) the original path. 184 185=cut 186 187sub splitpath { 188 my ($self,$path, $nofile) = @_; 189 my ($volume,$directory,$file) = ('','',''); 190 if ( $nofile ) { 191 $path =~ 192 m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 193 (.*) 194 }xs; 195 $volume = $1; 196 $directory = $2; 197 } 198 else { 199 $path =~ 200 m{^ ( (?: [a-zA-Z]: | 201 (?:\\\\|//)[^\\/]+[\\/][^\\/]+ 202 )? 203 ) 204 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) 205 (.*) 206 }xs; 207 $volume = $1; 208 $directory = $2; 209 $file = $3; 210 } 211 212 return ($volume,$directory,$file); 213} 214 215 216=item splitdir 217 218The opposite of L<catdir()|File::Spec/catdir()>. 219 220 @dirs = File::Spec->splitdir( $directories ); 221 222$directories must be only the directory portion of the path on systems 223that have the concept of a volume or that have path syntax that differentiates 224files from directories. 225 226Unlike just splitting the directories on the separator, leading empty and 227trailing directory entries can be returned, because these are significant 228on some OSs. So, 229 230 File::Spec->splitdir( "/a/b/c" ); 231 232Yields: 233 234 ( '', 'a', 'b', '', 'c', '' ) 235 236=cut 237 238sub splitdir { 239 my ($self,$directories) = @_ ; 240 # 241 # split() likes to forget about trailing null fields, so here we 242 # check to be sure that there will not be any before handling the 243 # simple case. 244 # 245 if ( $directories !~ m|[\\/]\Z(?!\n)| ) { 246 return split( m|[\\/]|, $directories ); 247 } 248 else { 249 # 250 # since there was a trailing separator, add a file name to the end, 251 # then do the split, then replace it with ''. 252 # 253 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; 254 $directories[ $#directories ]= '' ; 255 return @directories ; 256 } 257} 258 259 260=item catpath 261 262Takes volume, directory and file portions and returns an entire path. Under 263Unix, $volume is ignored, and this is just like catfile(). On other OSs, 264the $volume become significant. 265 266=cut 267 268sub catpath { 269 my ($self,$volume,$directory,$file) = @_; 270 271 # If it's UNC, make sure the glue separator is there, reusing 272 # whatever separator is first in the $volume 273 $volume .= $1 274 if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && 275 $directory =~ m@^[^\\/]@s 276 ) ; 277 278 $volume .= $directory ; 279 280 # If the volume is not just A:, make sure the glue separator is 281 # there, reusing whatever separator is first in the $volume if possible. 282 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && 283 $volume =~ m@[^\\/]\Z(?!\n)@ && 284 $file =~ m@[^\\/]@ 285 ) { 286 $volume =~ m@([\\/])@ ; 287 my $sep = $1 ? $1 : '\\' ; 288 $volume .= $sep ; 289 } 290 291 $volume .= $file ; 292 293 return $volume ; 294} 295 296 297sub abs2rel { 298 my($self,$path,$base) = @_; 299 $base = $self->_cwd() unless defined $base and length $base; 300 301 for ($path, $base) { $_ = $self->canonpath($_) } 302 303 my ($path_volume) = $self->splitpath($path, 1); 304 my ($base_volume) = $self->splitpath($base, 1); 305 306 # Can't relativize across volumes 307 return $path unless $path_volume eq $base_volume; 308 309 for ($path, $base) { $_ = $self->rel2abs($_) } 310 311 my $path_directories = ($self->splitpath($path, 1))[1]; 312 my $base_directories = ($self->splitpath($base, 1))[1]; 313 314 # Now, remove all leading components that are the same 315 my @pathchunks = $self->splitdir( $path_directories ); 316 my @basechunks = $self->splitdir( $base_directories ); 317 318 while ( @pathchunks && 319 @basechunks && 320 lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 321 ) { 322 shift @pathchunks ; 323 shift @basechunks ; 324 } 325 326 my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); 327 328 return $self->canonpath( $self->catpath('', $result_dirs, '') ); 329} 330 331 332sub rel2abs { 333 my ($self,$path,$base ) = @_; 334 335 if ( ! $self->file_name_is_absolute( $path ) ) { 336 337 if ( !defined( $base ) || $base eq '' ) { 338 $base = $self->_cwd() ; 339 } 340 elsif ( ! $self->file_name_is_absolute( $base ) ) { 341 $base = $self->rel2abs( $base ) ; 342 } 343 else { 344 $base = $self->canonpath( $base ) ; 345 } 346 347 my ( $path_directories, $path_file ) = 348 ($self->splitpath( $path, 1 ))[1,2] ; 349 350 my ( $base_volume, $base_directories ) = 351 $self->splitpath( $base, 1 ) ; 352 353 $path = $self->catpath( 354 $base_volume, 355 $self->catdir( $base_directories, $path_directories ), 356 $path_file 357 ) ; 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 SEE ALSO 370 371See L<File::Spec> and L<File::Spec::Unix>. This package overrides the 372implementation of these methods, not the semantics. 373 374=cut 375 3761; 377