prevent t/Functions.t from warning on undefined values when none supplied
[perl.git] / dist / PathTools / lib / File / Spec / Win32.pm
1 package File::Spec::Win32;
2
3 use strict;
4
5 use Cwd ();
6 require File::Spec::Unix;
7
8 our $VERSION = '3.75';
9 $VERSION =~ tr/_//d;
10
11 our @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 {
94     local @INC = @INC;
95     pop @INC if $INC[-1] eq '.';
96     require Win32API::File;
97   } or return 1;
98   my $drive = shift || "C:";
99   my $osFsType = "\0"x256;
100   my $osVolName = "\0"x256;
101   my $ouFsFlags = 0;
102   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
103   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
104   else { return 1; }
105 }
106
107 =item file_name_is_absolute
108
109 As of right now, this returns 2 if the path is absolute with a
110 volume, 1 if it's absolute with no volume, 0 otherwise.
111
112 =cut
113
114 sub file_name_is_absolute {
115
116     my ($self,$file) = @_;
117
118     if ($file =~ m{^($VOL_RX)}o) {
119       my $vol = $1;
120       return ($vol =~ m{^$UNC_RX}o ? 2
121               : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
122               : 0);
123     }
124     return $file =~  m{^[\\/]} ? 1 : 0;
125 }
126
127 =item catfile
128
129 Concatenate one or more directory names and a filename to form a
130 complete path ending with a filename
131
132 =cut
133
134 sub catfile {
135     shift;
136
137     # Legacy / compatibility support
138     #
139     shift, return _canon_cat( "/", @_ )
140         if !@_ || $_[0] eq "";
141
142     # Compatibility with File::Spec <= 3.26:
143     #     catfile('A:', 'foo') should return 'A:\foo'.
144     return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
145         if $_[0] =~ m{^$DRIVE_RX\z}o;
146
147     return _canon_cat( @_ );
148 }
149
150 sub catdir {
151     shift;
152
153     # Legacy / compatibility support
154     #
155     return ""
156         unless @_;
157     shift, return _canon_cat( "/", @_ )
158         if $_[0] eq "";
159
160     # Compatibility with File::Spec <= 3.26:
161     #     catdir('A:', 'foo') should return 'A:\foo'.
162     return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
163         if $_[0] =~ m{^$DRIVE_RX\z}o;
164
165     return _canon_cat( @_ );
166 }
167
168 sub path {
169     my @path = split(';', $ENV{PATH});
170     s/"//g for @path;
171     @path = grep length, @path;
172     unshift(@path, ".");
173     return @path;
174 }
175
176 =item canonpath
177
178 No physical check on the filesystem, but a logical cleanup of a
179 path. On UNIX eliminated successive slashes and successive "/.".
180 On Win32 makes 
181
182         dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
183         dir1\dir2\dir3\...\dir4   -> \dir\dir4
184
185 =cut
186
187 sub canonpath {
188     # Legacy / compatibility support
189     #
190     return $_[1] if !defined($_[1]) or $_[1] eq '';
191     return _canon_cat( $_[1] );
192 }
193
194 =item splitpath
195
196    ($volume,$directories,$file) = File::Spec->splitpath( $path );
197    ($volume,$directories,$file) = File::Spec->splitpath( $path,
198                                                          $no_file );
199
200 Splits a path into volume, directory, and filename portions. Assumes that 
201 the last file is a path unless the path ends in '\\', '\\.', '\\..'
202 or $no_file is true.  On Win32 this means that $no_file true makes this return 
203 ( $volume, $path, '' ).
204
205 Separators accepted are \ and /.
206
207 Volumes can be drive letters or UNC sharenames (\\server\share).
208
209 The results can be passed to L</catpath> to get back a path equivalent to
210 (usually identical to) the original path.
211
212 =cut
213
214 sub splitpath {
215     my ($self,$path, $nofile) = @_;
216     my ($volume,$directory,$file) = ('','','');
217     if ( $nofile ) {
218         $path =~ 
219             m{^ ( $VOL_RX ? ) (.*) }sox;
220         $volume    = $1;
221         $directory = $2;
222     }
223     else {
224         $path =~ 
225             m{^ ( $VOL_RX ? )
226                 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
227                 (.*)
228              }sox;
229         $volume    = $1;
230         $directory = $2;
231         $file      = $3;
232     }
233
234     return ($volume,$directory,$file);
235 }
236
237
238 =item splitdir
239
240 The opposite of L<catdir()|File::Spec/catdir>.
241
242     @dirs = File::Spec->splitdir( $directories );
243
244 $directories must be only the directory portion of the path on systems 
245 that have the concept of a volume or that have path syntax that differentiates
246 files from directories.
247
248 Unlike just splitting the directories on the separator, leading empty and 
249 trailing directory entries can be returned, because these are significant
250 on some OSs. So,
251
252     File::Spec->splitdir( "/a/b/c" );
253
254 Yields:
255
256     ( '', 'a', 'b', '', 'c', '' )
257
258 =cut
259
260 sub splitdir {
261     my ($self,$directories) = @_ ;
262     #
263     # split() likes to forget about trailing null fields, so here we
264     # check to be sure that there will not be any before handling the
265     # simple case.
266     #
267     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
268         return split( m|[\\/]|, $directories );
269     }
270     else {
271         #
272         # since there was a trailing separator, add a file name to the end, 
273         # then do the split, then replace it with ''.
274         #
275         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
276         $directories[ $#directories ]= '' ;
277         return @directories ;
278     }
279 }
280
281
282 =item catpath
283
284 Takes volume, directory and file portions and returns an entire path. Under
285 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
286 the $volume become significant.
287
288 =cut
289
290 sub catpath {
291     my ($self,$volume,$directory,$file) = @_;
292
293     # If it's UNC, make sure the glue separator is there, reusing
294     # whatever separator is first in the $volume
295     my $v;
296     $volume .= $v
297         if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
298              $directory =~ m@^[^\\/]@s
299            ) ;
300
301     $volume .= $directory ;
302
303     # If the volume is not just A:, make sure the glue separator is 
304     # there, reusing whatever separator is first in the $volume if possible.
305     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
306          $volume =~ m@[^\\/]\Z(?!\n)@      &&
307          $file   =~ m@[^\\/]@
308        ) {
309         $volume =~ m@([\\/])@ ;
310         my $sep = $1 ? $1 : '\\' ;
311         $volume .= $sep ;
312     }
313
314     $volume .= $file ;
315
316     return $volume ;
317 }
318
319 sub _same {
320   lc($_[1]) eq lc($_[2]);
321 }
322
323 sub rel2abs {
324     my ($self,$path,$base ) = @_;
325
326     my $is_abs = $self->file_name_is_absolute($path);
327
328     # Check for volume (should probably document the '2' thing...)
329     return $self->canonpath( $path ) if $is_abs == 2;
330
331     if ($is_abs) {
332       # It's missing a volume, add one
333       my $vol = ($self->splitpath( Cwd::getcwd() ))[0];
334       return $self->canonpath( $vol . $path );
335     }
336
337     if ( !defined( $base ) || $base eq '' ) {
338       $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
339       $base = Cwd::getcwd() 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;