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/ when called
 132                                    # from rel2abs() for ../dirs/
 133     1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx
 134
 135     my ($vol,$dirs,$file) = $self->splitpath($path);
 136     my @dirs = $self->splitdir($dirs);
 137     my (@base_dirs, @path_dirs);
 138     my $dest = \@base_dirs;
 139     for my $dir (@dirs){
 140         $dest = \@path_dirs if $dir eq $self->updir;
 141         push @$dest, $dir;
 142     }
 143     # for each .. in @path_dirs pop one item from
 144     # @base_dirs
 145     while (my $dir = shift @path_dirs){
 146         unless ($dir eq $self->updir){
 147             unshift @path_dirs, $dir;
 148             last;
 149         }
 150         pop @base_dirs;
 151     }
 152     $path = $self->catpath(
 153                            $vol,
 154                            $self->catdir(@base_dirs, @path_dirs),
 155                            $file
 156                           );
 157     return $path;
 158 }
 159
 160 =item splitpath
 161
 162     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 163     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 164
 165 Splits a path into volume, directory, and filename portions. Assumes that
 166 the last file is a path unless the path ends in '\\', '\\.', '\\..'
 167 or $no_file is true.  On Win32 this means that $no_file true makes this return
 168 ( $volume, $path, '' ).
 169
 170 Separators accepted are \ and /.
 171
 172 Volumes can be drive letters or UNC sharenames (\\server\share).
 173
 174 The results can be passed to L</catpath> to get back a path equivalent to
 175 (usually identical to) the original path.
 176
 177 =cut
 178
 179 sub splitpath {
 180     my ($self,$path, $nofile) = @_;
 181     my ($volume,$directory,$file) = ('','','');
 182     if ( $nofile ) {
 183         $path =~
 184             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
 185                  (.*)
 186              }xs;
 187         $volume    = $1;
 188         $directory = $2;
 189     }
 190     else {
 191         $path =~
 192             m{^ ( (?: [a-zA-Z]: |
 193                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
 194                   )?
 195                 )
 196                 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
 197                 (.*)
 198              }xs;
 199         $volume    = $1;
 200         $directory = $2;
 201         $file      = $3;
 202     }
 203
 204     return ($volume,$directory,$file);
 205 }
 206
 207
 208 =item splitdir
 209
 210 The opposite of L<catdir()|File::Spec/catdir()>.
 211
 212     @dirs = File::Spec->splitdir( $directories );
 213
 214 $directories must be only the directory portion of the path on systems
 215 that have the concept of a volume or that have path syntax that differentiates
 216 files from directories.
 217
 218 Unlike just splitting the directories on the separator, leading empty and
 219 trailing directory entries can be returned, because these are significant
 220 on some OSs. So,
 221
 222     File::Spec->splitdir( "/a/b/c" );
 223
 224 Yields:
 225
 226     ( '', 'a', 'b', '', 'c', '' )
 227
 228 =cut
 229
 230 sub splitdir {
 231     my ($self,$directories) = @_ ;
 232     #
 233     # split() likes to forget about trailing null fields, so here we
 234     # check to be sure that there will not be any before handling the
 235     # simple case.
 236     #
 237     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
 238         return split( m|[\\/]|, $directories );
 239     }
 240     else {
 241         #
 242         # since there was a trailing separator, add a file name to the end,
 243         # then do the split, then replace it with ''.
 244         #
 245         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
 246         $directories[ $#directories ]= '' ;
 247         return @directories ;
 248     }
 249 }
 250
 251
 252 =item catpath
 253
 254 Takes volume, directory and file portions and returns an entire path. Under
 255 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
 256 the $volume become significant.
 257
 258 =cut
 259
 260 sub catpath {
 261     my ($self,$volume,$directory,$file) = @_;
 262
 263     # If it's UNC, make sure the glue separator is there, reusing
 264     # whatever separator is first in the $volume
 265     $volume .= $1
 266         if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
 267              $directory =~ m@^[^\\/]@s
 268            ) ;
 269
 270     $volume .= $directory ;
 271
 272     # If the volume is not just A:, make sure the glue separator is
 273     # there, reusing whatever separator is first in the $volume if possible.
 274     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
 275          $volume =~ m@[^\\/]\Z(?!\n)@      &&
 276          $file   =~ m@[^\\/]@
 277        ) {
 278         $volume =~ m@([\\/])@ ;
 279         my $sep = $1 ? $1 : '\\' ;
 280         $volume .= $sep ;
 281     }
 282
 283     $volume .= $file ;
 284
 285     return $volume ;
 286 }
 287
 288
 289 sub abs2rel {
 290     my($self,$path,$base) = @_;
 291     $base = $self->cwd() unless defined $base and length $base;
 292
 293     for ($path, $base) {
 294       $_ = $self->canonpath($self->rel2abs($_));
 295     }
 296     my ($path_volume, $path_directories) = $self->splitpath($path, 1) ;
 297     my ($base_volume, $base_directories) = $self->splitpath($base, 1);
 298
 299     if ($path_volume and not $base_volume) {
 300         ($base_volume) = $self->splitpath($self->cwd);
 301     }
 302
 303     # Can't relativize across volumes
 304     return $path unless $path_volume eq $base_volume;
 305
 306     # Now, remove all leading components that are the same
 307     my @pathchunks = $self->splitdir( $path_directories );
 308     my @basechunks = $self->splitdir( $base_directories );
 309
 310     while ( @pathchunks &&
 311             @basechunks &&
 312             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 313           ) {
 314         shift @pathchunks ;
 315         shift @basechunks ;
 316     }
 317
 318     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
 319
 320     return $self->canonpath( $self->catpath('', $result_dirs, '') );
 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 = $self->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 =head2 Note For File::Spec::Win32 Maintainers
 358
 359 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
 360
 361 =head1 SEE ALSO
 362
 363 L<File::Spec>
 364
 365 =cut
 366
 367 1;