This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't bother generating the "Operation \"%s\": no method found..."
[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
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;
9d5071ba 66 $tmpdir = $_[0]->_tmpdir( map( $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 {
092026cf
SH
111 my @path = split(';', $ENV{PATH});
112 s/"//g for @path;
113 @path = grep length, @path;
114 unshift(@path, ".");
cbc7acb0 115 return @path;
270d1e39
GS
116}
117
118=item canonpath
119
120No physical check on the filesystem, but a logical cleanup of a
121path. On UNIX eliminated successive slashes and successive "/.".
cc23144f
IS
122On Win32 makes
123
124 dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
125 dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39
GS
126
127=cut
128
129sub canonpath {
0994714a 130 my ($self,$path) = @_;
9596c75c 131
1b1e14d3 132 $path =~ s/^([a-z]:)/\u$1/s;
270d1e39 133 $path =~ s|/|\\|g;
ecf68df6
DR
134 $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
135 $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
136 $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
9c045eb2 137 $path =~ s|\\\Z(?!\n)||
e021ab8e
JH
138 unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
139 # xx1/xx2/xx3/../../xx -> xx1/xx
140 $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
141 $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
142 return $path if $path =~ m|^\.\.|; # skip relative paths
143 return $path unless $path =~ /\.\./; # too few .'s to cleanup
144 return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
638113eb 145 $path =~ s{^\\\.\.$}{\\}; # \.. -> \
e021ab8e
JH
146 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
147
9596c75c 148 return $self->_collapse($path);
270d1e39
GS
149}
150
c27914c9
BS
151=item splitpath
152
153 ($volume,$directories,$file) = File::Spec->splitpath( $path );
154 ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
155
40d020d9 156Splits a path into volume, directory, and filename portions. Assumes that
c27914c9
BS
157the last file is a path unless the path ends in '\\', '\\.', '\\..'
158or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9 159( $volume, $path, '' ).
c27914c9
BS
160
161Separators accepted are \ and /.
162
163Volumes can be drive letters or UNC sharenames (\\server\share).
164
0994714a 165The results can be passed to L</catpath> to get back a path equivalent to
c27914c9
BS
166(usually identical to) the original path.
167
168=cut
169
170sub splitpath {
171 my ($self,$path, $nofile) = @_;
172 my ($volume,$directory,$file) = ('','','');
173 if ( $nofile ) {
174 $path =~
0994714a 175 m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
c27914c9 176 (.*)
1b1e14d3 177 }xs;
c27914c9
BS
178 $volume = $1;
179 $directory = $2;
180 }
181 else {
182 $path =~
0994714a
GS
183 m{^ ( (?: [a-zA-Z]: |
184 (?:\\\\|//)[^\\/]+[\\/][^\\/]+
c27914c9
BS
185 )?
186 )
5b287435 187 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9 188 (.*)
1b1e14d3 189 }xs;
c27914c9
BS
190 $volume = $1;
191 $directory = $2;
192 $file = $3;
193 }
194
195 return ($volume,$directory,$file);
196}
197
198
199=item splitdir
200
59605c55 201The opposite of L<catdir()|File::Spec/catdir()>.
c27914c9
BS
202
203 @dirs = File::Spec->splitdir( $directories );
204
205$directories must be only the directory portion of the path on systems
206that have the concept of a volume or that have path syntax that differentiates
207files from directories.
208
209Unlike just splitting the directories on the separator, leading empty and
210trailing directory entries can be returned, because these are significant
211on some OSs. So,
212
213 File::Spec->splitdir( "/a/b/c" );
214
215Yields:
216
217 ( '', 'a', 'b', '', 'c', '' )
218
219=cut
220
221sub splitdir {
222 my ($self,$directories) = @_ ;
223 #
224 # split() likes to forget about trailing null fields, so here we
225 # check to be sure that there will not be any before handling the
226 # simple case.
227 #
9c045eb2 228 if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
c27914c9
BS
229 return split( m|[\\/]|, $directories );
230 }
231 else {
232 #
233 # since there was a trailing separator, add a file name to the end,
234 # then do the split, then replace it with ''.
235 #
236 my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
237 $directories[ $#directories ]= '' ;
238 return @directories ;
239 }
240}
241
242
243=item catpath
244
245Takes volume, directory and file portions and returns an entire path. Under
246Unix, $volume is ignored, and this is just like catfile(). On other OSs,
247the $volume become significant.
248
249=cut
250
251sub catpath {
252 my ($self,$volume,$directory,$file) = @_;
253
254 # If it's UNC, make sure the glue separator is there, reusing
255 # whatever separator is first in the $volume
9596c75c
RGS
256 my $v;
257 $volume .= $v
258 if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3 259 $directory =~ m@^[^\\/]@s
c27914c9
BS
260 ) ;
261
262 $volume .= $directory ;
263
264 # If the volume is not just A:, make sure the glue separator is
265 # there, reusing whatever separator is first in the $volume if possible.
9c045eb2
GS
266 if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
267 $volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a 268 $file =~ m@[^\\/]@
c27914c9
BS
269 ) {
270 $volume =~ m@([\\/])@ ;
271 my $sep = $1 ? $1 : '\\' ;
272 $volume .= $sep ;
273 }
274
275 $volume .= $file ;
276
277 return $volume ;
278}
279
9d5071ba
SP
280sub _same {
281 lc($_[1]) eq lc($_[2]);
c27914c9
BS
282}
283
786b702f 284sub rel2abs {
c27914c9
BS
285 my ($self,$path,$base ) = @_;
286
c27914c9
BS
287 if ( ! $self->file_name_is_absolute( $path ) ) {
288
1d7cb664 289 if ( !defined( $base ) || $base eq '' ) {
5b287435
RGS
290 require Cwd ;
291 $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
292 $base = $self->_cwd() unless defined $base ;
c27914c9 293 }
1d7cb664
GS
294 elsif ( ! $self->file_name_is_absolute( $base ) ) {
295 $base = $self->rel2abs( $base ) ;
296 }
c27914c9
BS
297 else {
298 $base = $self->canonpath( $base ) ;
299 }
300
9c045eb2
GS
301 my ( $path_directories, $path_file ) =
302 ($self->splitpath( $path, 1 ))[1,2] ;
c27914c9 303
9c045eb2 304 my ( $base_volume, $base_directories ) =
c27914c9
BS
305 $self->splitpath( $base, 1 ) ;
306
307 $path = $self->catpath(
308 $base_volume,
309 $self->catdir( $base_directories, $path_directories ),
310 $path_file
311 ) ;
312 }
313
314 return $self->canonpath( $path ) ;
315}
316
270d1e39
GS
317=back
318
dd9bbc5b
JH
319=head2 Note For File::Spec::Win32 Maintainers
320
321Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
322
99f36a73
RGS
323=head1 COPYRIGHT
324
325Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
326
327This program is free software; you can redistribute it and/or modify
328it under the same terms as Perl itself.
329
cbc7acb0
JD
330=head1 SEE ALSO
331
72f15715
T
332See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
333implementation of these methods, not the semantics.
270d1e39 334
cbc7acb0
JD
335=cut
336
3371;