Fix when( scalar ... ) bug
[perl.git] / ext / Cwd / 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.30';
8 $VERSION = eval $VERSION;
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 Since Perl 5.8.0, if running under taint mode, and if the environment
96 variables are tainted, they are not used.
97
98 =cut
99
100 my $tmpdir;
101 sub tmpdir {
102     return $tmpdir if defined $tmpdir;
103     $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' );
104 }
105
106 =item case_tolerant
107
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
112
113 =cut
114
115 sub case_tolerant {
116   return 1 unless $^O eq 'cygwin'
117     and defined &Cygwin::mount_flags;
118
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   }
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 }
143
144 =back
145
146 =head1 COPYRIGHT
147
148 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
149
150 This program is free software; you can redistribute it and/or modify
151 it under the same terms as Perl itself.
152
153 =cut
154
155 1;