Commit | Line | Data |
270d1e39 |
1 | package File::Spec::Win32; |
2 | |
cbc7acb0 |
3 | use strict; |
07824bd1 |
4 | |
b4296952 |
5 | use vars qw(@ISA $VERSION); |
cbc7acb0 |
6 | require File::Spec::Unix; |
b4296952 |
7 | |
f5f48b4d |
8 | $VERSION = '1.6'; |
b4296952 |
9 | |
cbc7acb0 |
10 | @ISA = qw(File::Spec::Unix); |
11 | |
270d1e39 |
12 | =head1 NAME |
13 | |
14 | File::Spec::Win32 - methods for Win32 file specs |
15 | |
16 | =head1 SYNOPSIS |
17 | |
cbc7acb0 |
18 | require File::Spec::Win32; # Done internally by File::Spec if needed |
270d1e39 |
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 | |
bbc7dcd2 |
26 | =over 4 |
270d1e39 |
27 | |
cbc7acb0 |
28 | =item devnull |
270d1e39 |
29 | |
cbc7acb0 |
30 | Returns a string representation of the null device. |
270d1e39 |
31 | |
cbc7acb0 |
32 | =cut |
270d1e39 |
33 | |
cbc7acb0 |
34 | sub devnull { |
35 | return "nul"; |
36 | } |
270d1e39 |
37 | |
60598624 |
38 | sub rootdir () { '\\' } |
39 | |
40 | |
cbc7acb0 |
41 | =item tmpdir |
270d1e39 |
42 | |
cbc7acb0 |
43 | Returns a string representation of the first existing directory |
44 | from the following list: |
270d1e39 |
45 | |
cbc7acb0 |
46 | $ENV{TMPDIR} |
47 | $ENV{TEMP} |
48 | $ENV{TMP} |
dd9bbc5b |
49 | SYS:/temp |
27da23d5 |
50 | C:\system\temp |
28747828 |
51 | C:/temp |
cbc7acb0 |
52 | /tmp |
53 | / |
54 | |
27da23d5 |
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). |
dd9bbc5b |
57 | |
58 | Since Perl 5.8.0, if running under taint mode, and if the environment |
a384e9e1 |
59 | variables are tainted, they are not used. |
60 | |
cbc7acb0 |
61 | =cut |
270d1e39 |
62 | |
cbc7acb0 |
63 | my $tmpdir; |
64 | sub tmpdir { |
65 | return $tmpdir if defined $tmpdir; |
9d5071ba |
66 | $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), |
07824bd1 |
67 | 'SYS:/temp', |
27da23d5 |
68 | 'C:\system\temp', |
07824bd1 |
69 | 'C:/temp', |
70 | '/tmp', |
71 | '/' ); |
cbc7acb0 |
72 | } |
73 | |
46726cbe |
74 | sub case_tolerant { |
75 | return 1; |
76 | } |
77 | |
cbc7acb0 |
78 | sub file_name_is_absolute { |
79 | my ($self,$file) = @_; |
1b1e14d3 |
80 | return scalar($file =~ m{^([a-z]:)?[\\/]}is); |
270d1e39 |
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 { |
cbc7acb0 |
91 | my $self = shift; |
02961b52 |
92 | my $file = $self->canonpath(pop @_); |
270d1e39 |
93 | return $file unless @_; |
94 | my $dir = $self->catdir(@_); |
cbc7acb0 |
95 | $dir .= "\\" unless substr($dir,-1) eq "\\"; |
270d1e39 |
96 | return $dir.$file; |
97 | } |
98 | |
638113eb |
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 | |
270d1e39 |
110 | sub path { |
092026cf |
111 | my @path = split(';', $ENV{PATH}); |
112 | s/"//g for @path; |
113 | @path = grep length, @path; |
114 | unshift(@path, "."); |
cbc7acb0 |
115 | return @path; |
270d1e39 |
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 "/.". |
cc23144f |
122 | On Win32 makes |
123 | |
124 | dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even |
125 | dir1\dir2\dir3\...\dir4 -> \dir\dir4 |
270d1e39 |
126 | |
127 | =cut |
128 | |
129 | sub canonpath { |
0994714a |
130 | my ($self,$path) = @_; |
9596c75c |
131 | |
1b1e14d3 |
132 | $path =~ s/^([a-z]:)/\u$1/s; |
270d1e39 |
133 | $path =~ s|/|\\|g; |
ecf68df6 |
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 |
9c045eb2 |
137 | $path =~ s|\\\Z(?!\n)|| |
e021ab8e |
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 |
638113eb |
145 | $path =~ s{^\\\.\.$}{\\}; # \.. -> \ |
e021ab8e |
146 | 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx |
147 | |
9596c75c |
148 | return $self->_collapse($path); |
270d1e39 |
149 | } |
150 | |
c27914c9 |
151 | =item splitpath |
152 | |
153 | ($volume,$directories,$file) = File::Spec->splitpath( $path ); |
154 | ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); |
155 | |
40d020d9 |
156 | Splits a path into volume, directory, and filename portions. Assumes that |
c27914c9 |
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 |
40d020d9 |
159 | ( $volume, $path, '' ). |
c27914c9 |
160 | |
161 | Separators accepted are \ and /. |
162 | |
163 | Volumes can be drive letters or UNC sharenames (\\server\share). |
164 | |
0994714a |
165 | The results can be passed to L</catpath> to get back a path equivalent to |
c27914c9 |
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 =~ |
0994714a |
175 | m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) |
c27914c9 |
176 | (.*) |
1b1e14d3 |
177 | }xs; |
c27914c9 |
178 | $volume = $1; |
179 | $directory = $2; |
180 | } |
181 | else { |
182 | $path =~ |
0994714a |
183 | m{^ ( (?: [a-zA-Z]: | |
184 | (?:\\\\|//)[^\\/]+[\\/][^\\/]+ |
c27914c9 |
185 | )? |
186 | ) |
5b287435 |
187 | ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) |
c27914c9 |
188 | (.*) |
1b1e14d3 |
189 | }xs; |
c27914c9 |
190 | $volume = $1; |
191 | $directory = $2; |
192 | $file = $3; |
193 | } |
194 | |
195 | return ($volume,$directory,$file); |
196 | } |
197 | |
198 | |
199 | =item splitdir |
200 | |
59605c55 |
201 | The opposite of L<catdir()|File::Spec/catdir()>. |
c27914c9 |
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 | # |
9c045eb2 |
228 | if ( $directories !~ m|[\\/]\Z(?!\n)| ) { |
c27914c9 |
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 |
9596c75c |
256 | my $v; |
257 | $volume .= $v |
258 | if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && |
1b1e14d3 |
259 | $directory =~ m@^[^\\/]@s |
c27914c9 |
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. |
9c045eb2 |
266 | if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && |
267 | $volume =~ m@[^\\/]\Z(?!\n)@ && |
0994714a |
268 | $file =~ m@[^\\/]@ |
c27914c9 |
269 | ) { |
270 | $volume =~ m@([\\/])@ ; |
271 | my $sep = $1 ? $1 : '\\' ; |
272 | $volume .= $sep ; |
273 | } |
274 | |
275 | $volume .= $file ; |
276 | |
277 | return $volume ; |
278 | } |
279 | |
9d5071ba |
280 | sub _same { |
281 | lc($_[1]) eq lc($_[2]); |
c27914c9 |
282 | } |
283 | |
786b702f |
284 | sub rel2abs { |
c27914c9 |
285 | my ($self,$path,$base ) = @_; |
286 | |
c27914c9 |
287 | if ( ! $self->file_name_is_absolute( $path ) ) { |
288 | |
1d7cb664 |
289 | if ( !defined( $base ) || $base eq '' ) { |
5b287435 |
290 | require Cwd ; |
291 | $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; |
292 | $base = $self->_cwd() unless defined $base ; |
c27914c9 |
293 | } |
1d7cb664 |
294 | elsif ( ! $self->file_name_is_absolute( $base ) ) { |
295 | $base = $self->rel2abs( $base ) ; |
296 | } |
c27914c9 |
297 | else { |
298 | $base = $self->canonpath( $base ) ; |
299 | } |
300 | |
9c045eb2 |
301 | my ( $path_directories, $path_file ) = |
302 | ($self->splitpath( $path, 1 ))[1,2] ; |
c27914c9 |
303 | |
9c045eb2 |
304 | my ( $base_volume, $base_directories ) = |
c27914c9 |
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 | |
270d1e39 |
317 | =back |
318 | |
dd9bbc5b |
319 | =head2 Note For File::Spec::Win32 Maintainers |
320 | |
321 | Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. |
322 | |
99f36a73 |
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 | |
cbc7acb0 |
330 | =head1 SEE ALSO |
331 | |
72f15715 |
332 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the |
333 | implementation of these methods, not the semantics. |
270d1e39 |
334 | |
cbc7acb0 |
335 | =cut |
336 | |
337 | 1; |