1package File::Spec::Win32;
2
3use strict;
4
5use Cwd ();
6require File::Spec::Unix;
7
8our $VERSION = '3.88';
9$VERSION =~ tr/_//d;
10
11our @ISA = qw(File::Spec::Unix);
12
13# Some regexes we use for path splitting
14my $DRIVE_RX = '[a-zA-Z]:';
15my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
16my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
17
18
19=head1 NAME
20
21File::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
29See File::Spec::Unix for a documentation of the methods provided
30there. This package overrides the implementation of these methods, not
31the semantics.
32
33=over 4
34
35=item devnull
36
37Returns a string representation of the null device.
38
39=cut
40
41sub devnull {
42    return "nul";
43}
44
45sub rootdir { '\\' }
46
47
48=item tmpdir
49
50Returns a string representation of the first existing directory
51from 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
62The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
63for Symbian (the File::Spec::Win32 is used also for those platforms).
64
65If running under taint mode, and if the environment
66variables are tainted, they are not used.
67
68=cut
69
70sub 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
84MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
85indicating the case significance when comparing file specifications.
86Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
87See L<http://cygwin.com/ml/cygwin/2007-07/msg00891.html>
88Default: 1
89
90=cut
91
92sub 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
109As of right now, this returns 2 if the path is absolute with a
110volume, 1 if it's absolute with no volume, 0 otherwise.
111
112=cut
113
114sub 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
129Concatenate one or more directory names and a filename to form a
130complete path ending with a filename
131
132=cut
133
134sub 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
150sub 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
168sub 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
178No physical check on the filesystem, but a logical cleanup of a
179path. On UNIX eliminated successive slashes and successive "/.".
180On Win32 makes
181
182	dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
183	dir1\dir2\dir3\...\dir4   -> \dir\dir4
184
185=cut
186
187sub 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
200Splits a path into volume, directory, and filename portions. Assumes that
201the last file is a path unless the path ends in '\\', '\\.', '\\..'
202or $no_file is true.  On Win32 this means that $no_file true makes this return
203( $volume, $path, '' ).
204
205Separators accepted are \ and /.
206
207Volumes can be drive letters or UNC sharenames (\\server\share).
208
209The 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
214sub 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
240The 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
245that have the concept of a volume or that have path syntax that differentiates
246files from directories.
247
248Unlike just splitting the directories on the separator, leading empty and
249trailing directory entries can be returned, because these are significant
250on some OSs. So,
251
252    File::Spec->splitdir( "/a/b/c" );
253
254Yields:
255
256    ( '', 'a', 'b', '', 'c', '' )
257
258=cut
259
260sub 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
284Takes volume, directory and file portions and returns an entire path. Under
285Unix, $volume is ignored, and this is just like catfile(). On other OSs,
286the $volume become significant.
287
288=cut
289
290sub 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
319sub _same {
320  lc($_[1]) eq lc($_[2]);
321}
322
323sub 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
367Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
368
369=head1 COPYRIGHT
370
371Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
372
373This program is free software; you can redistribute it and/or modify
374it under the same terms as Perl itself.
375
376=head1 SEE ALSO
377
378See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
379implementation of these methods, not the semantics.
380
381=cut
382
383
384sub _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    					# xx\yy\..\zz --> xx\zz
411    while ( $path =~ s{(?:
412		(?:\A|\\)		# at begin or after a slash
413		[^\\]+			# rip this 'yy' off
414		\\\.\.
415		(?<!\A\.\.\\\.\.)	# do *not* replace ^..\..
416		(?<!\\\.\.\\\.\.)	# do *not* replace \..\..
417		(?:\\|\z) 		# at end or followed by slash
418	       )+			# performance boost -- I do not know why
419	     }{\\}sx ) {}
420
421    $path =~ s#\A\\##;			# \xx --> xx  NOTE: this is *not* root
422    $path =~ s#\\\z##;			# xx\ --> xx
423
424    if ( $volume =~ m#\\\z# )
425    {					# <vol>\.. --> <vol>\
426	$path =~ s{ \A			# at begin
427		    \.\.
428		    (?:\\\.\.)*		# and more
429		    (?:\\|\z) 		# at end or followed by slash
430		 }{}x;
431
432	return $1			# \\HOST\SHARE\ --> \\HOST\SHARE
433	    if    $path eq ""
434	      and $volume =~ m#\A(\\\\.*)\\\z#s;
435    }
436    return $path ne "" || $volume ? $volume.$path : ".";
437}
438
4391;
440