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

package File::Spec::Win32;

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

$VERSION = '1.3';

@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 4

=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}
    SYS:/temp
    C:/temp
    /tmp
    /

The SYS:/temp is preferred in Novell NetWare.

Since Perl 5.8.0, if running under taint mode, and if the environment
variables are tainted, they are not used.

=cut

my $tmpdir;
sub tmpdir {
    return $tmpdir if defined $tmpdir;
    my $self = shift;
    my @dirlist = (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /));
    {
	no strict 'refs';
	if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
	    require Scalar::Util;
	    @dirlist = grep { ! Scalar::Util::tainted $_ } @dirlist;
	}
    }
    foreach (@dirlist) {
	next unless defined && -d;
	$tmpdir = $_;
	last;
    }
    $tmpdir = '' unless defined $tmpdir;
    $tmpdir = $self->canonpath($tmpdir);
    return $tmpdir;
}

sub case_tolerant {
    return 1;
}

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

=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) = @_;
    $path =~ s/^([a-z]:)/\u$1/s;
    $path =~ s|/|\\|g;
    $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
    $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
    $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
    $path =~ s|\\\Z(?!\n)||
             unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s;   # 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]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
                 (.*)
             }xs;
        $volume    = $1;
        $directory = $2;
    }
    else {
        $path =~ 
            m{^ ( (?: [a-zA-Z]: |
                      (?:\\\\|//)[^\\/]+[\\/][^\\/]+
                  )?
                )
                ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
                (.*)
             }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(?!\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

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(?!\n)@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(?!\n)@s &&
         $volume =~ m@[^\\/]\Z(?!\n)@      &&
         $file   =~ m@[^\\/]@
       ) {
        $volume =~ m@([\\/])@ ;
        my $sep = $1 ? $1 : '\\' ;
        $volume .= $sep ;
    }

    $volume .= $file ;

    return $volume ;
}


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 ( !defined( $base ) || $base eq '' ) {
        $base = cwd() ;
    }
    elsif ( ! $self->file_name_is_absolute( $base ) ) {
        $base = $self->rel2abs( $base ) ;
    }
    else {
        $base = $self->canonpath( $base ) ;
    }

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

    my $base_directories = ($self->splitpath( $base, 1 ))[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_directories, $path_file ) 
    ) ;
}


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 ( $path_directories, $path_file ) =
            ($self->splitpath( $path, 1 ))[1,2] ;

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

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

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

=back

=head2 Note For File::Spec::Win32 Maintainers

Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.

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