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

package File::Spec::Epoc;

our $VERSION = '1.00';

use strict;
use Cwd;
use vars qw(@ISA);
require File::Spec::Unix;
@ISA = qw(File::Spec::Unix);

=head1 NAME

File::Spec::Epoc - methods for Epoc file specs

=head1 SYNOPSIS

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

=head1 DESCRIPTION

See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.

This package is still work in progress ;-)
o.flebbe@gmx.de


=over 4

=item devnull

Returns a string representation of the null device.

=cut

sub devnull {
    return "nul:";
}

=item tmpdir

Returns a string representation of a temporay directory:

=cut

my $tmpdir;
sub tmpdir {
    return "C:/System/temp";
}

sub case_tolerant {
    return 1;
}

sub file_name_is_absolute {
    my ($self,$file) = @_;
    return scalar($file =~ m{^([a-z?]:)?[\\/]}is);
}

=item path

Takes no argument, returns the environment variable PATH as an array. Since
there is no search path supported, it returns undef, sorry.

=cut

sub path {
    return undef;
}

=item canonpath()

No physical check on the filesystem, but a logical cleanup of a
path. On UNIX eliminated successive slashes and successive "/.".

=cut

sub canonpath {
    my ($self,$path) = @_;
    $path =~ s/^([a-z]:)/\u$1/s;

    $path =~ s|/+|/|g unless($^O eq 'cygwin');     # xx////xx  -> xx/xx
    $path =~ s|(/\.)+/|/|g;                        # xx/././xx -> xx/xx
    $path =~ s|^(\./)+||s unless $path eq "./";    # ./xx      -> xx
    $path =~ s|^/(\.\./)+|/|s;                     # /../../xx -> xx
    $path =~ s|/\z|| unless $path eq "/";          # xx/       -> xx
    return $path;
}

=item splitpath

    ($volume,$directories,$file) = File::Spec->splitpath( $path );
    ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );

Splits a path in to volume, directory, and filename portions. Assumes that 
the last file is a path unless the path ends in '\\', '\\.', '\\..'
or $no_file is true.  On Win32 this means that $no_file true makes this return 
( $volume, $path, undef ).

Separators accepted are \ and /.

The results can be passed to L</catpath> to get back a path equivalent to
(usually identical to) the original path.

=cut

