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