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