Fix when( scalar ... ) bug
[perl.git] / ext / 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.30';
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, $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
379 sub _canon_cat                          # @path -> path
380 {
381     my ($first, @rest) = @_;
382
383     my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x      # drive letter
384                ? ucfirst( $1 ).( $2 ? "\\" : "" )
385                : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
386                                  (?: [\\/] ([^\\/]+) )?
387                                  [\\/]? }{}xs                   # UNC volume
388                ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
389                : $first =~ s{ \A [\\/] }{}x                     # root dir
390                ? "\\"
391                : "";
392     my $path   = join "\\", $first, @rest;
393
394     $path =~ tr#\\/#\\\\#s;             # xx/yy --> xx\yy & xx\\yy --> xx\yy
395
396                                         # xx/././yy --> xx/yy
397     $path =~ s{(?:
398                 (?:\A|\\)               # at begin or after a slash
399                 \.
400                 (?:\\\.)*               # and more
401                 (?:\\|\z)               # at end or followed by slash
402                )+                       # performance boost -- I do not know why
403              }{\\}gx;
404
405     # XXX I do not know whether more dots are supported by the OS supporting
406     #     this ... annotation (NetWare or symbian but not MSWin32).
407     #     Then .... could easily become ../../.. etc:
408     # Replace \.\.\. by (\.\.\.+)  and substitute with
409     # { $1 . ".." . "\\.." x (length($2)-2) }gex
410                                         # ... --> ../..
411     $path =~ s{ (\A|\\)                 # at begin or after a slash
412                 \.\.\.
413                 (?=\\|\z)               # at end or followed by slash
414              }{$1..\\..}gx;
415                                         # xx\yy\..\zz --> xx\zz
416     while ( $path =~ s{(?:
417                 (?:\A|\\)               # at begin or after a slash
418                 [^\\]+                  # rip this 'yy' off
419                 \\\.\.
420                 (?<!\A\.\.\\\.\.)       # do *not* replace ^..\..
421                 (?<!\\\.\.\\\.\.)       # do *not* replace \..\..
422                 (?:\\|\z)               # at end or followed by slash
423                )+                       # performance boost -- I do not know why
424              }{\\}sx ) {}
425
426     $path =~ s#\A\\##;                  # \xx --> xx  NOTE: this is *not* root
427     $path =~ s#\\\z##;                  # xx\ --> xx
428
429     if ( $volume =~ m#\\\z# )
430     {                                   # <vol>\.. --> <vol>\
431         $path =~ s{ \A                  # at begin
432                     \.\.
433                     (?:\\\.\.)*         # and more
434                     (?:\\|\z)           # at end or followed by slash
435                  }{}x;
436
437         return $1                       # \\HOST\SHARE\ --> \\HOST\SHARE
438             if    $path eq ""
439               and $volume =~ m#\A(\\\\.*)\\\z#s;
440     }
441     return $path ne "" || $volume ? $volume.$path : ".";
442 }
443
444 1;