[perl5.git] / dist / PathTools / lib / File / Spec / Win32.pm

package File::Spec::Win32;

use strict;

use Cwd ();
require File::Spec::Unix;

our $VERSION = '3.91';
$VERSION =~ tr/_//d;

our @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).

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

=cut

sub tmpdir {
    my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP));
    return $tmpdir if defined $tmpdir;
    $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
			      'SYS:/temp',
			      'C:\system\temp',
			      'C:/temp',
			      '/tmp',
			      '/'  );
    $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP));
}

=item case_tolerant

MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
indicating the case significance when comparing file specifications.
Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
See L<http://cygwin.com/ml/cygwin/2007-07/msg00891.html>
Default: 1

=cut

sub case_tolerant {
  eval {
    local @INC = @INC;
    pop @INC if $INC[-1] eq '.';
    require Win32API::File;
  } or return 1;
  my $drive = shift || "C:";
  my $osFsType = "\0"x256;
  my $osVolName = "\0"x256;
  my $ouFsFlags = 0;
  Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
  if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
  else { return 1; }
}

=item 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.

=cut

sub file_name_is_absolute {

    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 {
    shift;

    # Legacy / compatibility support
    #
    shift, return _canon_cat( "/", @_ )
	if !@_ || $_[0] eq "";

    # Compatibility with File::Spec <= 3.26:
    #     catfile('A:', 'foo') should return 'A:\foo'.
    return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
        if $_[0] =~ m{^$DRIVE_RX\z}o;

    return _canon_cat( @_ );
}

sub catdir {
    shift;

    # Legacy / compatibility support
    #
    return ""
    	unless @_;
    shift, return _canon_cat( "/", @_ )
	if $_[0] eq "";

    # Compatibility with File::Spec <= 3.26:
    #     catdir('A:', 'foo') should return 'A:\foo'.
    return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
        if $_[0] =~ m{^$DRIVE_RX\z}o;

    return _canon_cat( @_ );
}

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 {
    # Legacy / compatibility support
    #
    return $_[1] if !defined($_[1]) or $_[1] eq '';
    return _canon_cat( $_[1] );
}

=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( Cwd::getcwd() ))[0];
      return $self->canonpath( $vol . $path );
    }

    if ( !defined( $base ) || $base eq '' ) {
      $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
      $base = Cwd::getcwd() 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,2007 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


sub _canon_cat				# @path -> path
{
    my ($first, @rest) = @_;

    my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x	# drive letter
    	       ? ucfirst( $1 ).( $2 ? "\\" : "" )
	       : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
				 (?: [\\/] ([^\\/]+) )?
	       			 [\\/]? }{}xs			# UNC volume
	       ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
	       : $first =~ s{ \A [\\/] }{}x			# root dir
	       ? "\\"
	       : "";
    my $path   = join "\\", $first, @rest;

    $path =~ tr#\\/#\\\\#s;		# xx/yy --> xx\yy & xx\\yy --> xx\yy

    					# xx/././yy --> xx/yy
    $path =~ s{(?:
		(?:\A|\\)		# at begin or after a slash
		\.
		(?:\\\.)*		# and more
		(?:\\|\z) 		# at end or followed by slash
	       )+			# performance boost -- I do not know why
	     }{\\}gx;

    					# xx\yy\..\zz --> xx\zz
    while ( $path =~ s{(?:
		(?:\A|\\)		# at begin or after a slash
		[^\\]+			# rip this 'yy' off
		\\\.\.
		(?<!\A\.\.\\\.\.)	# do *not* replace ^..\..
		(?<!\\\.\.\\\.\.)	# do *not* replace \..\..
		(?:\\|\z) 		# at end or followed by slash
	       )+			# performance boost -- I do not know why
	     }{\\}sx ) {}

    $path =~ s#\A\\##;			# \xx --> xx  NOTE: this is *not* root
    $path =~ s#\\\z##;			# xx\ --> xx

    if ( $volume =~ m#\\\z# )
    {					# <vol>\.. --> <vol>\
	$path =~ s{ \A			# at begin
		    \.\.
		    (?:\\\.\.)*		# and more
		    (?:\\|\z) 		# at end or followed by slash
		 }{}x;

	return $1			# \\HOST\SHARE\ --> \\HOST\SHARE
	    if    $path eq ""
	      and $volume =~ m#\A(\\\\.*)\\\z#s;
    }
    return $path ne "" || $volume ? $volume.$path : ".";
}

1;
Commit	Line	Data
270d1e39 GS	1	package File::Spec::Win32;
270d1e39 GS	2
cbc7acb0	3	use strict;
07824bd1	4
a3371546	5	use Cwd ();
cbc7acb0	6	require File::Spec::Unix;
b4296952	7
aa592962	8	our $VERSION = '3.91';
4f642d62	9	$VERSION =~ tr/_//d;
b4296952	10
1a58b39a	11	our @ISA = qw(File::Spec::Unix);
cbc7acb0	12
110c90cc SP	13	# Some regexes we use for path splitting
	14	my $DRIVE_RX = '[a-zA-Z]:';
	15	my $UNC_RX = '(?:\\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
	16	my $VOL_RX = "(?:$DRIVE_RX\|$UNC_RX)";
	17
	18
270d1e39 GS	19	=head1 NAME
	20
	21	File::Spec::Win32 - methods for Win32 file specs
	22
	23	=head1 SYNOPSIS
	24
cbc7acb0	25	require File::Spec::Win32; # Done internally by File::Spec if needed
270d1e39 GS	26
	27	=head1 DESCRIPTION
	28
	29	See File::Spec::Unix for a documentation of the methods provided
	30	there. This package overrides the implementation of these methods, not
	31	the semantics.
	32
bbc7dcd2	33	=over 4
270d1e39	34
cbc7acb0	35	=item devnull
270d1e39	36
cbc7acb0	37	Returns a string representation of the null device.
270d1e39	38
cbc7acb0	39	=cut
270d1e39	40
cbc7acb0 JD	41	sub devnull {
	42	return "nul";
	43	}
270d1e39	44
486bcc50	45	sub rootdir { '\\' }
60598624 RGS	46
60598624 RGS	47
cbc7acb0	48	=item tmpdir
270d1e39	49
cbc7acb0 JD	50	Returns a string representation of the first existing directory
cbc7acb0 JD	51	from the following list:
270d1e39	52
cbc7acb0 JD	53	$ENV{TMPDIR}
	54	$ENV{TEMP}
	55	$ENV{TMP}
dd9bbc5b	56	SYS:/temp
27da23d5	57	C:\system\temp
28747828	58	C:/temp
cbc7acb0 JD	59	/tmp
	60	/
	61
27da23d5 JH	62	The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
27da23d5 JH	63	for Symbian (the File::Spec::Win32 is used also for those platforms).
dd9bbc5b	64
1d0806cf	65	If running under taint mode, and if the environment
a384e9e1 RGS	66	variables are tainted, they are not used.
a384e9e1 RGS	67
cbc7acb0	68	=cut
270d1e39	69
cbc7acb0	70	sub tmpdir {
82730d4c	71	my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP));
cbc7acb0	72	return $tmpdir if defined $tmpdir;
9d5071ba	73	$tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
07824bd1	74	'SYS:/temp',
27da23d5	75	'C:\system\temp',
07824bd1 JH	76	'C:/temp',
	77	'/tmp',
	78	'/' );
