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