lib/File/Spec/Mac.pm

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