[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 = '3.28_03';
$VERSION = eval $VERSION;

@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',
			      '/'  );
}

=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 http://cygwin.com/ml/cygwin/2007-07/msg00891.html
Default: 1

=cut

sub case_tolerant {
  eval { 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( $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,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;

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