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