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(?!\n)||
 112              unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#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(?!\n))?)? )
 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(?!\n)| ) {
 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(?!\n)@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(?!\n)@s &&
 231          $volume =~ m@[^\\/]\Z(?!\n)@      &&
 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 $base_directories = ($self->splitpath( $base, 1 ))[1] ;
 300
 301     # Now, remove all leading components that are the same
 302     my @pathchunks = $self->splitdir( $path_directories );
 303     my @basechunks = $self->splitdir( $base_directories );
 304
 305     while ( @pathchunks &&
 306             @basechunks &&
 307             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 308           ) {
 309         shift @pathchunks ;
 310         shift @basechunks ;
 311     }
 312
 313     # No need to catdir, we know these are well formed.
 314     $path_directories = CORE::join( '\\', @pathchunks );
 315     $base_directories = CORE::join( '\\', @basechunks );
 316
 317     # $base_directories now contains the directories the resulting relative
 318     # path must ascend out of before it can descend to $path_directory.  So,
 319     # replace all names with $parentDir
 320
 321     #FA Need to replace between backslashes...
 322     $base_directories =~ s|[^\\]+|..|g ;
 323
 324     # Glue the two together, using a separator if necessary, and preventing an
 325     # empty result.
 326
 327     #FA Must check that new directories are not empty.
 328     if ( $path_directories ne '' && $base_directories ne '' ) {
 329         $path_directories = "$base_directories\\$path_directories" ;
 330     } else {
 331         $path_directories = "$base_directories$path_directories" ;
 332     }
 333
 334     # It makes no sense to add a relative path to a UNC volume
 335     $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ;
 336
 337     return $self->canonpath(
 338         $self->catpath($path_volume, $path_directories, $path_file )
 339     ) ;
 340 }
 341
 342 =item rel2abs
 343
 344 Converts a relative path to an absolute path.
 345
 346     $abs_path = File::Spec->rel2abs( $destination ) ;
 347     $abs_path = File::Spec->rel2abs( $destination, $base ) ;
 348
 349 If $base is not present or '', then L<cwd()> is used. If $base is relative,
 350 then it is converted to absolute form using L</rel2abs()>. This means that it
 351 is taken to be relative to L</cwd()>.
 352
 353 Assumes that both paths are on the $base volume, and ignores the
 354 $destination volume.
 355
 356 On systems that have a grammar that indicates filenames, this ignores the
 357 $base filename as well. Otherwise all path components are assumed to be
 358 directories.
 359
 360 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
 361
 362 Based on code written by Shigio Yamaguchi.
 363
 364 No checks against the filesystem are made.
 365
 366 =cut
 367
 368 sub rel2abs($;$;) {
 369     my ($self,$path,$base ) = @_;
 370
 371     if ( ! $self->file_name_is_absolute( $path ) ) {
 372
 373         if ( !defined( $base ) || $base eq '' ) {
 374             $base = cwd() ;
 375         }
 376         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 377             $base = $self->rel2abs( $base ) ;
 378         }
 379         else {
 380             $base = $self->canonpath( $base ) ;
 381         }
 382
 383         my ( $path_directories, $path_file ) =
 384             ($self->splitpath( $path, 1 ))[1,2] ;
 385
 386         my ( $base_volume, $base_directories ) =
 387             $self->splitpath( $base, 1 ) ;
 388
 389         $path = $self->catpath(
 390             $base_volume,
 391             $self->catdir( $base_directories, $path_directories ),
 392             $path_file
 393         ) ;
 394     }
 395
 396     return $self->canonpath( $path ) ;
 397 }
 398
 399 =back
 400
 401 =head1 SEE ALSO
 402
 403 L<File::Spec>
 404
 405 =cut
 406
 407 1;