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