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