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;