This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix broken abs2rel() (from Fran├žois Allard <franka@host.ott.igs.net>)
[perl5.git] / lib / File / Spec / Win32.pm
1 package File::Spec::Win32;
2
3 use strict;
4 use Cwd;
5 use vars qw(@ISA);
6 require File::Spec::Unix;
7 @ISA = qw(File::Spec::Unix);
8
9 =head1 NAME
10
11 File::Spec::Win32 - methods for Win32 file specs
12
13 =head1 SYNOPSIS
14
15  require File::Spec::Win32; # Done internally by File::Spec if needed
16
17 =head1 DESCRIPTION
18
19 See File::Spec::Unix for a documentation of the methods provided
20 there. This package overrides the implementation of these methods, not
21 the semantics.
22
23 =over
24
25 =item devnull
26
27 Returns a string representation of the null device.
28
29 =cut
30
31 sub devnull {
32     return "nul";
33 }
34
35 =item tmpdir
36
37 Returns a string representation of the first existing directory
38 from the following list:
39
40     $ENV{TMPDIR}
41     $ENV{TEMP}
42     $ENV{TMP}
43     /tmp
44     /
45
46 =cut
47
48 my $tmpdir;
49 sub tmpdir {
50     return $tmpdir if defined $tmpdir;
51     my $self = shift;
52     foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
53         next unless defined && -d;
54         $tmpdir = $_;
55         last;
56     }
57     $tmpdir = '' unless defined $tmpdir;
58     $tmpdir = $self->canonpath($tmpdir);
59     return $tmpdir;
60 }
61
62 sub file_name_is_absolute {
63     my ($self,$file) = @_;
64     return scalar($file =~ m{^([a-z]:)?[\\/]}i);
65 }
66
67 =item catfile
68
69 Concatenate one or more directory names and a filename to form a
70 complete path ending with a filename
71
72 =cut
73
74 sub catfile {
75     my $self = shift;
76     my $file = pop @_;
77     return $file unless @_;
78     my $dir = $self->catdir(@_);
79     $dir .= "\\" unless substr($dir,-1) eq "\\";
80     return $dir.$file;
81 }
82
83 sub path {
84     local $^W = 1;
85     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
86     my @path = split(';',$path);
87     foreach (@path) { $_ = '.' if $_ eq '' }
88     return @path;
89 }
90
91 =item canonpath
92
93 No physical check on the filesystem, but a logical cleanup of a
94 path. On UNIX eliminated successive slashes and successive "/.".
95
96 =cut
97
98 sub canonpath {
99     my ($self,$path,$reduce_ricochet) = @_;
100     $path =~ s/^([a-z]:)/\u$1/;
101     $path =~ s|/|\\|g;
102     $path =~ s|([^\\])\\+|$1\\|g;                  # xx////xx  -> xx/xx
103     $path =~ s|(\\\.)+\\|\\|g;                     # xx/././xx -> xx/xx
104     $path =~ s|^(\.\\)+|| unless $path eq ".\\";   # ./xx      -> xx
105     $path =~ s|\\$||
106              unless $path =~ m#^([A-Z]:)?\\$#;     # xx/       -> xx
107     return $path;
108 }
109
110 =item splitpath
111
112     ($volume,$directories,$file) = File::Spec->splitpath( $path );
113     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
114
115 Splits a path in to volume, directory, and filename portions. Assumes that 
116 the last file is a path unless the path ends in '\\', '\\.', '\\..'
117 or $no_file is true.  On Win32 this means that $no_file true makes this return 
118 ( $volume, $path, undef ).
119
120 Separators accepted are \ and /.
121
122 Volumes can be drive letters or UNC sharenames (\\server\share).
123
124 The results can be passed to L</catpath()> to get back a path equivalent to
125 (usually identical to) the original path.
126
127 =cut
128
129 sub splitpath {
130     my ($self,$path, $nofile) = @_;
131     my ($volume,$directory,$file) = ('','','');
132     if ( $nofile ) {
133         $path =~ 
134             m@^( (?:[a-zA-Z]:|(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+)? ) 
135                  (.*)
136              @x;
137         $volume    = $1;
138         $directory = $2;
139     }
140     else {
141         $path =~ 
142             m@^ ( (?: [a-zA-Z]: |
143                       (?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+
144                   )?
145                 )
146                 ( (?:.*[\\\\/](?:\.\.?$)?)? )
147                 (.*)
148              @x;
149         $volume    = $1;
150         $directory = $2;
151         $file      = $3;
152     }
153
154     return ($volume,$directory,$file);
155 }
156
157
158 =item splitdir
159
160 The opposite of L</catdir()>.
161
162     @dirs = File::Spec->splitdir( $directories );
163
164 $directories must be only the directory portion of the path on systems 
165 that have the concept of a volume or that have path syntax that differentiates
166 files from directories.
167
168 Unlike just splitting the directories on the separator, leading empty and 
169 trailing directory entries can be returned, because these are significant
170 on some OSs. So,
171
172     File::Spec->splitdir( "/a/b/c" );
173
174 Yields:
175
176     ( '', 'a', 'b', '', 'c', '' )
177
178 =cut
179
180 sub splitdir {
181     my ($self,$directories) = @_ ;
182     #
183     # split() likes to forget about trailing null fields, so here we
184     # check to be sure that there will not be any before handling the
185     # simple case.
186     #
187     if ( $directories !~ m|[\\/]$| ) {
188         return split( m|[\\/]|, $directories );
189     }
190     else {
191         #
192         # since there was a trailing separator, add a file name to the end, 
193         # then do the split, then replace it with ''.
194         #
195         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
196         $directories[ $#directories ]= '' ;
197         return @directories ;
198     }
199 }
200
201
202 =item catpath
203
204 Takes volume, directory and file portions and returns an entire path. Under
205 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
206 the $volume become significant.
207
208 =cut
209
210 sub catpath {
211     my ($self,$volume,$directory,$file) = @_;
212
213     # If it's UNC, make sure the glue separator is there, reusing
214     # whatever separator is first in the $volume
215     $volume .= $1
216         if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+$@ &&
217              $directory =~ m@^[^\\/]@
218            ) ;
219
220     $volume .= $directory ;
221
222     # If the volume is not just A:, make sure the glue separator is 
223     # there, reusing whatever separator is first in the $volume if possible.
224     if ( $volume !~ m@^[a-zA-Z]:$@ &&
225          $volume !~ m@[\\/]$@      &&
226          $file   !~ m@^[\\/]@
227        ) {
228         $volume =~ m@([\\/])@ ;
229         my $sep = $1 ? $1 : '\\' ;
230         $volume .= $sep ;
231     }
232
233     $volume .= $file ;
234
235     return $volume ;
236 }
237
238
239 =item abs2rel
240
241 Takes a destination path and an optional base path returns a relative path
242 from the base path to the destination path:
243
244     $rel_path = File::Spec->abs2rel( $destination ) ;
245     $rel_path = File::Spec->abs2rel( $destination, $base ) ;
246
247 If $base is not present or '', then L</cwd()> is used. If $base is relative, 
248 then it is converted to absolute form using L</rel2abs()>. This means that it
249 is taken to be relative to L<cwd()>.
250
251 On systems with the concept of a volume, this assumes that both paths 
252 are on the $destination volume, and ignores the $base volume. 
253
254 On systems that have a grammar that indicates filenames, this ignores the 
255 $base filename as well. Otherwise all path components are assumed to be
256 directories.
257
258 If $path is relative, it is converted to absolute form using L</rel2abs()>.
259 This means that it is taken to be relative to L</cwd()>.
260
261 Based on code written by Shigio Yamaguchi.
262
263 No checks against the filesystem are made. 
264
265 =cut
266
267 sub abs2rel {
268     my($self,$path,$base) = @_;
269
270     # Clean up $path
271     if ( ! $self->file_name_is_absolute( $path ) ) {
272         $path = $self->rel2abs( $path ) ;
273     }
274     else {
275         $path = $self->canonpath( $path ) ;
276     }
277
278     # Figure out the effective $base and clean it up.
279     if ( ! $self->file_name_is_absolute( $base ) ) {
280         $base = $self->rel2abs( $base ) ;
281     }
282     elsif ( !defined( $base ) || $base eq '' ) {
283         $base = cwd() ;
284     }
285     else {
286         $base = $self->canonpath( $base ) ;
287     }
288
289     # Split up paths
290     my ( $path_volume, $path_directories, $path_file ) =
291         $self->splitpath( $path, 1 ) ;
292
293     my ( undef, $base_directories, undef ) =
294         $self->splitpath( $base, 1 ) ;
295
296     # Now, remove all leading components that are the same
297     my @pathchunks = $self->splitdir( $path_directories );
298     my @basechunks = $self->splitdir( $base_directories );
299
300     while ( @pathchunks && 
301             @basechunks && 
302             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
303           ) {
304         shift @pathchunks ;
305         shift @basechunks ;
306     }
307
308     # No need to catdir, we know these are well formed.
309     $path_directories = CORE::join( '\\', @pathchunks );
310     $base_directories = CORE::join( '\\', @basechunks );
311
312     # $base_directories now contains the directories the resulting relative
313     # path must ascend out of before it can descend to $path_directory.  So, 
314     # replace all names with $parentDir
315
316     #FA Need to replace between backslashes...
317     $base_directories =~ s|[^\\]+|..|g ;
318
319     # Glue the two together, using a separator if necessary, and preventing an
320     # empty result.
321
322     #FA Must check that new directories are not empty.
323     if ( $path_directories ne '' && $base_directories ne '' ) {
324         $path_directories = "$base_directories\\$path_directories" ;
325     } else {
326         $path_directories = "$base_directories$path_directories" ;
327     }
328
329     return $self->canonpath( 
330         $self->catpath( $path_volume, $path_directories, $path_file )
331     ) ;
332 }
333
334 =item rel2abs
335
336 Converts a relative path to an absolute path. 
337
338     $abs_path = $File::Spec->rel2abs( $destination ) ;
339     $abs_path = $File::Spec->rel2abs( $destination, $base ) ;
340
341 If $base is not present or '', then L<cwd()> is used. If $base is relative, 
342 then it is converted to absolute form using L</rel2abs()>. This means that it
343 is taken to be relative to L</cwd()>.
344
345 Assumes that both paths are on the $base volume, and ignores the 
346 $destination volume. 
347
348 On systems that have a grammar that indicates filenames, this ignores the 
349 $base filename as well. Otherwise all path components are assumed to be
350 directories.
351
352 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
353
354 Based on code written by Shigio Yamaguchi.
355
356 No checks against the filesystem are made. 
357
358 =cut
359
360 sub rel2abs($;$;) {
361     my ($self,$path,$base ) = @_;
362
363     # Clean up and split up $path
364     if ( ! $self->file_name_is_absolute( $path ) ) {
365
366         # Figure out the effective $base and clean it up.
367         if ( ! $self->file_name_is_absolute( $base ) ) {
368             $base = $self->rel2abs( $base ) ;
369         }
370         elsif ( !defined( $base ) || $base eq '' ) {
371             $base = cwd() ;
372         }
373         else {
374             $base = $self->canonpath( $base ) ;
375         }
376
377         # Split up paths
378         my ( undef, $path_directories, $path_file ) =
379             $self->splitpath( $path, 1 ) ;
380
381         my ( $base_volume, $base_directories, undef ) =
382             $self->splitpath( $base, 1 ) ;
383
384         $path = $self->catpath( 
385             $base_volume, 
386             $self->catdir( $base_directories, $path_directories ), 
387             $path_file
388         ) ;
389     }
390
391     return $self->canonpath( $path ) ;
392 }
393
394 =back
395
396 =head1 SEE ALSO
397
398 L<File::Spec>
399
400 =cut
401
402 1;