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