Commit | Line | Data |
---|---|---|
920dae64 AT |
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( @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 | ||
281 | sub abs2rel { | |
282 | my($self,$path,$base) = @_; | |
283 | $base = $self->_cwd() unless defined $base and length $base; | |
284 | ||
285 | for ($path, $base) { $_ = $self->canonpath($_) } | |
286 | ||
287 | my ($path_volume) = $self->splitpath($path, 1); | |
288 | my ($base_volume) = $self->splitpath($base, 1); | |
289 | ||
290 | # Can't relativize across volumes | |
291 | return $path unless $path_volume eq $base_volume; | |
292 | ||
293 | for ($path, $base) { $_ = $self->rel2abs($_) } | |
294 | ||
295 | my $path_directories = ($self->splitpath($path, 1))[1]; | |
296 | my $base_directories = ($self->splitpath($base, 1))[1]; | |
297 | ||
298 | # Now, remove all leading components that are the same | |
299 | my @pathchunks = $self->splitdir( $path_directories ); | |
300 | my @basechunks = $self->splitdir( $base_directories ); | |
301 | ||
302 | while ( @pathchunks && | |
303 | @basechunks && | |
304 | lc( $pathchunks[0] ) eq lc( $basechunks[0] ) | |
305 | ) { | |
306 | shift @pathchunks ; | |
307 | shift @basechunks ; | |
308 | } | |
309 | ||
310 | my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); | |
311 | ||
312 | return $self->canonpath( $self->catpath('', $result_dirs, '') ); | |
313 | } | |
314 | ||
315 | ||
316 | sub rel2abs { | |
317 | my ($self,$path,$base ) = @_; | |
318 | ||
319 | if ( ! $self->file_name_is_absolute( $path ) ) { | |
320 | ||
321 | if ( !defined( $base ) || $base eq '' ) { | |
322 | require Cwd ; | |
323 | $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; | |
324 | $base = $self->_cwd() unless defined $base ; | |
325 | } | |
326 | elsif ( ! $self->file_name_is_absolute( $base ) ) { | |
327 | $base = $self->rel2abs( $base ) ; | |
328 | } | |
329 | else { | |
330 | $base = $self->canonpath( $base ) ; | |
331 | } | |
332 | ||
333 | my ( $path_directories, $path_file ) = | |
334 | ($self->splitpath( $path, 1 ))[1,2] ; | |
335 | ||
336 | my ( $base_volume, $base_directories ) = | |
337 | $self->splitpath( $base, 1 ) ; | |
338 | ||
339 | $path = $self->catpath( | |
340 | $base_volume, | |
341 | $self->catdir( $base_directories, $path_directories ), | |
342 | $path_file | |
343 | ) ; | |
344 | } | |
345 | ||
346 | return $self->canonpath( $path ) ; | |
347 | } | |
348 | ||
349 | =back | |
350 | ||
351 | =head2 Note For File::Spec::Win32 Maintainers | |
352 | ||
353 | Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. | |
354 | ||
355 | =head1 COPYRIGHT | |
356 | ||
357 | Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. | |
358 | ||
359 | This program is free software; you can redistribute it and/or modify | |
360 | it under the same terms as Perl itself. | |
361 | ||
362 | =head1 SEE ALSO | |
363 | ||
364 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the | |
365 | implementation of these methods, not the semantics. | |
366 | ||
367 | =cut | |
368 | ||
369 | 1; |