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