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     C:/temp
  44     /tmp
  45     /
  46
  47 =cut
  48
  49 my $tmpdir;
  50 sub tmpdir {
  51     return $tmpdir if defined $tmpdir;
  52     my $self = shift;
  53     foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /)) {
  54         next unless defined && -d;
  55         $tmpdir = $_;
  56         last;
  57     }
  58     $tmpdir = '' unless defined $tmpdir;
  59     $tmpdir = $self->canonpath($tmpdir);
  60     return $tmpdir;
  61 }
  62
  63 sub case_tolerant {
  64     return 1;
  65 }
  66
  67 sub file_name_is_absolute {
  68     my ($self,$file) = @_;
  69     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  70 }
  71
  72 =item catfile
  73
  74 Concatenate one or more directory names and a filename to form a
  75 complete path ending with a filename
  76
  77 =cut
  78
  79 sub catfile {
  80     my $self = shift;
  81     my $file = pop @_;
  82     return $file unless @_;
  83     my $dir = $self->catdir(@_);
  84     $dir .= "\\" unless substr($dir,-1) eq "\\";
  85     return $dir.$file;
  86 }
  87
  88 sub path {
  89     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
  90     my @path = split(';',$path);
  91     foreach (@path) { $_ = '.' if $_ eq '' }
  92     return @path;
  93 }
  94
  95 =item canonpath
  96
  97 No physical check on the filesystem, but a logical cleanup of a
  98 path. On UNIX eliminated successive slashes and successive "/.".
  99
 100 =cut
 101
 102 sub canonpath {
 103     my ($self,$path) = @_;
 104     $path =~ s/^([a-z]:)/\u$1/s;
 105     $path =~ s|/|\\|g;
 106     $path =~ s|([^\\])\\+|$1\\|g;                  # xx////xx  -> xx/xx
 107     $path =~ s|(\\\.)+\\|\\|g;                     # xx/././xx -> xx/xx
 108     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # ./xx      -> xx
 109     $path =~ s|\\\Z(?!\n)||
 110              unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s;   # xx/       -> xx
 111     return $path;
 112 }
 113
 114 =item splitpath
 115
 116     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 117     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 118
 119 Splits a path in to volume, directory, and filename portions. Assumes that
 120 the last file is a path unless the path ends in '\\', '\\.', '\\..'
 121 or $no_file is true.  On Win32 this means that $no_file true makes this return
 122 ( $volume, $path, undef ).
 123
 124 Separators accepted are \ and /.
 125
 126 Volumes can be drive letters or UNC sharenames (\\server\share).
 127
 128 The results can be passed to L</catpath> to get back a path equivalent to
 129 (usually identical to) the original path.
 130
 131 =cut
 132
 133 sub splitpath {
 134     my ($self,$path, $nofile) = @_;
 135     my ($volume,$directory,$file) = ('','','');
 136     if ( $nofile ) {
 137         $path =~
 138             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
 139                  (.*)
 140              }xs;
 141         $volume    = $1;
 142         $directory = $2;
 143     }
 144     else {
 145         $path =~
 146             m{^ ( (?: [a-zA-Z]: |
 147                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
 148                   )?
 149                 )
 150                 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
 151                 (.*)
 152              }xs;
 153         $volume    = $1;
 154         $directory = $2;
 155         $file      = $3;
 156     }
 157
 158     return ($volume,$directory,$file);
 159 }
 160
 161
 162 =item splitdir
 163
 164 The opposite of L</catdir()>.
 165
 166     @dirs = File::Spec->splitdir( $directories );
 167
 168 $directories must be only the directory portion of the path on systems
 169 that have the concept of a volume or that have path syntax that differentiates
 170 files from directories.
 171
 172 Unlike just splitting the directories on the separator, leading empty and
 173 trailing directory entries can be returned, because these are significant
 174 on some OSs. So,
 175
 176     File::Spec->splitdir( "/a/b/c" );
 177
 178 Yields:
 179
 180     ( '', 'a', 'b', '', 'c', '' )
 181
 182 =cut
 183
 184 sub splitdir {
 185     my ($self,$directories) = @_ ;
 186     #
 187     # split() likes to forget about trailing null fields, so here we
 188     # check to be sure that there will not be any before handling the
 189     # simple case.
 190     #
 191     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
 192         return split( m|[\\/]|, $directories );
 193     }
 194     else {
 195         #
 196         # since there was a trailing separator, add a file name to the end,
 197         # then do the split, then replace it with ''.
 198         #
 199         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
 200         $directories[ $#directories ]= '' ;
 201         return @directories ;
 202     }
 203 }
 204
 205
 206 =item catpath
 207
 208 Takes volume, directory and file portions and returns an entire path. Under
 209 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
 210 the $volume become significant.
 211
 212 =cut
 213
 214 sub catpath {
 215     my ($self,$volume,$directory,$file) = @_;
 216
 217     # If it's UNC, make sure the glue separator is there, reusing
 218     # whatever separator is first in the $volume
 219     $volume .= $1
 220         if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
 221              $directory =~ m@^[^\\/]@s
 222            ) ;
 223
 224     $volume .= $directory ;
 225
 226     # If the volume is not just A:, make sure the glue separator is
 227     # there, reusing whatever separator is first in the $volume if possible.
 228     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
 229          $volume =~ m@[^\\/]\Z(?!\n)@      &&
 230          $file   =~ m@[^\\/]@
 231        ) {
 232         $volume =~ m@([\\/])@ ;
 233         my $sep = $1 ? $1 : '\\' ;
 234         $volume .= $sep ;
 235     }
 236
 237     $volume .= $file ;
 238
 239     return $volume ;
 240 }
 241
 242
 243 =item abs2rel
 244
 245 Takes a destination path and an optional base path returns a relative path
 246 from the base path to the destination path:
 247
 248     $rel_path = File::Spec->abs2rel( $destination ) ;
 249     $rel_path = File::Spec->abs2rel( $destination, $base ) ;
 250
 251 If $base is not present or '', then L</cwd()> is used. If $base is relative,
 252 then it is converted to absolute form using L</rel2abs()>. This means that it
 253 is taken to be relative to L<cwd()>.
 254
 255 On systems with the concept of a volume, this assumes that both paths
 256 are on the $destination volume, and ignores the $base volume.
 257
 258 On systems that have a grammar that indicates filenames, this ignores the
 259 $base filename as well. Otherwise all path components are assumed to be
 260 directories.
 261
 262 If $path is relative, it is converted to absolute form using L</rel2abs()>.
 263 This means that it is taken to be relative to L</cwd()>.
 264
 265 Based on code written by Shigio Yamaguchi.
 266
 267 No checks against the filesystem are made.
 268
 269 =cut
 270
 271 sub abs2rel {
 272     my($self,$path,$base) = @_;
 273
 274     # Clean up $path
 275     if ( ! $self->file_name_is_absolute( $path ) ) {
 276         $path = $self->rel2abs( $path ) ;
 277     }
 278     else {
 279         $path = $self->canonpath( $path ) ;
 280     }
 281
 282     # Figure out the effective $base and clean it up.
 283     if ( ! $self->file_name_is_absolute( $base ) ) {
 284         $base = $self->rel2abs( $base ) ;
 285     }
 286     elsif ( !defined( $base ) || $base eq '' ) {
 287         $base = cwd() ;
 288     }
 289     else {
 290         $base = $self->canonpath( $base ) ;
 291     }
 292
 293     # Split up paths
 294     my ( $path_volume, $path_directories, $path_file ) =
 295         $self->splitpath( $path, 1 ) ;
 296
 297     my $base_directories = ($self->splitpath( $base, 1 ))[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 ( $path_directories, $path_file ) =
 382             ($self->splitpath( $path, 1 ))[1,2] ;
 383
 384         my ( $base_volume, $base_directories ) =
 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;