[Summary view] [Print] [Text view]

   1  package File::Spec::Cygwin;
   2  
   3  use strict;
   4  use vars qw(@ISA $VERSION);
   5  require File::Spec::Unix;
   6  
   7  $VERSION = '3.2501';
   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;