82730d4c	79	$_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP));
cbc7acb0 JD	80	}
cbc7acb0 JD	81
efa159bc RU	82	=item case_tolerant
	83
	84	MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
	85	indicating the case significance when comparing file specifications.
	86	Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
e30d9667	87	See L<http://cygwin.com/ml/cygwin/2007-07/msg00891.html>
efa159bc RU	88	Default: 1
	89
	90	=cut
	91
486bcc50	92	sub case_tolerant {
8901ddee TC	93	eval {
	94	local @INC = @INC;
	95	pop @INC if $INC[-1] eq '.';
	96	require Win32API::File;
	97	} or return 1;
a7f43cfc	98	my $drive = shift \|\| "C:";
efa159bc RU	99	my $osFsType = "\0"x256;
	100	my $osVolName = "\0"x256;
	101	my $ouFsFlags = 0;
	102	Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
	103	if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
	104	else { return 1; }
46726cbe CB	105	}
46726cbe CB	106
efa159bc RU	107	=item file_name_is_absolute
	108
	109	As of right now, this returns 2 if the path is absolute with a
	110	volume, 1 if it's absolute with no volume, 0 otherwise.
	111
	112	=cut
	113
cbc7acb0	114	sub file_name_is_absolute {
c1e8580e	115
cbc7acb0	116	my ($self,$file) = @_;
c1e8580e SP	117
	118	if ($file =~ m{^($VOL_RX)}o) {
	119	my $vol = $1;
	120	return ($vol =~ m{^$UNC_RX}o ? 2
	121	: $file =~ m{^$DRIVE_RX[\\/]}o ? 2
	122	: 0);
	123	}
	124	return $file =~ m{^[\\/]} ? 1 : 0;
270d1e39 GS	125	}
	126
	127	=item catfile
	128
	129	Concatenate one or more directory names and a filename to form a
	130	complete path ending with a filename
	131
	132	=cut
	133
	134	sub catfile {
bf7c0a3d SP	135	shift;
	136
	137	# Legacy / compatibility support
	138	#
	139	shift, return _canon_cat( "/", @_ )
81d45a9d	140	if !@_ \|\| $_[0] eq "";
bf7c0a3d	141
795ee885 SP	142	# Compatibility with File::Spec <= 3.26:
	143	# catfile('A:', 'foo') should return 'A:\foo'.
	144	return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
	145	if $_[0] =~ m{^$DRIVE_RX\z}o;
	146
bf7c0a3d	147	return _canon_cat( @_ );
270d1e39 GS	148	}
270d1e39 GS	149
638113eb	150	sub catdir {
bf7c0a3d SP	151	shift;
	152
	153	# Legacy / compatibility support
	154	#
	155	return ""
	156	unless @_;
	157	shift, return _canon_cat( "/", @_ )
	158	if $_[0] eq "";
	159
795ee885 SP	160	# Compatibility with File::Spec <= 3.26:
	161	# catdir('A:', 'foo') should return 'A:\foo'.
	162	return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
	163	if $_[0] =~ m{^$DRIVE_RX\z}o;
	164
bf7c0a3d	165	return _canon_cat( @_ );
638113eb JH	166	}
638113eb JH	167
270d1e39	168	sub path {
092026cf SH	169	my @path = split(';', $ENV{PATH});
	170	s/"//g for @path;
	171	@path = grep length, @path;
	172	unshift(@path, ".");
cbc7acb0	173	return @path;
270d1e39 GS	174	}
	175
	176	=item canonpath
	177
	178	No physical check on the filesystem, but a logical cleanup of a
	179	path. On UNIX eliminated successive slashes and successive "/.".
