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