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