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