This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
POSIX taint tests
[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}
28747828 46 C:/temp
cbc7acb0
JD
47 /tmp
48 /
49
a384e9e1
RGS
50Since perl 5.8.0, if running under taint mode, and if the environment
51variables are tainted, they are not used.
52
cbc7acb0 53=cut
270d1e39 54
cbc7acb0
JD
55my $tmpdir;
56sub tmpdir {
57 return $tmpdir if defined $tmpdir;
270d1e39 58 my $self = shift;
a384e9e1
RGS
59 my @dirlist = (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /));
60 {
61 no strict 'refs';
62 if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
63 require Scalar::Util;
64 @dirlist = grep { ! Scalar::Util::tainted $_ } @dirlist;
65 }
66 }
67 foreach (@dirlist) {
cbc7acb0
JD
68 next unless defined && -d;
69 $tmpdir = $_;
70 last;
270d1e39 71 }
cbc7acb0
JD
72 $tmpdir = '' unless defined $tmpdir;
73 $tmpdir = $self->canonpath($tmpdir);
74 return $tmpdir;
75}
76
46726cbe
CB
77sub case_tolerant {
78 return 1;
79}
80
cbc7acb0
JD
81sub file_name_is_absolute {
82 my ($self,$file) = @_;
1b1e14d3 83 return scalar($file =~ m{^([a-z]:)?[\\/]}is);
270d1e39
GS
84}
85
86=item catfile
87
88Concatenate one or more directory names and a filename to form a
89complete path ending with a filename
90
91=cut
92
93sub catfile {
cbc7acb0 94 my $self = shift;
270d1e39
GS
95 my $file = pop @_;
96 return $file unless @_;
97 my $dir = $self->catdir(@_);
cbc7acb0 98 $dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39
GS
99 return $dir.$file;
100}
101
102sub path {
270d1e39
GS
103 my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
104 my @path = split(';',$path);
cbc7acb0
JD
105 foreach (@path) { $_ = '.' if $_ eq '' }
106 return @path;
270d1e39
GS
107}
108
109=item canonpath
110
111No physical check on the filesystem, but a logical cleanup of a
112path. On UNIX eliminated successive slashes and successive "/.".
113
114=cut
115
116sub canonpath {
0994714a 117 my ($self,$path) = @_;
1b1e14d3 118 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 119 $path =~ s|/|\\|g;
ecf68df6
DR
120 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
121 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
122 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 123 $path =~ s|\\\Z(?!\n)||
ecf68df6 124 unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx\ -> xx
cbc7acb0 125 return $path;
270d1e39
GS
126}
127
c27914c9
BS
128=item splitpath
129
130 ($volume,$directories,$file) = File::Spec->splitpath( $path );
131 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
132
133Splits a path in to volume, directory, and filename portions. Assumes that
134the last file is a path unless the path ends in '\\', '\\.', '\\..'
135or $no_file is true. On Win32 this means that $no_file true makes this return
136( $volume, $path, undef ).
137
138Separators accepted are \ and /.
139
140Volumes can be drive letters or UNC sharenames (\\server\share).
141
0994714a 142The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
143(usually identical to) the original path.
144
145=cut
146
147sub splitpath {
148 my ($self,$path, $nofile) = @_;
149 my ($volume,$directory,$file) = ('','','');
150 if ( $nofile ) {
151 $path =~
0994714a 152 m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
c27914c9 153 (.*)
1b1e14d3 154 }xs;
c27914c9
BS
155 $volume = $1;
156 $directory = $2;
157 }
158 else {
159 $path =~
0994714a
GS
160 m{^ ( (?: [a-zA-Z]: |
161 (?:\\\\|//)[^\\/]+[\\/][^\\/]+
c27914c9
BS
162 )?
163 )
9c045eb2 164 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 165 (.*)
1b1e14d3 166 }xs;
c27914c9
BS
167 $volume = $1;
168 $directory = $2;
169 $file = $3;
170 }
171
172 return ($volume,$directory,$file);
173}
174
175
176=item splitdir
177
59605c55 178The opposite of L<catdir()|File::Spec/catdir()>.
c27914c9
BS
179
180 @dirs = File::Spec->splitdir( $directories );
181
182$directories must be only the directory portion of the path on systems
183that have the concept of a volume or that have path syntax that differentiates
184files from directories.
185
186Unlike just splitting the directories on the separator, leading empty and
187trailing directory entries can be returned, because these are significant
188on some OSs. So,
189
190 File::Spec->splitdir( "/a/b/c" );
191
192Yields:
193
194 ( '', 'a', 'b', '', 'c', '' )
195
196=cut
197
198sub splitdir {
199 my ($self,$directories) = @_ ;
200 #
201 # split() likes to forget about trailing null fields, so here we
202 # check to be sure that there will not be any before handling the
203 # simple case.
204 #
9c045eb2 205 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
206 return split( m|[\\/]|, $directories );
207 }
208 else {
209 #
210 # since there was a trailing separator, add a file name to the end,
211 # then do the split, then replace it with ''.
212 #
213 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
214 $directories[ $#directories ]= '' ;
215 return @directories ;
216 }
217}
218
219
220=item catpath
221
222Takes volume, directory and file portions and returns an entire path. Under
223Unix, $volume is ignored, and this is just like catfile(). On other OSs,
224the $volume become significant.
225
226=cut
227
228sub catpath {
229 my ($self,$volume,$directory,$file) = @_;
230
231 # If it's UNC, make sure the glue separator is there, reusing
232 # whatever separator is first in the $volume
233 $volume .= $1
9c045eb2 234 if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
1b1e14d3 235 $directory =~ m@^[^\\/]@s
c27914c9
BS
236 ) ;
237
238 $volume .= $directory ;
239
240 # If the volume is not just A:, make sure the glue separator is
241 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
242 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
243 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 244 $file =~ m@[^\\/]@
c27914c9
BS
245 ) {
246 $volume =~ m@([\\/])@ ;
247 my $sep = $1 ? $1 : '\\' ;
248 $volume .= $sep ;
249 }
250
251 $volume .= $file ;
252
253 return $volume ;
254}
255
256
c27914c9
BS
257sub abs2rel {
258 my($self,$path,$base) = @_;
259
260 # Clean up $path
261 if ( ! $self->file_name_is_absolute( $path ) ) {
262 $path = $self->rel2abs( $path ) ;
263 }
264 else {
265 $path = $self->canonpath( $path ) ;
266 }
267
268 # Figure out the effective $base and clean it up.
9c1370fb 269 if ( !defined( $base ) || $base eq '' ) {
c27914c9
BS
270 $base = cwd() ;
271 }
9c1370fb
NK
272 elsif ( ! $self->file_name_is_absolute( $base ) ) {
273 $base = $self->rel2abs( $base ) ;
274 }
c27914c9
BS
275 else {
276 $base = $self->canonpath( $base ) ;
277 }
278
279 # Split up paths
9b1c7707 280 my ( undef, $path_directories, $path_file ) =
c27914c9
BS
281 $self->splitpath( $path, 1 ) ;
282
9c045eb2 283 my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
c27914c9
BS
284
285 # Now, remove all leading components that are the same
286 my @pathchunks = $self->splitdir( $path_directories );
287 my @basechunks = $self->splitdir( $base_directories );
288
289 while ( @pathchunks &&
290 @basechunks &&
291 lc( $pathchunks[0] ) eq lc( $basechunks[0] )
292 ) {
293 shift @pathchunks ;
294 shift @basechunks ;
295 }
296
297 # No need to catdir, we know these are well formed.
298 $path_directories = CORE::join( '\\', @pathchunks );
299 $base_directories = CORE::join( '\\', @basechunks );
300
5cefc38b
GS
301 # $base_directories now contains the directories the resulting relative
302 # path must ascend out of before it can descend to $path_directory. So,
c27914c9 303 # replace all names with $parentDir
5cefc38b
GS
304
305 #FA Need to replace between backslashes...
306 $base_directories =~ s|[^\\]+|..|g ;
c27914c9
BS
307
308 # Glue the two together, using a separator if necessary, and preventing an
309 # empty result.
5cefc38b
GS
310
311 #FA Must check that new directories are not empty.
312 if ( $path_directories ne '' && $base_directories ne '' ) {
c27914c9
BS
313 $path_directories = "$base_directories\\$path_directories" ;
314 } else {
315 $path_directories = "$base_directories$path_directories" ;
316 }
317
318 return $self->canonpath(
9b1c7707 319 $self->catpath( "", $path_directories, $path_file )
c27914c9
BS
320 ) ;
321}
322
c27914c9 323
786b702f 324sub rel2abs {
c27914c9
BS
325 my ($self,$path,$base ) = @_;
326
c27914c9
BS
327 if ( ! $self->file_name_is_absolute( $path ) ) {
328
1d7cb664 329 if ( !defined( $base ) || $base eq '' ) {
c27914c9
BS
330 $base = cwd() ;
331 }
1d7cb664
GS
332 elsif ( ! $self->file_name_is_absolute( $base ) ) {
333 $base = $self->rel2abs( $base ) ;
334 }
c27914c9
BS
335 else {
336 $base = $self->canonpath( $base ) ;
337 }
338
9c045eb2
GS
339 my ( $path_directories, $path_file ) =
340 ($self->splitpath( $path, 1 ))[1,2] ;
c27914c9 341
9c045eb2 342 my ( $base_volume, $base_directories ) =
c27914c9
BS
343 $self->splitpath( $base, 1 ) ;
344
345 $path = $self->catpath(
346 $base_volume,
347 $self->catdir( $base_directories, $path_directories ),
348 $path_file
349 ) ;
350 }
351
352 return $self->canonpath( $path ) ;
353}
354
270d1e39
GS
355=back
356
cbc7acb0
JD
357=head1 SEE ALSO
358
359L<File::Spec>
270d1e39 360
cbc7acb0
JD
361=cut
362
3631;