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_03';
   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;
 116   if (! $drive) {
 117       my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
 118       my $prefix = pop(@flags);
 119       if (! $prefix || $prefix eq 'cygdrive') {
 120           $drive = '/cygdrive/c';
 121       } elsif ($prefix eq '/') {
 122           $drive = '/c';
 123       } else {
 124           $drive = "$prefix/c";
 125       }
 126   }
 127   my $mntopts = Cygwin::mount_flags($drive);
 128   if ($mntopts and ($mntopts =~ /,managed/)) {
 129     return 0;
 130   }
 131   eval { require Win32API::File; } or return 1;
 132   my $osFsType = "\0"x256;
 133   my $osVolName = "\0"x256;
 134   my $ouFsFlags = 0;
 135   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
 136   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
 137   else { return 1; }
 138 }
 139
 140 =back
 141
 142 =head1 COPYRIGHT
 143
 144 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
 145
 146 This program is free software; you can redistribute it and/or modify
 147 it under the same terms as Perl itself.
 148
 149 =cut
 150
 151 1;