cc23144f	180	On Win32 makes
	181
	182	dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
	183	dir1\dir2\dir3\...\dir4 -> \dir\dir4
270d1e39 GS	184
	185	=cut
	186
	187	sub canonpath {
bf7c0a3d SP	188	# Legacy / compatibility support
	189	#
	190	return $_[1] if !defined($_[1]) or $_[1] eq '';
	191	return _canon_cat( $_[1] );
270d1e39 GS	192	}
270d1e39 GS	193
c27914c9 BS	194	=item splitpath
c27914c9 BS	195
555bd962 BG	196	($volume,$directories,$file) = File::Spec->splitpath( $path );
	197	($volume,$directories,$file) = File::Spec->splitpath( $path,
	198	$no_file );
c27914c9	199
40d020d9	200	Splits a path into volume, directory, and filename portions. Assumes that
c27914c9 BS	201	the last file is a path unless the path ends in '\\', '\\.', '\\..'
c27914c9 BS	202	or $no_file is true. On Win32 this means that $no_file true makes this return
40d020d9	203	( $volume, $path, '' ).
c27914c9 BS	204
	205	Separators accepted are \ and /.
	206
	207	Volumes can be drive letters or UNC sharenames (\\server\share).
	208
0994714a	209	The results can be passed to L</catpath> to get back a path equivalent to
c27914c9 BS	210	(usually identical to) the original path.
	211
	212	=cut
	213
	214	sub splitpath {
	215	my ($self,$path, $nofile) = @_;
	216	my ($volume,$directory,$file) = ('','','');
	217	if ( $nofile ) {
	218	$path =~
110c90cc	219	m{^ ( $VOL_RX ? ) (.*) }sox;
c27914c9 BS	220	$volume = $1;
	221	$directory = $2;
	222	}
	223	else {
	224	$path =~
110c90cc	225	m{^ ( $VOL_RX ? )
5b287435	226	( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
c27914c9	227	(.*)
110c90cc	228	}sox;
c27914c9 BS	229	$volume = $1;
	230	$directory = $2;
	231	$file = $3;
	232	}
	233
	234	return ($volume,$directory,$file);
	235	}
	236
	237
	238	=item splitdir
	239
b60bb9a0	240	The opposite of L<catdir()\|File::Spec/catdir>.
c27914c9 BS	241
	242	@dirs = File::Spec->splitdir( $directories );
	243
	244	$directories must be only the directory portion of the path on systems
	245	that have the concept of a volume or that have path syntax that differentiates
	246	files from directories.
	247
	248	Unlike just splitting the directories on the separator, leading empty and
	249	trailing directory entries can be returned, because these are significant
	250	on some OSs. So,
	251
15ecc37f	252	File::Spec->splitdir( "/a/b//c/" );
c27914c9 BS	253
	254	Yields:
	255
	256	( '', 'a', 'b', '', 'c', '' )
	257
	258	=cut
	259
	260	sub splitdir {
	261	my ($self,$directories) = @_ ;
	262	#
	263	# split() likes to forget about trailing null fields, so here we
	264	# check to be sure that there will not be any before handling the
	265	# simple case.
	266	#
9c045eb2	267	if ( $directories !~ m\|[\\/]\Z(?!\n)\| ) {
c27914c9 BS	268	return split( m\|[\\/]\|, $directories );
	269	}
	270	else {
	271	#
	272	# since there was a trailing separator, add a file name to the end,
	273	# then do the split, then replace it with ''.
	274	#
	275	my( @directories )= split( m\|[\\/]\|, "${directories}dummy" ) ;
	276	$directories[ $#directories ]= '' ;
	277	return @directories ;
	278	}
	279	}
	280
	281
	282	=item catpath
	283
	284	Takes volume, directory and file portions and returns an entire path. Under
	285	Unix, $volume is ignored, and this is just like catfile(). On other OSs,
	286	the $volume become significant.
	287
	288	=cut
	289
	290	sub catpath {
	291	my ($self,$volume,$directory,$file) = @_;
	292
	293	# If it's UNC, make sure the glue separator is there, reusing
	294	# whatever separator is first in the $volume
9596c75c RGS	295	my $v;
	296	$volume .= $v
	297	if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
1b1e14d3	298	$directory =~ m@^[^\\/]@s
c27914c9 BS	299	) ;
	300
	301	$volume .= $directory ;
	302
	303	# If the volume is not just A:, make sure the glue separator is
	304	# there, reusing whatever separator is first in the $volume if possible.
9c045eb2 GS	305	if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
9c045eb2 GS	306	$volume =~ m@[^\\/]\Z(?!\n)@ &&
0994714a	307	$file =~ m@[^\\/]@
c27914c9 BS	308	) {
	309	$volume =~ m@([\\/])@ ;
	310	my $sep = $1 ? $1 : '\\' ;
	311	$volume .= $sep ;
	312	}
	313
	314	$volume .= $file ;
	315
	316	return $volume ;
	317	}
	318
