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