| 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 | <schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>. |
| 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; |