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.2';
   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 sub abs2rel {
 246     my($self,$path,$base) = @_;
 247
 248     # Clean up $path
 249     if ( ! $self->file_name_is_absolute( $path ) ) {
 250         $path = $self->rel2abs( $path ) ;
 251     }
 252     else {
 253         $path = $self->canonpath( $path ) ;
 254     }
 255
 256     # Figure out the effective $base and clean it up.
 257     if ( ! $self->file_name_is_absolute( $base ) ) {
 258         $base = $self->rel2abs( $base ) ;
 259     }
 260     elsif ( !defined( $base ) || $base eq '' ) {
 261         $base = cwd() ;
 262     }
 263     else {
 264         $base = $self->canonpath( $base ) ;
 265     }
 266
 267     # Split up paths
 268     my ( $path_volume, $path_directories, $path_file ) =
 269         $self->splitpath( $path, 1 ) ;
 270
 271     my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
 272
 273     # Now, remove all leading components that are the same
 274     my @pathchunks = $self->splitdir( $path_directories );
 275     my @basechunks = $self->splitdir( $base_directories );
 276
 277     while ( @pathchunks &&
 278             @basechunks &&
 279             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 280           ) {
 281         shift @pathchunks ;
 282         shift @basechunks ;
 283     }
 284
 285     # No need to catdir, we know these are well formed.
 286     $path_directories = CORE::join( '\\', @pathchunks );
 287     $base_directories = CORE::join( '\\', @basechunks );
 288
 289     # $base_directories now contains the directories the resulting relative
 290     # path must ascend out of before it can descend to $path_directory.  So,
 291     # replace all names with $parentDir
 292
 293     #FA Need to replace between backslashes...
 294     $base_directories =~ s|[^\\]+|..|g ;
 295
 296     # Glue the two together, using a separator if necessary, and preventing an
 297     # empty result.
 298
 299     #FA Must check that new directories are not empty.
 300     if ( $path_directories ne '' && $base_directories ne '' ) {
 301         $path_directories = "$base_directories\\$path_directories" ;
 302     } else {
 303         $path_directories = "$base_directories$path_directories" ;
 304     }
 305
 306     # It makes no sense to add a relative path to a UNC volume
 307     $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ;
 308
 309     return $self->canonpath(
 310         $self->catpath($path_volume, $path_directories, $path_file )
 311     ) ;
 312 }
 313
 314
 315 sub rel2abs($;$;) {
 316     my ($self,$path,$base ) = @_;
 317
 318     if ( ! $self->file_name_is_absolute( $path ) ) {
 319
 320         if ( !defined( $base ) || $base eq '' ) {
 321             $base = cwd() ;
 322         }
 323         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 324             $base = $self->rel2abs( $base ) ;
 325         }
 326         else {
 327             $base = $self->canonpath( $base ) ;
 328         }
 329
 330         my ( $path_directories, $path_file ) =
 331             ($self->splitpath( $path, 1 ))[1,2] ;
 332
 333         my ( $base_volume, $base_directories ) =
 334             $self->splitpath( $base, 1 ) ;
 335
 336         $path = $self->catpath(
 337             $base_volume,
 338             $self->catdir( $base_directories, $path_directories ),
 339             $path_file
 340         ) ;
 341     }
 342
 343     return $self->canonpath( $path ) ;
 344 }
 345
 346 =back
 347
 348 =head1 SEE ALSO
 349
 350 L<File::Spec>
 351
 352 =cut
 353
 354 1;