This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
grrr.
[perl5.git] / lib / File / Spec / Mac.pm
CommitLineData
270d1e39
GS
1package File::Spec::Mac;
2
270d1e39 3use strict;
b4296952 4use vars qw(@ISA $VERSION);
cbc7acb0 5require File::Spec::Unix;
b4296952 6
3c32ced9 7$VERSION = '1.2';
b4296952 8
270d1e39 9@ISA = qw(File::Spec::Unix);
270d1e39
GS
10
11=head1 NAME
12
13File::Spec::Mac - File::Spec for MacOS
14
15=head1 SYNOPSIS
16
cbc7acb0 17 require File::Spec::Mac; # Done internally by File::Spec if needed
270d1e39
GS
18
19=head1 DESCRIPTION
20
21Methods for manipulating file specifications.
22
23=head1 METHODS
24
25=over 2
26
27=item canonpath
28
29On MacOS, there's nothing to be done. Returns what it's given.
30
31=cut
32
33sub canonpath {
cbc7acb0
JD
34 my ($self,$path) = @_;
35 return $path;
270d1e39
GS
36}
37
38=item catdir
39
40Concatenate two or more directory names to form a complete path ending with
41a directory. Put a trailing : on the end of the complete path if there
42isn't one, because that's what's done in MacPerl's environment.
43
44The fundamental requirement of this routine is that
45
46 File::Spec->catdir(split(":",$path)) eq $path
47
48But because of the nature of Macintosh paths, some additional
8dcee03e 49possibilities are allowed to make using this routine give reasonable results
270d1e39
GS
50for some common situations. Here are the rules that are used. Each
51argument has its trailing ":" removed. Each argument, except the first,
52has its leading ":" removed. They are then joined together by a ":".
53
54So
55
56 File::Spec->catdir("a","b") = "a:b:"
57 File::Spec->catdir("a:",":b") = "a:b:"
58 File::Spec->catdir("a:","b") = "a:b:"
59 File::Spec->catdir("a",":b") = "a:b"
60 File::Spec->catdir("a","","b") = "a::b"
61
62etc.
63
64To get a relative path (one beginning with :), begin the first argument with :
65or put a "" as the first argument.
66
67If you don't want to worry about these rules, never allow a ":" on the ends
68of any of the arguments except at the beginning of the first.
69
70Under MacPerl, there is an additional ambiguity. Does the user intend that
71
72 File::Spec->catfile("LWP","Protocol","http.pm")
73
74be relative or absolute? There's no way of telling except by checking for the
8dcee03e 75existence of LWP: or :LWP, and even there he may mean a dismounted volume or
270d1e39
GS
76a relative path in a different directory (like in @INC). So those checks
77aren't done here. This routine will treat this as absolute.
78
79=cut
80
270d1e39
GS
81sub catdir {
82 shift;
83 my @args = @_;
cbc7acb0 84 my $result = shift @args;
9c045eb2 85 $result =~ s/:\Z(?!\n)//;
cbc7acb0 86 foreach (@args) {
9c045eb2 87 s/:\Z(?!\n)//;
1b1e14d3 88 s/^://s;
cbc7acb0 89 $result .= ":$_";
270d1e39 90 }
cbc7acb0 91 return "$result:";
270d1e39
GS
92}
93
94=item catfile
95
96Concatenate one or more directory names and a filename to form a
97complete path ending with a filename. Since this uses catdir, the
98same caveats apply. Note that the leading : is removed from the filename,
99so that
100
101 File::Spec->catfile($ENV{HOME},"file");
102
103and
104
105 File::Spec->catfile($ENV{HOME},":file");
106
107give the same answer, as one might expect.
108
109=cut
110
111sub catfile {
cbc7acb0 112 my $self = shift;
270d1e39
GS
113 my $file = pop @_;
114 return $file unless @_;
115 my $dir = $self->catdir(@_);
1b1e14d3 116 $file =~ s/^://s;
270d1e39
GS
117 return $dir.$file;
118}
119
120=item curdir
121
cbc7acb0 122Returns a string representing the current directory.
270d1e39
GS
123
124=cut
125
126sub curdir {
cbc7acb0
JD
127 return ":";
128}
129
130=item devnull
131
132Returns a string representing the null device.
133
134=cut
135
136sub devnull {
137 return "Dev:Null";
270d1e39
GS
138}
139
140=item rootdir
141
142Returns a string representing the root directory. Under MacPerl,
143returns the name of the startup volume, since that's the closest in
cbc7acb0 144concept, although other volumes aren't rooted there.
270d1e39
GS
145
146=cut
147
148sub rootdir {
149#
cbc7acb0
JD
150# There's no real root directory on MacOS. The name of the startup
151# volume is returned, since that's the closest in concept.
270d1e39 152#
cbc7acb0
JD
153 require Mac::Files;
154 my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
155 &Mac::Files::kSystemFolderType);
9c045eb2 156 $system =~ s/:.*\Z(?!\n)/:/s;
cbc7acb0
JD
157 return $system;
158}
159
160=item tmpdir
161
162Returns a string representation of the first existing directory
163from the following list or '' if none exist:
164
165 $ENV{TMPDIR}
166
167=cut
168
169my $tmpdir;
170sub tmpdir {
171 return $tmpdir if defined $tmpdir;
172 $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR};
173 $tmpdir = '' unless defined $tmpdir;
174 return $tmpdir;
270d1e39
GS
175}
176
177=item updir
178
179Returns a string representing the parent directory.
180
181=cut
182
183sub updir {
184 return "::";
185}
186
187=item file_name_is_absolute
188
189Takes as argument a path and returns true, if it is an absolute path. In
190the case where a name can be either relative or absolute (for example, a
191folder named "HD" in the current working directory on a drive named "HD"),
192relative wins. Use ":" in the appropriate place in the path if you want to
193distinguish unambiguously.
194
3c32ced9
BS
195As a special case, the file name '' is always considered to be absolute.
196
270d1e39
GS
197=cut
198
199sub file_name_is_absolute {
cbc7acb0
JD
200 my ($self,$file) = @_;
201 if ($file =~ /:/) {
1b1e14d3 202 return ($file !~ m/^:/s);
3c32ced9
BS
203 } elsif ( $file eq '' ) {
204 return 1 ;
cbc7acb0
JD
205 } else {
206 return (! -e ":$file");
270d1e39
GS
207 }
208}
209
210=item path
211
212Returns the null list for the MacPerl application, since the concept is
213usually meaningless under MacOS. But if you're using the MacPerl tool under
214MPW, it gives back $ENV{Commands} suitably split, as is done in
215:lib:ExtUtils:MM_Mac.pm.
216
217=cut
218
219sub path {
220#
221# The concept is meaningless under the MacPerl application.
222# Under MPW, it has a meaning.
223#
cbc7acb0
JD
224 return unless exists $ENV{Commands};
225 return split(/,/, $ENV{Commands});
270d1e39
GS
226}
227
0994714a
GS
228=item splitpath
229
230=cut
231
232sub splitpath {
233 my ($self,$path, $nofile) = @_;
234
235 my ($volume,$directory,$file) = ('','','');
236
237 if ( $nofile ) {
9c045eb2 238 ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\Z(?!\n)))?)(.*)@s;
0994714a
GS
239 }
240 else {
241 $path =~
242 m@^( (?: [^:]+: )? )
243 ( (?: .*: )? )
244 ( .* )
1b1e14d3 245 @xs;
0994714a
GS
246 $volume = $1;
247 $directory = $2;
248 $file = $3;
249 }
250
251 # Make sure non-empty volumes and directories end in ':'
9c045eb2
GS
252 $volume .= ':' if $volume =~ m@[^:]\Z(?!\n)@ ;
253 $directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ;
0994714a
GS
254 return ($volume,$directory,$file);
255}
256
257
258=item splitdir
259
260=cut
261
262sub splitdir {
263 my ($self,$directories) = @_ ;
264 #
265 # split() likes to forget about trailing null fields, so here we
266 # check to be sure that there will not be any before handling the
267 # simple case.
268 #
9c045eb2 269 if ( $directories !~ m@:\Z(?!\n)@ ) {
0994714a
GS
270 return split( m@:@, $directories );
271 }
272 else {
273 #
274 # since there was a trailing separator, add a file name to the end,
275 # then do the split, then replace it with ''.
276 #
277 my( @directories )= split( m@:@, "${directories}dummy" ) ;
278 $directories[ $#directories ]= '' ;
279 return @directories ;
280 }
281}
282
283
284=item catpath
285
286=cut
287
288sub catpath {
289 my $self = shift ;
290
291 my $result = shift ;
1b1e14d3 292 $result =~ s@^([^/])@/$1@s ;
0994714a
GS
293
294 my $segment ;
295 for $segment ( @_ ) {
9c045eb2 296 if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) {
0994714a
GS
297 $result .= "/$segment" ;
298 }
9c045eb2
GS
299 elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) {
300 $result =~ s@/+\Z(?!\n)@/@;
1b1e14d3 301 $segment =~ s@^/+@@s;
0994714a
GS
302 $result .= "$segment" ;
303 }
304 else {
305 $result .= $segment ;
306 }
307 }
308
309 return $result ;
310}
311
312=item abs2rel
313
3c32ced9
BS
314See L<File::Spec::Unix/abs2rel> for general documentation.
315
316Unlike C<File::Spec::Unix->abs2rel()>, this function will make
317checks against the local filesystem if necessary. See
318L</file_name_is_absolute> for details.
319
0994714a
GS
320=cut
321
322sub abs2rel {
323 my($self,$path,$base) = @_;
324
325 # Clean up $path
326 if ( ! $self->file_name_is_absolute( $path ) ) {
327 $path = $self->rel2abs( $path ) ;
328 }
329
330 # Figure out the effective $base and clean it up.
331 if ( !defined( $base ) || $base eq '' ) {
332 $base = cwd() ;
333 }
334 elsif ( ! $self->file_name_is_absolute( $base ) ) {
335 $base = $self->rel2abs( $base ) ;
336 }
337
338 # Now, remove all leading components that are the same
339 my @pathchunks = $self->splitdir( $path );
340 my @basechunks = $self->splitdir( $base );
341
342 while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
343 shift @pathchunks ;
344 shift @basechunks ;
345 }
346
347 $path = join( ':', @pathchunks );
348
349 # @basechunks now contains the number of directories to climb out of.
350 $base = ':' x @basechunks ;
351
352 return "$base:$path" ;
353}
354
355=item rel2abs
356
3c32ced9 357See L<File::Spec::Unix/rel2abs> for general documentation.
0994714a 358
3c32ced9
BS
359Unlike C<File::Spec::Unix->rel2abs()>, this function will make
360checks against the local filesystem if necessary. See
361L</file_name_is_absolute> for details.
0994714a
GS
362
363=cut
364
786b702f 365sub rel2abs {
0994714a
GS
366 my ($self,$path,$base ) = @_;
367
368 if ( ! $self->file_name_is_absolute( $path ) ) {
369 if ( !defined( $base ) || $base eq '' ) {
370 $base = cwd() ;
371 }
372 elsif ( ! $self->file_name_is_absolute( $base ) ) {
373 $base = $self->rel2abs( $base ) ;
374 }
375 else {
376 $base = $self->canonpath( $base ) ;
377 }
378
379 $path = $self->canonpath("$base$path") ;
380 }
381
382 return $path ;
383}
384
385
270d1e39
GS
386=back
387
388=head1 SEE ALSO
389
390L<File::Spec>
391
392=cut
393
3941;