sub splitpath {
    my ($self,$path, $nofile) = @_;
    my ($volume,$directory,$file) = ('','','');
    if ( $nofile ) {
        $path =~ 
            m{^( (?:[a-zA-Z?]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
                 (.*)
             }xs;
        $volume    = $1;
        $directory = $2;
    }
    else {
        $path =~ 
            m{^ ( (?: [a-zA-Z?]: |
                      (?:\\\\|//)[^\\/]+[\\/][^\\/]+
                  )?
                )
                ( (?:.*[\\\\/](?:\.\.?\z)?)? )
                (.*)
             }xs;
        $volume    = $1;
        $directory = $2;
        $file      = $3;
    }

    return ($volume,$directory,$file);
}


=item splitdir

The opposite of L<catdir()|File::Spec/catdir()>.

    @dirs = File::Spec->splitdir( $directories );

$directories must be only the directory portion of the path on systems 
that have the concept of a volume or that have path syntax that differentiates
files from directories.

Unlike just splitting the directories on the separator, leading empty and 
trailing directory entries can be returned, because these are significant
on some OSs. So,

    File::Spec->splitdir( "/a/b/c" );

Yields:

    ( '', 'a', 'b', '', 'c', '' )

=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| ) {
        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

Takes volume, directory and file portions and returns an entire path. Under
Unix, $volume is ignored, and this is just like catfile(). On other OSs,
the $volume become significant.

=cut

sub catpath {
    my ($self,$volume,$directory,$file) = @_;

    # If it's UNC, make sure the glue separator is there, reusing
    # whatever separator is first in the $volume
    $volume .= $1
        if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s &&
             $directory =~ m@^[^\\/]@s
           ) ;

    $volume .= $directory ;

    # If the volume is not just A:, make sure the glue separator is 
    # there, reusing whatever separator is first in the $volume if possible.
    if ( $volume !~ m@^[a-zA-Z]:\z@s &&
         $volume =~ m@[^\\/]\z@      &&
         $file   =~ m@[^\\/]@
       ) {
        $volume =~ m@([\\/])@ ;
        my $sep = $1 ? $1 : '\\' ;
        $volume .= $sep ;
    }

    $volume .= $file ;

    return $volume ;
}


=item abs2rel

Takes a destination path and an optional base path returns a relative path
from the base path to the destination path:

    $rel_path = File::Spec->abs2rel( $destination ) ;
    $rel_path = File::Spec->abs2rel( $destination, $base ) ;

If $base is not present or '', then L<cwd()|Cwd> is used. If $base is relative, 
then it is converted to absolute form using L</rel2abs()>. This means that it
is taken to be relative to L<cwd()|Cwd>.

On systems with the concept of a volume, this assumes that both paths 
are on the $destination volume, and ignores the $base volume.

On systems that have a grammar that indicates filenames, this ignores the 
$base filename as well. Otherwise all path components are assumed to be
directories.

If $path is relative, it is converted to absolute form using L</rel2abs()>.
This means that it is taken to be relative to L<cwd()|Cwd>.

Based on code written by Shigio Yamaguchi.

No checks against the filesystem are made. 

=cut

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

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

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

    # Split up paths
    my ( $path_volume, $path_directories, $path_file ) =
        $self->splitpath( $path, 1 ) ;

    my ( undef, $base_directories, undef ) =
        $self->splitpath( $base, 1 ) ;

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

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

    # No need to catdir, we know these are well formed.
    $path_directories = CORE::join( '\\', @pathchunks );
    $base_directories = CORE::join( '\\', @basechunks );

    # $base_directories now contains the directories the resulting relative
    # path must ascend out of before it can descend to $path_directory.  So, 
    # replace all names with $parentDir

    #FA Need to replace between backslashes...
    $base_directories =~ s|[^\\]+|..|g ;

    # Glue the two together, using a separator if necessary, and preventing an
    # empty result.

    #FA Must check that new directories are not empty.
    if ( $path_directories ne '' && $base_directories ne '' ) {
        $path_directories = "$base_directories\\$path_directories" ;
    } else {
        $path_directories = "$base_directories$path_directories" ;
    }

    # It makes no sense to add a relative path to a UNC volume
    $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ;

    return $self->canonpath( 
        $self->catpath($path_volume, $path_directories, $path_file ) 
    ) ;
}

=item rel2abs()

Converts a relative path to an absolute path. 

    $abs_path = File::Spec->rel2abs( $destination ) ;
    $abs_path = File::Spec->rel2abs( $destination, $base ) ;

If $base is not present or '', then L<cwd()|Cwd> is used. If $base is relative, 
then it is converted to absolute form using L</rel2abs()>. This means that it
is taken to be relative to L<cwd()|Cwd>.

Assumes that both paths are on the $base volume, and ignores the 
$destination volume. 

On systems that have a grammar that indicates filenames, this ignores the 
$base filename as well. Otherwise all path components are assumed to be
directories.

If $path is absolute, it is cleaned up and returned using L</canonpath()>.

Based on code written by Shigio Yamaguchi.

No checks against the filesystem are made. 

=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 ) ;
        }

        my ( undef, $path_directories, $path_file ) =
            $self->splitpath( $path, 1 ) ;

        my ( $base_volume, $base_directories, undef ) =
            $self->splitpath( $base, 1 ) ;

        $path = $self->catpath( 
            $base_volume, 
            $self->catdir( $base_directories, $path_directories ), 
            $path_file
        ) ;
    }

    return $self->canonpath( $path ) ;
}

=back

=head1 SEE ALSO

L<File::Spec>

=cut

