[Summary view] [Print] [Text view]

   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.2501';
   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 || "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;