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