lib/File/Spec/Mac.pm

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