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