This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
whichsig() really does return -1 for unknown signals.
[perl5.git] / lib / File / Spec / Win32.pm
CommitLineData
270d1e39
GS
1package File::Spec::Win32;
2
cbc7acb0 3use strict;
c27914c9 4use Cwd;
b4296952 5use vars qw(@ISA $VERSION);
cbc7acb0 6require File::Spec::Unix;
b4296952 7
88d01e8d 8$VERSION = '1.3';
b4296952 9
cbc7acb0
JD
10@ISA = qw(File::Spec::Unix);
11
270d1e39
GS
12=head1 NAME
13
14File::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
GS
19
20=head1 DESCRIPTION
21
22See File::Spec::Unix for a documentation of the methods provided
23there. This package overrides the implementation of these methods, not
24the semantics.
25
bbc7dcd2 26=over 4
270d1e39 27
cbc7acb0 28=item devnull
270d1e39 29
cbc7acb0 30Returns a string representation of the null device.
270d1e39 31
cbc7acb0 32=cut
270d1e39 33
cbc7acb0
JD
34sub devnull {
35 return "nul";
36}
270d1e39 37
cbc7acb0 38=item tmpdir
270d1e39 39
cbc7acb0
JD
40Returns a string representation of the first existing directory
41from the following list:
270d1e39 42
cbc7acb0
JD
43 $ENV{TMPDIR}
44 $ENV{TEMP}
45 $ENV{TMP}
dd9bbc5b 46 SYS:/temp
28747828 47 C:/temp
cbc7acb0
JD
48 /tmp
49 /
50
dd9bbc5b
JH
51The SYS:/temp is preferred in Novell NetWare.
52
53Since Perl 5.8.0, if running under taint mode, and if the environment
a384e9e1
RGS
54variables are tainted, they are not used.
55
cbc7acb0 56=cut
270d1e39 57
cbc7acb0
JD
58my $tmpdir;
59sub tmpdir {
60 return $tmpdir if defined $tmpdir;
270d1e39 61 my $self = shift;
a384e9e1
RGS
62 my @dirlist = (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /));
63 {
64 no strict 'refs';
65 if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
66 require Scalar::Util;
67 @dirlist = grep { ! Scalar::Util::tainted $_ } @dirlist;
68 }
69 }
70 foreach (@dirlist) {
cbc7acb0
JD
71 next unless defined && -d;
72 $tmpdir = $_;
73 last;
270d1e39 74 }
9ceb3593 75 $tmpdir = File::Spec->curdir unless defined $tmpdir;
cbc7acb0
JD
76 $tmpdir = $self->canonpath($tmpdir);
77 return $tmpdir;
78}
79
46726cbe
CB
80sub case_tolerant {
81 return 1;
82}
83
cbc7acb0
JD
84sub file_name_is_absolute {
85 my ($self,$file) = @_;
1b1e14d3 86 return scalar($file =~ m{^([a-z]:)?[\\/]}is);
270d1e39
GS
87}
88
89=item catfile
90
91Concatenate one or more directory names and a filename to form a
92complete path ending with a filename
93
94=cut
95
96sub catfile {
cbc7acb0 97 my $self = shift;
02961b52 98 my $file = $self->canonpath(pop @_);
270d1e39
GS
99 return $file unless @_;
100 my $dir = $self->catdir(@_);
cbc7acb0 101 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
102 return $dir.$file;
103}
104
105sub path {
270d1e39
GS
106 my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
107 my @path = split(';',$path);
cbc7acb0
JD
108 foreach (@path) { $_ = '.' if $_ eq '' }
109 return @path;
270d1e39
GS
110}
111
112=item canonpath
113
114No physical check on the filesystem, but a logical cleanup of a
115path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
116On Win32 makes
117
118 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
119 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
120
121=cut
122
123sub canonpath {
0994714a 124 my ($self,$path) = @_;
cc23144f 125 my $orig_path = $path;
1b1e14d3 126 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 127 $path =~ s|/|\\|g;
ecf68df6
DR
128 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
129 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
130 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 131 $path =~ s|\\\Z(?!\n)||
ecf68df6 132 unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx\ -> xx
cc23144f
IS
133 # xx1/xx2/xx3/../../xx -> xx1/xx
134 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
135 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
136 return $path if $path =~ m|^\.\.|; # skip relative paths
137 return $path unless $path =~ /\.\./; # too few .'s to cleanup
138 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
139 return $path if $orig_path =~ m|^\Q/../\E|
140 and $orig_path =~ m|\/$|; # don't do /../dirs/
141 # when called from rel2abs()
142 # for ../dirs/
143 my ($vol,$dirs,$file) = $self->splitpath($path);
144 my @dirs = $self->splitdir($dirs);
145 my (@base_dirs, @path_dirs);
146 my $dest = \@base_dirs;
147 for my $dir (@dirs){
148 $dest = \@path_dirs if $dir eq $self->updir;
149 push @$dest, $dir;
150 }
151 # for each .. in @path_dirs pop one item from
152 # @base_dirs
153 while (my $dir = shift @path_dirs){
154 unless ($dir eq $self->updir){
155 unshift @path_dirs, $dir;
156 last;
157 }
158 pop @base_dirs;
159 }
160 $path = $self->catpath(
161 $vol,
162 $self->catdir(@base_dirs, @path_dirs),
163 $file
164 );
cbc7acb0 165 return $path;
270d1e39
GS
166}
167
c27914c9
BS
168=item splitpath
169
170 ($volume,$directories,$file) = File::Spec->splitpath( $path );
171 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
172
40d020d9 173Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
174the last file is a path unless the path ends in '\\', '\\.', '\\..'
175or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 176( $volume, $path, '' ).
c27914c9
BS
177
178Separators accepted are \ and /.
179
180Volumes can be drive letters or UNC sharenames (\\server\share).
181
0994714a 182The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
183(usually identical to) the original path.
184
185=cut
186
187sub splitpath {
188 my ($self,$path, $nofile) = @_;
189 my ($volume,$directory,$file) = ('','','');
190 if ( $nofile ) {
191 $path =~
0994714a 192 m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
c27914c9 193 (.*)
1b1e14d3 194 }xs;
c27914c9
BS
195 $volume = $1;
196 $directory = $2;
197 }
198 else {
199 $path =~
0994714a
GS
200 m{^ ( (?: [a-zA-Z]: |
201 (?:\\\\|//)[^\\/]+[\\/][^\\/]+
c27914c9
BS
202 )?
203 )
9c045eb2 204 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 205 (.*)
1b1e14d3 206 }xs;
c27914c9
BS
207 $volume = $1;
208 $directory = $2;
209 $file = $3;
210 }
211
212 return ($volume,$directory,$file);
213}
214
215
216=item splitdir
217
59605c55 218The opposite of L<catdir()|File::Spec/catdir()>.
c27914c9
BS
219
220 @dirs = File::Spec->splitdir( $directories );
221
222$directories must be only the directory portion of the path on systems
223that have the concept of a volume or that have path syntax that differentiates
224files from directories.
225
226Unlike just splitting the directories on the separator, leading empty and
227trailing directory entries can be returned, because these are significant
228on some OSs. So,
229
230 File::Spec->splitdir( "/a/b/c" );
231
232Yields:
233
234 ( '', 'a', 'b', '', 'c', '' )
235
236=cut
237
238sub splitdir {
239 my ($self,$directories) = @_ ;
240 #
241 # split() likes to forget about trailing null fields, so here we
242 # check to be sure that there will not be any before handling the
243 # simple case.
244 #
9c045eb2 245 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
246 return split( m|[\\/]|, $directories );
247 }
248 else {
249 #
250 # since there was a trailing separator, add a file name to the end,
251 # then do the split, then replace it with ''.
252 #
253 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
254 $directories[ $#directories ]= '' ;
255 return @directories ;
256 }
257}
258
259
260=item catpath
261
262Takes volume, directory and file portions and returns an entire path. Under
263Unix, $volume is ignored, and this is just like catfile(). On other OSs,
264the $volume become significant.
265
266=cut
267
268sub catpath {
269 my ($self,$volume,$directory,$file) = @_;
270
271 # If it's UNC, make sure the glue separator is there, reusing
272 # whatever separator is first in the $volume
273 $volume .= $1
9c045eb2 274 if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
1b1e14d3 275 $directory =~ m@^[^\\/]@s
c27914c9
BS
276 ) ;
277
278 $volume .= $directory ;
279
280 # If the volume is not just A:, make sure the glue separator is
281 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
282 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
283 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 284 $file =~ m@[^\\/]@
c27914c9
BS
285 ) {
286 $volume =~ m@([\\/])@ ;
287 my $sep = $1 ? $1 : '\\' ;
288 $volume .= $sep ;
289 }
290
291 $volume .= $file ;
292
293 return $volume ;
294}
295
296
c27914c9
BS
297sub abs2rel {
298 my($self,$path,$base) = @_;
299
300 # Clean up $path
301 if ( ! $self->file_name_is_absolute( $path ) ) {
302 $path = $self->rel2abs( $path ) ;
303 }
304 else {
305 $path = $self->canonpath( $path ) ;
306 }
307
308 # Figure out the effective $base and clean it up.
9c1370fb 309 if ( !defined( $base ) || $base eq '' ) {
c27914c9
BS
310 $base = cwd() ;
311 }
9c1370fb
NK
312 elsif ( ! $self->file_name_is_absolute( $base ) ) {
313 $base = $self->rel2abs( $base ) ;
314 }
c27914c9
BS
315 else {
316 $base = $self->canonpath( $base ) ;
317 }
318
319 # Split up paths
9b1c7707 320 my ( undef, $path_directories, $path_file ) =
c27914c9
BS
321 $self->splitpath( $path, 1 ) ;
322
9c045eb2 323 my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
c27914c9
BS
324
325 # Now, remove all leading components that are the same
326 my @pathchunks = $self->splitdir( $path_directories );
327 my @basechunks = $self->splitdir( $base_directories );
328
329 while ( @pathchunks &&
330 @basechunks &&
331 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
332 ) {
333 shift @pathchunks ;
334 shift @basechunks ;
335 }
336
337 # No need to catdir, we know these are well formed.
338 $path_directories = CORE::join( '\\', @pathchunks );
339 $base_directories = CORE::join( '\\', @basechunks );
340
5cefc38b
GS
341 # $base_directories now contains the directories the resulting relative
342 # path must ascend out of before it can descend to $path_directory. So,
c27914c9 343 # replace all names with $parentDir
5cefc38b
GS
344
345 #FA Need to replace between backslashes...
346 $base_directories =~ s|[^\\]+|..|g ;
c27914c9
BS
347
348 # Glue the two together, using a separator if necessary, and preventing an
349 # empty result.
5cefc38b
GS
350
351 #FA Must check that new directories are not empty.
352 if ( $path_directories ne '' && $base_directories ne '' ) {
c27914c9
BS
353 $path_directories = "$base_directories\\$path_directories" ;
354 } else {
355 $path_directories = "$base_directories$path_directories" ;
356 }
357
358 return $self->canonpath(
9b1c7707 359 $self->catpath( "", $path_directories, $path_file )
c27914c9
BS
360 ) ;
361}
362
c27914c9 363
786b702f 364sub rel2abs {
c27914c9
BS
365 my ($self,$path,$base ) = @_;
366
c27914c9
BS
367 if ( ! $self->file_name_is_absolute( $path ) ) {
368
1d7cb664 369 if ( !defined( $base ) || $base eq '' ) {
c27914c9
BS
370 $base = cwd() ;
371 }
1d7cb664
GS
372 elsif ( ! $self->file_name_is_absolute( $base ) ) {
373 $base = $self->rel2abs( $base ) ;
374 }
c27914c9
BS
375 else {
376 $base = $self->canonpath( $base ) ;
377 }
378
9c045eb2
GS
379 my ( $path_directories, $path_file ) =
380 ($self->splitpath( $path, 1 ))[1,2] ;
c27914c9 381
9c045eb2 382 my ( $base_volume, $base_directories ) =
c27914c9
BS
383 $self->splitpath( $base, 1 ) ;
384
385 $path = $self->catpath(
386 $base_volume,
387 $self->catdir( $base_directories, $path_directories ),
388 $path_file
389 ) ;
390 }
391
392 return $self->canonpath( $path ) ;
393}
394
270d1e39
GS
395=back
396
dd9bbc5b
JH
397=head2 Note For File::Spec::Win32 Maintainers
398
399Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
400
cbc7acb0
JD
401=head1 SEE ALSO
402
403L<File::Spec>
270d1e39 404
cbc7acb0
JD
405=cut
406
4071;