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