9d5071ba SP	319	sub _same {
9d5071ba SP	320	lc($_[1]) eq lc($_[2]);
c27914c9 BS	321	}
c27914c9 BS	322
786b702f	323	sub rel2abs {
c27914c9 BS	324	my ($self,$path,$base ) = @_;
c27914c9 BS	325
110c90cc SP	326	my $is_abs = $self->file_name_is_absolute($path);
	327
	328	# Check for volume (should probably document the '2' thing...)
	329	return $self->canonpath( $path ) if $is_abs == 2;
	330
	331	if ($is_abs) {
	332	# It's missing a volume, add one
a3371546	333	my $vol = ($self->splitpath( Cwd::getcwd() ))[0];
110c90cc SP	334	return $self->canonpath( $vol . $path );
	335	}
	336
	337	if ( !defined( $base ) \|\| $base eq '' ) {
110c90cc	338	$base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
a3371546	339	$base = Cwd::getcwd() unless defined $base ;
c27914c9	340	}
110c90cc SP	341	elsif ( ! $self->file_name_is_absolute( $base ) ) {
	342	$base = $self->rel2abs( $base ) ;
	343	}
	344	else {
	345	$base = $self->canonpath( $base ) ;
	346	}
	347
	348	my ( $path_directories, $path_file ) =
	349	($self->splitpath( $path, 1 ))[1,2] ;
	350
	351	my ( $base_volume, $base_directories ) =
	352	$self->splitpath( $base, 1 ) ;
	353
	354	$path = $self->catpath(
	355	$base_volume,
	356	$self->catdir( $base_directories, $path_directories ),
	357	$path_file
	358	) ;
c27914c9 BS	359
	360	return $self->canonpath( $path ) ;
	361	}
	362
