File/Spec/Win32.pm

package File::Spec::Win32;

use strict;

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

$VERSION = '1.5';

@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 (the File::Spec::Win32
is used also for 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;
    $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
                              'SYS:/temp',
                              'C:/temp',
                              '/tmp',
                              '/'  );
}

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 = $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 = $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 "/.".
On Win32 makes 

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

=cut

sub canonpath {
    my ($self,$path) = @_;
    my $orig_path = $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

    my ($vol,$dirs,$file) = $self->splitpath($path);
    my @dirs = $self->splitdir($dirs);
    my (@base_dirs, @path_dirs);
    my $dest = \@base_dirs;
    for my $dir (@dirs){
        $dest = \@path_dirs if $dir eq $self->updir;
        push @$dest, $dir;
    }
    # for each .. in @path_dirs pop one item from 
    # @base_dirs
    while (my $dir = shift @path_dirs){ 
        unless ($dir eq $self->updir){
            unshift @path_dirs, $dir;
            last;
        }
        pop @base_dirs;
    }
    $path = $self->catpath( 
                           $vol, 
                           $self->catdir(@base_dirs, @path_dirs), 
                           $file
                          );
    return $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{^( (?:[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) = @_;
    $base = $self->_cwd() unless defined $base and length $base;

    for ($path, $base) { $_ = $self->canonpath($_) }

    my ($path_volume) = $self->splitpath($path, 1);
    my ($base_volume) = $self->splitpath($base, 1);

    # Can't relativize across volumes
    return $path unless $path_volume eq $base_volume;

    for ($path, $base) { $_ = $self->rel2abs($_) }

    my $path_directories = ($self->splitpath($path, 1))[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 ;
    }

    my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );

    return $self->canonpath( $self->catpath('', $result_dirs, '') );
}


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

    if ( ! $self->file_name_is_absolute( $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;
Revision:	1.1
Committed:	Thu Jun 30 14:27:12 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package File::Spec::Win32;
2
3			use strict;
4
5			use vars qw(@ISA $VERSION);
6			require File::Spec::Unix;
7
8			$VERSION = '1.5';
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 (the File::Spec::Win32
52			is used also for NetWare).
53
54			Since Perl 5.8.0, if running under taint mode, and if the environment
55			variables are tainted, they are not used.
56
57			=cut
58
59			my $tmpdir;
60			sub tmpdir {
61			return $tmpdir if defined $tmpdir;
62			my $self = shift;
63			$tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
64			'SYS:/temp',
65			'C:/temp',
66			'/tmp',
67			'/' );
68			}
69
70			sub case_tolerant {
71			return 1;
72			}
73
74			sub file_name_is_absolute {
75			my ($self,$file) = @_;
76			return scalar($file =~ m{^([a-z]:)?[\\/]}is);
77			}
78
79			=item catfile
80
81			Concatenate one or more directory names and a filename to form a
82			complete path ending with a filename
83
84			=cut
85
86			sub catfile {
87			my $self = shift;
88			my $file = $self->canonpath(pop @_);
89			return $file unless @_;
90			my $dir = $self->catdir(@_);
91			$dir .= "\\" unless substr($dir,-1) eq "\\";
92			return $dir.$file;
93			}
94
95			sub catdir {
96			my $self = shift;
97			my @args = @_;
98			foreach (@args) {
99			tr[/][\\];
100			# append a backslash to each argument unless it has one there
101			$_ .= "\\" unless m{\\$};
102			}
103			return $self->canonpath(join('', @args));
104			}
105
106			sub path {
107			my $path = $ENV{'PATH'} \|\| $ENV{'Path'} \|\| $ENV{'path'};
108			my @path = split(';',$path);
109			foreach (@path) { $_ = '.' if $_ eq '' }
110			return @path;
111			}
112
113			=item canonpath
114
115			No physical check on the filesystem, but a logical cleanup of a
116			path. On UNIX eliminated successive slashes and successive "/.".
117			On Win32 makes
118
119			dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
120			dir1\dir2\dir3\...\dir4 -> \dir\dir4
121
122			=cut
123
124			sub canonpath {
125			my ($self,$path) = @_;
126			my $orig_path = $path;
127			$path =~ s/^([a-z]:)/\u$1/s;
128			$path =~ s\|/\|\\\|g;
129			$path =~ s\|([^\\])\\+\|$1\\\|g; # xx\\\\xx -> xx\xx
130			$path =~ s\|(\\\.)+\\\|\\\|g; # xx\.\.\xx -> xx\xx
131			$path =~ s\|^(\.\\)+\|\|s unless $path eq ".\\"; # .\xx -> xx
132			$path =~ s\|\\\Z(?!\n)\|\|
133			unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
134			# xx1/xx2/xx3/../../xx -> xx1/xx
135			$path =~ s\|\\\.\.\.\\\|\\\.\.\\\.\.\\\|g; # \...\ is 2 levels up
136			$path =~ s\|^\.\.\.\\\|\.\.\\\.\.\\\|g; # ...\ is 2 levels up
137			return $path if $path =~ m\|^\.\.\|; # skip relative paths
138			return $path unless $path =~ /\.\./; # too few .'s to cleanup
139			return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
140			$path =~ s{^\\\.\.$}{\\}; # \.. -> \
141			1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
142
143			my ($vol,$dirs,$file) = $self->splitpath($path);
144			my @dirs = $self->splitdir($dirs);
145			my (@base_dirs, @path_dirs);
146			my $dest = \@base_dirs;
147			for my $dir (@dirs){
148			$dest = \@path_dirs if $dir eq $self->updir;
149			push @$dest, $dir;
150			}
151			# for each .. in @path_dirs pop one item from
152			# @base_dirs
153			while (my $dir = shift @path_dirs){
154			unless ($dir eq $self->updir){
155			unshift @path_dirs, $dir;
156			last;
157			}
158			pop @base_dirs;
159			}
160			$path = $self->catpath(
161			$vol,
162			$self->catdir(@base_dirs, @path_dirs),
163			$file
164			);
165			return $path;
166			}
167
168			=item splitpath
169
170			($volume,$directories,$file) = File::Spec->splitpath( $path );
171			($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
172
173			Splits a path into volume, directory, and filename portions. Assumes that
174			the last file is a path unless the path ends in '\\', '\\.', '\\..'
175			or $no_file is true. On Win32 this means that $no_file true makes this return
176			( $volume, $path, '' ).
177
178			Separators accepted are \ and /.
179
180			Volumes can be drive letters or UNC sharenames (\\server\share).
181
182			The results can be passed to L</catpath> to get back a path equivalent to
183			(usually identical to) the original path.
184
185			=cut
186
187			sub splitpath {
188			my ($self,$path, $nofile) = @_;
189			my ($volume,$directory,$file) = ('','','');
190			if ( $nofile ) {
191			$path =~
192			m{^( (?:[a-zA-Z]:\|(?:\\\\\|//)[^\\/]+[\\/][^\\/]+)? )
193			(.*)
194			}xs;
195			$volume = $1;
196			$directory = $2;
197			}
198			else {
199			$path =~
200			m{^ ( (?: [a-zA-Z]: \|
201			(?:\\\\\|//)[^\\/]+[\\/][^\\/]+
202			)?
203			)
204			( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
205			(.*)
206			}xs;
207			$volume = $1;
208			$directory = $2;
209			$file = $3;
210			}
211
212			return ($volume,$directory,$file);
213			}
214
215
216			=item splitdir
217
218			The opposite of L<catdir()\|File::Spec/catdir()>.
219
220			@dirs = File::Spec->splitdir( $directories );
221
222			$directories must be only the directory portion of the path on systems
223			that have the concept of a volume or that have path syntax that differentiates
224			files from directories.
225
226			Unlike just splitting the directories on the separator, leading empty and
227			trailing directory entries can be returned, because these are significant
228			on some OSs. So,
229
230			File::Spec->splitdir( "/a/b/c" );
231
232			Yields:
233
234			( '', 'a', 'b', '', 'c', '' )
235
236			=cut
237
238			sub splitdir {
239			my ($self,$directories) = @_ ;
240			#
241			# split() likes to forget about trailing null fields, so here we
242			# check to be sure that there will not be any before handling the
243			# simple case.
244			#
245			if ( $directories !~ m\|[\\/]\Z(?!\n)\| ) {
246			return split( m\|[\\/]\|, $directories );
247			}
248			else {
249			#
250			# since there was a trailing separator, add a file name to the end,
251			# then do the split, then replace it with ''.
252			#
253			my( @directories )= split( m\|[\\/]\|, "${directories}dummy" ) ;
254			$directories[ $#directories ]= '' ;
255			return @directories ;
256			}
257			}
258
259
260			=item catpath
261
262			Takes volume, directory and file portions and returns an entire path. Under
263			Unix, $volume is ignored, and this is just like catfile(). On other OSs,
264			the $volume become significant.
265
266			=cut
267
268			sub catpath {
269			my ($self,$volume,$directory,$file) = @_;
270
271			# If it's UNC, make sure the glue separator is there, reusing
272			# whatever separator is first in the $volume
273			$volume .= $1
274			if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
275			$directory =~ m@^[^\\/]@s
276			) ;
277
278			$volume .= $directory ;
279
280			# If the volume is not just A:, make sure the glue separator is
281			# there, reusing whatever separator is first in the $volume if possible.
282			if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
283			$volume =~ m@[^\\/]\Z(?!\n)@ &&
284			$file =~ m@[^\\/]@
285			) {
286			$volume =~ m@([\\/])@ ;
287			my $sep = $1 ? $1 : '\\' ;
288			$volume .= $sep ;
289			}
290
291			$volume .= $file ;
292
293			return $volume ;
294			}
295
296
297			sub abs2rel {
298			my($self,$path,$base) = @_;
299			$base = $self->_cwd() unless defined $base and length $base;
300
301			for ($path, $base) { $_ = $self->canonpath($_) }
302
303			my ($path_volume) = $self->splitpath($path, 1);
304			my ($base_volume) = $self->splitpath($base, 1);
305
306			# Can't relativize across volumes
307			return $path unless $path_volume eq $base_volume;
308
309			for ($path, $base) { $_ = $self->rel2abs($_) }
310
311			my $path_directories = ($self->splitpath($path, 1))[1];
312			my $base_directories = ($self->splitpath($base, 1))[1];
313
314			# Now, remove all leading components that are the same
315			my @pathchunks = $self->splitdir( $path_directories );
316			my @basechunks = $self->splitdir( $base_directories );
317
318			while ( @pathchunks &&
319			@basechunks &&
320			lc( $pathchunks[0] ) eq lc( $basechunks[0] )
321			) {
322			shift @pathchunks ;
323			shift @basechunks ;
324			}
325
326			my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
327
328			return $self->canonpath( $self->catpath('', $result_dirs, '') );
329			}
330
331
332			sub rel2abs {
333			my ($self,$path,$base ) = @_;
334
335			if ( ! $self->file_name_is_absolute( $path ) ) {
336
337			if ( !defined( $base ) \|\| $base eq '' ) {
338			require Cwd ;
339			$base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
340			$base = $self->_cwd() unless defined $base ;
341			}
342			elsif ( ! $self->file_name_is_absolute( $base ) ) {
343			$base = $self->rel2abs( $base ) ;
344			}
345			else {
346			$base = $self->canonpath( $base ) ;
347			}
348
349			my ( $path_directories, $path_file ) =
350			($self->splitpath( $path, 1 ))[1,2] ;
351
352			my ( $base_volume, $base_directories ) =
353			$self->splitpath( $base, 1 ) ;
354
355			$path = $self->catpath(
356			$base_volume,
357			$self->catdir( $base_directories, $path_directories ),
358			$path_file
359			) ;
360			}
361
362			return $self->canonpath( $path ) ;
363			}
364
365			=back
366
367			=head2 Note For File::Spec::Win32 Maintainers
368
369			Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
370
371			=head1 COPYRIGHT
372
373			Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
374
375			This program is free software; you can redistribute it and/or modify
376			it under the same terms as Perl itself.
377
378			=head1 SEE ALSO
379
380			See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
381			implementation of these methods, not the semantics.
382
383			=cut
384
385			1;