1 | package File::Spec::Mac;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use vars qw(@ISA $VERSION);
|
---|
5 | require File::Spec::Unix;
|
---|
6 |
|
---|
7 | $VERSION = '1.4';
|
---|
8 |
|
---|
9 | @ISA = qw(File::Spec::Unix);
|
---|
10 |
|
---|
11 | my $macfiles;
|
---|
12 | if ($^O eq 'MacOS') {
|
---|
13 | $macfiles = eval { require Mac::Files };
|
---|
14 | }
|
---|
15 |
|
---|
16 | sub case_tolerant { 1 }
|
---|
17 |
|
---|
18 |
|
---|
19 | =head1 NAME
|
---|
20 |
|
---|
21 | File::Spec::Mac - File::Spec for Mac OS (Classic)
|
---|
22 |
|
---|
23 | =head1 SYNOPSIS
|
---|
24 |
|
---|
25 | require File::Spec::Mac; # Done internally by File::Spec if needed
|
---|
26 |
|
---|
27 | =head1 DESCRIPTION
|
---|
28 |
|
---|
29 | Methods for manipulating file specifications.
|
---|
30 |
|
---|
31 | =head1 METHODS
|
---|
32 |
|
---|
33 | =over 2
|
---|
34 |
|
---|
35 | =item canonpath
|
---|
36 |
|
---|
37 | On Mac OS, there's nothing to be done. Returns what it's given.
|
---|
38 |
|
---|
39 | =cut
|
---|
40 |
|
---|
41 | sub canonpath {
|
---|
42 | my ($self,$path) = @_;
|
---|
43 | return $path;
|
---|
44 | }
|
---|
45 |
|
---|
46 | =item catdir()
|
---|
47 |
|
---|
48 | Concatenate two or more directory names to form a path separated by colons
|
---|
49 | (":") ending with a directory. Resulting paths are B<relative> by default,
|
---|
50 | but can be forced to be absolute (but avoid this, see below). Automatically
|
---|
51 | puts a trailing ":" on the end of the complete path, because that's what's
|
---|
52 | done in MacPerl's environment and helps to distinguish a file path from a
|
---|
53 | directory path.
|
---|
54 |
|
---|
55 | B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting
|
---|
56 | path is relative by default and I<not> absolute. This decision was made due
|
---|
57 | to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths
|
---|
58 | on all other operating systems, it will now also follow this convention on Mac
|
---|
59 | OS. Note that this may break some existing scripts.
|
---|
60 |
|
---|
61 | The intended purpose of this routine is to concatenate I<directory names>.
|
---|
62 | But because of the nature of Macintosh paths, some additional possibilities
|
---|
63 | are allowed to make using this routine give reasonable results for some
|
---|
64 | common situations. In other words, you are also allowed to concatenate
|
---|
65 | I<paths> instead of directory names (strictly speaking, a string like ":a"
|
---|
66 | is a path, but not a name, since it contains a punctuation character ":").
|
---|
67 |
|
---|
68 | So, beside calls like
|
---|
69 |
|
---|
70 | catdir("a") = ":a:"
|
---|
71 | catdir("a","b") = ":a:b:"
|
---|
72 | catdir() = "" (special case)
|
---|
73 |
|
---|
74 | calls like the following
|
---|
75 |
|
---|
76 | catdir(":a:") = ":a:"
|
---|
77 | catdir(":a","b") = ":a:b:"
|
---|
78 | catdir(":a:","b") = ":a:b:"
|
---|
79 | catdir(":a:",":b:") = ":a:b:"
|
---|
80 | catdir(":") = ":"
|
---|
81 |
|
---|
82 | are allowed.
|
---|
83 |
|
---|
84 | Here are the rules that are used in C<catdir()>; note that we try to be as
|
---|
85 | compatible as possible to Unix:
|
---|
86 |
|
---|
87 | =over 2
|
---|
88 |
|
---|
89 | =item 1.
|
---|
90 |
|
---|
91 | The resulting path is relative by default, i.e. the resulting path will have a
|
---|
92 | leading colon.
|
---|
93 |
|
---|
94 | =item 2.
|
---|
95 |
|
---|
96 | A trailing colon is added automatically to the resulting path, to denote a
|
---|
97 | directory.
|
---|
98 |
|
---|
99 | =item 3.
|
---|
100 |
|
---|
101 | Generally, each argument has one leading ":" and one trailing ":"
|
---|
102 | removed (if any). They are then joined together by a ":". Special
|
---|
103 | treatment applies for arguments denoting updir paths like "::lib:",
|
---|
104 | see (4), or arguments consisting solely of colons ("colon paths"),
|
---|
105 | see (5).
|
---|
106 |
|
---|
107 | =item 4.
|
---|
108 |
|
---|
109 | When an updir path like ":::lib::" is passed as argument, the number
|
---|
110 | of directories to climb up is handled correctly, not removing leading
|
---|
111 | or trailing colons when necessary. E.g.
|
---|
112 |
|
---|
113 | catdir(":::a","::b","c") = ":::a::b:c:"
|
---|
114 | catdir(":::a::","::b","c") = ":::a:::b:c:"
|
---|
115 |
|
---|
116 | =item 5.
|
---|
117 |
|
---|
118 | Adding a colon ":" or empty string "" to a path at I<any> position
|
---|
119 | doesn't alter the path, i.e. these arguments are ignored. (When a ""
|
---|
120 | is passed as the first argument, it has a special meaning, see
|
---|
121 | (6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
|
---|
122 | while an empty string "" is generally ignored (see
|
---|
123 | C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".."
|
---|
124 | (updir), and a ":::" is handled like a "../.." etc. E.g.
|
---|
125 |
|
---|
126 | catdir("a",":",":","b") = ":a:b:"
|
---|
127 | catdir("a",":","::",":b") = ":a::b:"
|
---|
128 |
|
---|
129 | =item 6.
|
---|
130 |
|
---|
131 | If the first argument is an empty string "" or is a volume name, i.e. matches
|
---|
132 | the pattern /^[^:]+:/, the resulting path is B<absolute>.
|
---|
133 |
|
---|
134 | =item 7.
|
---|
135 |
|
---|
136 | Passing an empty string "" as the first argument to C<catdir()> is
|
---|
137 | like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e.
|
---|
138 |
|
---|
139 | catdir("","a","b") is the same as
|
---|
140 |
|
---|
141 | catdir(rootdir(),"a","b").
|
---|
142 |
|
---|
143 | This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and
|
---|
144 | C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup
|
---|
145 | volume, which is the closest in concept to Unix' "/". This should help
|
---|
146 | to run existing scripts originally written for Unix.
|
---|
147 |
|
---|
148 | =item 8.
|
---|
149 |
|
---|
150 | For absolute paths, some cleanup is done, to ensure that the volume
|
---|
151 | name isn't immediately followed by updirs. This is invalid, because
|
---|
152 | this would go beyond "root". Generally, these cases are handled like
|
---|
153 | their Unix counterparts:
|
---|
154 |
|
---|
155 | Unix:
|
---|
156 | Unix->catdir("","") = "/"
|
---|
157 | Unix->catdir("",".") = "/"
|
---|
158 | Unix->catdir("","..") = "/" # can't go beyond root
|
---|
159 | Unix->catdir("",".","..","..","a") = "/a"
|
---|
160 | Mac:
|
---|
161 | Mac->catdir("","") = rootdir() # (e.g. "HD:")
|
---|
162 | Mac->catdir("",":") = rootdir()
|
---|
163 | Mac->catdir("","::") = rootdir() # can't go beyond root
|
---|
164 | Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:")
|
---|
165 |
|
---|
166 | However, this approach is limited to the first arguments following
|
---|
167 | "root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
|
---|
168 | arguments that move up the directory tree, an invalid path going
|
---|
169 | beyond root can be created.
|
---|
170 |
|
---|
171 | =back
|
---|
172 |
|
---|
173 | As you've seen, you can force C<catdir()> to create an absolute path
|
---|
174 | by passing either an empty string or a path that begins with a volume
|
---|
175 | name as the first argument. However, you are strongly encouraged not
|
---|
176 | to do so, since this is done only for backward compatibility. Newer
|
---|
177 | versions of File::Spec come with a method called C<catpath()> (see
|
---|
178 | below), that is designed to offer a portable solution for the creation
|
---|
179 | of absolute paths. It takes volume, directory and file portions and
|
---|
180 | returns an entire path. While C<catdir()> is still suitable for the
|
---|
181 | concatenation of I<directory names>, you are encouraged to use
|
---|
182 | C<catpath()> to concatenate I<volume names> and I<directory
|
---|
183 | paths>. E.g.
|
---|
184 |
|
---|
185 | $dir = File::Spec->catdir("tmp","sources");
|
---|
186 | $abs_path = File::Spec->catpath("MacintoshHD:", $dir,"");
|
---|
187 |
|
---|
188 | yields
|
---|
189 |
|
---|
190 | "MacintoshHD:tmp:sources:" .
|
---|
191 |
|
---|
192 | =cut
|
---|
193 |
|
---|
194 | sub catdir {
|
---|
195 | my $self = shift;
|
---|
196 | return '' unless @_;
|
---|
197 | my @args = @_;
|
---|
198 | my $first_arg;
|
---|
199 | my $relative;
|
---|
200 |
|
---|
201 | # take care of the first argument
|
---|
202 |
|
---|
203 | if ($args[0] eq '') { # absolute path, rootdir
|
---|
204 | shift @args;
|
---|
205 | $relative = 0;
|
---|
206 | $first_arg = $self->rootdir;
|
---|
207 |
|
---|
208 | } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name
|
---|
209 | $relative = 0;
|
---|
210 | $first_arg = shift @args;
|
---|
211 | # add a trailing ':' if need be (may be it's a path like HD:dir)
|
---|
212 | $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
|
---|
213 |
|
---|
214 | } else { # relative path
|
---|
215 | $relative = 1;
|
---|
216 | if ( $args[0] =~ /^::+\Z(?!\n)/ ) {
|
---|
217 | # updir colon path ('::', ':::' etc.), don't shift
|
---|
218 | $first_arg = ':';
|
---|
219 | } elsif ($args[0] eq ':') {
|
---|
220 | $first_arg = shift @args;
|
---|
221 | } else {
|
---|
222 | # add a trailing ':' if need be
|
---|
223 | $first_arg = shift @args;
|
---|
224 | $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
|
---|
225 | }
|
---|
226 | }
|
---|
227 |
|
---|
228 | # For all other arguments,
|
---|
229 | # (a) ignore arguments that equal ':' or '',
|
---|
230 | # (b) handle updir paths specially:
|
---|
231 | # '::' -> concatenate '::'
|
---|
232 | # '::' . '::' -> concatenate ':::' etc.
|
---|
233 | # (c) add a trailing ':' if need be
|
---|
234 |
|
---|
235 | my $result = $first_arg;
|
---|
236 | while (@args) {
|
---|
237 | my $arg = shift @args;
|
---|
238 | unless (($arg eq '') || ($arg eq ':')) {
|
---|
239 | if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::'
|
---|
240 | my $updir_count = length($arg) - 1;
|
---|
241 | while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path
|
---|
242 | $arg = shift @args;
|
---|
243 | $updir_count += (length($arg) - 1);
|
---|
244 | }
|
---|
245 | $arg = (':' x $updir_count);
|
---|
246 | } else {
|
---|
247 | $arg =~ s/^://s; # remove a leading ':' if any
|
---|
248 | $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':'
|
---|
249 | }
|
---|
250 | $result .= $arg;
|
---|
251 | }#unless
|
---|
252 | }
|
---|
253 |
|
---|
254 | if ( ($relative) && ($result !~ /^:/) ) {
|
---|
255 | # add a leading colon if need be
|
---|
256 | $result = ":$result";
|
---|
257 | }
|
---|
258 |
|
---|
259 | unless ($relative) {
|
---|
260 | # remove updirs immediately following the volume name
|
---|
261 | $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/;
|
---|
262 | }
|
---|
263 |
|
---|
264 | return $result;
|
---|
265 | }
|
---|
266 |
|
---|
267 | =item catfile
|
---|
268 |
|
---|
269 | Concatenate one or more directory names and a filename to form a
|
---|
270 | complete path ending with a filename. Resulting paths are B<relative>
|
---|
271 | by default, but can be forced to be absolute (but avoid this).
|
---|
272 |
|
---|
273 | B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the
|
---|
274 | resulting path is relative by default and I<not> absolute. This
|
---|
275 | decision was made due to portability reasons. Since
|
---|
276 | C<File::Spec-E<gt>catfile()> returns relative paths on all other
|
---|
277 | operating systems, it will now also follow this convention on Mac OS.
|
---|
278 | Note that this may break some existing scripts.
|
---|
279 |
|
---|
280 | The last argument is always considered to be the file portion. Since
|
---|
281 | C<catfile()> uses C<catdir()> (see above) for the concatenation of the
|
---|
282 | directory portions (if any), the following with regard to relative and
|
---|
283 | absolute paths is true:
|
---|
284 |
|
---|
285 | catfile("") = ""
|
---|
286 | catfile("file") = "file"
|
---|
287 |
|
---|
288 | but
|
---|
289 |
|
---|
290 | catfile("","") = rootdir() # (e.g. "HD:")
|
---|
291 | catfile("","file") = rootdir() . file # (e.g. "HD:file")
|
---|
292 | catfile("HD:","file") = "HD:file"
|
---|
293 |
|
---|
294 | This means that C<catdir()> is called only when there are two or more
|
---|
295 | arguments, as one might expect.
|
---|
296 |
|
---|
297 | Note that the leading ":" is removed from the filename, so that
|
---|
298 |
|
---|
299 | catfile("a","b","file") = ":a:b:file" and
|
---|
300 |
|
---|
301 | catfile("a","b",":file") = ":a:b:file"
|
---|
302 |
|
---|
303 | give the same answer.
|
---|
304 |
|
---|
305 | To concatenate I<volume names>, I<directory paths> and I<filenames>,
|
---|
306 | you are encouraged to use C<catpath()> (see below).
|
---|
307 |
|
---|
308 | =cut
|
---|
309 |
|
---|
310 | sub catfile {
|
---|
311 | my $self = shift;
|
---|
312 | return '' unless @_;
|
---|
313 | my $file = pop @_;
|
---|
314 | return $file unless @_;
|
---|
315 | my $dir = $self->catdir(@_);
|
---|
316 | $file =~ s/^://s;
|
---|
317 | return $dir.$file;
|
---|
318 | }
|
---|
319 |
|
---|
320 | =item curdir
|
---|
321 |
|
---|
322 | Returns a string representing the current directory. On Mac OS, this is ":".
|
---|
323 |
|
---|
324 | =cut
|
---|
325 |
|
---|
326 | sub curdir {
|
---|
327 | return ":";
|
---|
328 | }
|
---|
329 |
|
---|
330 | =item devnull
|
---|
331 |
|
---|
332 | Returns a string representing the null device. On Mac OS, this is "Dev:Null".
|
---|
333 |
|
---|
334 | =cut
|
---|
335 |
|
---|
336 | sub devnull {
|
---|
337 | return "Dev:Null";
|
---|
338 | }
|
---|
339 |
|
---|
340 | =item rootdir
|
---|
341 |
|
---|
342 | Returns a string representing the root directory. Under MacPerl,
|
---|
343 | returns the name of the startup volume, since that's the closest in
|
---|
344 | concept, although other volumes aren't rooted there. The name has a
|
---|
345 | trailing ":", because that's the correct specification for a volume
|
---|
346 | name on Mac OS.
|
---|
347 |
|
---|
348 | If Mac::Files could not be loaded, the empty string is returned.
|
---|
349 |
|
---|
350 | =cut
|
---|
351 |
|
---|
352 | sub rootdir {
|
---|
353 | #
|
---|
354 | # There's no real root directory on Mac OS. The name of the startup
|
---|
355 | # volume is returned, since that's the closest in concept.
|
---|
356 | #
|
---|
357 | return '' unless $macfiles;
|
---|
358 | my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
|
---|
359 | &Mac::Files::kSystemFolderType);
|
---|
360 | $system =~ s/:.*\Z(?!\n)/:/s;
|
---|
361 | return $system;
|
---|
362 | }
|
---|
363 |
|
---|
364 | =item tmpdir
|
---|
365 |
|
---|
366 | Returns the contents of $ENV{TMPDIR}, if that directory exits or the
|
---|
367 | current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will
|
---|
368 | contain a path like "MacintoshHD:Temporary Items:", which is a hidden
|
---|
369 | directory on your startup volume.
|
---|
370 |
|
---|
371 | =cut
|
---|
372 |
|
---|
373 | my $tmpdir;
|
---|
374 | sub tmpdir {
|
---|
375 | return $tmpdir if defined $tmpdir;
|
---|
376 | $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} );
|
---|
377 | }
|
---|
378 |
|
---|
379 | =item updir
|
---|
380 |
|
---|
381 | Returns a string representing the parent directory. On Mac OS, this is "::".
|
---|
382 |
|
---|
383 | =cut
|
---|
384 |
|
---|
385 | sub updir {
|
---|
386 | return "::";
|
---|
387 | }
|
---|
388 |
|
---|
389 | =item file_name_is_absolute
|
---|
390 |
|
---|
391 | Takes as argument a path and returns true, if it is an absolute path.
|
---|
392 | If the path has a leading ":", it's a relative path. Otherwise, it's an
|
---|
393 | absolute path, unless the path doesn't contain any colons, i.e. it's a name
|
---|
394 | like "a". In this particular case, the path is considered to be relative
|
---|
395 | (i.e. it is considered to be a filename). Use ":" in the appropriate place
|
---|
396 | in the path if you want to distinguish unambiguously. As a special case,
|
---|
397 | the filename '' is always considered to be absolute. Note that with version
|
---|
398 | 1.2 of File::Spec::Mac, this does no longer consult the local filesystem.
|
---|
399 |
|
---|
400 | E.g.
|
---|
401 |
|
---|
402 | File::Spec->file_name_is_absolute("a"); # false (relative)
|
---|
403 | File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
|
---|
404 | File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute)
|
---|
405 | File::Spec->file_name_is_absolute(""); # true (absolute)
|
---|
406 |
|
---|
407 |
|
---|
408 | =cut
|
---|
409 |
|
---|
410 | sub file_name_is_absolute {
|
---|
411 | my ($self,$file) = @_;
|
---|
412 | if ($file =~ /:/) {
|
---|
413 | return (! ($file =~ m/^:/s) );
|
---|
414 | } elsif ( $file eq '' ) {
|
---|
415 | return 1 ;
|
---|
416 | } else {
|
---|
417 | return 0; # i.e. a file like "a"
|
---|
418 | }
|
---|
419 | }
|
---|
420 |
|
---|
421 | =item path
|
---|
422 |
|
---|
423 | Returns the null list for the MacPerl application, since the concept is
|
---|
424 | usually meaningless under Mac OS. But if you're using the MacPerl tool under
|
---|
425 | MPW, it gives back $ENV{Commands} suitably split, as is done in
|
---|
426 | :lib:ExtUtils:MM_Mac.pm.
|
---|
427 |
|
---|
428 | =cut
|
---|
429 |
|
---|
430 | sub path {
|
---|
431 | #
|
---|
432 | # The concept is meaningless under the MacPerl application.
|
---|
433 | # Under MPW, it has a meaning.
|
---|
434 | #
|
---|
435 | return unless exists $ENV{Commands};
|
---|
436 | return split(/,/, $ENV{Commands});
|
---|
437 | }
|
---|
438 |
|
---|
439 | =item splitpath
|
---|
440 |
|
---|
441 | ($volume,$directories,$file) = File::Spec->splitpath( $path );
|
---|
442 | ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
|
---|
443 |
|
---|
444 | Splits a path into volume, directory, and filename portions.
|
---|
445 |
|
---|
446 | On Mac OS, assumes that the last part of the path is a filename unless
|
---|
447 | $no_file is true or a trailing separator ":" is present.
|
---|
448 |
|
---|
449 | The volume portion is always returned with a trailing ":". The directory portion
|
---|
450 | is always returned with a leading (to denote a relative path) and a trailing ":"
|
---|
451 | (to denote a directory). The file portion is always returned I<without> a leading ":".
|
---|
452 | Empty portions are returned as empty string ''.
|
---|
453 |
|
---|
454 | The results can be passed to C<catpath()> to get back a path equivalent to
|
---|
455 | (usually identical to) the original path.
|
---|
456 |
|
---|
457 |
|
---|
458 | =cut
|
---|
459 |
|
---|
460 | sub splitpath {
|
---|
461 | my ($self,$path, $nofile) = @_;
|
---|
462 | my ($volume,$directory,$file);
|
---|
463 |
|
---|
464 | if ( $nofile ) {
|
---|
465 | ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s;
|
---|
466 | }
|
---|
467 | else {
|
---|
468 | $path =~
|
---|
469 | m|^( (?: [^:]+: )? )
|
---|
470 | ( (?: .*: )? )
|
---|
471 | ( .* )
|
---|
472 | |xs;
|
---|
473 | $volume = $1;
|
---|
474 | $directory = $2;
|
---|
475 | $file = $3;
|
---|
476 | }
|
---|
477 |
|
---|
478 | $volume = '' unless defined($volume);
|
---|
479 | $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir"
|
---|
480 | if ($directory) {
|
---|
481 | # Make sure non-empty directories begin and end in ':'
|
---|
482 | $directory .= ':' unless (substr($directory,-1) eq ':');
|
---|
483 | $directory = ":$directory" unless (substr($directory,0,1) eq ':');
|
---|
484 | } else {
|
---|
485 | $directory = '';
|
---|
486 | }
|
---|
487 | $file = '' unless defined($file);
|
---|
488 |
|
---|
489 | return ($volume,$directory,$file);
|
---|
490 | }
|
---|
491 |
|
---|
492 |
|
---|
493 | =item splitdir
|
---|
494 |
|
---|
495 | The opposite of C<catdir()>.
|
---|
496 |
|
---|
497 | @dirs = File::Spec->splitdir( $directories );
|
---|
498 |
|
---|
499 | $directories should be only the directory portion of the path on systems
|
---|
500 | that have the concept of a volume or that have path syntax that differentiates
|
---|
501 | files from directories. Consider using C<splitpath()> otherwise.
|
---|
502 |
|
---|
503 | Unlike just splitting the directories on the separator, empty directory names
|
---|
504 | (C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing
|
---|
505 | colon to distinguish a directory path from a file path, a single trailing colon
|
---|
506 | will be ignored, i.e. there's no empty directory name after it.
|
---|
507 |
|
---|
508 | Hence, on Mac OS, both
|
---|
509 |
|
---|
510 | File::Spec->splitdir( ":a:b::c:" ); and
|
---|
511 | File::Spec->splitdir( ":a:b::c" );
|
---|
512 |
|
---|
513 | yield:
|
---|
514 |
|
---|
515 | ( "a", "b", "::", "c")
|
---|
516 |
|
---|
517 | while
|
---|
518 |
|
---|
519 | File::Spec->splitdir( ":a:b::c::" );
|
---|
520 |
|
---|
521 | yields:
|
---|
522 |
|
---|
523 | ( "a", "b", "::", "c", "::")
|
---|
524 |
|
---|
525 |
|
---|
526 | =cut
|
---|
527 |
|
---|
528 | sub splitdir {
|
---|
529 | my ($self, $path) = @_;
|
---|
530 | my @result = ();
|
---|
531 | my ($head, $sep, $tail, $volume, $directories);
|
---|
532 |
|
---|
533 | return ('') if ( (!defined($path)) || ($path eq '') );
|
---|
534 | return (':') if ($path eq ':');
|
---|
535 |
|
---|
536 | ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
|
---|
537 |
|
---|
538 | # deprecated, but handle it correctly
|
---|
539 | if ($volume) {
|
---|
540 | push (@result, $volume);
|
---|
541 | $sep .= ':';
|
---|
542 | }
|
---|
543 |
|
---|
544 | while ($sep || $directories) {
|
---|
545 | if (length($sep) > 1) {
|
---|
546 | my $updir_count = length($sep) - 1;
|
---|
547 | for (my $i=0; $i<$updir_count; $i++) {
|
---|
548 | # push '::' updir_count times;
|
---|
549 | # simulate Unix '..' updirs
|
---|
550 | push (@result, '::');
|
---|
551 | }
|
---|
552 | }
|
---|
553 | $sep = '';
|
---|
554 | if ($directories) {
|
---|
555 | ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s;
|
---|
556 | push (@result, $head);
|
---|
557 | $directories = $tail;
|
---|
558 | }
|
---|
559 | }
|
---|
560 | return @result;
|
---|
561 | }
|
---|
562 |
|
---|
563 |
|
---|
564 | =item catpath
|
---|
565 |
|
---|
566 | $path = File::Spec->catpath($volume,$directory,$file);
|
---|
567 |
|
---|
568 | Takes volume, directory and file portions and returns an entire path. On Mac OS,
|
---|
569 | $volume, $directory and $file are concatenated. A ':' is inserted if need be. You
|
---|
570 | may pass an empty string for each portion. If all portions are empty, the empty
|
---|
571 | string is returned. If $volume is empty, the result will be a relative path,
|
---|
572 | beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any)
|
---|
573 | is removed form $file and the remainder is returned. If $file is empty, the
|
---|
574 | resulting path will have a trailing ':'.
|
---|
575 |
|
---|
576 |
|
---|
577 | =cut
|
---|
578 |
|
---|
579 | sub catpath {
|
---|
580 | my ($self,$volume,$directory,$file) = @_;
|
---|
581 |
|
---|
582 | if ( (! $volume) && (! $directory) ) {
|
---|
583 | $file =~ s/^:// if $file;
|
---|
584 | return $file ;
|
---|
585 | }
|
---|
586 |
|
---|
587 | # We look for a volume in $volume, then in $directory, but not both
|
---|
588 |
|
---|
589 | my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
|
---|
590 |
|
---|
591 | $volume = $dir_volume unless length $volume;
|
---|
592 | my $path = $volume; # may be ''
|
---|
593 | $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
|
---|
594 |
|
---|
595 | if ($directory) {
|
---|
596 | $directory = $dir_dirs if $volume;
|
---|
597 | $directory =~ s/^://; # remove leading ':' if any
|
---|
598 | $path .= $directory;
|
---|
599 | $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
|
---|
600 | }
|
---|
601 |
|
---|
602 | if ($file) {
|
---|
603 | $file =~ s/^://; # remove leading ':' if any
|
---|
604 | $path .= $file;
|
---|
605 | }
|
---|
606 |
|
---|
607 | return $path;
|
---|
608 | }
|
---|
609 |
|
---|
610 | =item abs2rel
|
---|
611 |
|
---|
612 | Takes a destination path and an optional base path and returns a relative path
|
---|
613 | from the base path to the destination path:
|
---|
614 |
|
---|
615 | $rel_path = File::Spec->abs2rel( $path ) ;
|
---|
616 | $rel_path = File::Spec->abs2rel( $path, $base ) ;
|
---|
617 |
|
---|
618 | Note that both paths are assumed to have a notation that distinguishes a
|
---|
619 | directory path (with trailing ':') from a file path (without trailing ':').
|
---|
620 |
|
---|
621 | If $base is not present or '', then the current working directory is used.
|
---|
622 | If $base is relative, then it is converted to absolute form using C<rel2abs()>.
|
---|
623 | This means that it is taken to be relative to the current working directory.
|
---|
624 |
|
---|
625 | If $path and $base appear to be on two different volumes, we will not
|
---|
626 | attempt to resolve the two paths, and we will instead simply return
|
---|
627 | $path. Note that previous versions of this module ignored the volume
|
---|
628 | of $base, which resulted in garbage results part of the time.
|
---|
629 |
|
---|
630 | If $base doesn't have a trailing colon, the last element of $base is
|
---|
631 | assumed to be a filename. This filename is ignored. Otherwise all path
|
---|
632 | components are assumed to be directories.
|
---|
633 |
|
---|
634 | If $path is relative, it is converted to absolute form using C<rel2abs()>.
|
---|
635 | This means that it is taken to be relative to the current working directory.
|
---|
636 |
|
---|
637 | Based on code written by Shigio Yamaguchi.
|
---|
638 |
|
---|
639 |
|
---|
640 | =cut
|
---|
641 |
|
---|
642 | # maybe this should be done in canonpath() ?
|
---|
643 | sub _resolve_updirs {
|
---|
644 | my $path = shift @_;
|
---|
645 | my $proceed;
|
---|
646 |
|
---|
647 | # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file"
|
---|
648 | do {
|
---|
649 | $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
|
---|
650 | } while ($proceed);
|
---|
651 |
|
---|
652 | return $path;
|
---|
653 | }
|
---|
654 |
|
---|
655 |
|
---|
656 | sub abs2rel {
|
---|
657 | my($self,$path,$base) = @_;
|
---|
658 |
|
---|
659 | # Clean up $path
|
---|
660 | if ( ! $self->file_name_is_absolute( $path ) ) {
|
---|
661 | $path = $self->rel2abs( $path ) ;
|
---|
662 | }
|
---|
663 |
|
---|
664 | # Figure out the effective $base and clean it up.
|
---|
665 | if ( !defined( $base ) || $base eq '' ) {
|
---|
666 | $base = $self->_cwd();
|
---|
667 | }
|
---|
668 | elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
---|
669 | $base = $self->rel2abs( $base ) ;
|
---|
670 | $base = _resolve_updirs( $base ); # resolve updirs in $base
|
---|
671 | }
|
---|
672 | else {
|
---|
673 | $base = _resolve_updirs( $base );
|
---|
674 | }
|
---|
675 |
|
---|
676 | # Split up paths - ignore $base's file
|
---|
677 | my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path );
|
---|
678 | my ( $base_vol, $base_dirs ) = $self->splitpath( $base );
|
---|
679 |
|
---|
680 | return $path unless lc( $path_vol ) eq lc( $base_vol );
|
---|
681 |
|
---|
682 | # Now, remove all leading components that are the same
|
---|
683 | my @pathchunks = $self->splitdir( $path_dirs );
|
---|
684 | my @basechunks = $self->splitdir( $base_dirs );
|
---|
685 |
|
---|
686 | while ( @pathchunks &&
|
---|
687 | @basechunks &&
|
---|
688 | lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
|
---|
689 | shift @pathchunks ;
|
---|
690 | shift @basechunks ;
|
---|
691 | }
|
---|
692 |
|
---|
693 | # @pathchunks now has the directories to descend in to.
|
---|
694 | # ensure relative path, even if @pathchunks is empty
|
---|
695 | $path_dirs = $self->catdir( ':', @pathchunks );
|
---|
696 |
|
---|
697 | # @basechunks now contains the number of directories to climb out of.
|
---|
698 | $base_dirs = (':' x @basechunks) . ':' ;
|
---|
699 |
|
---|
700 | return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ;
|
---|
701 | }
|
---|
702 |
|
---|
703 | =item rel2abs
|
---|
704 |
|
---|
705 | Converts a relative path to an absolute path:
|
---|
706 |
|
---|
707 | $abs_path = File::Spec->rel2abs( $path ) ;
|
---|
708 | $abs_path = File::Spec->rel2abs( $path, $base ) ;
|
---|
709 |
|
---|
710 | Note that both paths are assumed to have a notation that distinguishes a
|
---|
711 | directory path (with trailing ':') from a file path (without trailing ':').
|
---|
712 |
|
---|
713 | If $base is not present or '', then $base is set to the current working
|
---|
714 | directory. If $base is relative, then it is converted to absolute form
|
---|
715 | using C<rel2abs()>. This means that it is taken to be relative to the
|
---|
716 | current working directory.
|
---|
717 |
|
---|
718 | If $base doesn't have a trailing colon, the last element of $base is
|
---|
719 | assumed to be a filename. This filename is ignored. Otherwise all path
|
---|
720 | components are assumed to be directories.
|
---|
721 |
|
---|
722 | If $path is already absolute, it is returned and $base is ignored.
|
---|
723 |
|
---|
724 | Based on code written by Shigio Yamaguchi.
|
---|
725 |
|
---|
726 | =cut
|
---|
727 |
|
---|
728 | sub rel2abs {
|
---|
729 | my ($self,$path,$base) = @_;
|
---|
730 |
|
---|
731 | if ( ! $self->file_name_is_absolute($path) ) {
|
---|
732 | # Figure out the effective $base and clean it up.
|
---|
733 | if ( !defined( $base ) || $base eq '' ) {
|
---|
734 | $base = $self->_cwd();
|
---|
735 | }
|
---|
736 | elsif ( ! $self->file_name_is_absolute($base) ) {
|
---|
737 | $base = $self->rel2abs($base) ;
|
---|
738 | }
|
---|
739 |
|
---|
740 | # Split up paths
|
---|
741 |
|
---|
742 | # igonore $path's volume
|
---|
743 | my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
|
---|
744 |
|
---|
745 | # ignore $base's file part
|
---|
746 | my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
|
---|
747 |
|
---|
748 | # Glom them together
|
---|
749 | $path_dirs = ':' if ($path_dirs eq '');
|
---|
750 | $base_dirs =~ s/:$//; # remove trailing ':', if any
|
---|
751 | $base_dirs = $base_dirs . $path_dirs;
|
---|
752 |
|
---|
753 | $path = $self->catpath( $base_vol, $base_dirs, $path_file );
|
---|
754 | }
|
---|
755 | return $path;
|
---|
756 | }
|
---|
757 |
|
---|
758 |
|
---|
759 | =back
|
---|
760 |
|
---|
761 | =head1 AUTHORS
|
---|
762 |
|
---|
763 | See the authors list in I<File::Spec>. Mac OS support by Paul Schinder
|
---|
764 | <[email protected]> and Thomas Wegner <[email protected]>.
|
---|
765 |
|
---|
766 | =head1 COPYRIGHT
|
---|
767 |
|
---|
768 | Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
---|
769 |
|
---|
770 | This program is free software; you can redistribute it and/or modify
|
---|
771 | it under the same terms as Perl itself.
|
---|
772 |
|
---|
773 | =head1 SEE ALSO
|
---|
774 |
|
---|
775 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
---|
776 | implementation of these methods, not the semantics.
|
---|
777 |
|
---|
778 | =cut
|
---|
779 |
|
---|
780 | 1;
|
---|