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

package File::Spec::Win32;

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

=head1 NAME

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

=head1 SYNOPSIS

 require File::Spec::Win32; # 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.

=over

=item devnull

Returns a string representation of the null device.

=cut

sub devnull {
    return "nul";
}

=item tmpdir

Returns a string representation of the first existing directory
from the following list:

    $ENV{TMPDIR}
    $ENV{TEMP}
    $ENV{TMP}
    /tmp
    /

=cut

my $tmpdir;
sub tmpdir {
    return $tmpdir if defined $tmpdir;
    my $self = shift;
    foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) {
	next unless defined && -d;
	$tmpdir = $_;
	last;
    }
    $tmpdir = '' unless defined $tmpdir;
    $tmpdir = $self->canonpath($tmpdir);
    return $tmpdir;
}

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

=item catfile

Concatenate one or more directory names and a filename to form a
complete path ending with a filename

=cut

sub catfile {
    my $self = shift;
    my $file = pop @_;
    return $file unless @_;
    my $dir = $self->catdir(@_);
    $dir .= "\\" unless substr($dir,-1) eq "\\";
    return $dir.$file;
}

sub path {
    my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
    my @path = split(';',$path);
    foreach (@path) { $_ = '.' if $_ eq '' }
    return @path;
}

=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,$reduce_ricochet) = @_;
    $path =~ s/^([a-z]:)/\u$1/;
    $path =~ s|/|\\|g;
    $path =~ s|([^\\])\\+|$1\\|g;                  # xx////xx  -> xx/xx
    $path =~ s|(\\\.)+\\|\\|g;                     # xx/././xx -> xx/xx
    $path =~ s|^(\.\\)+|| unless $path eq ".\\";   # ./xx      -> xx
    $path =~ s|\\$||
             unless $path =~ m#^([A-Z]:)?\\$#;     # 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 /.

Volumes can be drive letters or UNC sharenames (\\server\share).

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]:|(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+)? ) 
                 (.*)
             @x;
        $volume    = $1;
        $directory = $2;
    }
    else {
        $path =~ 
            m@^ ( (?: [a-zA-Z]: |
                      (?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+
                  )?
                )
                ( (?:.*[\\\\/](?:\.\.?$)?)? )
                (.*)
             @x;
        $volume    = $1;
        $directory = $2;
        $file      = $3;
    }

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


=item splitdir

The opposite of L</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|[\\/]$| ) {
        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@^([\\/])[\\/][^\\/]+[\\/][^\\/]+$@ &&
             $directory =~ m@^[^\\/]@
           ) ;

    $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]:$@ &&
         $volume !~ m@[\\/]$@      &&
         $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()> 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()>.

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()>.

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" ;
    }

    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()> 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()>.

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 ) = @_;

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