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;
|
---|