Commit | Line | Data |
ecf68df6 |
1 | package File::Spec::Cygwin; |
2 | |
3 | use strict; |
4 | use vars qw(@ISA $VERSION); |
5 | require File::Spec::Unix; |
6 | |
21887892 |
7 | $VERSION = '3.29'; |
486bcc50 |
8 | $VERSION = eval $VERSION; |
ecf68df6 |
9 | |
10 | @ISA = qw(File::Spec::Unix); |
11 | |
07824bd1 |
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 |
22 | See L<File::Spec> and L<File::Spec::Unix>. This package overrides the |
23 | implementation of these methods, not the semantics. |
07824bd1 |
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 |
32 | =over 4 |
33 | |
07824bd1 |
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 |
41 | sub canonpath { |
42 | my($self,$path) = @_; |
bf7c0a3d |
43 | return unless defined $path; |
44 | |
ecf68df6 |
45 | $path =~ s|\\|/|g; |
e9475de8 |
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 |
53 | } |
54 | |
9d5071ba |
55 | sub catdir { |
56 | my $self = shift; |
bf7c0a3d |
57 | return unless @_; |
9d5071ba |
58 | |
59 | # Don't create something that looks like a //network/path |
e4f3fca4 |
60 | if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { |
9d5071ba |
61 | shift; |
62 | return $self->SUPER::catdir('', @_); |
63 | } |
64 | |
65 | $self->SUPER::catdir(@_); |
66 | } |
67 | |
07824bd1 |
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 |
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 |
86 | Returns a string representation of the first existing directory |
87 | from the following list: |
ecf68df6 |
88 | |
07824bd1 |
89 | $ENV{TMPDIR} |
90 | /tmp |
efa159bc |
91 | $ENV{'TMP'} |
92 | $ENV{'TEMP'} |
07824bd1 |
93 | C:/temp |
ecf68df6 |
94 | |
07824bd1 |
95 | Since Perl 5.8.0, if running under taint mode, and if the environment |
96 | variables are tainted, they are not used. |
ecf68df6 |
97 | |
07824bd1 |
98 | =cut |
ecf68df6 |
99 | |
07824bd1 |
100 | my $tmpdir; |
101 | sub tmpdir { |
102 | return $tmpdir if defined $tmpdir; |
efa159bc |
103 | $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' ); |
07824bd1 |
104 | } |
ecf68df6 |
105 | |
8915552c |
106 | =item case_tolerant |
107 | |
efa159bc |
108 | Override Unix. Cygwin case-tolerance depends on managed mount settings and |
109 | as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE, |
110 | indicating the case significance when comparing file specifications. |
111 | Default: 1 |
8915552c |
112 | |
113 | =cut |
114 | |
486bcc50 |
115 | sub case_tolerant { |
bf7c0a3d |
116 | return 1 unless $^O eq 'cygwin' |
117 | and defined &Cygwin::mount_flags; |
118 | |
74dc058d |
119 | my $drive = shift; |
120 | if (! $drive) { |
121 | my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); |
122 | my $prefix = pop(@flags); |
123 | if (! $prefix || $prefix eq 'cygdrive') { |
124 | $drive = '/cygdrive/c'; |
125 | } elsif ($prefix eq '/') { |
126 | $drive = '/c'; |
127 | } else { |
128 | $drive = "$prefix/c"; |
129 | } |
130 | } |
efa159bc |
131 | my $mntopts = Cygwin::mount_flags($drive); |
132 | if ($mntopts and ($mntopts =~ /,managed/)) { |
133 | return 0; |
134 | } |
135 | eval { require Win32API::File; } or return 1; |
136 | my $osFsType = "\0"x256; |
137 | my $osVolName = "\0"x256; |
138 | my $ouFsFlags = 0; |
139 | Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 ); |
140 | if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; } |
141 | else { return 1; } |
142 | } |
8915552c |
143 | |
95fb0f99 |
144 | =back |
145 | |
99f36a73 |
146 | =head1 COPYRIGHT |
147 | |
efa159bc |
148 | Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved. |
99f36a73 |
149 | |
150 | This program is free software; you can redistribute it and/or modify |
151 | it under the same terms as Perl itself. |
152 | |
95fb0f99 |
153 | =cut |
154 | |
07824bd1 |
155 | 1; |