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