[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 {
    # As of right now, this returns 2 if the path is absolute with a
    # volume, 1 if it's absolute with no volume, 0 otherwise.

    my ($self,$file) = @_;

    if ($file =~ m{^($VOL_RX)}o) {
      my $vol = $1;
      return ($vol =~ m{^$UNC_RX}o ? 2
	      : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
	      : 0);
    }
    return $file =~  m{^[\\/]} ? 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 {
c1e8580e	85	# As of right now, this returns 2 if the path is absolute with a
	86	# volume, 1 if it's absolute with no volume, 0 otherwise.
	87
cbc7acb0	88	my ($self,$file) = @_;
c1e8580e	89
	90	if ($file =~ m{^($VOL_RX)}o) {
	91	my $vol = $1;
	92	return ($vol =~ m{^$UNC_RX}o ? 2
	93	: $file =~ m{^$DRIVE_RX[\\/]}o ? 2
	94	: 0);
	95	}
	96	return $file =~ m{^[\\/]} ? 1 : 0;
270d1e39	97	}
	98
	99	=item catfile
	100
	101	Concatenate one or more directory names and a filename to form a
	102	complete path ending with a filename
	103
	104	=cut
	105
	106	sub catfile {
cbc7acb0	107	my $self = shift;
02961b52	108	my $file = $self->canonpath(pop @_);
270d1e39	109	return $file unless @_;
270d1e39	110	my $dir = $self->catdir(@_);
cbc7acb0	111	$dir .= "\\" unless substr($dir,-1) eq "\\";
270d1e39	112	return $dir.$file;
	113	}
	114
638113eb	115	sub catdir {
	116	my $self = shift;
	117	my @args = @_;
	118	foreach (@args) {
	119	tr[/][\\];
	120	# append a backslash to each argument unless it has one there
	121	$_ .= "\\" unless m{\\$};
	122	}
	123	return $self->canonpath(join('', @args));
	124	}
	125
270d1e39	126	sub path {
092026cf	127	my @path = split(';', $ENV{PATH});
	128	s/"//g for @path;
	129	@path = grep length, @path;
	130	unshift(@path, ".");
cbc7acb0	131	return @path;
270d1e39	132	}
	133
	134	=item canonpath
	135
	136	No physical check on the filesystem, but a logical cleanup of a
	137	path. On UNIX eliminated successive slashes and successive "/.".
cc23144f	138	On Win32 makes
	139
	140	dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
	141	dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39	142
	143	=cut
	144
	145	sub canonpath {
0994714a	146	my ($self,$path) = @_;
9596c75c	147
1b1e14d3	148	$path =~ s/^([a-z]:)/\u$1/s;
270d1e39	149	$path =~ s\|/\|\\\|g;
ecf68df6	150	$path =~ s\|([^\\])\\+\|$1\\\|g; # xx\\\\xx -> xx\xx
	151	$path =~ s\|(\\\.)+\\\|\\\|g; # xx\.\.\xx -> xx\xx
	152	$path =~ s\|^(\.\\)+\|\|s unless $path eq ".\\"; # .\xx -> xx
9c045eb2	153	$path =~ s\|\\\Z(?!\n)\|\|
e021ab8e	154	unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
	155	# xx1/xx2/xx3/../../xx -> xx1/xx
	156	$path =~ s\|\\\.\.\.\\\|\\\.\.\\\.\.\\\|g; # \...\ is 2 levels up
	157	$path =~ s\|^\.\.\.\\\|\.\.\\\.\.\\\|g; # ...\ is 2 levels up
	158	return $path if $path =~ m\|^\.\.\|; # skip relative paths
	159	return $path unless $path =~ /\.\./; # too few .'s to cleanup
	160	return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
638113eb	161	$path =~ s{^\\\.\.$}{\\}; # \.. -> \
e021ab8e	162	1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
e021ab8e	163
9596c75c	164	return $self->_collapse($path);
270d1e39	165	}
270d1e39	166
c27914c9	167	=item splitpath
	168
	169	($volume,$directories,$file) = File::Spec->splitpath( $path );
	170	($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
	171
40d020d9	172	Splits a path into volume, directory, and filename portions. Assumes that
c27914c9	173	the last file is a path unless the path ends in '\\', '\\.', '\\..'
c27914c9	174	or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9	175	( $volume, $path, '' ).
c27914c9	176
	177	Separators accepted are \ and /.
	178
	179	Volumes can be drive letters or UNC sharenames (\\server\share).
	180
0994714a	181	The results can be passed to L</catpath> to get back a path equivalent to
c27914c9	182	(usually identical to) the original path.
	183
	184	=cut
	185
	186	sub splitpath {
	187	my ($self,$path, $nofile) = @_;
	188	my ($volume,$directory,$file) = ('','','');
	189	if ( $nofile ) {
	190	$path =~
110c90cc	191	m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9	192	$volume = $1;
	193	$directory = $2;
	194	}
	195	else {
	196	$path =~
110c90cc	197	m{^ ( $VOL_RX ? )
5b287435	198	( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9	199	(.*)
110c90cc	200	}sox;
c27914c9	201	$volume = $1;
	202	$directory = $2;
	203	$file = $3;
	204	}
	205
	206	return ($volume,$directory,$file);
	207	}
	208
	209
	210	=item splitdir
	211
59605c55	212	The opposite of L<catdir()\|File::Spec/catdir()>.
c27914c9	213
	214	@dirs = File::Spec->splitdir( $directories );
	215
	216	$directories must be only the directory portion of the path on systems
	217	that have the concept of a volume or that have path syntax that differentiates
	218	files from directories.
	219
	220	Unlike just splitting the directories on the separator, leading empty and
	221	trailing directory entries can be returned, because these are significant
	222	on some OSs. So,
	223
	224	File::Spec->splitdir( "/a/b/c" );
	225
	226	Yields:
	227
	228	( '', 'a', 'b', '', 'c', '' )
	229
	230	=cut
	231
	232	sub splitdir {
	233	my ($self,$directories) = @_ ;
	234	#
	235	# split() likes to forget about trailing null fields, so here we
	236	# check to be sure that there will not be any before handling the
	237	# simple case.
	238	#
9c045eb2	239	if ( $directories !~ m\|[\\/]\Z(?!\n)\| ) {
c27914c9	240	return split( m\|[\\/]\|, $directories );
	241	}
	242	else {
	243	#
	244	# since there was a trailing separator, add a file name to the end,
	245	# then do the split, then replace it with ''.
	246	#
	247	my( @directories )= split( m\|[\\/]\|, "${directories}dummy" ) ;
	248	$directories[ $#directories ]= '' ;
	249	return @directories ;
	250	}
	251	}
	252
	253
	254	=item catpath
	255
	256	Takes volume, directory and file portions and returns an entire path. Under
	257	Unix, $volume is ignored, and this is just like catfile(). On other OSs,
	258	the $volume become significant.
	259
	260	=cut
	261
	262	sub catpath {
	263	my ($self,$volume,$directory,$file) = @_;
	264
	265	# If it's UNC, make sure the glue separator is there, reusing
	266	# whatever separator is first in the $volume
9596c75c	267	my $v;
	268	$volume .= $v
	269	if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3	270	$directory =~ m@^[^\\/]@s
c27914c9	271	) ;
	272
	273	$volume .= $directory ;
	274
	275	# If the volume is not just A:, make sure the glue separator is
	276	# there, reusing whatever separator is first in the $volume if possible.
9c045eb2	277	if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
9c045eb2	278	$volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a	279	$file =~ m@[^\\/]@
c27914c9	280	) {
	281	$volume =~ m@([\\/])@ ;
	282	my $sep = $1 ? $1 : '\\' ;
	283	$volume .= $sep ;
	284	}
	285
	286	$volume .= $file ;
	287
	288	return $volume ;
	289	}
	290
9d5071ba	291	sub _same {
9d5071ba	292	lc($_[1]) eq lc($_[2]);
c27914c9	293	}
c27914c9	294
786b702f	295	sub rel2abs {
c27914c9	296	my ($self,$path,$base ) = @_;
c27914c9	297
110c90cc	298	my $is_abs = $self->file_name_is_absolute($path);
	299
	300	# Check for volume (should probably document the '2' thing...)
	301	return $self->canonpath( $path ) if $is_abs == 2;
	302
	303	if ($is_abs) {
	304	# It's missing a volume, add one
	305	my $vol = ($self->splitpath( $self->_cwd() ))[0];
	306	return $self->canonpath( $vol . $path );
	307	}
	308
	309	if ( !defined( $base ) \|\| $base eq '' ) {
	310	require Cwd ;
	311	$base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
	312	$base = $self->_cwd() unless defined $base ;
c27914c9	313	}
110c90cc	314	elsif ( ! $self->file_name_is_absolute( $base ) ) {
	315	$base = $self->rel2abs( $base ) ;
	316	}
	317	else {
	318	$base = $self->canonpath( $base ) ;
	319	}
	320
	321	my ( $path_directories, $path_file ) =
	322	($self->splitpath( $path, 1 ))[1,2] ;
	323
	324	my ( $base_volume, $base_directories ) =
	325	$self->splitpath( $base, 1 ) ;
	326
	327	$path = $self->catpath(
	328	$base_volume,
	329	$self->catdir( $base_directories, $path_directories ),
	330	$path_file
	331	) ;
c27914c9	332
	333	return $self->canonpath( $path ) ;
	334	}
	335
270d1e39	336	=back
270d1e39	337
dd9bbc5b	338	=head2 Note For File::Spec::Win32 Maintainers
	339
	340	Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
	341
99f36a73	342	=head1 COPYRIGHT
	343
	344	Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
	345
	346	This program is free software; you can redistribute it and/or modify
	347	it under the same terms as Perl itself.
	348
cbc7acb0	349	=head1 SEE ALSO
cbc7acb0	350
72f15715	351	See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
72f15715	352	implementation of these methods, not the semantics.
270d1e39	353
cbc7acb0	354	=cut
	355
	356	1;