This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
threads::shared 1.04
[perl5.git] / lib / File / Spec / Win32.pm
CommitLineData
270d1e39
GS
1package File::Spec::Win32;
2
cbc7acb0 3use strict;
07824bd1 4
b4296952 5use vars qw(@ISA $VERSION);
cbc7acb0 6require File::Spec::Unix;
b4296952 7
f5f48b4d 8$VERSION = '1.6';
b4296952 9
cbc7acb0
JD
10@ISA = qw(File::Spec::Unix);
11
110c90cc
SP
12# Some regexes we use for path splitting
13my $DRIVE_RX = '[a-zA-Z]:';
14my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
15my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
16
17
270d1e39
GS
18=head1 NAME
19
20File::Spec::Win32 - methods for Win32 file specs
21
22=head1 SYNOPSIS
23
cbc7acb0 24 require File::Spec::Win32; # Done internally by File::Spec if needed
270d1e39
GS
25
26=head1 DESCRIPTION
27
28See File::Spec::Unix for a documentation of the methods provided
29there. This package overrides the implementation of these methods, not
30the semantics.
31
bbc7dcd2 32=over 4
270d1e39 33
cbc7acb0 34=item devnull
270d1e39 35
cbc7acb0 36Returns a string representation of the null device.
270d1e39 37
cbc7acb0 38=cut
270d1e39 39
cbc7acb0
JD
40sub devnull {
41 return "nul";
42}
270d1e39 43
60598624
RGS
44sub rootdir () { '\\' }
45
46
cbc7acb0 47=item tmpdir
270d1e39 48
cbc7acb0
JD
49Returns a string representation of the first existing directory
50from the following list:
270d1e39 51
cbc7acb0
JD
52 $ENV{TMPDIR}
53 $ENV{TEMP}
54 $ENV{TMP}
dd9bbc5b 55 SYS:/temp
27da23d5 56 C:\system\temp
28747828 57 C:/temp
cbc7acb0
JD
58 /tmp
59 /
60
27da23d5
JH
61The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
62for Symbian (the File::Spec::Win32 is used also for those platforms).
dd9bbc5b
JH
63
64Since Perl 5.8.0, if running under taint mode, and if the environment
a384e9e1
RGS
65variables are tainted, they are not used.
66
cbc7acb0 67=cut
270d1e39 68
cbc7acb0
JD
69my $tmpdir;
70sub tmpdir {
71 return $tmpdir if defined $tmpdir;
9d5071ba 72 $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
07824bd1 73 'SYS:/temp',
27da23d5 74 'C:\system\temp',
07824bd1
JH
75 'C:/temp',
76 '/tmp',
77 '/' );
cbc7acb0
JD
78}
79
46726cbe
CB
80sub case_tolerant {
81 return 1;
82}
83
cbc7acb0
JD
84sub file_name_is_absolute {
85 my ($self,$file) = @_;
110c90cc
SP
86 return $file =~ m{^$VOL_RX}os ? 2 :
87 $file =~ m{^[\\/]}is ? 1 :
88 0;
270d1e39
GS
89}
90
91=item catfile
92
93Concatenate one or more directory names and a filename to form a
94complete path ending with a filename
95
96=cut
97
98sub catfile {
cbc7acb0 99 my $self = shift;
02961b52 100 my $file = $self->canonpath(pop @_);
270d1e39
GS
101 return $file unless @_;
102 my $dir = $self->catdir(@_);
cbc7acb0 103 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
104 return $dir.$file;
105}
106
638113eb
JH
107sub catdir {
108 my $self = shift;
109 my @args = @_;
110 foreach (@args) {
111 tr[/][\\];
112 # append a backslash to each argument unless it has one there
113 $_ .= "\\" unless m{\\$};
114 }
115 return $self->canonpath(join('', @args));
116}
117
270d1e39 118sub path {
092026cf
SH
119 my @path = split(';', $ENV{PATH});
120 s/"//g for @path;
121 @path = grep length, @path;
122 unshift(@path, ".");
cbc7acb0 123 return @path;
270d1e39
GS
124}
125
126=item canonpath
127
128No physical check on the filesystem, but a logical cleanup of a
129path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
130On Win32 makes
131
132 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
133 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
134
135=cut
136
137sub canonpath {
0994714a 138 my ($self,$path) = @_;
9596c75c 139
1b1e14d3 140 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 141 $path =~ s|/|\\|g;
ecf68df6
DR
142 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
143 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
144 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 145 $path =~ s|\\\Z(?!\n)||
e021ab8e
JH
146 unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
147 # xx1/xx2/xx3/../../xx -> xx1/xx
148 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
149 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
150 return $path if $path =~ m|^\.\.|; # skip relative paths
151 return $path unless $path =~ /\.\./; # too few .'s to cleanup
152 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
638113eb 153 $path =~ s{^\\\.\.$}{\\}; # \.. -> \
e021ab8e
JH
154 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
155
9596c75c 156 return $self->_collapse($path);
270d1e39
GS
157}
158
c27914c9
BS
159=item splitpath
160
161 ($volume,$directories,$file) = File::Spec->splitpath( $path );
162 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
163
40d020d9 164Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
165the last file is a path unless the path ends in '\\', '\\.', '\\..'
166or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 167( $volume, $path, '' ).
c27914c9
BS
168
169Separators accepted are \ and /.
170
171Volumes can be drive letters or UNC sharenames (\\server\share).
172
0994714a 173The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
174(usually identical to) the original path.
175
176=cut
177
178sub splitpath {
179 my ($self,$path, $nofile) = @_;
180 my ($volume,$directory,$file) = ('','','');
181 if ( $nofile ) {
182 $path =~
110c90cc 183 m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9
BS
184 $volume = $1;
185 $directory = $2;
186 }
187 else {
188 $path =~
110c90cc 189 m{^ ( $VOL_RX ? )
5b287435 190 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 191 (.*)
110c90cc 192 }sox;
c27914c9
BS
193 $volume = $1;
194 $directory = $2;
195 $file = $3;
196 }
197
198 return ($volume,$directory,$file);
199}
200
201
202=item splitdir
203
59605c55 204The opposite of L<catdir()|File::Spec/catdir()>.
c27914c9
BS
205
206 @dirs = File::Spec->splitdir( $directories );
207
208$directories must be only the directory portion of the path on systems
209that have the concept of a volume or that have path syntax that differentiates
210files from directories.
211
212Unlike just splitting the directories on the separator, leading empty and
213trailing directory entries can be returned, because these are significant
214on some OSs. So,
215
216 File::Spec->splitdir( "/a/b/c" );
217
218Yields:
219
220 ( '', 'a', 'b', '', 'c', '' )
221
222=cut
223
224sub splitdir {
225 my ($self,$directories) = @_ ;
226 #
227 # split() likes to forget about trailing null fields, so here we
228 # check to be sure that there will not be any before handling the
229 # simple case.
230 #
9c045eb2 231 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
232 return split( m|[\\/]|, $directories );
233 }
234 else {
235 #
236 # since there was a trailing separator, add a file name to the end,
237 # then do the split, then replace it with ''.
238 #
239 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
240 $directories[ $#directories ]= '' ;
241 return @directories ;
242 }
243}
244
245
246=item catpath
247
248Takes volume, directory and file portions and returns an entire path. Under
249Unix, $volume is ignored, and this is just like catfile(). On other OSs,
250the $volume become significant.
251
252=cut
253
254sub catpath {
255 my ($self,$volume,$directory,$file) = @_;
256
257 # If it's UNC, make sure the glue separator is there, reusing
258 # whatever separator is first in the $volume
9596c75c
RGS
259 my $v;
260 $volume .= $v
261 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3 262 $directory =~ m@^[^\\/]@s
c27914c9
BS
263 ) ;
264
265 $volume .= $directory ;
266
267 # If the volume is not just A:, make sure the glue separator is
268 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
269 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
270 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 271 $file =~ m@[^\\/]@
c27914c9
BS
272 ) {
273 $volume =~ m@([\\/])@ ;
274 my $sep = $1 ? $1 : '\\' ;
275 $volume .= $sep ;
276 }
277
278 $volume .= $file ;
279
280 return $volume ;
281}
282
9d5071ba
SP
283sub _same {
284 lc($_[1]) eq lc($_[2]);
c27914c9
BS
285}
286
786b702f 287sub rel2abs {
c27914c9
BS
288 my ($self,$path,$base ) = @_;
289
110c90cc
SP
290 my $is_abs = $self->file_name_is_absolute($path);
291
292 # Check for volume (should probably document the '2' thing...)
293 return $self->canonpath( $path ) if $is_abs == 2;
294
295 if ($is_abs) {
296 # It's missing a volume, add one
297 my $vol = ($self->splitpath( $self->_cwd() ))[0];
298 return $self->canonpath( $vol . $path );
299 }
300
301 if ( !defined( $base ) || $base eq '' ) {
302 require Cwd ;
303 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
304 $base = $self->_cwd() unless defined $base ;
c27914c9 305 }
110c90cc
SP
306 elsif ( ! $self->file_name_is_absolute( $base ) ) {
307 $base = $self->rel2abs( $base ) ;
308 }
309 else {
310 $base = $self->canonpath( $base ) ;
311 }
312
313 my ( $path_directories, $path_file ) =
314 ($self->splitpath( $path, 1 ))[1,2] ;
315
316 my ( $base_volume, $base_directories ) =
317 $self->splitpath( $base, 1 ) ;
318
319 $path = $self->catpath(
320 $base_volume,
321 $self->catdir( $base_directories, $path_directories ),
322 $path_file
323 ) ;
c27914c9
BS
324
325 return $self->canonpath( $path ) ;
326}
327
270d1e39
GS
328=back
329
dd9bbc5b
JH
330=head2 Note For File::Spec::Win32 Maintainers
331
332Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
333
99f36a73
RGS
334=head1 COPYRIGHT
335
336Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
337
338This program is free software; you can redistribute it and/or modify
339it under the same terms as Perl itself.
340
cbc7acb0
JD
341=head1 SEE ALSO
342
72f15715
T
343See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
344implementation of these methods, not the semantics.
270d1e39 345
cbc7acb0
JD
346=cut
347
3481;