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