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