1package File::Spec::Win32;
2
3use strict;
4
5use vars qw(@ISA $VERSION);
6require File::Spec::Unix;
7
8$VERSION = '1.4';
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
38=item tmpdir
39
40Returns a string representation of the first existing directory
41from the following list:
42
43    $ENV{TMPDIR}
44    $ENV{TEMP}
45    $ENV{TMP}
46    SYS:/temp
47    C:/temp
48    /tmp
49    /
50
51The SYS:/temp is preferred in Novell NetWare (the File::Spec::Win32
52is used also for NetWare).
53
54Since Perl 5.8.0, if running under taint mode, and if the environment
55variables are tainted, they are not used.
56
57=cut
58
59my $tmpdir;
60sub 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
70sub case_tolerant {
71    return 1;
72}
73
74sub file_name_is_absolute {
75    my ($self,$file) = @_;
76    return scalar($file =~ m{^([a-z]:)?[\\/]}is);
77}
78
79=item catfile
80
81Concatenate one or more directory names and a filename to form a
82complete path ending with a filename
83
84=cut
85
86sub 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
95sub 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
106sub 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
115No physical check on the filesystem, but a logical cleanup of a
116path. On UNIX eliminated successive slashes and successive "/.".
117On Win32 makes
118
119	dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
120	dir1\dir2\dir3\...\dir4   -> \dir\dir4
121
122=cut
123
124sub 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
173Splits a path into volume, directory, and filename portions. Assumes that
174the last file is a path unless the path ends in '\\', '\\.', '\\..'
175or $no_file is true.  On Win32 this means that $no_file true makes this return
176( $volume, $path, '' ).
177
178Separators accepted are \ and /.
179
180Volumes can be drive letters or UNC sharenames (\\server\share).
181
182The 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
187sub 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
218The 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
223that have the concept of a volume or that have path syntax that differentiates
224files from directories.
225
226Unlike just splitting the directories on the separator, leading empty and
227trailing directory entries can be returned, because these are significant
228on some OSs. So,
229
230    File::Spec->splitdir( "/a/b/c" );
231
232Yields:
233
234    ( '', 'a', 'b', '', 'c', '' )
235
236=cut
237
238sub 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
262Takes volume, directory and file portions and returns an entire path. Under
263Unix, $volume is ignored, and this is just like catfile(). On other OSs,
264the $volume become significant.
265
266=cut
267
268sub 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
297sub 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
332sub rel2abs {
333    my ($self,$path,$base ) = @_;
334
335    if ( ! $self->file_name_is_absolute( $path ) ) {
336
337        if ( !defined( $base ) || $base eq '' ) {
338            $base = $self->_cwd() ;
339        }
340        elsif ( ! $self->file_name_is_absolute( $base ) ) {
341            $base = $self->rel2abs( $base ) ;
342        }
343        else {
344            $base = $self->canonpath( $base ) ;
345        }
346
347        my ( $path_directories, $path_file ) =
348            ($self->splitpath( $path, 1 ))[1,2] ;
349
350        my ( $base_volume, $base_directories ) =
351            $self->splitpath( $base, 1 ) ;
352
353        $path = $self->catpath(
354            $base_volume,
355            $self->catdir( $base_directories, $path_directories ),
356            $path_file
357        ) ;
358    }
359
360    return $self->canonpath( $path ) ;
361}
362
363=back
364
365=head2 Note For File::Spec::Win32 Maintainers
366
367Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
368
369=head1 SEE ALSO
370
371See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
372implementation of these methods, not the semantics.
373
374=cut
375
3761;
377