1;
Commit	Line	Data
fa6a1c44	1	package File::Spec::Epoc;
fa6a1c44	2
8de1277c	3	our $VERSION = '1.00';
8de1277c	4
fa6a1c44	5	use strict;
	6	use Cwd;
	7	use vars qw(@ISA);
	8	require File::Spec::Unix;
	9	@ISA = qw(File::Spec::Unix);
	10
	11	=head1 NAME
	12
	13	File::Spec::Epoc - methods for Epoc file specs
	14
	15	=head1 SYNOPSIS
	16
	17	require File::Spec::Epoc; # Done internally by File::Spec if needed
	18
	19	=head1 DESCRIPTION
	20
	21	See File::Spec::Unix for a documentation of the methods provided
	22	there. This package overrides the implementation of these methods, not
	23	the semantics.
	24
	25	This package is still work in progress ;-)
	26	o.flebbe@gmx.de
	27
	28
4ac9195f	29	=over 4
fa6a1c44	30
	31	=item devnull
	32
	33	Returns a string representation of the null device.
	34
	35	=cut
	36
	37	sub devnull {
	38	return "nul:";
	39	}
	40
	41	=item tmpdir
	42
	43	Returns a string representation of a temporay directory:
	44
	45	=cut
	46
	47	my $tmpdir;
	48	sub tmpdir {
	49	return "C:/System/temp";
	50	}
	51
	52	sub case_tolerant {
	53	return 1;
	54	}
	55
	56	sub file_name_is_absolute {
	57	my ($self,$file) = @_;
	58	return scalar($file =~ m{^([a-z?]:)?[\\/]}is);
	59	}
	60
	61	=item path
	62
	63	Takes no argument, returns the environment variable PATH as an array. Since
	64	there is no search path supported, it returns undef, sorry.
	65
	66	=cut
4ac9195f	67
fa6a1c44	68	sub path {
	69	return undef;
	70	}
	71
