lib/File/Spec/Win32.pm

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