This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
6878c83f163c461e15470e9bc770d052b24c14fd
[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 =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( map( $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 = split(';', $ENV{PATH});
112     s/"//g for @path;
113     @path = grep length, @path;
114     unshift(@path, ".");
115     return @path;
116 }
117
118 =item canonpath
119
120 No physical check on the filesystem, but a logical cleanup of a
121 path. On UNIX eliminated successive slashes and successive "/.".
122 On Win32 makes 
123
124         dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
125         dir1\dir2\dir3\...\dir4   -> \dir\dir4
126
127 =cut
128
129 sub canonpath {
130     my ($self,$path) = @_;
131     
132     $path =~ s/^([a-z]:)/\u$1/s;
133     $path =~ s|/|\\|g;
134     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
135     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
136     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
137     $path =~ s|\\\Z(?!\n)||
138         unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s;  # xx\       -> xx
139     # xx1/xx2/xx3/../../xx -> xx1/xx
140     $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
141     $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
142     return $path if $path =~ m|^\.\.|;      # skip relative paths
143     return $path unless $path =~ /\.\./;    # too few .'s to cleanup
144     return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
145     $path =~ s{^\\\.\.$}{\\};                      # \..    -> \
146     1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx
147
148     return $self->_collapse($path);
149 }
150
151 =item splitpath
152
153     ($volume,$directories,$file) = File::Spec->splitpath( $path );
154     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
155
156 Splits a path into volume, directory, and filename portions. Assumes that 
157 the last file is a path unless the path ends in '\\', '\\.', '\\..'
158 or $no_file is true.  On Win32 this means that $no_file true makes this return 
159 ( $volume, $path, '' ).
160
161 Separators accepted are \ and /.
162
163 Volumes can be drive letters or UNC sharenames (\\server\share).
164
165 The results can be passed to L</catpath> to get back a path equivalent to
166 (usually identical to) the original path.
167
168 =cut
169
170 sub splitpath {
171     my ($self,$path, $nofile) = @_;
172     my ($volume,$directory,$file) = ('','','');
173     if ( $nofile ) {
174         $path =~ 
175             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
176                  (.*)
177              }xs;
178         $volume    = $1;
179         $directory = $2;
180     }
181     else {
182         $path =~ 
183             m{^ ( (?: [a-zA-Z]: |
184                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
185                   )?
186                 )
187                 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
188                 (.*)
189              }xs;
190         $volume    = $1;
191         $directory = $2;
192         $file      = $3;
193     }
194
195     return ($volume,$directory,$file);
196 }
197
198
199 =item splitdir
200
201 The opposite of L<catdir()|File::Spec/catdir()>.
202
203     @dirs = File::Spec->splitdir( $directories );
204
205 $directories must be only the directory portion of the path on systems 
206 that have the concept of a volume or that have path syntax that differentiates
207 files from directories.
208
209 Unlike just splitting the directories on the separator, leading empty and 
210 trailing directory entries can be returned, because these are significant
211 on some OSs. So,
212
213     File::Spec->splitdir( "/a/b/c" );
214
215 Yields:
216
217     ( '', 'a', 'b', '', 'c', '' )
218
219 =cut
220
221 sub splitdir {
222     my ($self,$directories) = @_ ;
223     #
224     # split() likes to forget about trailing null fields, so here we
225     # check to be sure that there will not be any before handling the
226     # simple case.
227     #
228     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
229         return split( m|[\\/]|, $directories );
230     }
231     else {
232         #
233         # since there was a trailing separator, add a file name to the end, 
234         # then do the split, then replace it with ''.
235         #
236         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
237         $directories[ $#directories ]= '' ;
238         return @directories ;
239     }
240 }
241
242
243 =item catpath
244
245 Takes volume, directory and file portions and returns an entire path. Under
246 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
247 the $volume become significant.
248
249 =cut
250
251 sub catpath {
252     my ($self,$volume,$directory,$file) = @_;
253
254     # If it's UNC, make sure the glue separator is there, reusing
255     # whatever separator is first in the $volume
256     my $v;
257     $volume .= $v
258         if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
259              $directory =~ m@^[^\\/]@s
260            ) ;
261
262     $volume .= $directory ;
263
264     # If the volume is not just A:, make sure the glue separator is 
265     # there, reusing whatever separator is first in the $volume if possible.
266     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
267          $volume =~ m@[^\\/]\Z(?!\n)@      &&
268          $file   =~ m@[^\\/]@
269        ) {
270         $volume =~ m@([\\/])@ ;
271         my $sep = $1 ? $1 : '\\' ;
272         $volume .= $sep ;
273     }
274
275     $volume .= $file ;
276
277     return $volume ;
278 }
279
280 sub _same {
281   lc($_[1]) eq lc($_[2]);
282 }
283
284 sub rel2abs {
285     my ($self,$path,$base ) = @_;
286
287     if ( ! $self->file_name_is_absolute( $path ) ) {
288
289         if ( !defined( $base ) || $base eq '' ) {
290             require Cwd ;
291             $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
292             $base = $self->_cwd() unless defined $base ;
293         }
294         elsif ( ! $self->file_name_is_absolute( $base ) ) {
295             $base = $self->rel2abs( $base ) ;
296         }
297         else {
298             $base = $self->canonpath( $base ) ;
299         }
300
301         my ( $path_directories, $path_file ) =
302             ($self->splitpath( $path, 1 ))[1,2] ;
303
304         my ( $base_volume, $base_directories ) =
305             $self->splitpath( $base, 1 ) ;
306
307         $path = $self->catpath( 
308             $base_volume, 
309             $self->catdir( $base_directories, $path_directories ), 
310             $path_file
311         ) ;
312     }
313
314     return $self->canonpath( $path ) ;
315 }
316
317 =back
318
319 =head2 Note For File::Spec::Win32 Maintainers
320
321 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
322
323 =head1 COPYRIGHT
324
325 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
326
327 This program is free software; you can redistribute it and/or modify
328 it under the same terms as Perl itself.
329
330 =head1 SEE ALSO
331
332 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
333 implementation of these methods, not the semantics.
334
335 =cut
336
337 1;