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