dist/PathTools/lib/File/Spec/Cygwin.pm

   1 package File::Spec::Cygwin;
   2
   3 use strict;
   4 require File::Spec::Unix;
   5
   6 our $VERSION = '3.72';
   7 $VERSION =~ tr/_//d;
   8
   9 our @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     return unless defined $path;
  43
  44     $path =~ s|\\|/|g;
  45
  46     # Handle network path names beginning with double slash
  47     my $node = '';
  48     if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
  49         $node = $1;
  50     }
  51     return $node . $self->SUPER::canonpath($path);
  52 }
  53
  54 sub catdir {
  55     my $self = shift;
  56     return unless @_;
  57
  58     # Don't create something that looks like a //network/path
  59     if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
  60         shift;
  61         return $self->SUPER::catdir('', @_);
  62     }
  63
  64     $self->SUPER::catdir(@_);
  65 }
  66
  67 =pod
  68
  69 =item file_name_is_absolute
  70
  71 True is returned if the file name begins with C<drive_letter:>,
  72 and if not, File::Spec::Unix file_name_is_absolute() is called.
  73
  74 =cut
  75
  76
  77 sub file_name_is_absolute {
  78     my ($self,$file) = @_;
  79     return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
  80     return $self->SUPER::file_name_is_absolute($file);
  81 }
  82
  83 =item tmpdir (override)
  84
  85 Returns a string representation of the first existing directory
  86 from the following list:
  87
  88     $ENV{TMPDIR}
  89     /tmp
  90     $ENV{'TMP'}
  91     $ENV{'TEMP'}
  92     C:/temp
  93
  94 If running under taint mode, and if the environment
  95 variables are tainted, they are not used.
  96
  97 =cut
  98
  99 sub tmpdir {
 100     my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP');
 101     return $cached if defined $cached;
 102     $_[0]->_cache_tmpdir(
 103         $_[0]->_tmpdir(
 104             $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp'
 105         ),
 106         qw 'TMPDIR TMP TEMP'
 107     );
 108 }
 109
 110 =item case_tolerant
 111
 112 Override Unix. Cygwin case-tolerance depends on managed mount settings and
 113 as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
 114 indicating the case significance when comparing file specifications.
 115 Default: 1
 116
 117 =cut
 118
 119 sub case_tolerant {
 120   return 1 unless $^O eq 'cygwin'
 121     and defined &Cygwin::mount_flags;
 122
 123   my $drive = shift;
 124   if (! $drive) {
 125       my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
 126       my $prefix = pop(@flags);
 127       if (! $prefix || $prefix eq 'cygdrive') {
 128           $drive = '/cygdrive/c';
 129       } elsif ($prefix eq '/') {
 130           $drive = '/c';
 131       } else {
 132           $drive = "$prefix/c";
 133       }
 134   }
 135   my $mntopts = Cygwin::mount_flags($drive);
 136   if ($mntopts and ($mntopts =~ /,managed/)) {
 137     return 0;
 138   }
 139   eval {
 140       local @INC = @INC;
 141       pop @INC if $INC[-1] eq '.';
 142       require Win32API::File;
 143   } or return 1;
 144   my $osFsType = "\0"x256;
 145   my $osVolName = "\0"x256;
 146   my $ouFsFlags = 0;
 147   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
 148   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
 149   else { return 1; }
 150 }
 151
 152 =back
 153
 154 =head1 COPYRIGHT
 155
 156 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
 157
 158 This program is free software; you can redistribute it and/or modify
 159 it under the same terms as Perl itself.
 160
 161 =cut
 162
 163 1;