This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9bfcb185ecea204a13d9b6a133a9d62f0491d812
[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.6';
9
10 @ISA = qw(File::Spec::Unix);
11
12 # Some regexes we use for path splitting
13 my $DRIVE_RX = '[a-zA-Z]:';
14 my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
15 my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
16
17
18 =head1 NAME
19
20 File::Spec::Win32 - methods for Win32 file specs
21
22 =head1 SYNOPSIS
23
24  require File::Spec::Win32; # Done internally by File::Spec if needed
25
26 =head1 DESCRIPTION
27
28 See File::Spec::Unix for a documentation of the methods provided
29 there. This package overrides the implementation of these methods, not
30 the semantics.
31
32 =over 4
33
34 =item devnull
35
36 Returns a string representation of the null device.
37
38 =cut
39
40 sub devnull {
41     return "nul";
42 }
43
44 sub rootdir () { '\\' }
45
46
47 =item tmpdir
48
49 Returns a string representation of the first existing directory
50 from the following list:
51
52     $ENV{TMPDIR}
53     $ENV{TEMP}
54     $ENV{TMP}
55     SYS:/temp
56     C:\system\temp
57     C:/temp
58     /tmp
59     /
60
61 The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
62 for Symbian (the File::Spec::Win32 is used also for those platforms).
63
64 Since Perl 5.8.0, if running under taint mode, and if the environment
65 variables are tainted, they are not used.
66
67 =cut
68
69 my $tmpdir;
70 sub tmpdir {
71     return $tmpdir if defined $tmpdir;
72     $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
73                               'SYS:/temp',
74                               'C:\system\temp',
75                               'C:/temp',
76                               '/tmp',
77                               '/'  );
78 }
79
80 sub case_tolerant {
81     return 1;
82 }
83
84 sub file_name_is_absolute {
85     # As of right now, this returns 2 if the path is absolute with a
86     # volume, 1 if it's absolute with no volume, 0 otherwise.
87
88     my ($self,$file) = @_;
89
90     if ($file =~ m{^($VOL_RX)}o) {
91       my $vol = $1;
92       return ($vol =~ m{^$UNC_RX}o ? 2
93               : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
94               : 0);
95     }
96     return $file =~  m{^[\\/]} ? 1 : 0;
97 }
98
99 =item catfile
100
101 Concatenate one or more directory names and a filename to form a
102 complete path ending with a filename
103
104 =cut
105
106 sub catfile {
107     my $self = shift;
108     my $file = $self->canonpath(pop @_);
109     return $file unless @_;
110     my $dir = $self->catdir(@_);
111     $dir .= "\\" unless substr($dir,-1) eq "\\";
112     return $dir.$file;
113 }
114
115 sub catdir {
116     my $self = shift;
117     my @args = @_;
118     foreach (@args) {
119         tr[/][\\];
120         # append a backslash to each argument unless it has one there
121         $_ .= "\\" unless m{\\$};
122     }
123     return $self->canonpath(join('', @args));
124 }
125
126 sub path {
127     my @path = split(';', $ENV{PATH});
128     s/"//g for @path;
129     @path = grep length, @path;
130     unshift(@path, ".");
131     return @path;
132 }
133
134 =item canonpath
135
136 No physical check on the filesystem, but a logical cleanup of a
137 path. On UNIX eliminated successive slashes and successive "/.".
138 On Win32 makes 
139
140         dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
141         dir1\dir2\dir3\...\dir4   -> \dir\dir4
142
143 =cut
144
145 sub canonpath {
146     my ($self,$path) = @_;
147     
148     $path =~ s/^([a-z]:)/\u$1/s;
149     $path =~ s|/|\\|g;
150     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
151     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
152     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
153     $path =~ s|\\\Z(?!\n)||
154         unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s;  # xx\       -> xx
155     # xx1/xx2/xx3/../../xx -> xx1/xx
156     $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
157     $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
158     return $path if $path =~ m|^\.\.|;      # skip relative paths
159     return $path unless $path =~ /\.\./;    # too few .'s to cleanup
160     return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
161     $path =~ s{^\\\.\.$}{\\};                      # \..    -> \
162     1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx
163
164     return $self->_collapse($path);
165 }
166
167 =item splitpath
168
169     ($volume,$directories,$file) = File::Spec->splitpath( $path );
170     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
171
172 Splits a path into volume, directory, and filename portions. Assumes that 
173 the last file is a path unless the path ends in '\\', '\\.', '\\..'
174 or $no_file is true.  On Win32 this means that $no_file true makes this return 
175 ( $volume, $path, '' ).
176
177 Separators accepted are \ and /.
178
179 Volumes can be drive letters or UNC sharenames (\\server\share).
180
181 The results can be passed to L</catpath> to get back a path equivalent to
182 (usually identical to) the original path.
183
184 =cut
185
186 sub splitpath {
187     my ($self,$path, $nofile) = @_;
188     my ($volume,$directory,$file) = ('','','');
189     if ( $nofile ) {
190         $path =~ 
191             m{^ ( $VOL_RX ? ) (.*) }sox;
192         $volume    = $1;
193         $directory = $2;
194     }
195     else {
196         $path =~ 
197             m{^ ( $VOL_RX ? )
198                 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
199                 (.*)
200              }sox;
201         $volume    = $1;
202         $directory = $2;
203         $file      = $3;
204     }
205
206     return ($volume,$directory,$file);
207 }
208
209
210 =item splitdir
211
212 The opposite of L<catdir()|File::Spec/catdir()>.
213
214     @dirs = File::Spec->splitdir( $directories );
215
216 $directories must be only the directory portion of the path on systems 
217 that have the concept of a volume or that have path syntax that differentiates
218 files from directories.
219
220 Unlike just splitting the directories on the separator, leading empty and 
221 trailing directory entries can be returned, because these are significant
222 on some OSs. So,
223
224     File::Spec->splitdir( "/a/b/c" );
225
226 Yields:
227
228     ( '', 'a', 'b', '', 'c', '' )
229
230 =cut
231
232 sub splitdir {
233     my ($self,$directories) = @_ ;
234     #
235     # split() likes to forget about trailing null fields, so here we
236     # check to be sure that there will not be any before handling the
237     # simple case.
238     #
239     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
240         return split( m|[\\/]|, $directories );
241     }
242     else {
243         #
244         # since there was a trailing separator, add a file name to the end, 
245         # then do the split, then replace it with ''.
246         #
247         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
248         $directories[ $#directories ]= '' ;
249         return @directories ;
250     }
251 }
252
253
254 =item catpath
255
256 Takes volume, directory and file portions and returns an entire path. Under
257 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
258 the $volume become significant.
259
260 =cut
261
262 sub catpath {
263     my ($self,$volume,$directory,$file) = @_;
264
265     # If it's UNC, make sure the glue separator is there, reusing
266     # whatever separator is first in the $volume
267     my $v;
268     $volume .= $v
269         if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
270              $directory =~ m@^[^\\/]@s
271            ) ;
272
273     $volume .= $directory ;
274
275     # If the volume is not just A:, make sure the glue separator is 
276     # there, reusing whatever separator is first in the $volume if possible.
277     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
278          $volume =~ m@[^\\/]\Z(?!\n)@      &&
279          $file   =~ m@[^\\/]@
280        ) {
281         $volume =~ m@([\\/])@ ;
282         my $sep = $1 ? $1 : '\\' ;
283         $volume .= $sep ;
284     }
285
286     $volume .= $file ;
287
288     return $volume ;
289 }
290
291 sub _same {
292   lc($_[1]) eq lc($_[2]);
293 }
294
295 sub rel2abs {
296     my ($self,$path,$base ) = @_;
297
298     my $is_abs = $self->file_name_is_absolute($path);
299
300     # Check for volume (should probably document the '2' thing...)
301     return $self->canonpath( $path ) if $is_abs == 2;
302
303     if ($is_abs) {
304       # It's missing a volume, add one
305       my $vol = ($self->splitpath( $self->_cwd() ))[0];
306       return $self->canonpath( $vol . $path );
307     }
308
309     if ( !defined( $base ) || $base eq '' ) {
310       require Cwd ;
311       $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
312       $base = $self->_cwd() unless defined $base ;
313     }
314     elsif ( ! $self->file_name_is_absolute( $base ) ) {
315       $base = $self->rel2abs( $base ) ;
316     }
317     else {
318       $base = $self->canonpath( $base ) ;
319     }
320
321     my ( $path_directories, $path_file ) =
322       ($self->splitpath( $path, 1 ))[1,2] ;
323
324     my ( $base_volume, $base_directories ) =
325       $self->splitpath( $base, 1 ) ;
326
327     $path = $self->catpath( 
328                            $base_volume, 
329                            $self->catdir( $base_directories, $path_directories ), 
330                            $path_file
331                           ) ;
332
333     return $self->canonpath( $path ) ;
334 }
335
336 =back
337
338 =head2 Note For File::Spec::Win32 Maintainers
339
340 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
341
342 =head1 COPYRIGHT
343
344 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
345
346 This program is free software; you can redistribute it and/or modify
347 it under the same terms as Perl itself.
348
349 =head1 SEE ALSO
350
351 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
352 implementation of these methods, not the semantics.
353
354 =cut
355
356 1;