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