1package File::Spec::Cygwin;
2
3use strict;
4require File::Spec::Unix;
5
6our $VERSION = '3.84';
7$VERSION =~ tr/_//d;
8
9our @ISA = qw(File::Spec::Unix);
10
11=head1 NAME
12
13File::Spec::Cygwin - methods for Cygwin file specs
14
15=head1 SYNOPSIS
16
17 require File::Spec::Cygwin; # Done internally by File::Spec if needed
18
19=head1 DESCRIPTION
20
21See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
22implementation of these methods, not the semantics.
23
24This module is still in beta.  Cygwin-knowledgeable folks are invited
25to offer patches and suggestions.
26
27=cut
28
29=pod
30
31=over 4
32
33=item canonpath
34
35Any C<\> (backslashes) are converted to C</> (forward slashes),
36and then File::Spec::Unix canonpath() is called on the result.
37
38=cut
39
40sub canonpath {
41    my($self,$path) = @_;
42    return unless defined $path;
43
44    $path =~ s|\\|/|g;
45
46    # Handle network path names beginning with double slash
47    my $node = '';
48    if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
49        $node = $1;
50    }
51    return $node . $self->SUPER::canonpath($path);
52}
53
54sub catdir {
55    my $self = shift;
56    return unless @_;
57
58    # Don't create something that looks like a //network/path
59    if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
60        shift;
61        return $self->SUPER::catdir('', @_);
62    }
63
64    $self->SUPER::catdir(@_);
65}
66
67=pod
68
69=item file_name_is_absolute
70
71True is returned if the file name begins with C<drive_letter:>,
72and if not, File::Spec::Unix file_name_is_absolute() is called.
73
74=cut
75
76
77sub file_name_is_absolute {
78    my ($self,$file) = @_;
79    return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
80    return $self->SUPER::file_name_is_absolute($file);
81}
82
83=item tmpdir (override)
84
85Returns a string representation of the first existing directory
86from the following list:
87
88    $ENV{TMPDIR}
89    /tmp
90    $ENV{'TMP'}
91    $ENV{'TEMP'}
92    C:/temp
93
94If running under taint mode, and if the environment
95variables are tainted, they are not used.
96
97=cut
98
99sub tmpdir {
100    my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP');
101    return $cached if defined $cached;
102    $_[0]->_cache_tmpdir(
103        $_[0]->_tmpdir(
104            $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp'
105        ),
106        qw 'TMPDIR TMP TEMP'
107    );
108}
109
110=item case_tolerant
111
112Override Unix. Cygwin case-tolerance depends on managed mount settings and
113as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
114indicating the case significance when comparing file specifications.
115Default: 1
116
117=cut
118
119sub case_tolerant {
120  return 1 unless $^O eq 'cygwin'
121    and defined &Cygwin::mount_flags;
122
123  my $drive = shift;
124  if (! $drive) {
125      my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
126      my $prefix = pop(@flags);
127      if (! $prefix || $prefix eq 'cygdrive') {
128          $drive = '/cygdrive/c';
129      } elsif ($prefix eq '/') {
130          $drive = '/c';
131      } else {
132          $drive = "$prefix/c";
133      }
134  }
135  my $mntopts = Cygwin::mount_flags($drive);
136  if ($mntopts and ($mntopts =~ /,managed/)) {
137    return 0;
138  }
139  eval {
140      local @INC = @INC;
141      pop @INC if $INC[-1] eq '.';
142      require Win32API::File;
143  } or return 1;
144  my $osFsType = "\0"x256;
145  my $osVolName = "\0"x256;
146  my $ouFsFlags = 0;
147  Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
148  if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
149  else { return 1; }
150}
151
152=back
153
154=head1 COPYRIGHT
155
156Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
157
158This program is free software; you can redistribute it and/or modify
159it under the same terms as Perl itself.
160
161=cut
162
1631;
164