[p5sagit/p5-mst-13.2.git] / lib / File / Spec / Mac.pm

package File::Spec::Mac;

use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;

$VERSION = '1.2';

@ISA = qw(File::Spec::Unix);

=head1 NAME

File::Spec::Mac - File::Spec for MacOS

=head1 SYNOPSIS

 require File::Spec::Mac; # Done internally by File::Spec if needed

=head1 DESCRIPTION

Methods for manipulating file specifications.

=head1 METHODS

=over 2

=item canonpath

On MacOS, there's nothing to be done.  Returns what it's given.

=cut

sub canonpath {
    my ($self,$path) = @_;
    return $path;
}

=item catdir

Concatenate two or more directory names to form a complete path ending with 
a directory.  Put a trailing : on the end of the complete path if there 
isn't one, because that's what's done in MacPerl's environment.

The fundamental requirement of this routine is that

	  File::Spec->catdir(split(":",$path)) eq $path

But because of the nature of Macintosh paths, some additional 
possibilities are allowed to make using this routine give reasonable results 
for some common situations.  Here are the rules that are used.  Each 
argument has its trailing ":" removed.  Each argument, except the first,
has its leading ":" removed.  They are then joined together by a ":".

So

	  File::Spec->catdir("a","b") = "a:b:"
	  File::Spec->catdir("a:",":b") = "a:b:"
	  File::Spec->catdir("a:","b") = "a:b:"
	  File::Spec->catdir("a",":b") = "a:b"
	  File::Spec->catdir("a","","b") = "a::b"

etc.

To get a relative path (one beginning with :), begin the first argument with :
or put a "" as the first argument.

If you don't want to worry about these rules, never allow a ":" on the ends 
of any of the arguments except at the beginning of the first.

Under MacPerl, there is an additional ambiguity.  Does the user intend that

	  File::Spec->catfile("LWP","Protocol","http.pm")

be relative or absolute?  There's no way of telling except by checking for the
existence of LWP: or :LWP, and even there he may mean a dismounted volume or
a relative path in a different directory (like in @INC).   So those checks
aren't done here. This routine will treat this as absolute.

=cut

sub catdir {
    shift;
    my @args = @_;
    my $result = shift @args;
    $result =~ s/:\Z(?!\n)//;
    foreach (@args) {
	s/:\Z(?!\n)//;
	s/^://s;
	$result .= ":$_";
    }
    return "$result:";
}

=item catfile

Concatenate one or more directory names and a filename to form a
complete path ending with a filename.  Since this uses catdir, the
same caveats apply.  Note that the leading : is removed from the filename,
so that 

	  File::Spec->catfile($ENV{HOME},"file");

and

	  File::Spec->catfile($ENV{HOME},":file");

give the same answer, as one might expect.

=cut

sub catfile {
    my $self = shift;
    my $file = pop @_;
    return $file unless @_;
    my $dir = $self->catdir(@_);
    $file =~ s/^://s;
    return $dir.$file;
}

=item curdir

Returns a string representing the current directory.

=cut

sub curdir {
    return ":";
}

=item devnull

Returns a string representing the null device.

=cut

sub devnull {
    return "Dev:Null";
}

=item rootdir

Returns a string representing the root directory.  Under MacPerl,
returns the name of the startup volume, since that's the closest in
concept, although other volumes aren't rooted there.

=cut

sub rootdir {
#
#  There's no real root directory on MacOS.  The name of the startup
#  volume is returned, since that's the closest in concept.
#
    require Mac::Files;
    my $system =  Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
					 &Mac::Files::kSystemFolderType);
    $system =~ s/:.*\Z(?!\n)/:/s;
    return $system;
}

=item tmpdir

Returns a string representation of the first existing directory
from the following list or '' if none exist:

    $ENV{TMPDIR}

=cut

my $tmpdir;
sub tmpdir {
    return $tmpdir if defined $tmpdir;
    $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR};
    $tmpdir = '' unless defined $tmpdir;
    return $tmpdir;
}

=item updir

Returns a string representing the parent directory.

=cut

sub updir {
    return "::";
}

=item file_name_is_absolute

Takes as argument a path and returns true, if it is an absolute path.  In 
the case where a name can be either relative or absolute (for example, a 
folder named "HD" in the current working directory on a drive named "HD"), 
relative wins.  Use ":" in the appropriate place in the path if you want to
distinguish unambiguously.

As a special case, the file name '' is always considered to be absolute.

=cut

sub file_name_is_absolute {
    my ($self,$file) = @_;
    if ($file =~ /:/) {
	return ($file !~ m/^:/s);
    } elsif ( $file eq '' ) {
        return 1 ;
    } else {
	return (! -e ":$file");
    }
}

=item path