59605c55	72	=item canonpath()
fa6a1c44	73
	74	No physical check on the filesystem, but a logical cleanup of a
	75	path. On UNIX eliminated successive slashes and successive "/.".
	76
	77	=cut
	78
	79	sub canonpath {
	80	my ($self,$path) = @_;
	81	$path =~ s/^([a-z]:)/\u$1/s;
	82
	83	$path =~ s\|/+\|/\|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx
	84	$path =~ s\|(/\.)+/\|/\|g; # xx/././xx -> xx/xx
	85	$path =~ s\|^(\./)+\|\|s unless $path eq "./"; # ./xx -> xx
	86	$path =~ s\|^/(\.\./)+\|/\|s; # /../../xx -> xx
	87	$path =~ s\|/\z\|\| unless $path eq "/"; # xx/ -> xx
	88	return $path;
	89	}
	90
	91	=item splitpath
	92
	93	($volume,$directories,$file) = File::Spec->splitpath( $path );
	94	($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
	95
	96	Splits a path in to volume, directory, and filename portions. Assumes that
	97	the last file is a path unless the path ends in '\\', '\\.', '\\..'
	98	or $no_file is true. On Win32 this means that $no_file true makes this return
	99	( $volume, $path, undef ).
	100
	101	Separators accepted are \ and /.
	102
	103	The results can be passed to L</catpath> to get back a path equivalent to
	104	(usually identical to) the original path.
	105
	106	=cut
	107
	108	sub splitpath {
	109	my ($self,$path, $nofile) = @_;
	110	my ($volume,$directory,$file) = ('','','');
	111	if ( $nofile ) {
	112	$path =~
	113	m{^( (?:[a-zA-Z?]:\|(?:\\\\\|//)[^\\/]+[\\/][^\\/]+)? )
	114	(.*)
	115	}xs;
	116	$volume = $1;
	117	$directory = $2;
	118	}
	119	else {
	120	$path =~
	121	m{^ ( (?: [a-zA-Z?]: \|
	122	(?:\\\\\|//)[^\\/]+[\\/][^\\/]+
	123	)?
	124	)
	125	( (?:.*[\\\\/](?:\.\.?\z)?)? )
	126	(.*)
	127	}xs;
	128	$volume = $1;
	129	$directory = $2;
	130	$file = $3;
	131	}
	132
	133	return ($volume,$directory,$file);
	134	}
	135
	136
137	=item splitdir
138
59605c55	139	The opposite of L<catdir()\|File::Spec/catdir()>.
fa6a1c44	140
	141	@dirs = File::Spec->splitdir( $directories );
	142
	143	$directories must be only the directory portion of the path on systems
	144	that have the concept of a volume or that have path syntax that differentiates
	145	files from directories.
	146
	147	Unlike just splitting the directories on the separator, leading empty and
	148	trailing directory entries can be returned, because these are significant
	149	on some OSs. So,
	150
	151	File::Spec->splitdir( "/a/b/c" );
	152
	153	Yields:
	154
	155	( '', 'a', 'b', '', 'c', '' )
	156
	157	=cut
	158
	159	sub splitdir {
	160	my ($self,$directories) = @_ ;
	161	#
	162	# split() likes to forget about trailing null fields, so here we
	163	# check to be sure that there will not be any before handling the
	164	# simple case.
	165	#
	166	if ( $directories !~ m\|[\\/]\z\| ) {
	167	return split( m\|[\\/]\|, $directories );
	168	}
	169	else {
	170	#
	171	# since there was a trailing separator, add a file name to the end,
	172	# then do the split, then replace it with ''.
	173	#
	174	my( @directories )= split( m\|[\\/]\|, "${directories}dummy" ) ;
	175	$directories[ $#directories ]= '' ;
	176	return @directories ;
	177	}
	178	}
	179
	180
	181	=item catpath
	182
	183	Takes volume, directory and file portions and returns an entire path. Under
	184	Unix, $volume is ignored, and this is just like catfile(). On other OSs,
	185	the $volume become significant.
	186
	187	=cut
	188
	189	sub catpath {
	190	my ($self,$volume,$directory,$file) = @_;
	191
	192	# If it's UNC, make sure the glue separator is there, reusing
	193	# whatever separator is first in the $volume
	194	$volume .= $1
	195	if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s &&
	196	$directory =~ m@^[^\\/]@s
	197	) ;
	198
	199	$volume .= $directory ;
	200
	201	# If the volume is not just A:, make sure the glue separator is
	202	# there, reusing whatever separator is first in the $volume if possible.
	203	if ( $volume !~ m@^[a-zA-Z]:\z@s &&
204	$volume =~ m@[^\\/]\z@ &&
205	$file =~ m@[^\\/]@
206	) {
207	$volume =~ m@([\\/])@ ;
208	my $sep = $1 ? $1 : '\\' ;
209	$volume .= $sep ;
210	}
211
212	$volume .= $file ;
213
214	return $volume ;
215	}
216
217
218	=item abs2rel
219
220	Takes a destination path and an optional base path returns a relative path
221	from the base path to the destination path:
222
223	$rel_path = File::Spec->abs2rel( $destination ) ;
224	$rel_path = File::Spec->abs2rel( $destination, $base ) ;
225
59605c55	226	If $base is not present or '', then L<cwd()\|Cwd> is used. If $base is relative,
fa6a1c44	227	then it is converted to absolute form using L</rel2abs()>. This means that it
59605c55	228	is taken to be relative to L<cwd()\|Cwd>.
fa6a1c44	229
	230	On systems with the concept of a volume, this assumes that both paths
	231	are on the $destination volume, and ignores the $base volume.
	232
	233	On systems that have a grammar that indicates filenames, this ignores the
	234	$base filename as well. Otherwise all path components are assumed to be
	235	directories.
	236
	237	If $path is relative, it is converted to absolute form using L</rel2abs()>.
59605c55	238	This means that it is taken to be relative to L<cwd()\|Cwd>.
fa6a1c44	239
	240	Based on code written by Shigio Yamaguchi.
	241
	242	No checks against the filesystem are made.
	243
	244	=cut
	245
	246	sub abs2rel {
	247	my($self,$path,$base) = @_;
	248
	249	# Clean up $path
	250	if ( ! $self->file_name_is_absolute( $path ) ) {
	251	$path = $self->rel2abs( $path ) ;
	252	}
	253	else {
	254	$path = $self->canonpath( $path ) ;
	255	}
	256
	257	# Figure out the effective $base and clean it up.
	258	if ( ! $self->file_name_is_absolute( $base ) ) {
	259	$base = $self->rel2abs( $base ) ;
	260	}
	261	elsif ( !defined( $base ) \|\| $base eq '' ) {
	262	$base = cwd() ;
	263	}
	264	else {
	265	$base = $self->canonpath( $base ) ;
	266	}
	267
	268	# Split up paths
	269	my ( $path_volume, $path_directories, $path_file ) =
	270	$self->splitpath( $path, 1 ) ;
	271
	272	my ( undef, $base_directories, undef ) =
	273	$self->splitpath( $base, 1 ) ;
	274
	275	# Now, remove all leading components that are the same
	276	my @pathchunks = $self->splitdir( $path_directories );
	277	my @basechunks = $self->splitdir( $base_directories );
	278
	279	while ( @pathchunks &&
	280	@basechunks &&
	281	lc( $pathchunks[0] ) eq lc( $basechunks[0] )
	282	) {
	283	shift @pathchunks ;
	284	shift @basechunks ;
	285	}
	286
	287	# No need to catdir, we know these are well formed.
	288	$path_directories = CORE::join( '\\', @pathchunks );
	289	$base_directories = CORE::join( '\\', @basechunks );
	290
	291	# $base_directories now contains the directories the resulting relative
	292	# path must ascend out of before it can descend to $path_directory. So,
	293	# replace all names with $parentDir
	294
	295	#FA Need to replace between backslashes...
	296	$base_directories =~ s\|[^\\]+\|..\|g ;
	297
	298	# Glue the two together, using a separator if necessary, and preventing an
	299	# empty result.
	300
	301	#FA Must check that new directories are not empty.
	302	if ( $path_directories ne '' && $base_directories ne '' ) {
303	$path_directories = "$base_directories\\$path_directories" ;
304	} else {
305	$path_directories = "$base_directories$path_directories" ;
306	}
307
308	# It makes no sense to add a relative path to a UNC volume
309	$path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ;
310
311	return $self->canonpath(
312	$self->catpath($path_volume, $path_directories, $path_file )
313	) ;
314	}
315
59605c55	316	=item rel2abs()
fa6a1c44	317
	318	Converts a relative path to an absolute path.
	319
	320	$abs_path = File::Spec->rel2abs( $destination ) ;
	321	$abs_path = File::Spec->rel2abs( $destination, $base ) ;
	322
59605c55	323	If $base is not present or '', then L<cwd()\|Cwd> is used. If $base is relative,
fa6a1c44	324	then it is converted to absolute form using L</rel2abs()>. This means that it
59605c55	325	is taken to be relative to L<cwd()\|Cwd>.
fa6a1c44	326
	327	Assumes that both paths are on the $base volume, and ignores the
	328	$destination volume.
	329
	330	On systems that have a grammar that indicates filenames, this ignores the
	331	$base filename as well. Otherwise all path components are assumed to be
	332	directories.
	333
	334	If $path is absolute, it is cleaned up and returned using L</canonpath()>.
	335
	336	Based on code written by Shigio Yamaguchi.
	337
	338	No checks against the filesystem are made.
	339
	340	=cut
	341
	342	sub rel2abs($;$;) {
	343	my ($self,$path,$base ) = @_;
	344
	345	if ( ! $self->file_name_is_absolute( $path ) ) {
	346
	347	if ( !defined( $base ) \|\| $base eq '' ) {
	348	$base = cwd() ;
	349	}
	350	elsif ( ! $self->file_name_is_absolute( $base ) ) {
	351	$base = $self->rel2abs( $base ) ;
	352	}
	353	else {
	354	$base = $self->canonpath( $base ) ;
	355	}
	356
	357	my ( undef, $path_directories, $path_file ) =
	358	$self->splitpath( $path, 1 ) ;
	359
	360	my ( $base_volume, $base_directories, undef ) =
	361	$self->splitpath( $base, 1 ) ;
	362
	363	$path = $self->catpath(
	364	$base_volume,
	365	$self->catdir( $base_directories, $path_directories ),
	366	$path_file
	367	) ;
	368	}
	369
	370	return $self->canonpath( $path ) ;
	371	}
	372
	373	=back
	374
	375	=head1 SEE ALSO
	376
	377	L<File::Spec>
	378
	379	=cut
	380
	381	1;