dist/PathTools/lib/File/Spec/Win32.pm

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