This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0ea4970b4140d4773ad5c6a5bccd1be69f3606b3
[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 now contains the directories the resulting relative path 
313     # must ascend out of before it can descend to $path_directory.  So, 
314     # replace all names with $parentDir
315     $base_directories =~ s|[^/]+|..|g ;
316
317     # Glue the two together, using a separator if necessary, and preventing an
318     # empty result.
319     if ( $path ne '' && $base ne '' ) {
320         $path_directories = "$base_directories\\$path_directories" ;
321     } else {
322         $path_directories = "$base_directories$path_directories" ;
323     }
324
325     return $self->canonpath( 
326         $self->catpath( $path_volume, $path_directories, $path_file )
327     ) ;
328 }
329
330 =item rel2abs
331
332 Converts a relative path to an absolute path. 
333
334     $abs_path = $File::Spec->rel2abs( $destination ) ;
335     $abs_path = $File::Spec->rel2abs( $destination, $base ) ;
336
337 If $base is not present or '', then L<cwd()> is used. If $base is relative, 
338 then it is converted to absolute form using L</rel2abs()>. This means that it
339 is taken to be relative to L</cwd()>.
340
341 Assumes that both paths are on the $base volume, and ignores the 
342 $destination volume. 
343
344 On systems that have a grammar that indicates filenames, this ignores the 
345 $base filename as well. Otherwise all path components are assumed to be
346 directories.
347
348 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
349
350 Based on code written by Shigio Yamaguchi.
351
352 No checks against the filesystem are made. 
353
354 =cut
355
356 sub rel2abs($;$;) {
357     my ($self,$path,$base ) = @_;
358
359     # Clean up and split up $path
360     if ( ! $self->file_name_is_absolute( $path ) ) {
361
362         # Figure out the effective $base and clean it up.
363         if ( ! $self->file_name_is_absolute( $base ) ) {
364             $base = $self->rel2abs( $base ) ;
365         }
366         elsif ( !defined( $base ) || $base eq '' ) {
367             $base = cwd() ;
368         }
369         else {
370             $base = $self->canonpath( $base ) ;
371         }
372
373         # Split up paths
374         my ( undef, $path_directories, $path_file ) =
375             $self->splitpath( $path, 1 ) ;
376
377         my ( $base_volume, $base_directories, undef ) =
378             $self->splitpath( $base, 1 ) ;
379
380         $path = $self->catpath( 
381             $base_volume, 
382             $self->catdir( $base_directories, $path_directories ), 
383             $path_file
384         ) ;
385     }
386
387     return $self->canonpath( $path ) ;
388 }
389
390 =back
391
392 =head1 SEE ALSO
393
394 L<File::Spec>
395
396 =cut
397
398 1;