lib/File/Spec/Win32.pm

   1 package File::Spec::Win32;
   2
   3 use strict;
   4 use Cwd;
   5 use vars qw(@ISA $VERSION);
   6 require File::Spec::Unix;
   7
   8 $VERSION = '1.3';
   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.
  52
  53 Since Perl 5.8.0, if running under taint mode, and if the environment
  54 variables are tainted, they are not used.
  55
  56 =cut
  57
  58 my $tmpdir;
  59 sub tmpdir {
  60     return $tmpdir if defined $tmpdir;
  61     my $self = shift;
  62     my @dirlist = (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /));
  63     {
  64         no strict 'refs';
  65         if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
  66             require Scalar::Util;
  67             @dirlist = grep { ! Scalar::Util::tainted $_ } @dirlist;
  68         }
  69     }
  70     foreach (@dirlist) {
  71         next unless defined && -d;
  72         $tmpdir = $_;
  73         last;
  74     }
  75     $tmpdir = '' unless defined $tmpdir;
  76     $tmpdir = $self->canonpath($tmpdir);
  77     return $tmpdir;
  78 }
  79
  80 sub case_tolerant {
  81     return 1;
  82 }
  83
  84 sub file_name_is_absolute {
  85     my ($self,$file) = @_;
  86     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  87 }
  88
  89 =item catfile
  90
  91 Concatenate one or more directory names and a filename to form a
  92 complete path ending with a filename
  93
  94 =cut
  95
  96 sub catfile {
  97     my $self = shift;
  98     my $file = pop @_;
  99     return $file unless @_;
 100     my $dir = $self->catdir(@_);
 101     $dir .= "\\" unless substr($dir,-1) eq "\\";
 102     return $dir.$file;
 103 }
 104
 105 sub path {
 106     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
 107     my @path = split(';',$path);
 108     foreach (@path) { $_ = '.' if $_ eq '' }
 109     return @path;
 110 }
 111
 112 =item canonpath
 113
 114 No physical check on the filesystem, but a logical cleanup of a
 115 path. On UNIX eliminated successive slashes and successive "/.".
 116
 117 =cut
 118
 119 sub canonpath {
 120     my ($self,$path) = @_;
 121     $path =~ s/^([a-z]:)/\u$1/s;
 122     $path =~ s|/|\\|g;
 123     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
 124     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
 125     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
 126     $path =~ s|\\\Z(?!\n)||
 127              unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s;   # xx\       -> xx
 128     return $path;
 129 }
 130
 131 =item splitpath
 132
 133     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 134     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 135
 136 Splits a path in to volume, directory, and filename portions. Assumes that
 137 the last file is a path unless the path ends in '\\', '\\.', '\\..'
 138 or $no_file is true.  On Win32 this means that $no_file true makes this return
 139 ( $volume, $path, undef ).
 140
 141 Separators accepted are \ and /.
 142
 143 Volumes can be drive letters or UNC sharenames (\\server\share).
 144
 145 The results can be passed to L</catpath> to get back a path equivalent to
 146 (usually identical to) the original path.
 147
 148 =cut
 149
 150 sub splitpath {
 151     my ($self,$path, $nofile) = @_;
 152     my ($volume,$directory,$file) = ('','','');
 153     if ( $nofile ) {
 154         $path =~
 155             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
 156                  (.*)
 157              }xs;
 158         $volume    = $1;
 159         $directory = $2;
 160     }
 161     else {
 162         $path =~
 163             m{^ ( (?: [a-zA-Z]: |
 164                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
 165                   )?
 166                 )
 167                 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
 168                 (.*)
 169              }xs;
 170         $volume    = $1;
 171         $directory = $2;
 172         $file      = $3;
 173     }
 174
 175     return ($volume,$directory,$file);
 176 }
 177
 178
 179 =item splitdir
 180
 181 The opposite of L<catdir()|File::Spec/catdir()>.
 182
 183     @dirs = File::Spec->splitdir( $directories );
 184
 185 $directories must be only the directory portion of the path on systems
 186 that have the concept of a volume or that have path syntax that differentiates
 187 files from directories.
 188
 189 Unlike just splitting the directories on the separator, leading empty and
 190 trailing directory entries can be returned, because these are significant
 191 on some OSs. So,
 192
 193     File::Spec->splitdir( "/a/b/c" );
 194
 195 Yields:
 196
 197     ( '', 'a', 'b', '', 'c', '' )
 198
 199 =cut
 200
 201 sub splitdir {
 202     my ($self,$directories) = @_ ;
 203     #
 204     # split() likes to forget about trailing null fields, so here we
 205     # check to be sure that there will not be any before handling the
 206     # simple case.
 207     #
 208     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
 209         return split( m|[\\/]|, $directories );
 210     }
 211     else {
 212         #
 213         # since there was a trailing separator, add a file name to the end,
 214         # then do the split, then replace it with ''.
 215         #
 216         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
 217         $directories[ $#directories ]= '' ;
 218         return @directories ;
 219     }
 220 }
 221
 222
 223 =item catpath
 224
 225 Takes volume, directory and file portions and returns an entire path. Under
 226 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
 227 the $volume become significant.
 228
 229 =cut
 230
 231 sub catpath {
 232     my ($self,$volume,$directory,$file) = @_;
 233
 234     # If it's UNC, make sure the glue separator is there, reusing
 235     # whatever separator is first in the $volume
 236     $volume .= $1
 237         if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
 238              $directory =~ m@^[^\\/]@s
 239            ) ;
 240
 241     $volume .= $directory ;
 242
 243     # If the volume is not just A:, make sure the glue separator is
 244     # there, reusing whatever separator is first in the $volume if possible.
 245     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
 246          $volume =~ m@[^\\/]\Z(?!\n)@      &&
 247          $file   =~ m@[^\\/]@
 248        ) {
 249         $volume =~ m@([\\/])@ ;
 250         my $sep = $1 ? $1 : '\\' ;
 251         $volume .= $sep ;
 252     }
 253
 254     $volume .= $file ;
 255
 256     return $volume ;
 257 }
 258
 259
 260 sub abs2rel {
 261     my($self,$path,$base) = @_;
 262
 263     # Clean up $path
 264     if ( ! $self->file_name_is_absolute( $path ) ) {
 265         $path = $self->rel2abs( $path ) ;
 266     }
 267     else {
 268         $path = $self->canonpath( $path ) ;
 269     }
 270
 271     # Figure out the effective $base and clean it up.
 272     if ( !defined( $base ) || $base eq '' ) {
 273         $base = cwd() ;
 274     }
 275     elsif ( ! $self->file_name_is_absolute( $base ) ) {
 276         $base = $self->rel2abs( $base ) ;
 277     }
 278     else {
 279         $base = $self->canonpath( $base ) ;
 280     }
 281
 282     # Split up paths
 283     my ( undef, $path_directories, $path_file ) =
 284         $self->splitpath( $path, 1 ) ;
 285
 286     my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
 287
 288     # Now, remove all leading components that are the same
 289     my @pathchunks = $self->splitdir( $path_directories );
 290     my @basechunks = $self->splitdir( $base_directories );
 291
 292     while ( @pathchunks &&
 293             @basechunks &&
 294             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 295           ) {
 296         shift @pathchunks ;
 297         shift @basechunks ;
 298     }
 299
 300     # No need to catdir, we know these are well formed.
 301     $path_directories = CORE::join( '\\', @pathchunks );
 302     $base_directories = CORE::join( '\\', @basechunks );
 303
 304     # $base_directories now contains the directories the resulting relative
 305     # path must ascend out of before it can descend to $path_directory.  So,
 306     # replace all names with $parentDir
 307
 308     #FA Need to replace between backslashes...
 309     $base_directories =~ s|[^\\]+|..|g ;
 310
 311     # Glue the two together, using a separator if necessary, and preventing an
 312     # empty result.
 313
 314     #FA Must check that new directories are not empty.
 315     if ( $path_directories ne '' && $base_directories ne '' ) {
 316         $path_directories = "$base_directories\\$path_directories" ;
 317     } else {
 318         $path_directories = "$base_directories$path_directories" ;
 319     }
 320
 321     return $self->canonpath(
 322         $self->catpath( "", $path_directories, $path_file )
 323     ) ;
 324 }
 325
 326
 327 sub rel2abs {
 328     my ($self,$path,$base ) = @_;
 329
 330     if ( ! $self->file_name_is_absolute( $path ) ) {
 331
 332         if ( !defined( $base ) || $base eq '' ) {
 333             $base = cwd() ;
 334         }
 335         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 336             $base = $self->rel2abs( $base ) ;
 337         }
 338         else {
 339             $base = $self->canonpath( $base ) ;
 340         }
 341
 342         my ( $path_directories, $path_file ) =
 343             ($self->splitpath( $path, 1 ))[1,2] ;
 344
 345         my ( $base_volume, $base_directories ) =
 346             $self->splitpath( $base, 1 ) ;
 347
 348         $path = $self->catpath(
 349             $base_volume,
 350             $self->catdir( $base_directories, $path_directories ),
 351             $path_file
 352         ) ;
 353     }
 354
 355     return $self->canonpath( $path ) ;
 356 }
 357
 358 =back
 359
 360 =head2 Note For File::Spec::Win32 Maintainers
 361
 362 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
 363
 364 =head1 SEE ALSO
 365
 366 L<File::Spec>
 367
 368 =cut
 369
 370 1;