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