Returns the null list for the MacPerl application, since the concept is 
usually meaningless under MacOS. But if you're using the MacPerl tool under 
MPW, it gives back $ENV{Commands} suitably split, as is done in 
:lib:ExtUtils:MM_Mac.pm.

=cut

sub path {
#
#  The concept is meaningless under the MacPerl application.
#  Under MPW, it has a meaning.
#
    return unless exists $ENV{Commands};
    return split(/,/, $ENV{Commands});
}

=item splitpath

=cut

sub splitpath {
    my ($self,$path, $nofile) = @_;

    my ($volume,$directory,$file) = ('','','');

    if ( $nofile ) {
        ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\Z(?!\n)))?)(.*)@s;
    }
    else {
        $path =~ 
            m@^( (?: [^:]+: )? ) 
                ( (?: .*: )? )
                ( .* )
             @xs;
        $volume    = $1;
        $directory = $2;
        $file      = $3;
    }

    # Make sure non-empty volumes and directories end in ':'
    $volume    .= ':' if $volume    =~ m@[^:]\Z(?!\n)@ ;
    $directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ;
    return ($volume,$directory,$file);
}


=item splitdir

=cut

sub splitdir {
    my ($self,$directories) = @_ ;
    #
    # split() likes to forget about trailing null fields, so here we
    # check to be sure that there will not be any before handling the
    # simple case.
    #
    if ( $directories !~ m@:\Z(?!\n)@ ) {
        return split( m@:@, $directories );
    }
    else {
        #
        # since there was a trailing separator, add a file name to the end, 
        # then do the split, then replace it with ''.
        #
        my( @directories )= split( m@:@, "${directories}dummy" ) ;
        $directories[ $#directories ]= '' ;
        return @directories ;
    }
}


=item catpath

=cut

sub catpath {
    my $self = shift ;

    my $result = shift ;
    $result =~ s@^([^/])@/$1@s ;

    my $segment ;
    for $segment ( @_ ) {
        if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) {
            $result .= "/$segment" ;
        }
        elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) {
            $result  =~ s@/+\Z(?!\n)@/@;
            $segment =~ s@^/+@@s;
            $result  .= "$segment" ;
        }
        else {
            $result  .= $segment ;
        }
    }

    return $result ;
}

=item abs2rel

See L<File::Spec::Unix/abs2rel> for general documentation.

Unlike C<File::Spec::Unix->abs2rel()>, this function will make
checks against the local filesystem if necessary.  See
L</file_name_is_absolute> for details.

=cut

sub abs2rel {
    my($self,$path,$base) = @_;

    # Clean up $path
    if ( ! $self->file_name_is_absolute( $path ) ) {
        $path = $self->rel2abs( $path ) ;
    }

    # Figure out the effective $base and clean it up.
    if ( !defined( $base ) || $base eq '' ) {
        $base = cwd() ;
    }
    elsif ( ! $self->file_name_is_absolute( $base ) ) {
        $base = $self->rel2abs( $base ) ;
    }

    # Now, remove all leading components that are the same
    my @pathchunks = $self->splitdir( $path );
    my @basechunks = $self->splitdir( $base );

    while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
        shift @pathchunks ;
        shift @basechunks ;
    }

    $path = join( ':', @pathchunks );

    # @basechunks now contains the number of directories to climb out of.
    $base = ':' x @basechunks ;

    return "$base:$path" ;
}

=item rel2abs

See L<File::Spec::Unix/rel2abs> for general documentation.

Unlike C<File::Spec::Unix->rel2abs()>, this function will make
checks against the local filesystem if necessary.  See
L</file_name_is_absolute> for details.

=cut

sub rel2abs {
    my ($self,$path,$base ) = @_;

    if ( ! $self->file_name_is_absolute( $path ) ) {
        if ( !defined( $base ) || $base eq '' ) {
            $base = cwd() ;
        }
        elsif ( ! $self->file_name_is_absolute( $base ) ) {
            $base = $self->rel2abs( $base ) ;
        }
        else {
            $base = $self->canonpath( $base ) ;
        }

        $path = $self->canonpath("$base$path") ;
    }

    return $path ;
}


=back

=head1 SEE ALSO

L<File::Spec>

=cut

1;
Commit	Line	Data
270d1e39	1	package File::Spec::Mac;
270d1e39	2
270d1e39	3	use strict;
b4296952	4	use vars qw(@ISA $VERSION);
cbc7acb0	5	require File::Spec::Unix;
b4296952	6
3c32ced9	7	$VERSION = '1.2';
b4296952	8
270d1e39	9	@ISA = qw(File::Spec::Unix);
270d1e39	10
	11	=head1 NAME
	12
	13	File::Spec::Mac - File::Spec for MacOS
	14
	15	=head1 SYNOPSIS
	16
