d2ff9a06de123190ca43872e5f6ba26c6e0d072d
[perl.git] / dist / PathTools / lib / File / Spec / Cygwin.pm
1 package File::Spec::Cygwin;
2
3 use strict;
4 use vars qw(@ISA $VERSION);
5 require File::Spec::Unix;
6
7 $VERSION = '3.59';
8 $VERSION =~ tr/_//d;
9
10 @ISA = qw(File::Spec::Unix);
11
12 =head1 NAME
13
14 File::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
22 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
23 implementation of these methods, not the semantics.
24
25 This module is still in beta.  Cygwin-knowledgeable folks are invited
26 to offer patches and suggestions.
27
28 =cut
29
30 =pod
31
32 =over 4
33
34 =item canonpath
35
36 Any C<\> (backslashes) are converted to C</> (forward slashes),
37 and then File::Spec::Unix canonpath() is called on the result.
38
39 =cut
40
41 sub 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
55 sub 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
72 True is returned if the file name begins with C<drive_letter:>,
73 and if not, File::Spec::Unix file_name_is_absolute() is called.
74
75 =cut
76
77
78 sub 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
86 Returns a string representation of the first existing directory
87 from the following list:
88
89     $ENV{TMPDIR}
90     /tmp
91     $ENV{'TMP'}
92     $ENV{'TEMP'}
93     C:/temp
94
95 If running under taint mode, and if the environment
96 variables are tainted, they are not used.
97
98 =cut
99
100 sub 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
113 Override Unix. Cygwin case-tolerance depends on managed mount settings and
114 as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
115 indicating the case significance when comparing file specifications.
116 Default: 1
117
118 =cut
119
120 sub 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 { require Win32API::File; } or return 1;
141   my $osFsType = "\0"x256;
142   my $osVolName = "\0"x256;
143   my $ouFsFlags = 0;
144   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
145   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
146   else { return 1; }
147 }
148
149 =back
150
151 =head1 COPYRIGHT
152
153 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
154
155 This program is free software; you can redistribute it and/or modify
156 it under the same terms as Perl itself.
157
158 =cut
159
160 1;