270d1e39 GS	363	=back
270d1e39 GS	364
dd9bbc5b JH	365	=head2 Note For File::Spec::Win32 Maintainers
	366
	367	Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
	368
99f36a73 RGS	369	=head1 COPYRIGHT
99f36a73 RGS	370
efa159bc	371	Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
99f36a73 RGS	372
	373	This program is free software; you can redistribute it and/or modify
	374	it under the same terms as Perl itself.
	375
cbc7acb0 JD	376	=head1 SEE ALSO
cbc7acb0 JD	377
72f15715 T	378	See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
72f15715 T	379	implementation of these methods, not the semantics.
270d1e39	380
cbc7acb0 JD	381	=cut
cbc7acb0 JD	382
bf7c0a3d	383
486bcc50	384	sub _canon_cat # @path -> path
bf7c0a3d	385	{
486bcc50 NC	386	my ($first, @rest) = @_;
486bcc50 NC	387
bf7c0a3d SP	388	my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
	389	? ucfirst( $1 ).( $2 ? "\\" : "" )
	390	: $first =~ s{ \A (?:\\\\\|//) ([^\\/]+)
	391	(?: [\\/] ([^\\/]+) )?
	392	[\\/]? }{}xs # UNC volume
	393	? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
	394	: $first =~ s{ \A [\\/] }{}x # root dir
	395	? "\\"
	396	: "";
486bcc50	397	my $path = join "\\", $first, @rest;
bf7c0a3d SP	398
	399	$path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
	400
	401	# xx/././yy --> xx/yy
	402	$path =~ s{(?:
	403	(?:\A\|\\) # at begin or after a slash
	404	\.
	405	(?:\\\.)* # and more
	406	(?:\\\|\z) # at end or followed by slash
	407	)+ # performance boost -- I do not know why
	408	}{\\}gx;
	409
bf7c0a3d SP	410	# xx\yy\..\zz --> xx\zz
	411	while ( $path =~ s{(?:
	412	(?:\A\|\\) # at begin or after a slash
	413	[^\\]+ # rip this 'yy' off
	414	\\\.\.
	415	(?<!\A\.\.\\\.\.) # do not replace ^..\..
	416	(?<!\\\.\.\\\.\.) # do not replace \..\..
	417	(?:\\\|\z) # at end or followed by slash
	418	)+ # performance boost -- I do not know why
	419	}{\\}sx ) {}
	420
	421	$path =~ s#\A\\##; # \xx --> xx NOTE: this is not root
	422	$path =~ s#\\\z##; # xx\ --> xx
	423
	424	if ( $volume =~ m#\\\z# )
	425	{ # <vol>\.. --> <vol>\
	426	$path =~ s{ \A # at begin
	427	\.\.
	428	(?:\\\.\.)* # and more
	429	(?:\\\|\z) # at end or followed by slash
	430	}{}x;
	431
	432	return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
	433	if $path eq ""
	434	and $volume =~ m#\A(\\\\.*)\\\z#s;
	435	}
	436	return $path ne "" \|\| $volume ? $volume.$path : ".";
	437	}
	438
cbc7acb0	439	1;