Commit | Line | Data |
---|---|---|
ecf68df6 DR |
1 | package File::Spec::Cygwin; |
2 | ||
3 | use strict; | |
4 | use vars qw(@ISA $VERSION); | |
5 | require File::Spec::Unix; | |
6 | ||
b740ac38 | 7 | $VERSION = '3.45'; |
3d2a0adf | 8 | $VERSION =~ tr/_//; |
ecf68df6 DR |
9 | |
10 | @ISA = qw(File::Spec::Unix); | |
11 | ||
07824bd1 JH |
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 | ||
72f15715 T |
22 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the |
23 | implementation of these methods, not the semantics. | |
07824bd1 JH |
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 | ||
95fb0f99 KW |
32 | =over 4 |
33 | ||
07824bd1 JH |
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 | ||
ecf68df6 DR |
41 | sub canonpath { |
42 | my($self,$path) = @_; | |
bf7c0a3d SP |
43 | return unless defined $path; |
44 | ||
ecf68df6 | 45 | $path =~ s|\\|/|g; |
e9475de8 SP |
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); | |
ecf68df6 DR |
53 | } |
54 | ||
9d5071ba SP |
55 | sub catdir { |
56 | my $self = shift; | |
bf7c0a3d | 57 | return unless @_; |
9d5071ba SP |
58 | |
59 | # Don't create something that looks like a //network/path | |
e4f3fca4 | 60 | if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { |
9d5071ba SP |
61 | shift; |
62 | return $self->SUPER::catdir('', @_); | |
63 | } | |
64 | ||
65 | $self->SUPER::catdir(@_); | |
66 | } | |
67 | ||
07824bd1 JH |
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 | ||
3ed25742 GN |
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 | ||
07824bd1 | 84 | =item tmpdir (override) |
f534ab20 | 85 | |
07824bd1 JH |
86 | Returns a string representation of the first existing directory |
87 | from the following list: | |
ecf68df6 | 88 | |
07824bd1 JH |
89 | $ENV{TMPDIR} |
90 | /tmp | |
efa159bc RU |
91 | $ENV{'TMP'} |
92 | $ENV{'TEMP'} | |
07824bd1 | 93 | C:/temp |
ecf68df6 | 94 | |
1d0806cf | 95 | If running under taint mode, and if the environment |
07824bd1 | 96 | variables are tainted, they are not used. |
ecf68df6 | 97 | |
07824bd1 | 98 | =cut |
ecf68df6 | 99 | |
07824bd1 | 100 | sub tmpdir { |
82730d4c FC |
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 | ); | |
07824bd1 | 109 | } |
ecf68df6 | 110 | |
8915552c RU |
111 | =item case_tolerant |
112 | ||
efa159bc RU |
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 | |
8915552c RU |
117 | |
118 | =cut | |
119 | ||
486bcc50 | 120 | sub case_tolerant { |
bf7c0a3d SP |
121 | return 1 unless $^O eq 'cygwin' |
122 | and defined &Cygwin::mount_flags; | |
123 | ||
74dc058d JH |
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 | } | |
efa159bc RU |
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 | } | |
8915552c | 148 | |
95fb0f99 KW |
149 | =back |
150 | ||
99f36a73 RGS |
151 | =head1 COPYRIGHT |
152 | ||
efa159bc | 153 | Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. |
99f36a73 RGS |
154 | |
155 | This program is free software; you can redistribute it and/or modify | |
156 | it under the same terms as Perl itself. | |
157 | ||
95fb0f99 KW |
158 | =cut |
159 | ||
07824bd1 | 160 | 1; |