[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 {
    local $^W = 1;
    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 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
    $base_directories =~ s|[^/]+|..|g ;

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