Commit | Line | Data |
---|---|---|
270d1e39 GS |
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 | |
6c34c321 | 8 | $VERSION = '3.30'; |
486bcc50 | 9 | $VERSION = eval $VERSION; |
b4296952 | 10 | |
cbc7acb0 JD |
11 | @ISA = qw(File::Spec::Unix); |
12 | ||
110c90cc SP |
13 | # Some regexes we use for path splitting |
14 | my $DRIVE_RX = '[a-zA-Z]:'; | |
15 | my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+'; | |
16 | my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)"; | |
17 | ||
18 | ||
270d1e39 GS |
19 | =head1 NAME |
20 | ||
21 | File::Spec::Win32 - methods for Win32 file specs | |
22 | ||
23 | =head1 SYNOPSIS | |
24 | ||
cbc7acb0 | 25 | require File::Spec::Win32; # Done internally by File::Spec if needed |
270d1e39 GS |
26 | |
27 | =head1 DESCRIPTION | |
28 | ||
29 | See File::Spec::Unix for a documentation of the methods provided | |
30 | there. This package overrides the implementation of these methods, not | |
31 | the semantics. | |
32 | ||
bbc7dcd2 | 33 | =over 4 |
270d1e39 | 34 | |
cbc7acb0 | 35 | =item devnull |
270d1e39 | 36 | |
cbc7acb0 | 37 | Returns a string representation of the null device. |
270d1e39 | 38 | |
cbc7acb0 | 39 | =cut |
270d1e39 | 40 | |
cbc7acb0 JD |
41 | sub devnull { |
42 | return "nul"; | |
43 | } | |
270d1e39 | 44 | |
486bcc50 | 45 | sub rootdir { '\\' } |
60598624 RGS |
46 | |
47 | ||
cbc7acb0 | 48 | =item tmpdir |
270d1e39 | 49 | |
cbc7acb0 JD |
50 | Returns a string representation of the first existing directory |
51 | from the following list: | |
270d1e39 | 52 | |
cbc7acb0 JD |
53 | $ENV{TMPDIR} |
54 | $ENV{TEMP} | |
55 | $ENV{TMP} | |
dd9bbc5b | 56 | SYS:/temp |
27da23d5 | 57 | C:\system\temp |
28747828 | 58 | C:/temp |
cbc7acb0 JD |
59 | /tmp |
60 | / | |
61 | ||
27da23d5 JH |
62 | The SYS:/temp is preferred in Novell NetWare and the C:\system\temp |
63 | for Symbian (the File::Spec::Win32 is used also for those platforms). | |
dd9bbc5b JH |
64 | |
65 | Since Perl 5.8.0, if running under taint mode, and if the environment | |
a384e9e1 RGS |
66 | variables are tainted, they are not used. |
67 | ||
cbc7acb0 | 68 | =cut |
270d1e39 | 69 | |
cbc7acb0 JD |
70 | my $tmpdir; |
71 | sub tmpdir { | |
72 | return $tmpdir if defined $tmpdir; | |
9d5071ba | 73 | $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), |
07824bd1 | 74 | 'SYS:/temp', |
27da23d5 | 75 | 'C:\system\temp', |
07824bd1 JH |
76 | 'C:/temp', |
77 | '/tmp', | |
78 | '/' ); | |
cbc7acb0 JD |
79 | } |
80 | ||
efa159bc RU |
81 | =item case_tolerant |
82 | ||
83 | MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, | |
84 | indicating the case significance when comparing file specifications. | |
85 | Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem. | |
86 | See http://cygwin.com/ml/cygwin/2007-07/msg00891.html | |
87 | Default: 1 | |
88 | ||
89 | =cut | |
90 | ||
486bcc50 | 91 | sub case_tolerant { |
efa159bc | 92 | eval { require Win32API::File; } or return 1; |
a7f43cfc | 93 | my $drive = shift || "C:"; |
efa159bc RU |
94 | my $osFsType = "\0"x256; |
95 | my $osVolName = "\0"x256; | |
96 | my $ouFsFlags = 0; | |
97 | Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); | |
98 | if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } | |
99 | else { return 1; } | |
46726cbe CB |
100 | } |
101 | ||
efa159bc RU |
102 | =item file_name_is_absolute |
103 | ||
104 | As of right now, this returns 2 if the path is absolute with a | |
105 | volume, 1 if it's absolute with no volume, 0 otherwise. | |
106 | ||
107 | =cut | |
108 | ||
cbc7acb0 | 109 | sub file_name_is_absolute { |
c1e8580e | 110 | |
cbc7acb0 | 111 | my ($self,$file) = @_; |
c1e8580e SP |
112 | |
113 | if ($file =~ m{^($VOL_RX)}o) { | |
114 | my $vol = $1; | |
115 | return ($vol =~ m{^$UNC_RX}o ? 2 | |
116 | : $file =~ m{^$DRIVE_RX[\\/]}o ? 2 | |
117 | : 0); | |
118 | } | |
119 | return $file =~ m{^[\\/]} ? 1 : 0; | |
270d1e39 GS |
120 | } |
121 | ||
122 | =item catfile | |
123 | ||
124 | Concatenate one or more directory names and a filename to form a | |
125 | complete path ending with a filename | |
126 | ||
127 | =cut | |
128 | ||
129 | sub catfile { | |
bf7c0a3d SP |
130 | shift; |
131 | ||
132 | # Legacy / compatibility support | |
133 | # | |
134 | shift, return _canon_cat( "/", @_ ) | |
135 | if $_[0] eq ""; | |
136 | ||
795ee885 SP |
137 | # Compatibility with File::Spec <= 3.26: |
138 | # catfile('A:', 'foo') should return 'A:\foo'. | |
139 | return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) | |
140 | if $_[0] =~ m{^$DRIVE_RX\z}o; | |
141 | ||
bf7c0a3d | 142 | return _canon_cat( @_ ); |
270d1e39 GS |
143 | } |
144 | ||
638113eb | 145 | sub catdir { |
bf7c0a3d SP |
146 | shift; |
147 | ||
148 | # Legacy / compatibility support | |
149 | # | |
150 | return "" | |
151 | unless @_; | |
152 | shift, return _canon_cat( "/", @_ ) | |
153 | if $_[0] eq ""; | |
154 | ||
795ee885 SP |
155 | # Compatibility with File::Spec <= 3.26: |
156 | # catdir('A:', 'foo') should return 'A:\foo'. | |
157 | return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) | |
158 | if $_[0] =~ m{^$DRIVE_RX\z}o; | |
159 | ||
bf7c0a3d | 160 | return _canon_cat( @_ ); |
638113eb JH |
161 | } |
162 | ||
270d1e39 | 163 | sub path { |
092026cf SH |
164 | my @path = split(';', $ENV{PATH}); |
165 | s/"//g for @path; | |
166 | @path = grep length, @path; | |
167 | unshift(@path, "."); | |
cbc7acb0 | 168 | return @path; |
270d1e39 GS |
169 | } |
170 | ||
171 | =item canonpath | |
172 | ||
173 | No physical check on the filesystem, but a logical cleanup of a | |
174 | path. On UNIX eliminated successive slashes and successive "/.". | |
cc23144f | 175 | On Win32 makes |
176 | ||
177 | dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even | |
178 | dir1\dir2\dir3\...\dir4 -> \dir\dir4 | |
270d1e39 GS |
179 | |
180 | =cut | |
181 | ||
182 | sub canonpath { | |
bf7c0a3d SP |
183 | # Legacy / compatibility support |
184 | # | |
185 | return $_[1] if !defined($_[1]) or $_[1] eq ''; | |
186 | return _canon_cat( $_[1] ); | |
270d1e39 GS |
187 | } |
188 | ||
c27914c9 BS |
189 | =item splitpath |
190 | ||
191 | ($volume,$directories,$file) = File::Spec->splitpath( $path ); | |
192 | ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); | |
193 | ||
40d020d9 | 194 | Splits a path into volume, directory, and filename portions. Assumes that |
c27914c9 BS |
195 | the last file is a path unless the path ends in '\\', '\\.', '\\..' |
196 | or $no_file is true. On Win32 this means that $no_file true makes this return | |
40d020d9 | 197 | ( $volume, $path, '' ). |
c27914c9 BS |
198 | |
199 | Separators accepted are \ and /. | |
200 | ||
201 | Volumes can be drive letters or UNC sharenames (\\server\share). | |
202 | ||
0994714a | 203 | The results can be passed to L</catpath> to get back a path equivalent to |
c27914c9 BS |
204 | (usually identical to) the original path. |
205 | ||
206 | =cut | |
207 | ||
208 | sub splitpath { | |
209 | my ($self,$path, $nofile) = @_; | |
210 | my ($volume,$directory,$file) = ('','',''); | |
211 | if ( $nofile ) { | |
212 | $path =~ | |
110c90cc | 213 | m{^ ( $VOL_RX ? ) (.*) }sox; |
c27914c9 BS |
214 | $volume = $1; |
215 | $directory = $2; | |
216 | } | |
217 | else { | |
218 | $path =~ | |
110c90cc | 219 | m{^ ( $VOL_RX ? ) |
5b287435 | 220 | ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) |
c27914c9 | 221 | (.*) |
110c90cc | 222 | }sox; |
c27914c9 BS |
223 | $volume = $1; |
224 | $directory = $2; | |
225 | $file = $3; | |
226 | } | |
227 | ||
228 | return ($volume,$directory,$file); | |
229 | } | |
230 | ||
231 | ||
232 | =item splitdir | |
233 | ||
59605c55 | 234 | The opposite of L<catdir()|File::Spec/catdir()>. |
c27914c9 BS |
235 | |
236 | @dirs = File::Spec->splitdir( $directories ); | |
237 | ||
238 | $directories must be only the directory portion of the path on systems | |
239 | that have the concept of a volume or that have path syntax that differentiates | |
240 | files from directories. | |
241 | ||
242 | Unlike just splitting the directories on the separator, leading empty and | |
243 | trailing directory entries can be returned, because these are significant | |
244 | on some OSs. So, | |
245 | ||
246 | File::Spec->splitdir( "/a/b/c" ); | |
247 | ||
248 | Yields: | |
249 | ||
250 | ( '', 'a', 'b', '', 'c', '' ) | |
251 | ||
252 | =cut | |
253 | ||
254 | sub splitdir { | |
255 | my ($self,$directories) = @_ ; | |
256 | # | |
257 | # split() likes to forget about trailing null fields, so here we | |
258 | # check to be sure that there will not be any before handling the | |
259 | # simple case. | |
260 | # | |
9c045eb2 | 261 | if ( $directories !~ m|[\\/]\Z(?!\n)| ) { |
c27914c9 BS |
262 | return split( m|[\\/]|, $directories ); |
263 | } | |
264 | else { | |
265 | # | |
266 | # since there was a trailing separator, add a file name to the end, | |
267 | # then do the split, then replace it with ''. | |
268 | # | |
269 | my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; | |
270 | $directories[ $#directories ]= '' ; | |
271 | return @directories ; | |
272 | } | |
273 | } | |
274 | ||
275 | ||
276 | =item catpath | |
277 | ||
278 | Takes volume, directory and file portions and returns an entire path. Under | |
279 | Unix, $volume is ignored, and this is just like catfile(). On other OSs, | |
280 | the $volume become significant. | |
281 | ||
282 | =cut | |
283 | ||
284 | sub catpath { | |
285 | my ($self,$volume,$directory,$file) = @_; | |
286 | ||
287 | # If it's UNC, make sure the glue separator is there, reusing | |
288 | # whatever separator is first in the $volume | |
9596c75c RGS |
289 | my $v; |
290 | $volume .= $v | |
291 | if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && | |
1b1e14d3 | 292 | $directory =~ m@^[^\\/]@s |
c27914c9 BS |
293 | ) ; |
294 | ||
295 | $volume .= $directory ; | |
296 | ||
297 | # If the volume is not just A:, make sure the glue separator is | |
298 | # there, reusing whatever separator is first in the $volume if possible. | |
9c045eb2 GS |
299 | if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && |
300 | $volume =~ m@[^\\/]\Z(?!\n)@ && | |
0994714a | 301 | $file =~ m@[^\\/]@ |
c27914c9 BS |
302 | ) { |
303 | $volume =~ m@([\\/])@ ; | |
304 | my $sep = $1 ? $1 : '\\' ; | |
305 | $volume .= $sep ; | |
306 | } | |
307 | ||
308 | $volume .= $file ; | |
309 | ||
310 | return $volume ; | |
311 | } | |
312 | ||
9d5071ba SP |
313 | sub _same { |
314 | lc($_[1]) eq lc($_[2]); | |
c27914c9 BS |
315 | } |
316 | ||
786b702f | 317 | sub rel2abs { |
c27914c9 BS |
318 | my ($self,$path,$base ) = @_; |
319 | ||
110c90cc SP |
320 | my $is_abs = $self->file_name_is_absolute($path); |
321 | ||
322 | # Check for volume (should probably document the '2' thing...) | |
323 | return $self->canonpath( $path ) if $is_abs == 2; | |
324 | ||
325 | if ($is_abs) { | |
326 | # It's missing a volume, add one | |
327 | my $vol = ($self->splitpath( $self->_cwd() ))[0]; | |
328 | return $self->canonpath( $vol . $path ); | |
329 | } | |
330 | ||
331 | if ( !defined( $base ) || $base eq '' ) { | |
332 | require Cwd ; | |
333 | $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; | |
334 | $base = $self->_cwd() unless defined $base ; | |
c27914c9 | 335 | } |
110c90cc SP |
336 | elsif ( ! $self->file_name_is_absolute( $base ) ) { |
337 | $base = $self->rel2abs( $base ) ; | |
338 | } | |
339 | else { | |
340 | $base = $self->canonpath( $base ) ; | |
341 | } | |
342 | ||
343 | my ( $path_directories, $path_file ) = | |
344 | ($self->splitpath( $path, 1 ))[1,2] ; | |
345 | ||
346 | my ( $base_volume, $base_directories ) = | |
347 | $self->splitpath( $base, 1 ) ; | |
348 | ||
349 | $path = $self->catpath( | |
350 | $base_volume, | |
351 | $self->catdir( $base_directories, $path_directories ), | |
352 | $path_file | |
353 | ) ; | |
c27914c9 BS |
354 | |
355 | return $self->canonpath( $path ) ; | |
356 | } | |
357 | ||
270d1e39 GS |
358 | =back |
359 | ||
dd9bbc5b JH |
360 | =head2 Note For File::Spec::Win32 Maintainers |
361 | ||
362 | Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. | |
363 | ||
99f36a73 RGS |
364 | =head1 COPYRIGHT |
365 | ||
efa159bc | 366 | Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. |
99f36a73 RGS |
367 | |
368 | This program is free software; you can redistribute it and/or modify | |
369 | it under the same terms as Perl itself. | |
370 | ||
cbc7acb0 JD |
371 | =head1 SEE ALSO |
372 | ||
72f15715 T |
373 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the |
374 | implementation of these methods, not the semantics. | |
270d1e39 | 375 | |
cbc7acb0 JD |
376 | =cut |
377 | ||
bf7c0a3d | 378 | |
486bcc50 | 379 | sub _canon_cat # @path -> path |
bf7c0a3d | 380 | { |
486bcc50 NC |
381 | my ($first, @rest) = @_; |
382 | ||
bf7c0a3d SP |
383 | my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter |
384 | ? ucfirst( $1 ).( $2 ? "\\" : "" ) | |
385 | : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) | |
386 | (?: [\\/] ([^\\/]+) )? | |
387 | [\\/]? }{}xs # UNC volume | |
388 | ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" | |
389 | : $first =~ s{ \A [\\/] }{}x # root dir | |
390 | ? "\\" | |
391 | : ""; | |
486bcc50 | 392 | my $path = join "\\", $first, @rest; |
bf7c0a3d SP |
393 | |
394 | $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy | |
395 | ||
396 | # xx/././yy --> xx/yy | |
397 | $path =~ s{(?: | |
398 | (?:\A|\\) # at begin or after a slash | |
399 | \. | |
400 | (?:\\\.)* # and more | |
401 | (?:\\|\z) # at end or followed by slash | |
402 | )+ # performance boost -- I do not know why | |
403 | }{\\}gx; | |
404 | ||
405 | # XXX I do not know whether more dots are supported by the OS supporting | |
406 | # this ... annotation (NetWare or symbian but not MSWin32). | |
407 | # Then .... could easily become ../../.. etc: | |
408 | # Replace \.\.\. by (\.\.\.+) and substitute with | |
409 | # { $1 . ".." . "\\.." x (length($2)-2) }gex | |
410 | # ... --> ../.. | |
411 | $path =~ s{ (\A|\\) # at begin or after a slash | |
412 | \.\.\. | |
413 | (?=\\|\z) # at end or followed by slash | |
414 | }{$1..\\..}gx; | |
415 | # xx\yy\..\zz --> xx\zz | |
416 | while ( $path =~ s{(?: | |
417 | (?:\A|\\) # at begin or after a slash | |
418 | [^\\]+ # rip this 'yy' off | |
419 | \\\.\. | |
420 | (?<!\A\.\.\\\.\.) # do *not* replace ^..\.. | |
421 | (?<!\\\.\.\\\.\.) # do *not* replace \..\.. | |
422 | (?:\\|\z) # at end or followed by slash | |
423 | )+ # performance boost -- I do not know why | |
424 | }{\\}sx ) {} | |
425 | ||
426 | $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root | |
427 | $path =~ s#\\\z##; # xx\ --> xx | |
428 | ||
429 | if ( $volume =~ m#\\\z# ) | |
430 | { # <vol>\.. --> <vol>\ | |
431 | $path =~ s{ \A # at begin | |
432 | \.\. | |
433 | (?:\\\.\.)* # and more | |
434 | (?:\\|\z) # at end or followed by slash | |
435 | }{}x; | |
436 | ||
437 | return $1 # \\HOST\SHARE\ --> \\HOST\SHARE | |
438 | if $path eq "" | |
439 | and $volume =~ m#\A(\\\\.*)\\\z#s; | |
440 | } | |
441 | return $path ne "" || $volume ? $volume.$path : "."; | |
442 | } | |
443 | ||
cbc7acb0 | 444 | 1; |