lib/File/Spec/Win32.pm

   1 package File::Spec::Win32;
   2
   3 use strict;
   4
   5 use vars qw(@ISA $VERSION);
   6 require File::Spec::Unix;
   7
   8 $VERSION = '1.5';
   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 (the File::Spec::Win32
  52 is used also for NetWare).
  53
  54 Since Perl 5.8.0, if running under taint mode, and if the environment
  55 variables are tainted, they are not used.
  56
  57 =cut
  58
  59 my $tmpdir;
  60 sub tmpdir {
  61     return $tmpdir if defined $tmpdir;
  62     my $self = shift;
  63     $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
  64                               'SYS:/temp',
  65                               'C:/temp',
  66                               '/tmp',
  67                               '/'  );
  68 }
  69
  70 sub case_tolerant {
  71     return 1;
  72 }
  73
  74 sub file_name_is_absolute {
  75     my ($self,$file) = @_;
  76     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  77 }
  78
  79 =item catfile
  80
  81 Concatenate one or more directory names and a filename to form a
  82 complete path ending with a filename
  83
  84 =cut
  85
  86 sub catfile {
  87     my $self = shift;
  88     my $file = $self->canonpath(pop @_);
  89     return $file unless @_;
  90     my $dir = $self->catdir(@_);
  91     $dir .= "\\" unless substr($dir,-1) eq "\\";
  92     return $dir.$file;
  93 }
  94
  95 sub catdir {
  96     my $self = shift;
  97     my @args = @_;
  98     foreach (@args) {
  99         tr[/][\\];
 100         # append a backslash to each argument unless it has one there
 101         $_ .= "\\" unless m{\\$};
 102     }
 103     return $self->canonpath(join('', @args));
 104 }
 105
 106 sub path {
 107     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
 108     my @path = split(';',$path);
 109     foreach (@path) { $_ = '.' if $_ eq '' }
 110     return @path;
 111 }
 112
 113 =item canonpath
 114
 115 No physical check on the filesystem, but a logical cleanup of a
 116 path. On UNIX eliminated successive slashes and successive "/.".
 117 On Win32 makes
 118
 119         dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
 120         dir1\dir2\dir3\...\dir4   -> \dir\dir4
 121
 122 =cut
 123
 124 sub canonpath {
 125     my ($self,$path) = @_;
 126     my $orig_path = $path;
 127     $path =~ s/^([a-z]:)/\u$1/s;
 128     $path =~ s|/|\\|g;
 129     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
 130     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
 131     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
 132     $path =~ s|\\\Z(?!\n)||
 133         unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s;  # xx\       -> xx
 134     # xx1/xx2/xx3/../../xx -> xx1/xx
 135     $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
 136     $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
 137     return $path if $path =~ m|^\.\.|;      # skip relative paths
 138     return $path unless $path =~ /\.\./;    # too few .'s to cleanup
 139     return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
 140     $path =~ s{^\\\.\.$}{\\};                      # \..    -> \
 141     1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx
 142
 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     $base = $self->_cwd() unless defined $base and length $base;
 300
 301     for ($path, $base) { $_ = $self->canonpath($_) }
 302
 303     my ($path_volume) = $self->splitpath($path, 1);
 304     my ($base_volume) = $self->splitpath($base, 1);
 305
 306     # Can't relativize across volumes
 307     return $path unless $path_volume eq $base_volume;
 308
 309     for ($path, $base) { $_ = $self->rel2abs($_) }
 310
 311     my $path_directories = ($self->splitpath($path, 1))[1];
 312     my $base_directories = ($self->splitpath($base, 1))[1];
 313
 314     # Now, remove all leading components that are the same
 315     my @pathchunks = $self->splitdir( $path_directories );
 316     my @basechunks = $self->splitdir( $base_directories );
 317
 318     while ( @pathchunks &&
 319             @basechunks &&
 320             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 321           ) {
 322         shift @pathchunks ;
 323         shift @basechunks ;
 324     }
 325
 326     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
 327
 328     return $self->canonpath( $self->catpath('', $result_dirs, '') );
 329 }
 330
 331
 332 sub rel2abs {
 333     my ($self,$path,$base ) = @_;
 334
 335     if ( ! $self->file_name_is_absolute( $path ) ) {
 336
 337         if ( !defined( $base ) || $base eq '' ) {
 338             require Cwd ;
 339             $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
 340             $base = $self->_cwd() unless defined $base ;
 341         }
 342         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 343             $base = $self->rel2abs( $base ) ;
 344         }
 345         else {
 346             $base = $self->canonpath( $base ) ;
 347         }
 348
 349         my ( $path_directories, $path_file ) =
 350             ($self->splitpath( $path, 1 ))[1,2] ;
 351
 352         my ( $base_volume, $base_directories ) =
 353             $self->splitpath( $base, 1 ) ;
 354
 355         $path = $self->catpath(
 356             $base_volume,
 357             $self->catdir( $base_directories, $path_directories ),
 358             $path_file
 359         ) ;
 360     }
 361
 362     return $self->canonpath( $path ) ;
 363 }
 364
 365 =back
 366
 367 =head2 Note For File::Spec::Win32 Maintainers
 368
 369 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
 370
 371 =head1 SEE ALSO
 372
 373 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
 374 implementation of these methods, not the semantics.
 375
 376 =cut
 377
 378 1;