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.4';
   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 path {
  96     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
  97     my @path = split(';',$path);
  98     foreach (@path) { $_ = '.' if $_ eq '' }
  99     return @path;
 100 }
 101
 102 =item canonpath
 103
 104 No physical check on the filesystem, but a logical cleanup of a
 105 path. On UNIX eliminated successive slashes and successive "/.".
 106 On Win32 makes
 107
 108         dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
 109         dir1\dir2\dir3\...\dir4   -> \dir\dir4
 110
 111 =cut
 112
 113 sub canonpath {
 114     my ($self,$path) = @_;
 115     my $orig_path = $path;
 116     $path =~ s/^([a-z]:)/\u$1/s;
 117     $path =~ s|/|\\|g;
 118     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
 119     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
 120     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
 121     $path =~ s|\\\Z(?!\n)||
 122         unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s;  # xx\       -> xx
 123     # xx1/xx2/xx3/../../xx -> xx1/xx
 124     $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
 125     $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
 126     return $path if $path =~ m|^\.\.|;      # skip relative paths
 127     return $path unless $path =~ /\.\./;    # too few .'s to cleanup
 128     return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
 129     return $path if $orig_path =~ m|^\Q/../\E|
 130         and $orig_path =~ m|\/$|;  # don't do /../dirs/ when called
 131                                    # from rel2abs() for ../dirs/
 132     1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx
 133
 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     $base = $self->cwd() unless defined $base and length $base;
 291
 292     for ($path, $base) {
 293       $_ = $self->canonpath($self->rel2abs($_));
 294     }
 295     my ($path_volume, $path_directories) = $self->splitpath($path, 1) ;
 296     my ($base_volume, $base_directories) = $self->splitpath($base, 1);
 297
 298     if ($path_volume and not $base_volume) {
 299         ($base_volume) = $self->splitpath($self->cwd);
 300     }
 301
 302     # Can't relativize across volumes
 303     return $path unless $path_volume eq $base_volume;
 304
 305     # Now, remove all leading components that are the same
 306     my @pathchunks = $self->splitdir( $path_directories );
 307     my @basechunks = $self->splitdir( $base_directories );
 308
 309     while ( @pathchunks &&
 310             @basechunks &&
 311             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 312           ) {
 313         shift @pathchunks ;
 314         shift @basechunks ;
 315     }
 316
 317     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
 318
 319     return $self->canonpath( $self->catpath('', $result_dirs, '') );
 320 }
 321
 322
 323 sub rel2abs {
 324     my ($self,$path,$base ) = @_;
 325
 326     if ( ! $self->file_name_is_absolute( $path ) ) {
 327
 328         if ( !defined( $base ) || $base eq '' ) {
 329             $base = $self->cwd() ;
 330         }
 331         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 332             $base = $self->rel2abs( $base ) ;
 333         }
 334         else {
 335             $base = $self->canonpath( $base ) ;
 336         }
 337
 338         my ( $path_directories, $path_file ) =
 339             ($self->splitpath( $path, 1 ))[1,2] ;
 340
 341         my ( $base_volume, $base_directories ) =
 342             $self->splitpath( $base, 1 ) ;
 343
 344         $path = $self->catpath(
 345             $base_volume,
 346             $self->catdir( $base_directories, $path_directories ),
 347             $path_file
 348         ) ;
 349     }
 350
 351     return $self->canonpath( $path ) ;
 352 }
 353
 354 =back
 355
 356 =head2 Note For File::Spec::Win32 Maintainers
 357
 358 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
 359
 360 =head1 SEE ALSO
 361
 362 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
 363 implementation of these methods, not the semantics.
 364
 365 =cut
 366
 367 1;