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