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

package File::Spec::Win32;

use strict;

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

$VERSION = '1.6';

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

# Some regexes we use for path splitting
my $DRIVE_RX = '[a-zA-Z]:';
my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";


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

sub rootdir () { '\\' }


=item tmpdir

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

    $ENV{TMPDIR}
    $ENV{TEMP}
    $ENV{TMP}
    SYS:/temp
    C:\system\temp
    C:/temp
    /tmp
    /

The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
for Symbian (the File::Spec::Win32 is used also for those platforms).

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;
    $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
			      'SYS:/temp',
			      'C:\system\temp',
			      'C:/temp',
			      '/tmp',
			      '/'  );
}

sub case_tolerant {
    return 1;
}

sub file_name_is_absolute {
    my ($self,$file) = @_;
    return $file =~ m{^$VOL_RX}os ? 2 :
           $file =~   m{^[\\/]}is ? 1 :
           0;
}

=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 = $self->canonpath(pop @_);
    return $file unless @_;
    my $dir = $self->catdir(@_);
    $dir .= "\\" unless substr($dir,-1) eq "\\";
    return $dir.$file;
}

sub catdir {
    my $self = shift;
    my @args = @_;
    foreach (@args) {
	tr[/][\\];
        # append a backslash to each argument unless it has one there
        $_ .= "\\" unless m{\\$};
    }
    return $self->canonpath(join('', @args));
}

sub path {
    my @path = split(';', $ENV{PATH});
    s/"//g for @path;
    @path = grep length, @path;
    unshift(@path, ".");
    return @path;
}

=item canonpath

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

	dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
	dir1\dir2\dir3\...\dir4   -> \dir\dir4

=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
    # xx1/xx2/xx3/../../xx -> xx1/xx
    $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
    $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
    return $path if $path =~ m|^\.\.|;      # skip relative paths
    return $path unless $path =~ /\.\./;    # too few .'s to cleanup
    return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
    $path =~ s{^\\\.\.$}{\\};                      # \..    -> \
    1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx

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

=item splitpath

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

