lib/File/Spec/Win32.pm

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