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