lib/File/Spec/Win32.pm

   1 package File::Spec::Win32;
   2
   3 use strict;
   4 use Cwd;
   5 use vars qw(@ISA);
   6 require File::Spec::Unix;
   7 @ISA = qw(File::Spec::Unix);
   8
   9 =head1 NAME
  10
  11 File::Spec::Win32 - methods for Win32 file specs
  12
  13 =head1 SYNOPSIS
  14
  15  require File::Spec::Win32; # Done internally by File::Spec if needed
  16
  17 =head1 DESCRIPTION
  18
  19 See File::Spec::Unix for a documentation of the methods provided
  20 there. This package overrides the implementation of these methods, not
  21 the semantics.
  22
  23 =over
  24
  25 =item devnull
  26
  27 Returns a string representation of the null device.
  28
  29 =cut
  30
  31 sub devnull {
  32     return "nul";
  33 }
  34
  35 =item tmpdir
  36
  37 Returns a string representation of the first existing directory
  38 from the following list:
  39
  40     $ENV{TMPDIR}
  41     $ENV{TEMP}
  42     $ENV{TMP}
  43     /tmp
  44     /
  45
  46 =cut
  47
  48 my $tmpdir;
  49 sub tmpdir {
  50     return $tmpdir if defined $tmpdir;
  51     my $self = shift;
  52     foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
  53         next unless defined && -d;
  54         $tmpdir = $_;
  55         last;
  56     }
  57     $tmpdir = '' unless defined $tmpdir;
  58     $tmpdir = $self->canonpath($tmpdir);
  59     return $tmpdir;
  60 }
  61
  62 sub case_tolerant {
  63     return 1;
  64 }
  65
  66 sub file_name_is_absolute {
  67     my ($self,$file) = @_;
  68     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  69 }
  70
  71 =item catfile
  72
  73 Concatenate one or more directory names and a filename to form a
  74 complete path ending with a filename
  75
  76 =cut
  77
  78 sub catfile {
  79     my $self = shift;
  80     my $file = pop @_;
  81     return $file unless @_;
  82     my $dir = $self->catdir(@_);
  83     $dir .= "\\" unless substr($dir,-1) eq "\\";
  84     return $dir.$file;
  85 }
  86
  87 sub path {
  88     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
  89     my @path = split(';',$path);
  90     foreach (@path) { $_ = '.' if $_ eq '' }
  91     return @path;
  92 }
  93
  94 =item canonpath
  95
  96 No physical check on the filesystem, but a logical cleanup of a
  97 path. On UNIX eliminated successive slashes and successive "/.".
  98
  99 =cut
 100
 101 sub canonpath {
 102     my ($self,$path) = @_;
 103     $path =~ s/^([a-z]:)/\u$1/s;
 104     $path =~ s|/|\\|g;
 105     $path =~ s|([^\\])\\+|$1\\|g;                  # xx////xx  -> xx/xx
 106     $path =~ s|(\\\.)+\\|\\|g;                     # xx/././xx -> xx/xx
 107     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # ./xx      -> xx
 108     $path =~ s|\\\z||
 109              unless $path =~ m#^([A-Z]:)?\\\z#s;   # xx/       -> xx
 110     return $path;
 111 }
 112
 113 =item splitpath
 114
 115     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 116     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 117
 118 Splits a path in to volume, directory, and filename portions. Assumes that
 119 the last file is a path unless the path ends in '\\', '\\.', '\\..'
 120 or $no_file is true.  On Win32 this means that $no_file true makes this return
 121 ( $volume, $path, undef ).
 122
 123 Separators accepted are \ and /.
 124
 125 Volumes can be drive letters or UNC sharenames (\\server\share).
 126
 127 The results can be passed to L</catpath> to get back a path equivalent to
 128 (usually identical to) the original path.
 129
 130 =cut
 131
 132 sub splitpath {
 133     my ($self,$path, $nofile) = @_;
 134     my ($volume,$directory,$file) = ('','','');
 135     if ( $nofile ) {
 136         $path =~
 137             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
 138                  (.*)
 139              }xs;
 140         $volume    = $1;
 141         $directory = $2;
 142     }
 143     else {
 144         $path =~
 145             m{^ ( (?: [a-zA-Z]: |
 146                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
 147                   )?
 148                 )
 149                 ( (?:.*[\\\\/](?:\.\.?\z)?)? )
 150                 (.*)
 151              }xs;
 152         $volume    = $1;
 153         $directory = $2;
 154         $file      = $3;
 155     }
 156
 157     return ($volume,$directory,$file);
 158 }
 159
 160
 161 =item splitdir
 162
 163 The opposite of L</catdir()>.
 164
 165     @dirs = File::Spec->splitdir( $directories );
 166
 167 $directories must be only the directory portion of the path on systems
 168 that have the concept of a volume or that have path syntax that differentiates
 169 files from directories.
 170
 171 Unlike just splitting the directories on the separator, leading empty and
 172 trailing directory entries can be returned, because these are significant
 173 on some OSs. So,
 174
 175     File::Spec->splitdir( "/a/b/c" );
 176
 177 Yields:
 178
 179     ( '', 'a', 'b', '', 'c', '' )
 180
 181 =cut
 182
 183 sub splitdir {
 184     my ($self,$directories) = @_ ;
 185     #
 186     # split() likes to forget about trailing null fields, so here we
 187     # check to be sure that there will not be any before handling the
 188     # simple case.
 189     #
 190     if ( $directories !~ m|[\\/]\z| ) {
 191         return split( m|[\\/]|, $directories );
 192     }
 193     else {
 194         #
 195         # since there was a trailing separator, add a file name to the end,
 196         # then do the split, then replace it with ''.
 197         #
 198         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
 199         $directories[ $#directories ]= '' ;
 200         return @directories ;
 201     }
 202 }
 203
 204
 205 =item catpath
 206
 207 Takes volume, directory and file portions and returns an entire path. Under
 208 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
 209 the $volume become significant.
 210
 211 =cut
 212
 213 sub catpath {
 214     my ($self,$volume,$directory,$file) = @_;
 215
 216     # If it's UNC, make sure the glue separator is there, reusing
 217     # whatever separator is first in the $volume
 218     $volume .= $1
 219         if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s &&
 220              $directory =~ m@^[^\\/]@s
 221            ) ;
 222
 223     $volume .= $directory ;
 224
 225     # If the volume is not just A:, make sure the glue separator is
 226     # there, reusing whatever separator is first in the $volume if possible.
 227     if ( $volume !~ m@^[a-zA-Z]:\z@s &&
 228          $volume =~ m@[^\\/]\z@      &&
 229          $file   =~ m@[^\\/]@
 230        ) {
 231         $volume =~ m@([\\/])@ ;
 232         my $sep = $1 ? $1 : '\\' ;
 233         $volume .= $sep ;
 234     }
 235
 236     $volume .= $file ;
 237
 238     return $volume ;
 239 }
 240
 241
 242 =item abs2rel
 243
 244 Takes a destination path and an optional base path returns a relative path
 245 from the base path to the destination path:
 246
 247     $rel_path = File::Spec->abs2rel( $destination ) ;
 248     $rel_path = File::Spec->abs2rel( $destination, $base ) ;
 249
 250 If $base is not present or '', then L</cwd()> is used. If $base is relative,
 251 then it is converted to absolute form using L</rel2abs()>. This means that it
 252 is taken to be relative to L<cwd()>.
 253
 254 On systems with the concept of a volume, this assumes that both paths
 255 are on the $destination volume, and ignores the $base volume.
 256
 257 On systems that have a grammar that indicates filenames, this ignores the
 258 $base filename as well. Otherwise all path components are assumed to be
 259 directories.
 260
 261 If $path is relative, it is converted to absolute form using L</rel2abs()>.
 262 This means that it is taken to be relative to L</cwd()>.
 263
 264 Based on code written by Shigio Yamaguchi.
 265
 266 No checks against the filesystem are made.
 267
 268 =cut
 269
 270 sub abs2rel {
 271     my($self,$path,$base) = @_;
 272
 273     # Clean up $path
 274     if ( ! $self->file_name_is_absolute( $path ) ) {
 275         $path = $self->rel2abs( $path ) ;
 276     }
 277     else {
 278         $path = $self->canonpath( $path ) ;
 279     }
 280
 281     # Figure out the effective $base and clean it up.
 282     if ( ! $self->file_name_is_absolute( $base ) ) {
 283         $base = $self->rel2abs( $base ) ;
 284     }
 285     elsif ( !defined( $base ) || $base eq '' ) {
 286         $base = cwd() ;
 287     }
 288     else {
 289         $base = $self->canonpath( $base ) ;
 290     }
 291
 292     # Split up paths
 293     my ( $path_volume, $path_directories, $path_file ) =
 294         $self->splitpath( $path, 1 ) ;
 295
 296     my ( undef, $base_directories, undef ) =
 297         $self->splitpath( $base, 1 ) ;
 298
 299     # Now, remove all leading components that are the same
 300     my @pathchunks = $self->splitdir( $path_directories );
 301     my @basechunks = $self->splitdir( $base_directories );
 302
 303     while ( @pathchunks &&
 304             @basechunks &&
 305             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 306           ) {
 307         shift @pathchunks ;
 308         shift @basechunks ;
 309     }
 310
 311     # No need to catdir, we know these are well formed.
 312     $path_directories = CORE::join( '\\', @pathchunks );
 313     $base_directories = CORE::join( '\\', @basechunks );
 314
 315     # $base_directories now contains the directories the resulting relative
 316     # path must ascend out of before it can descend to $path_directory.  So,
 317     # replace all names with $parentDir
 318
 319     #FA Need to replace between backslashes...
 320     $base_directories =~ s|[^\\]+|..|g ;
 321
 322     # Glue the two together, using a separator if necessary, and preventing an
 323     # empty result.
 324
 325     #FA Must check that new directories are not empty.
 326     if ( $path_directories ne '' && $base_directories ne '' ) {
 327         $path_directories = "$base_directories\\$path_directories" ;
 328     } else {
 329         $path_directories = "$base_directories$path_directories" ;
 330     }
 331
 332     # It makes no sense to add a relative path to a UNC volume
 333     $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ;
 334
 335     return $self->canonpath(
 336         $self->catpath($path_volume, $path_directories, $path_file )
 337     ) ;
 338 }
 339
 340 =item rel2abs
 341
 342 Converts a relative path to an absolute path.
 343
 344     $abs_path = File::Spec->rel2abs( $destination ) ;
 345     $abs_path = File::Spec->rel2abs( $destination, $base ) ;
 346
 347 If $base is not present or '', then L<cwd()> is used. If $base is relative,
 348 then it is converted to absolute form using L</rel2abs()>. This means that it
 349 is taken to be relative to L</cwd()>.
 350
 351 Assumes that both paths are on the $base volume, and ignores the
 352 $destination volume.
 353
 354 On systems that have a grammar that indicates filenames, this ignores the
 355 $base filename as well. Otherwise all path components are assumed to be
 356 directories.
 357
 358 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
 359
 360 Based on code written by Shigio Yamaguchi.
 361
 362 No checks against the filesystem are made.
 363
 364 =cut
 365
 366 sub rel2abs($;$;) {
 367     my ($self,$path,$base ) = @_;
 368
 369     if ( ! $self->file_name_is_absolute( $path ) ) {
 370
 371         if ( !defined( $base ) || $base eq '' ) {
 372             $base = cwd() ;
 373         }
 374         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 375             $base = $self->rel2abs( $base ) ;
 376         }
 377         else {
 378             $base = $self->canonpath( $base ) ;
 379         }
 380
 381         my ( undef, $path_directories, $path_file ) =
 382             $self->splitpath( $path, 1 ) ;
 383
 384         my ( $base_volume, $base_directories, undef ) =
 385             $self->splitpath( $base, 1 ) ;
 386
 387         $path = $self->catpath(
 388             $base_volume,
 389             $self->catdir( $base_directories, $path_directories ),
 390             $path_file
 391         ) ;
 392     }
 393
 394     return $self->canonpath( $path ) ;
 395 }
 396
 397 =back
 398
 399 =head1 SEE ALSO
 400
 401 L<File::Spec>
 402
 403 =cut
 404
 405 1;