This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5d89fe5305bfccea26c82c7983e67c663b013581
[perl5.git] / 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 = '1.1_02';
8
9 @ISA = qw(File::Spec::Unix);
10
11 =head1 NAME
12
13 File::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
21 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
22 implementation of these methods, not the semantics.
23
24 This module is still in beta.  Cygwin-knowledgeable folks are invited
25 to offer patches and suggestions.
26
27 =cut
28
29 =pod
30
31 =over 4
32
33 =item canonpath
34
35 Any C<\> (backslashes) are converted to C</> (forward slashes),
36 and then File::Spec::Unix canonpath() is called on the result.
37
38 =cut
39
40 sub canonpath {
41     my($self,$path) = @_;
42     $path =~ s|\\|/|g;
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);
50 }
51
52 sub catdir {
53     my $self = shift;
54
55     # Don't create something that looks like a //network/path
56     if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
57         shift;
58         return $self->SUPER::catdir('', @_);
59     }
60
61     $self->SUPER::catdir(@_);
62 }
63
64 =pod
65
66 =item file_name_is_absolute
67
68 True is returned if the file name begins with C<drive_letter:>,
69 and if not, File::Spec::Unix file_name_is_absolute() is called.
70
71 =cut
72
73
74 sub 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
80 =item tmpdir (override)
81
82 Returns a string representation of the first existing directory
83 from the following list:
84
85     $ENV{TMPDIR}
86     /tmp
87     $ENV{'TMP'}
88     $ENV{'TEMP'}
89     C:/temp
90
91 Since Perl 5.8.0, if running under taint mode, and if the environment
92 variables are tainted, they are not used.
93
94 =cut
95
96 my $tmpdir;
97 sub tmpdir {
98     return $tmpdir if defined $tmpdir;
99     $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' );
100 }
101
102 =item case_tolerant
103
104 Override Unix. Cygwin case-tolerance depends on managed mount settings and
105 as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
106 indicating the case significance when comparing file specifications.
107 Default: 1
108
109 =cut
110
111 sub case_tolerant () {
112   if ($^O ne 'cygwin') {
113     return 1;
114   }
115   my $drive = shift || "/cygdrive/c";
116   my $mntopts = Cygwin::mount_flags($drive);
117   if ($mntopts and ($mntopts =~ /,managed/)) {
118     return 0;
119   }
120   eval { require Win32API::File; } or return 1;
121   my $osFsType = "\0"x256;
122   my $osVolName = "\0"x256;
123   my $ouFsFlags = 0;
124   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
125   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
126   else { return 1; }
127 }
128
129 =back
130
131 =head1 COPYRIGHT
132
133 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
134
135 This program is free software; you can redistribute it and/or modify
136 it under the same terms as Perl itself.
137
138 =cut
139
140 1;