Splits a path into 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, '' ).

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{^ ( $VOL_RX ? ) (.*) }sox;
        $volume    = $1;
        $directory = $2;
    }
    else {
        $path =~ 
            m{^ ( $VOL_RX ? )
                ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
                (.*)
             }sox;
        $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
    my $v;
    $volume .= $v
        if ( (($v) = $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 _same {
  lc($_[1]) eq lc($_[2]);
}

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

    my $is_abs = $self->file_name_is_absolute($path);

    # Check for volume (should probably document the '2' thing...)
    return $self->canonpath( $path ) if $is_abs == 2;

    if ($is_abs) {
      # It's missing a volume, add one
      my $vol = ($self->splitpath( $self->_cwd() ))[0];
      return $self->canonpath( $vol . $path );
    }

    if ( !defined( $base ) || $base eq '' ) {
      require Cwd ;
      $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
      $base = $self->_cwd() unless defined $base ;
    }
    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 COPYRIGHT

Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
implementation of these methods, not the semantics.

=cut

1;
Commit	Line	Data
270d1e39	1	package File::Spec::Win32;
270d1e39	2
cbc7acb0	3	use strict;
07824bd1	4
b4296952	5	use vars qw(@ISA $VERSION);
cbc7acb0	6	require File::Spec::Unix;
b4296952	7
f5f48b4d	8	$VERSION = '1.6';
b4296952	9
cbc7acb0	10	@ISA = qw(File::Spec::Unix);
cbc7acb0	11
110c90cc	12	# Some regexes we use for path splitting
	13	my $DRIVE_RX = '[a-zA-Z]:';
	14	my $UNC_RX = '(?:\\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
	15	my $VOL_RX = "(?:$DRIVE_RX\|$UNC_RX)";
	16
	17
270d1e39	18	=head1 NAME
	19
	20	File::Spec::Win32 - methods for Win32 file specs
	21
	22	=head1 SYNOPSIS
	23
cbc7acb0	24	require File::Spec::Win32; # Done internally by File::Spec if needed
270d1e39	25
	26	=head1 DESCRIPTION
	27
	28	See File::Spec::Unix for a documentation of the methods provided
	29	there. This package overrides the implementation of these methods, not
	30	the semantics.
	31
bbc7dcd2	32	=over 4
270d1e39	33
cbc7acb0	34	=item devnull
270d1e39	35
cbc7acb0	36	Returns a string representation of the null device.
270d1e39	37
cbc7acb0	38	=cut
270d1e39	39
cbc7acb0	40	sub devnull {
	41	return "nul";
	42	}
270d1e39	43
60598624	44	sub rootdir () { '\\' }
	45
	46
cbc7acb0	47	=item tmpdir
270d1e39	48
cbc7acb0	49	Returns a string representation of the first existing directory
cbc7acb0	50	from the following list:
270d1e39	51
cbc7acb0	52	$ENV{TMPDIR}
	53	$ENV{TEMP}
	54	$ENV{TMP}
dd9bbc5b	55	SYS:/temp
27da23d5	56	C:\system\temp
28747828	57	C:/temp
cbc7acb0	58	/tmp
	59	/
	60
27da23d5	61	The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
27da23d5	62	for Symbian (the File::Spec::Win32 is used also for those platforms).
dd9bbc5b	63
dd9bbc5b	64	Since Perl 5.8.0, if running under taint mode, and if the environment
a384e9e1	65	variables are tainted, they are not used.
a384e9e1	66
cbc7acb0	67	=cut
270d1e39	68
cbc7acb0	69	my $tmpdir;
	70	sub tmpdir {
	71	return $tmpdir if defined $tmpdir;
9d5071ba	72	$tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
07824bd1	73	'SYS:/temp',
27da23d5	74	'C:\system\temp',
07824bd1	75	'C:/temp',
	76	'/tmp',
	77	'/' );
cbc7acb0	78	}
cbc7acb0	79
46726cbe	80	sub case_tolerant {
	81	return 1;
	82	}
	83
cbc7acb0	84	sub file_name_is_absolute {
cbc7acb0	85	my ($self,$file) = @_;
110c90cc	86	return $file =~ m{^$VOL_RX}os ? 2 :
	87	$file =~ m{^[\\/]}is ? 1 :
	88	0;
270d1e39	89	}
	90
	91	=item catfile
	92
	93	Concatenate one or more directory names and a filename to form a
	94	complete path ending with a filename
	95
	96	=cut
	97
	98	sub catfile {
cbc7acb0	99	my $self = shift;
02961b52	100	my $file = $self->canonpath(pop @_);
270d1e39	101	return $file unless @_;
270d1e39	102	my $dir = $self->catdir(@_);
cbc7acb0	103	$dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39	104	return $dir.$file;
	105	}
	106
638113eb	107	sub catdir {
	108	my $self = shift;
	109	my @args = @_;
	110	foreach (@args) {
	111	tr[/][\\];
	112	# append a backslash to each argument unless it has one there
	113	$_ .= "\\" unless m{\\$};
	114	}
	115	return $self->canonpath(join('', @args));
	116	}
	117
270d1e39	118	sub path {
092026cf	119	my @path = split(';', $ENV{PATH});
	120	s/"//g for @path;
	121	@path = grep length, @path;
	122	unshift(@path, ".");
cbc7acb0	123	return @path;
270d1e39	124	}
	125
	126	=item canonpath
	127
	128	No physical check on the filesystem, but a logical cleanup of a
	129	path. On UNIX eliminated successive slashes and successive "/.".
cc23144f	130	On Win32 makes
	131
	132	dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
	133	dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39	134
	135	=cut
	136
	137	sub canonpath {
0994714a	138	my ($self,$path) = @_;
9596c75c	139
1b1e14d3	140	$path =~ s/^([a-z]:)/\u$1/s;
270d1e39	141	$path =~ s\|/\|\\\|g;
ecf68df6	142	$path =~ s\|([^\\])\\+\|$1\\\|g; # xx\\\\xx -> xx\xx
	143	$path =~ s\|(\\\.)+\\\|\\\|g; # xx\.\.\xx -> xx\xx
	144	$path =~ s\|^(\.\\)+\|\|s unless $path eq ".\\"; # .\xx -> xx
9c045eb2	145	$path =~ s\|\\\Z(?!\n)\|\|
e021ab8e	146	unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
	147	# xx1/xx2/xx3/../../xx -> xx1/xx
	148	$path =~ s\|\\\.\.\.\\\|\\\.\.\\\.\.\\\|g; # \...\ is 2 levels up
	149	$path =~ s\|^\.\.\.\\\|\.\.\\\.\.\\\|g; # ...\ is 2 levels up
	150	return $path if $path =~ m\|^\.\.\|; # skip relative paths
	151	return $path unless $path =~ /\.\./; # too few .'s to cleanup
	152	return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
638113eb	153	$path =~ s{^\\\.\.$}{\\}; # \.. -> \
e021ab8e	154	1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
e021ab8e	155
9596c75c	156	return $self->_collapse($path);
270d1e39	157	}
270d1e39	158
c27914c9	159	=item splitpath
	160
	161	($volume,$directories,$file) = File::Spec->splitpath( $path );
	162	($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
	163
40d020d9	164	Splits a path into volume, directory, and filename portions. Assumes that
c27914c9	165	the last file is a path unless the path ends in '\\', '\\.', '\\..'
c27914c9	166	or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9	167	( $volume, $path, '' ).
c27914c9	168
	169	Separators accepted are \ and /.
	170
	171	Volumes can be drive letters or UNC sharenames (\\server\share).
	172
0994714a	173	The results can be passed to L</catpath> to get back a path equivalent to
c27914c9	174	(usually identical to) the original path.
	175
	176	=cut
	177
	178	sub splitpath {
	179	my ($self,$path, $nofile) = @_;
	180	my ($volume,$directory,$file) = ('','','');
	181	if ( $nofile ) {
	182	$path =~
110c90cc	183	m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9	184	$volume = $1;
	185	$directory = $2;
	186	}
	187	else {
	188	$path =~
110c90cc	189	m{^ ( $VOL_RX ? )
5b287435	190	( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9	191	(.*)
110c90cc	192	}sox;
c27914c9	193	$volume = $1;
	194	$directory = $2;
	195	$file = $3;
	196	}
	197
	198	return ($volume,$directory,$file);
	199	}
	200
	201
	202	=item splitdir
	203
59605c55	204	The opposite of L<catdir()\|File::Spec/catdir()>.
c27914c9	205
	206	@dirs = File::Spec->splitdir( $directories );
	207
	208	$directories must be only the directory portion of the path on systems
	209	that have the concept of a volume or that have path syntax that differentiates
	210	files from directories.
	211
	212	Unlike just splitting the directories on the separator, leading empty and
	213	trailing directory entries can be returned, because these are significant
	214	on some OSs. So,
	215
	216	File::Spec->splitdir( "/a/b/c" );
	217
	218	Yields:
	219
	220	( '', 'a', 'b', '', 'c', '' )
	221
	222	=cut
	223
	224	sub splitdir {
	225	my ($self,$directories) = @_ ;
	226	#
	227	# split() likes to forget about trailing null fields, so here we
	228	# check to be sure that there will not be any before handling the
	229	# simple case.
	230	#
9c045eb2	231	if ( $directories !~ m\|[\\/]\Z(?!\n)\| ) {
c27914c9	232	return split( m\|[\\/]\|, $directories );
	233	}
	234	else {
	235	#
	236	# since there was a trailing separator, add a file name to the end,
	237	# then do the split, then replace it with ''.
	238	#
	239	my( @directories )= split( m\|[\\/]\|, "${directories}dummy" ) ;
	240	$directories[ $#directories ]= '' ;
	241	return @directories ;
	242	}
	243	}
	244
	245
	246	=item catpath
	247
	248	Takes volume, directory and file portions and returns an entire path. Under
	249	Unix, $volume is ignored, and this is just like catfile(). On other OSs,
	250	the $volume become significant.
	251
	252	=cut
	253
	254	sub catpath {
	255	my ($self,$volume,$directory,$file) = @_;
	256
	257	# If it's UNC, make sure the glue separator is there, reusing
	258	# whatever separator is first in the $volume
9596c75c	259	my $v;
	260	$volume .= $v
	261	if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3	262	$directory =~ m@^[^\\/]@s
c27914c9	263	) ;
	264
	265	$volume .= $directory ;
	266
	267	# If the volume is not just A:, make sure the glue separator is
	268	# there, reusing whatever separator is first in the $volume if possible.
9c045eb2	269	if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
9c045eb2	270	$volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a	271	$file =~ m@[^\\/]@
c27914c9	272	) {
	273	$volume =~ m@([\\/])@ ;
	274	my $sep = $1 ? $1 : '\\' ;
	275	$volume .= $sep ;
	276	}
	277
	278	$volume .= $file ;
	279
	280	return $volume ;
	281	}
	282
9d5071ba	283	sub _same {
9d5071ba	284	lc($_[1]) eq lc($_[2]);
c27914c9	285	}
c27914c9	286
786b702f	287	sub rel2abs {
c27914c9	288	my ($self,$path,$base ) = @_;
c27914c9	289
110c90cc	290	my $is_abs = $self->file_name_is_absolute($path);
	291
	292	# Check for volume (should probably document the '2' thing...)
	293	return $self->canonpath( $path ) if $is_abs == 2;
	294
	295	if ($is_abs) {
	296	# It's missing a volume, add one
	297	my $vol = ($self->splitpath( $self->_cwd() ))[0];
	298	return $self->canonpath( $vol . $path );
	299	}
	300
	301	if ( !defined( $base ) \|\| $base eq '' ) {
	302	require Cwd ;
	303	$base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
	304	$base = $self->_cwd() unless defined $base ;
c27914c9	305	}
110c90cc	306	elsif ( ! $self->file_name_is_absolute( $base ) ) {
	307	$base = $self->rel2abs( $base ) ;
	308	}
	309	else {
	310	$base = $self->canonpath( $base ) ;
	311	}
	312
	313	my ( $path_directories, $path_file ) =
	314	($self->splitpath( $path, 1 ))[1,2] ;
	315
	316	my ( $base_volume, $base_directories ) =
	317	$self->splitpath( $base, 1 ) ;
	318
	319	$path = $self->catpath(
	320	$base_volume,
	321	$self->catdir( $base_directories, $path_directories ),
	322	$path_file
	323	) ;
c27914c9	324
	325	return $self->canonpath( $path ) ;
	326	}
	327
270d1e39	328	=back
270d1e39	329
dd9bbc5b	330	=head2 Note For File::Spec::Win32 Maintainers
	331
	332	Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
	333
99f36a73	334	=head1 COPYRIGHT
	335
	336	Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
	337
	338	This program is free software; you can redistribute it and/or modify
	339	it under the same terms as Perl itself.
	340
cbc7acb0	341	=head1 SEE ALSO
cbc7acb0	342
72f15715	343	See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
72f15715	344	implementation of these methods, not the semantics.
270d1e39	345
cbc7acb0	346	=cut
	347
	348	1;