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
CommitLineData
270d1e39
GS
1package File::Spec::Win32;
2
cbc7acb0 3use strict;
c27914c9 4use Cwd;
cbc7acb0
JD
5use vars qw(@ISA);
6require File::Spec::Unix;
7@ISA = qw(File::Spec::Unix);
8
270d1e39
GS
9=head1 NAME
10
11File::Spec::Win32 - methods for Win32 file specs
12
13=head1 SYNOPSIS
14
cbc7acb0 15 require File::Spec::Win32; # Done internally by File::Spec if needed
270d1e39
GS
16
17=head1 DESCRIPTION
18
19See File::Spec::Unix for a documentation of the methods provided
20there. This package overrides the implementation of these methods, not
21the semantics.
22
23=over
24
cbc7acb0 25=item devnull
270d1e39 26
cbc7acb0 27Returns a string representation of the null device.
270d1e39 28
cbc7acb0 29=cut
270d1e39 30
cbc7acb0
JD
31sub devnull {
32 return "nul";
33}
270d1e39 34
cbc7acb0 35=item tmpdir
270d1e39 36
cbc7acb0
JD
37Returns a string representation of the first existing directory
38from the following list:
270d1e39 39
cbc7acb0
JD
40 $ENV{TMPDIR}
41 $ENV{TEMP}
42 $ENV{TMP}
43 /tmp
44 /
45
46=cut
270d1e39 47
cbc7acb0
JD
48my $tmpdir;
49sub tmpdir {
50 return $tmpdir if defined $tmpdir;
270d1e39 51 my $self = shift;
cbc7acb0
JD
52 foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
53 next unless defined && -d;
54 $tmpdir = $_;
55 last;
270d1e39 56 }
cbc7acb0
JD
57 $tmpdir = '' unless defined $tmpdir;
58 $tmpdir = $self->canonpath($tmpdir);
59 return $tmpdir;
60}
61
62sub file_name_is_absolute {
63 my ($self,$file) = @_;
64 return scalar($file =~ m{^([a-z]:)?[\\/]}i);
270d1e39
GS
65}
66
67=item catfile
68
69Concatenate one or more directory names and a filename to form a
70complete path ending with a filename
71
72=cut
73
74sub catfile {
cbc7acb0 75 my $self = shift;
270d1e39
GS
76 my $file = pop @_;
77 return $file unless @_;
78 my $dir = $self->catdir(@_);
cbc7acb0 79 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
80 return $dir.$file;
81}
82
83sub path {
84 local $^W = 1;
270d1e39
GS
85 my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
86 my @path = split(';',$path);
cbc7acb0
JD
87 foreach (@path) { $_ = '.' if $_ eq '' }
88 return @path;
270d1e39
GS
89}
90
91=item canonpath
92
93No physical check on the filesystem, but a logical cleanup of a
94path. On UNIX eliminated successive slashes and successive "/.".
95
96=cut
97
98sub canonpath {
c27914c9 99 my ($self,$path,$reduce_ricochet) = @_;
270d1e39
GS
100 $path =~ s/^([a-z]:)/\u$1/;
101 $path =~ s|/|\\|g;
f505c983 102 $path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx
cbc7acb0 103 $path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx
270d1e39 104 $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx
cbc7acb0 105 $path =~ s|\\$||
c27914c9 106 unless $path =~ m#^([A-Z]:)?\\$#; # xx/ -> xx
cbc7acb0 107 return $path;
270d1e39
GS
108}
109
c27914c9
BS
110=item splitpath
111
112 ($volume,$directories,$file) = File::Spec->splitpath( $path );
113 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
114
115Splits a path in to volume, directory, and filename portions. Assumes that
116the last file is a path unless the path ends in '\\', '\\.', '\\..'
117or $no_file is true. On Win32 this means that $no_file true makes this return
118( $volume, $path, undef ).
119
120Separators accepted are \ and /.
121
122Volumes can be drive letters or UNC sharenames (\\server\share).
123
124The 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
129sub 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
160The 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
165that have the concept of a volume or that have path syntax that differentiates
166files from directories.
167
168Unlike just splitting the directories on the separator, leading empty and
169trailing directory entries can be returned, because these are significant
170on some OSs. So,
171
172 File::Spec->splitdir( "/a/b/c" );
173
174Yields:
175
176 ( '', 'a', 'b', '', 'c', '' )
177
178=cut
179
180sub 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
204Takes volume, directory and file portions and returns an entire path. Under
205Unix, $volume is ignored, and this is just like catfile(). On other OSs,
206the $volume become significant.
207
208=cut
209
210sub 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
241Takes a destination path and an optional base path returns a relative path
242from the base path to the destination path:
243
244 $rel_path = File::Spec->abs2rel( $destination ) ;
245 $rel_path = File::Spec->abs2rel( $destination, $base ) ;
246
247If $base is not present or '', then L</cwd()> is used. If $base is relative,
248then it is converted to absolute form using L</rel2abs()>. This means that it
249is taken to be relative to L<cwd()>.
250
251On systems with the concept of a volume, this assumes that both paths
252are on the $destination volume, and ignores the $base volume.
253
254On systems that have a grammar that indicates filenames, this ignores the
255$base filename as well. Otherwise all path components are assumed to be
256directories.
257
258If $path is relative, it is converted to absolute form using L</rel2abs()>.
259This means that it is taken to be relative to L</cwd()>.
260
261Based on code written by Shigio Yamaguchi.
262
263No checks against the filesystem are made.
264
265=cut
266
267sub 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
5cefc38b
GS
312 # $base_directories now contains the directories the resulting relative
313 # path must ascend out of before it can descend to $path_directory. So,
c27914c9 314 # replace all names with $parentDir
5cefc38b
GS
315
316 #FA Need to replace between backslashes...
317 $base_directories =~ s|[^\\]+|..|g ;
c27914c9
BS
318
319 # Glue the two together, using a separator if necessary, and preventing an
320 # empty result.
5cefc38b
GS
321
322 #FA Must check that new directories are not empty.
323 if ( $path_directories ne '' && $base_directories ne '' ) {
c27914c9
BS
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
336Converts a relative path to an absolute path.
337
338 $abs_path = $File::Spec->rel2abs( $destination ) ;
339 $abs_path = $File::Spec->rel2abs( $destination, $base ) ;
340
341If $base is not present or '', then L<cwd()> is used. If $base is relative,
342then it is converted to absolute form using L</rel2abs()>. This means that it
343is taken to be relative to L</cwd()>.
344
345Assumes that both paths are on the $base volume, and ignores the
346$destination volume.
347
348On systems that have a grammar that indicates filenames, this ignores the
349$base filename as well. Otherwise all path components are assumed to be
350directories.
351
352If $path is absolute, it is cleaned up and returned using L</canonpath()>.
353
354Based on code written by Shigio Yamaguchi.
355
356No checks against the filesystem are made.
357
358=cut
359
360sub 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
270d1e39
GS
394=back
395
cbc7acb0
JD
396=head1 SEE ALSO
397
398L<File::Spec>
270d1e39 399
cbc7acb0
JD
400=cut
401
4021;