This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add perldelta entry for new version of Module::CoreList
[perl5.git] / dist / Cwd / 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 = '3.35';
9 $VERSION = eval $VERSION;
10
11 @ISA = qw(File::Spec::Unix);
12
13 # Some regexes we use for path splitting
14 my $DRIVE_RX = '[a-zA-Z]:';
15 my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
16 my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
17
18
19 =head1 NAME
20
21 File::Spec::Win32 - methods for Win32 file specs
22
23 =head1 SYNOPSIS
24
25  require File::Spec::Win32; # Done internally by File::Spec if needed
26
27 =head1 DESCRIPTION
28
29 See File::Spec::Unix for a documentation of the methods provided
30 there. This package overrides the implementation of these methods, not
31 the semantics.
32
33 =over 4
34
35 =item devnull
36
37 Returns a string representation of the null device.
38
39 =cut
40
41 sub devnull {
42     return "nul";
43 }
44
45 sub rootdir { '\\' }
46
47
48 =item tmpdir
49
50 Returns a string representation of the first existing directory
51 from the following list:
52
53     $ENV{TMPDIR}
54     $ENV{TEMP}
55     $ENV{TMP}
56     SYS:/temp
57     C:\system\temp
58     C:/temp
59     /tmp
60     /
61
62 The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
63 for Symbian (the File::Spec::Win32 is used also for those platforms).
64
65 Since Perl 5.8.0, if running under taint mode, and if the environment
66 variables are tainted, they are not used.
67
68 =cut
69
70 my $tmpdir;
71 sub tmpdir {
72     return $tmpdir if defined $tmpdir;
73     $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
74                               'SYS:/temp',
75                               'C:\system\temp',
76                               'C:/temp',
77                               '/tmp',
78                               '/'  );
79 }
80
81 =item case_tolerant
82
83 MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
84 indicating the case significance when comparing file specifications.
85 Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
86 See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
87 Default: 1
88
89 =cut
90
91 sub case_tolerant {
92   eval { require Win32API::File; } or return 1;
93   my $drive = shift || "C:";
94   my $osFsType = "\0"x256;
95   my $osVolName = "\0"x256;
96   my $ouFsFlags = 0;
97   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
98   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
99   else { return 1; }
100 }
101
102 =item file_name_is_absolute
103
104 As of right now, this returns 2 if the path is absolute with a
105 volume, 1 if it's absolute with no volume, 0 otherwise.
106
107 =cut
108
109 sub file_name_is_absolute {
110
111     my ($self,$file) = @_;
112
113     if ($file =~ m{^($VOL_RX)}o) {
114       my $vol = $1;
115       return ($vol =~ m{^$UNC_RX}o ? 2
116               : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
117               : 0);
118     }
119     return $file =~  m{^[\\/]} ? 1 : 0;
120 }
121
122 =item catfile
123
124 Concatenate one or more directory names and a filename to form a
125 complete path ending with a filename
126
127 =cut
128
129 sub catfile {
130     shift;
131
132     # Legacy / compatibility support
133     #
134     shift, return _canon_cat( "/", @_ )
135         if $_[0] eq "";
136
137     # Compatibility with File::Spec <= 3.26:
138     #     catfile('A:', 'foo') should return 'A:\foo'.
139     return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
140         if $_[0] =~ m{^$DRIVE_RX\z}o;
141
142     return _canon_cat( @_ );
143 }
144
145 sub catdir {
146     shift;
147
148     # Legacy / compatibility support
149     #
150     return ""
151         unless @_;
152     shift, return _canon_cat( "/", @_ )
153         if $_[0] eq "";
154
155     # Compatibility with File::Spec <= 3.26:
156     #     catdir('A:', 'foo') should return 'A:\foo'.
157     return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
158         if $_[0] =~ m{^$DRIVE_RX\z}o;
159
160     return _canon_cat( @_ );
161 }
162
163 sub path {
164     my @path = split(';', $ENV{PATH});
165     s/"//g for @path;
166     @path = grep length, @path;
167     unshift(@path, ".");
168     return @path;
169 }
170
171 =item canonpath
172
173 No physical check on the filesystem, but a logical cleanup of a
174 path. On UNIX eliminated successive slashes and successive "/.".
175 On Win32 makes 
176
177         dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
178         dir1\dir2\dir3\...\dir4   -> \dir\dir4
179
180 =cut
181
182 sub canonpath {
183     # Legacy / compatibility support
184     #
185     return $_[1] if !defined($_[1]) or $_[1] eq '';
186     return _canon_cat( $_[1] );
187 }
188
189 =item splitpath
190
191     ($volume,$directories,$file) = File::Spec->splitpath( $path );
192     ($volume,$directories,$file) = File::Spec->splitpath( $path,
193                                                           $no_file );
194
195 Splits a path into volume, directory, and filename portions. Assumes that 
196 the last file is a path unless the path ends in '\\', '\\.', '\\..'
197 or $no_file is true.  On Win32 this means that $no_file true makes this return 
198 ( $volume, $path, '' ).
199
200 Separators accepted are \ and /.
201
202 Volumes can be drive letters or UNC sharenames (\\server\share).
203
204 The results can be passed to L</catpath> to get back a path equivalent to
205 (usually identical to) the original path.
206
207 =cut
208
209 sub splitpath {
210     my ($self,$path, $nofile) = @_;
211     my ($volume,$directory,$file) = ('','','');
212     if ( $nofile ) {
213         $path =~ 
214             m{^ ( $VOL_RX ? ) (.*) }sox;
215         $volume    = $1;
216         $directory = $2;
217     }
218     else {
219         $path =~ 
220             m{^ ( $VOL_RX ? )
221                 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
222                 (.*)
223              }sox;
224         $volume    = $1;
225         $directory = $2;
226         $file      = $3;
227     }
228
229     return ($volume,$directory,$file);
230 }
231
232
233 =item splitdir
234
235 The opposite of L<catdir()|File::Spec/catdir>.
236
237     @dirs = File::Spec->splitdir( $directories );
238
239 $directories must be only the directory portion of the path on systems 
240 that have the concept of a volume or that have path syntax that differentiates
241 files from directories.
242
243 Unlike just splitting the directories on the separator, leading empty and 
244 trailing directory entries can be returned, because these are significant
245 on some OSs. So,
246
247     File::Spec->splitdir( "/a/b/c" );
248
249 Yields:
250
251     ( '', 'a', 'b', '', 'c', '' )
252
253 =cut
254
255 sub splitdir {
256     my ($self,$directories) = @_ ;
257     #
258     # split() likes to forget about trailing null fields, so here we
259     # check to be sure that there will not be any before handling the
260     # simple case.
261     #
262     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
263         return split( m|[\\/]|, $directories );
264     }
265     else {
266         #
267         # since there was a trailing separator, add a file name to the end, 
268         # then do the split, then replace it with ''.
269         #
270         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
271         $directories[ $#directories ]= '' ;
272         return @directories ;
273     }
274 }
275
276
277 =item catpath
278
279 Takes volume, directory and file portions and returns an entire path. Under
280 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
281 the $volume become significant.
282
283 =cut
284
285 sub catpath {
286     my ($self,$volume,$directory,$file) = @_;
287
288     # If it's UNC, make sure the glue separator is there, reusing
289     # whatever separator is first in the $volume
290     my $v;
291     $volume .= $v
292         if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
293              $directory =~ m@^[^\\/]@s
294            ) ;
295
296     $volume .= $directory ;
297
298     # If the volume is not just A:, make sure the glue separator is 
299     # there, reusing whatever separator is first in the $volume if possible.
300     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
301          $volume =~ m@[^\\/]\Z(?!\n)@      &&
302          $file   =~ m@[^\\/]@
303        ) {
304         $volume =~ m@([\\/])@ ;
305         my $sep = $1 ? $1 : '\\' ;
306         $volume .= $sep ;
307     }
308
309     $volume .= $file ;
310
311     return $volume ;
312 }
313
314 sub _same {
315   lc($_[1]) eq lc($_[2]);
316 }
317
318 sub rel2abs {
319     my ($self,$path,$base ) = @_;
320
321     my $is_abs = $self->file_name_is_absolute($path);
322
323     # Check for volume (should probably document the '2' thing...)
324     return $self->canonpath( $path ) if $is_abs == 2;
325
326     if ($is_abs) {
327       # It's missing a volume, add one
328       my $vol = ($self->splitpath( $self->_cwd() ))[0];
329       return $self->canonpath( $vol . $path );
330     }
331
332     if ( !defined( $base ) || $base eq '' ) {
333       require Cwd ;
334       $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
335       $base = $self->_cwd() unless defined $base ;
336     }
337     elsif ( ! $self->file_name_is_absolute( $base ) ) {
338       $base = $self->rel2abs( $base ) ;
339     }
340     else {
341       $base = $self->canonpath( $base ) ;
342     }
343
344     my ( $path_directories, $path_file ) =
345       ($self->splitpath( $path, 1 ))[1,2] ;
346
347     my ( $base_volume, $base_directories ) =
348       $self->splitpath( $base, 1 ) ;
349
350     $path = $self->catpath( 
351                            $base_volume, 
352                            $self->catdir( $base_directories, $path_directories ), 
353                            $path_file
354                           ) ;
355
356     return $self->canonpath( $path ) ;
357 }
358
359 =back
360
361 =head2 Note For File::Spec::Win32 Maintainers
362
363 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
364
365 =head1 COPYRIGHT
366
367 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
368
369 This program is free software; you can redistribute it and/or modify
370 it under the same terms as Perl itself.
371
372 =head1 SEE ALSO
373
374 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
375 implementation of these methods, not the semantics.
376
377 =cut
378
379
380 sub _canon_cat                          # @path -> path
381 {
382     my ($first, @rest) = @_;
383
384     my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x      # drive letter
385                ? ucfirst( $1 ).( $2 ? "\\" : "" )
386                : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
387                                  (?: [\\/] ([^\\/]+) )?
388                                  [\\/]? }{}xs                   # UNC volume
389                ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
390                : $first =~ s{ \A [\\/] }{}x                     # root dir
391                ? "\\"
392                : "";
393     my $path   = join "\\", $first, @rest;
394
395     $path =~ tr#\\/#\\\\#s;             # xx/yy --> xx\yy & xx\\yy --> xx\yy
396
397                                         # xx/././yy --> xx/yy
398     $path =~ s{(?:
399                 (?:\A|\\)               # at begin or after a slash
400                 \.
401                 (?:\\\.)*               # and more
402                 (?:\\|\z)               # at end or followed by slash
403                )+                       # performance boost -- I do not know why
404              }{\\}gx;
405
406     # XXX I do not know whether more dots are supported by the OS supporting
407     #     this ... annotation (NetWare or symbian but not MSWin32).
408     #     Then .... could easily become ../../.. etc:
409     # Replace \.\.\. by (\.\.\.+)  and substitute with
410     # { $1 . ".." . "\\.." x (length($2)-2) }gex
411                                         # ... --> ../..
412     $path =~ s{ (\A|\\)                 # at begin or after a slash
413                 \.\.\.
414                 (?=\\|\z)               # at end or followed by slash
415              }{$1..\\..}gx;
416                                         # xx\yy\..\zz --> xx\zz
417     while ( $path =~ s{(?:
418                 (?:\A|\\)               # at begin or after a slash
419                 [^\\]+                  # rip this 'yy' off
420                 \\\.\.
421                 (?<!\A\.\.\\\.\.)       # do *not* replace ^..\..
422                 (?<!\\\.\.\\\.\.)       # do *not* replace \..\..
423                 (?:\\|\z)               # at end or followed by slash
424                )+                       # performance boost -- I do not know why
425              }{\\}sx ) {}
426
427     $path =~ s#\A\\##;                  # \xx --> xx  NOTE: this is *not* root
428     $path =~ s#\\\z##;                  # xx\ --> xx
429
430     if ( $volume =~ m#\\\z# )
431     {                                   # <vol>\.. --> <vol>\
432         $path =~ s{ \A                  # at begin
433                     \.\.
434                     (?:\\\.\.)*         # and more
435                     (?:\\|\z)           # at end or followed by slash
436                  }{}x;
437
438         return $1                       # \\HOST\SHARE\ --> \\HOST\SHARE
439             if    $path eq ""
440               and $volume =~ m#\A(\\\\.*)\\\z#s;
441     }
442     return $path ne "" || $volume ? $volume.$path : ".";
443 }
444
445 1;