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