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