This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
speed up building with less disk IO pod moves+__END__+misc
[perl5.git] / dist / PathTools / lib / File / Spec / Cygwin.pm
CommitLineData
ecf68df6
DR
1package File::Spec::Cygwin;
2
3use strict;
4use vars qw(@ISA $VERSION);
5require File::Spec::Unix;
6
f4eedc6b 7$VERSION = '3.51';
3d2a0adf 8$VERSION =~ tr/_//;
ecf68df6
DR
9
10@ISA = qw(File::Spec::Unix);
11
07824bd1
JH
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
72f15715
T
22See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
23implementation of these methods, not the semantics.
07824bd1
JH
24
25This module is still in beta. Cygwin-knowledgeable folks are invited
26to offer patches and suggestions.
27
28=cut
29
30=pod
31
95fb0f99
KW
32=over 4
33
07824bd1
JH
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
ecf68df6
DR
41sub 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
55sub 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
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
3ed25742
GN
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
07824bd1 84=item tmpdir (override)
f534ab20 85
07824bd1
JH
86Returns a string representation of the first existing directory
87from 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 95If running under taint mode, and if the environment
07824bd1 96variables are tainted, they are not used.
ecf68df6 97
07824bd1 98=cut
ecf68df6 99
07824bd1 100sub 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
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
8915552c
RU
117
118=cut
119
486bcc50 120sub 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 153Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
99f36a73
RGS
154
155This program is free software; you can redistribute it and/or modify
156it under the same terms as Perl itself.
157
95fb0f99
KW
158=cut
159
07824bd1 1601;