This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Improve File::Spec::Win32->path() and fix MM_Win32.t
[perl5.git] / 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.5_01';
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( @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
281 sub abs2rel {
282     my($self,$path,$base) = @_;
283     $base = $self->_cwd() unless defined $base and length $base;
284
285     for ($path, $base) { $_ = $self->canonpath($_) }
286
287     my ($path_volume) = $self->splitpath($path, 1);
288     my ($base_volume) = $self->splitpath($base, 1);
289
290     # Can't relativize across volumes
291     return $path unless $path_volume eq $base_volume;
292
293     for ($path, $base) { $_ = $self->rel2abs($_) }
294
295     my $path_directories = ($self->splitpath($path, 1))[1];
296     my $base_directories = ($self->splitpath($base, 1))[1];
297
298     # Now, remove all leading components that are the same
299     my @pathchunks = $self->splitdir( $path_directories );
300     my @basechunks = $self->splitdir( $base_directories );
301
302     while ( @pathchunks && 
303             @basechunks && 
304             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
305           ) {
306         shift @pathchunks ;
307         shift @basechunks ;
308     }
309
310     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
311
312     return $self->canonpath( $self->catpath('', $result_dirs, '') );
313 }
314
315
316 sub rel2abs {
317     my ($self,$path,$base ) = @_;
318
319     if ( ! $self->file_name_is_absolute( $path ) ) {
320
321         if ( !defined( $base ) || $base eq '' ) {
322             require Cwd ;
323             $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
324             $base = $self->_cwd() unless defined $base ;
325         }
326         elsif ( ! $self->file_name_is_absolute( $base ) ) {
327             $base = $self->rel2abs( $base ) ;
328         }
329         else {
330             $base = $self->canonpath( $base ) ;
331         }
332
333         my ( $path_directories, $path_file ) =
334             ($self->splitpath( $path, 1 ))[1,2] ;
335
336         my ( $base_volume, $base_directories ) =
337             $self->splitpath( $base, 1 ) ;
338
339         $path = $self->catpath( 
340             $base_volume, 
341             $self->catdir( $base_directories, $path_directories ), 
342             $path_file
343         ) ;
344     }
345
346     return $self->canonpath( $path ) ;
347 }
348
349 =back
350
351 =head2 Note For File::Spec::Win32 Maintainers
352
353 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
354
355 =head1 COPYRIGHT
356
357 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
358
359 This program is free software; you can redistribute it and/or modify
360 it under the same terms as Perl itself.
361
362 =head1 SEE ALSO
363
364 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
365 implementation of these methods, not the semantics.
366
367 =cut
368
369 1;