This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Pod::LaTeX 0.58
[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
5b287435 8$VERSION = '1.5';
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
07824bd1
JH
51The SYS:/temp is preferred in Novell NetWare (the File::Spec::Win32
52is used also for NetWare).
dd9bbc5b
JH
53
54Since Perl 5.8.0, if running under taint mode, and if the environment
a384e9e1
RGS
55variables are tainted, they are not used.
56
cbc7acb0 57=cut
270d1e39 58
cbc7acb0
JD
59my $tmpdir;
60sub tmpdir {
61 return $tmpdir if defined $tmpdir;
270d1e39 62 my $self = shift;
07824bd1
JH
63 $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
64 'SYS:/temp',
65 'C:/temp',
66 '/tmp',
67 '/' );
cbc7acb0
JD
68}
69
46726cbe
CB
70sub case_tolerant {
71 return 1;
72}
73
cbc7acb0
JD
74sub file_name_is_absolute {
75 my ($self,$file) = @_;
1b1e14d3 76 return scalar($file =~ m{^([a-z]:)?[\\/]}is);
270d1e39
GS
77}
78
79=item catfile
80
81Concatenate one or more directory names and a filename to form a
82complete path ending with a filename
83
84=cut
85
86sub catfile {
cbc7acb0 87 my $self = shift;
02961b52 88 my $file = $self->canonpath(pop @_);
270d1e39
GS
89 return $file unless @_;
90 my $dir = $self->catdir(@_);
cbc7acb0 91 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
92 return $dir.$file;
93}
94
638113eb
JH
95sub catdir {
96 my $self = shift;
97 my @args = @_;
98 foreach (@args) {
99 tr[/][\\];
100 # append a backslash to each argument unless it has one there
101 $_ .= "\\" unless m{\\$};
102 }
103 return $self->canonpath(join('', @args));
104}
105
270d1e39 106sub path {
270d1e39
GS
107 my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
108 my @path = split(';',$path);
cbc7acb0
JD
109 foreach (@path) { $_ = '.' if $_ eq '' }
110 return @path;
270d1e39
GS
111}
112
113=item canonpath
114
115No physical check on the filesystem, but a logical cleanup of a
116path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
117On Win32 makes
118
119 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
120 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
121
122=cut
123
124sub canonpath {
0994714a 125 my ($self,$path) = @_;
cc23144f 126 my $orig_path = $path;
1b1e14d3 127 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 128 $path =~ s|/|\\|g;
ecf68df6
DR
129 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
130 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
131 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 132 $path =~ s|\\\Z(?!\n)||
e021ab8e
JH
133 unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
134 # xx1/xx2/xx3/../../xx -> xx1/xx
135 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
136 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
137 return $path if $path =~ m|^\.\.|; # skip relative paths
138 return $path unless $path =~ /\.\./; # too few .'s to cleanup
139 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
638113eb 140 $path =~ s{^\\\.\.$}{\\}; # \.. -> \
e021ab8e
JH
141 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
142
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;
cc23144f 157 }
e021ab8e
JH
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 )
5b287435 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) = @_;
0fab864c 299 $base = $self->_cwd() unless defined $base and length $base;
c27914c9 300
638113eb 301 for ($path, $base) { $_ = $self->canonpath($_) }
c27914c9 302
638113eb
JH
303 my ($path_volume) = $self->splitpath($path, 1);
304 my ($base_volume) = $self->splitpath($base, 1);
c27914c9 305
e021ab8e
JH
306 # Can't relativize across volumes
307 return $path unless $path_volume eq $base_volume;
c27914c9 308
638113eb
JH
309 for ($path, $base) { $_ = $self->rel2abs($_) }
310
311 my $path_directories = ($self->splitpath($path, 1))[1];
312 my $base_directories = ($self->splitpath($base, 1))[1];
313
c27914c9
BS
314 # Now, remove all leading components that are the same
315 my @pathchunks = $self->splitdir( $path_directories );
316 my @basechunks = $self->splitdir( $base_directories );
317
318 while ( @pathchunks &&
319 @basechunks &&
320 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
321 ) {
322 shift @pathchunks ;
323 shift @basechunks ;
324 }
325
e021ab8e 326 my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
c27914c9 327
e021ab8e 328 return $self->canonpath( $self->catpath('', $result_dirs, '') );
c27914c9
BS
329}
330
c27914c9 331
786b702f 332sub rel2abs {
c27914c9
BS
333 my ($self,$path,$base ) = @_;
334
c27914c9
BS
335 if ( ! $self->file_name_is_absolute( $path ) ) {
336
1d7cb664 337 if ( !defined( $base ) || $base eq '' ) {
5b287435
RGS
338 require Cwd ;
339 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
340 $base = $self->_cwd() unless defined $base ;
c27914c9 341 }
1d7cb664
GS
342 elsif ( ! $self->file_name_is_absolute( $base ) ) {
343 $base = $self->rel2abs( $base ) ;
344 }
c27914c9
BS
345 else {
346 $base = $self->canonpath( $base ) ;
347 }
348
9c045eb2
GS
349 my ( $path_directories, $path_file ) =
350 ($self->splitpath( $path, 1 ))[1,2] ;
c27914c9 351
9c045eb2 352 my ( $base_volume, $base_directories ) =
c27914c9
BS
353 $self->splitpath( $base, 1 ) ;
354
355 $path = $self->catpath(
356 $base_volume,
357 $self->catdir( $base_directories, $path_directories ),
358 $path_file
359 ) ;
360 }
361
362 return $self->canonpath( $path ) ;
363}
364
270d1e39
GS
365=back
366
dd9bbc5b
JH
367=head2 Note For File::Spec::Win32 Maintainers
368
369Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
370
cbc7acb0
JD
371=head1 SEE ALSO
372
72f15715
T
373See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
374implementation of these methods, not the semantics.
270d1e39 375
cbc7acb0
JD
376=cut
377
3781;