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.1';
   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 =cut
 196
 197 sub file_name_is_absolute {
 198     my ($self,$file) = @_;
 199     if ($file =~ /:/) {
 200         return ($file !~ m/^:/s);
 201     } else {
 202         return (! -e ":$file");
 203     }
 204 }
 205
 206 =item path
 207
 208 Returns the null list for the MacPerl application, since the concept is
 209 usually meaningless under MacOS. But if you're using the MacPerl tool under
 210 MPW, it gives back $ENV{Commands} suitably split, as is done in
 211 :lib:ExtUtils:MM_Mac.pm.
 212
 213 =cut
 214
 215 sub path {
 216 #
 217 #  The concept is meaningless under the MacPerl application.
 218 #  Under MPW, it has a meaning.
 219 #
 220     return unless exists $ENV{Commands};
 221     return split(/,/, $ENV{Commands});
 222 }
 223
 224 =item splitpath
 225
 226 =cut
 227
 228 sub splitpath {
 229     my ($self,$path, $nofile) = @_;
 230
 231     my ($volume,$directory,$file) = ('','','');
 232
 233     if ( $nofile ) {
 234         ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\Z(?!\n)))?)(.*)@s;
 235     }
 236     else {
 237         $path =~
 238             m@^( (?: [^:]+: )? )
 239                 ( (?: .*: )? )
 240                 ( .* )
 241              @xs;
 242         $volume    = $1;
 243         $directory = $2;
 244         $file      = $3;
 245     }
 246
 247     # Make sure non-empty volumes and directories end in ':'
 248     $volume    .= ':' if $volume    =~ m@[^:]\Z(?!\n)@ ;
 249     $directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ;
 250     return ($volume,$directory,$file);
 251 }
 252
 253
 254 =item splitdir
 255
 256 =cut
 257
 258 sub splitdir {
 259     my ($self,$directories) = @_ ;
 260     #
 261     # split() likes to forget about trailing null fields, so here we
 262     # check to be sure that there will not be any before handling the
 263     # simple case.
 264     #
 265     if ( $directories !~ m@:\Z(?!\n)@ ) {
 266         return split( m@:@, $directories );
 267     }
 268     else {
 269         #
 270         # since there was a trailing separator, add a file name to the end,
 271         # then do the split, then replace it with ''.
 272         #
 273         my( @directories )= split( m@:@, "${directories}dummy" ) ;
 274         $directories[ $#directories ]= '' ;
 275         return @directories ;
 276     }
 277 }
 278
 279
 280 =item catpath
 281
 282 =cut
 283
 284 sub catpath {
 285     my $self = shift ;
 286
 287     my $result = shift ;
 288     $result =~ s@^([^/])@/$1@s ;
 289
 290     my $segment ;
 291     for $segment ( @_ ) {
 292         if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) {
 293             $result .= "/$segment" ;
 294         }
 295         elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) {
 296             $result  =~ s@/+\Z(?!\n)@/@;
 297             $segment =~ s@^/+@@s;
 298             $result  .= "$segment" ;
 299         }
 300         else {
 301             $result  .= $segment ;
 302         }
 303     }
 304
 305     return $result ;
 306 }
 307
 308 =item abs2rel
 309
 310 =cut
 311
 312 sub abs2rel {
 313     my($self,$path,$base) = @_;
 314
 315     # Clean up $path
 316     if ( ! $self->file_name_is_absolute( $path ) ) {
 317         $path = $self->rel2abs( $path ) ;
 318     }
 319
 320     # Figure out the effective $base and clean it up.
 321     if ( !defined( $base ) || $base eq '' ) {
 322         $base = cwd() ;
 323     }
 324     elsif ( ! $self->file_name_is_absolute( $base ) ) {
 325         $base = $self->rel2abs( $base ) ;
 326     }
 327
 328     # Now, remove all leading components that are the same
 329     my @pathchunks = $self->splitdir( $path );
 330     my @basechunks = $self->splitdir( $base );
 331
 332     while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
 333         shift @pathchunks ;
 334         shift @basechunks ;
 335     }
 336
 337     $path = join( ':', @pathchunks );
 338
 339     # @basechunks now contains the number of directories to climb out of.
 340     $base = ':' x @basechunks ;
 341
 342     return "$base:$path" ;
 343 }
 344
 345 =item rel2abs
 346
 347 Converts a relative path to an absolute path.
 348
 349     $abs_path = File::Spec->rel2abs( $destination ) ;
 350     $abs_path = File::Spec->rel2abs( $destination, $base ) ;
 351
 352 If $base is not present or '', then L<cwd()> is used. If $base is relative,
 353 then it is converted to absolute form using L</rel2abs()>. This means that it
 354 is taken to be relative to L<cwd()>.
 355
 356 On systems with the concept of a volume, this assumes that both paths
 357 are on the $base volume, and ignores the $destination volume.
 358
 359 On systems that have a grammar that indicates filenames, this ignores the
 360 $base filename as well. Otherwise all path components are assumed to be
 361 directories.
 362
 363 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
 364
 365 Based on code written by Shigio Yamaguchi.
 366
 367 No checks against the filesystem are made.
 368
 369 =cut
 370
 371 sub rel2abs($;$;) {
 372     my ($self,$path,$base ) = @_;
 373
 374     if ( ! $self->file_name_is_absolute( $path ) ) {
 375         if ( !defined( $base ) || $base eq '' ) {
 376             $base = cwd() ;
 377         }
 378         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 379             $base = $self->rel2abs( $base ) ;
 380         }
 381         else {
 382             $base = $self->canonpath( $base ) ;
 383         }
 384
 385         $path = $self->canonpath("$base$path") ;
 386     }
 387
 388     return $path ;
 389 }
 390
 391
 392 =back
 393
 394 =head1 SEE ALSO
 395
 396 L<File::Spec>
 397
 398 =cut
 399
 400 1;