cbc7acb0	17	require File::Spec::Mac; # Done internally by File::Spec if needed
270d1e39	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 {
cbc7acb0	34	my ($self,$path) = @_;
cbc7acb0	35	return $path;
270d1e39	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
8dcee03e	49	possibilities are allowed to make using this routine give reasonable results
270d1e39	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
8dcee03e	75	existence of LWP: or :LWP, and even there he may mean a dismounted volume or
270d1e39	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
270d1e39	81	sub catdir {
	82	shift;
	83	my @args = @_;
cbc7acb0	84	my $result = shift @args;
9c045eb2	85	$result =~ s/:\Z(?!\n)//;
cbc7acb0	86	foreach (@args) {
9c045eb2	87	s/:\Z(?!\n)//;
1b1e14d3	88	s/^://s;
cbc7acb0	89	$result .= ":$_";
270d1e39	90	}
cbc7acb0	91	return "$result:";
270d1e39	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 {
cbc7acb0	112	my $self = shift;
270d1e39	113	my $file = pop @_;
	114	return $file unless @_;
	115	my $dir = $self->catdir(@_);
1b1e14d3	116	$file =~ s/^://s;
270d1e39	117	return $dir.$file;
	118	}
	119
	120	=item curdir
	121
cbc7acb0	122	Returns a string representing the current directory.
270d1e39	123
	124	=cut
	125
	126	sub curdir {
cbc7acb0	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";
270d1e39	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
cbc7acb0	144	concept, although other volumes aren't rooted there.
270d1e39	145
	146	=cut
	147
	148	sub rootdir {
	149	#
cbc7acb0	150	# There's no real root directory on MacOS. The name of the startup
cbc7acb0	151	# volume is returned, since that's the closest in concept.
270d1e39	152	#
cbc7acb0	153	require Mac::Files;
	154	my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
	155	&Mac::Files::kSystemFolderType);
9c045eb2	156	$system =~ s/:.*\Z(?!\n)/:/s;
cbc7acb0	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;
270d1e39	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
3c32ced9	195	As a special case, the file name '' is always considered to be absolute.
3c32ced9	196
270d1e39	197	=cut
	198
	199	sub file_name_is_absolute {
cbc7acb0	200	my ($self,$file) = @_;
cbc7acb0	201	if ($file =~ /:/) {
1b1e14d3	202	return ($file !~ m/^:/s);
3c32ced9	203	} elsif ( $file eq '' ) {
3c32ced9	204	return 1 ;
cbc7acb0	205	} else {
cbc7acb0	206	return (! -e ":$file");
270d1e39	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	#
cbc7acb0	224	return unless exists $ENV{Commands};
cbc7acb0	225	return split(/,/, $ENV{Commands});
270d1e39	226	}
270d1e39	227
0994714a	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 ) {
9c045eb2	238	( $volume, $directory ) = $path =~ m@((?:[^:]+(?::\|\Z(?!\n)))?)(.*)@s;
0994714a	239	}
	240	else {
	241	$path =~
	242	m@^( (?: [^:]+: )? )
	243	( (?: .*: )? )
	244	( .* )
1b1e14d3	245	@xs;
0994714a	246	$volume = $1;
	247	$directory = $2;
	248	$file = $3;
	249	}
	250
	251	# Make sure non-empty volumes and directories end in ':'
9c045eb2	252	$volume .= ':' if $volume =~ m@[^:]\Z(?!\n)@ ;
9c045eb2	253	$directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ;
0994714a	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	#
9c045eb2	269	if ( $directories !~ m@:\Z(?!\n)@ ) {
0994714a	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 ;
1b1e14d3	292	$result =~ s@^([^/])@/$1@s ;
0994714a	293
	294	my $segment ;
	295	for $segment ( @_ ) {
9c045eb2	296	if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) {
0994714a	297	$result .= "/$segment" ;
0994714a	298	}
9c045eb2	299	elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) {
9c045eb2	300	$result =~ s@/+\Z(?!\n)@/@;
1b1e14d3	301	$segment =~ s@^/+@@s;
0994714a	302	$result .= "$segment" ;
	303	}
	304	else {
	305	$result .= $segment ;
	306	}
	307	}
	308
	309	return $result ;
	310	}
	311
	312	=item abs2rel
	313
3c32ced9	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
0994714a	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
3c32ced9	357	See L<File::Spec::Unix/rel2abs> for general documentation.
0994714a	358
3c32ced9	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.
0994714a	362
	363	=cut
	364
786b702f	365	sub rel2abs {
0994714a	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
270d1e39	386	=back
	387
	388	=head1 SEE ALSO
	389
	390	L<File::Spec>
	391
	392	=cut
	393
	394	1;