dist/PathTools/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.51';
   8 $VERSION =~ tr/_//;
   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 If running under taint mode, and if the environment
  96 variables are tainted, they are not used.
  97
  98 =cut
  99
 100 sub tmpdir {
 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     );
 109 }
 110
 111 =item case_tolerant
 112
 113 Override Unix. Cygwin case-tolerance depends on managed mount settings and
 114 as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
 115 indicating the case significance when comparing file specifications.
 116 Default: 1
 117
 118 =cut
 119
 120 sub case_tolerant {
 121   return 1 unless $^O eq 'cygwin'
 122     and defined &Cygwin::mount_flags;
 123
 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   }
 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 }
 148
 149 =back
 150
 151 =head1 COPYRIGHT
 152
 153 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
 154
 155 This program is free software; you can redistribute it and/or modify
 156 it under the same terms as Perl itself.
 157
 158 =cut
 159
 160 1;