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