[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / 5.8.0 / 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
86530b38 AT	1	package File::Spec::Win32;
	2
	3	use strict;
	4	use Cwd;
	5	use vars qw(@ISA $VERSION);
	6	require File::Spec::Unix;
	7
	8	$VERSION = '1.3';
	9
	10	@ISA = qw(File::Spec::Unix);
	11
	12	=head1 NAME
	13
	14	File::Spec::Win32 - methods for Win32 file specs
	15
	16	=head1 SYNOPSIS
	17
	18	require File::Spec::Win32; # Done internally by File::Spec if needed
	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
	26	=over 4
	27
	28	=item devnull
	29
	30	Returns a string representation of the null device.
	31
	32	=cut
	33
	34	sub devnull {
	35	return "nul";
	36	}
	37
	38	=item tmpdir
	39
	40	Returns a string representation of the first existing directory
	41	from the following list:
	42
	43	$ENV{TMPDIR}
	44	$ENV{TEMP}
	45	$ENV{TMP}
	46	SYS:/temp
	47	C:/temp
	48	/tmp
	49	/
	50
	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
	54	variables are tainted, they are not used.
	55
	56	=cut
	57
	58	my $tmpdir;
	59	sub tmpdir {
	60	return $tmpdir if defined $tmpdir;
	61	my $self = shift;
	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) {
71	next unless defined && -d;
72	$tmpdir = $_;
73	last;
74	}
75	$tmpdir = '' unless defined $tmpdir;
76	$tmpdir = $self->canonpath($tmpdir);
77	return $tmpdir;
78	}
79
80	sub case_tolerant {
81	return 1;
82	}
83
84	sub file_name_is_absolute {
85	my ($self,$file) = @_;
86	return scalar($file =~ m{^([a-z]:)?[\\/]}is);
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 {
97	my $self = shift;
98	my $file = pop @_;
99	return $file unless @_;
100	my $dir = $self->catdir(@_);
101	$dir .= "\\" unless substr($dir,-1) eq "\\";
102	return $dir.$file;
103	}
104
105	sub path {
106	my $path = $ENV{'PATH'} \|\| $ENV{'Path'} \|\| $ENV{'path'};
107	my @path = split(';',$path);
108	foreach (@path) { $_ = '.' if $_ eq '' }
109	return @path;
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 {
120	my ($self,$path) = @_;
121	$path =~ s/^([a-z]:)/\u$1/s;
122	$path =~ s\|/\|\\\|g;
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
126	$path =~ s\|\\\Z(?!\n)\|\|
127	unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx\ -> xx
128	return $path;
129	}
130
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
145	The results can be passed to L</catpath> to get back a path equivalent to
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 =~
155	m{^( (?:[a-zA-Z]:\|(?:\\\\\|//)[^\\/]+[\\/][^\\/]+)? )
156	(.*)
157	}xs;
158	$volume = $1;
159	$directory = $2;
160	}
161	else {
162	$path =~
163	m{^ ( (?: [a-zA-Z]: \|
164	(?:\\\\\|//)[^\\/]+[\\/][^\\/]+
165	)?
166	)
167	( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
168	(.*)
169	}xs;
170	$volume = $1;
171	$directory = $2;
172	$file = $3;
173	}
174
175	return ($volume,$directory,$file);
176	}
177
178
179	=item splitdir
180
181	The opposite of L<catdir()\|File::Spec/catdir()>.
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	#
208	if ( $directories !~ m\|[\\/]\Z(?!\n)\| ) {
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
237	if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
238	$directory =~ m@^[^\\/]@s
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.
245	if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
246	$volume =~ m@[^\\/]\Z(?!\n)@ &&
247	$file =~ m@[^\\/]@
248	) {
249	$volume =~ m@([\\/])@ ;
250	my $sep = $1 ? $1 : '\\' ;
251	$volume .= $sep ;
252	}
253
254	$volume .= $file ;
255
256	return $volume ;
257	}
258
259
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.
272	if ( !defined( $base ) \|\| $base eq '' ) {
273	$base = cwd() ;
274	}
275	elsif ( ! $self->file_name_is_absolute( $base ) ) {
276	$base = $self->rel2abs( $base ) ;
277	}
278	else {
279	$base = $self->canonpath( $base ) ;
280	}
281
282	# Split up paths
283	my ( undef, $path_directories, $path_file ) =
284	$self->splitpath( $path, 1 ) ;
285
286	my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
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
304	# $base_directories now contains the directories the resulting relative
305	# path must ascend out of before it can descend to $path_directory. So,
306	# replace all names with $parentDir
307
308	#FA Need to replace between backslashes...
309	$base_directories =~ s\|[^\\]+\|..\|g ;
310
311	# Glue the two together, using a separator if necessary, and preventing an
312	# empty result.
313
314	#FA Must check that new directories are not empty.
315	if ( $path_directories ne '' && $base_directories ne '' ) {
316	$path_directories = "$base_directories\\$path_directories" ;
317	} else {
318	$path_directories = "$base_directories$path_directories" ;
319	}
320
321	return $self->canonpath(
322	$self->catpath( "", $path_directories, $path_file )
323	) ;
324	}
325
326
327	sub rel2abs {
328	my ($self,$path,$base ) = @_;
329
330	if ( ! $self->file_name_is_absolute( $path ) ) {
331
332	if ( !defined( $base ) \|\| $base eq '' ) {
333	$base = cwd() ;
334	}
335	elsif ( ! $self->file_name_is_absolute( $base ) ) {
336	$base = $self->rel2abs( $base ) ;
337	}
338	else {
339	$base = $self->canonpath( $base ) ;
340	}
341
342	my ( $path_directories, $path_file ) =
343	($self->splitpath( $path, 1 ))[1,2] ;
344
345	my ( $base_volume, $base_directories ) =
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
358	=back
359
360	=head2 Note For File::Spec::Win32 Maintainers
361
362	Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
363
364	=head1 SEE ALSO
365
366	L<File::Spec>
367
368	=cut
369
370	1;