File Coverage

blib/lib/Win32/DriveInfo.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

#  Copyright (c) 1998-2001 by Mike Blazer.  All rights reserved.

package Win32::DriveInfo;

use Win32::API;
use Cwd;
use strict 'vars';
use vars qw/$VERSION
  $GetVolumeInformation $GetDriveType $GetLogicalDrives
  $GetVersionEx $GetDiskFreeSpace $GetDiskFreeSpaceEx/;

use constant DWORD_NULL => pack("L",0);
$VERSION = '0.06';

#==================
sub GetVersionEx () {
#==================
# on Win95 if returning $dwBuildNumber(low word of original)
# is greater than 1000, the system is running OSR 2 or a later release.
   $GetVersionEx ||= new Win32::API("kernel32", "GetVersionEx", ['P'], 'N') or return;

   my ($dwOSVersionInfoSize, $dwMajorVersion, $dwMinorVersion,
       $dwBuildNumber,       $dwPlatformId,   $szCSDVersion) =
       (148, 0, 0, 0, 0, "\0"x128);

   my $OSVERSIONINFO = pack "LLLLLa128",
      ($dwOSVersionInfoSize, $dwMajorVersion, $dwMinorVersion,
       $dwBuildNumber,       $dwPlatformId,   $szCSDVersion);

   return undef if $GetVersionEx->Call($OSVERSIONINFO) == 0;
   ($dwOSVersionInfoSize, $dwMajorVersion, $dwMinorVersion,
    $dwBuildNumber,       $dwPlatformId,   $szCSDVersion) =
   unpack "LLLLLa128", $OSVERSIONINFO;

   $szCSDVersion =~ s/\0.*$//;
   $szCSDVersion =~ s/^\s*(.*?)\s*$/$1/;
   $dwBuildNumber = $dwBuildNumber & 0xffff if Win32::IsWin95();

   ($dwMajorVersion, $dwMinorVersion, $dwBuildNumber,
    $dwPlatformId, $szCSDVersion);
}

#==================
sub GetDiskFreeSpace ($) {
#==================
   my $drive = shift;
   return undef unless $drive =~ s/^([a-z])(:(\\)?)?$/$1:\\/i;

   $GetDiskFreeSpace ||=
     new Win32::API("kernel32", "GetDiskFreeSpace", ['P','P','P','P','P'], 'N') or return;

   my ($lpRootPathName, $lpSectorsPerCluster, $lpBytesPerSector,
       $lpNumberOfFreeClusters, $lpTotalNumberOfClusters) =
       ($drive, DWORD_NULL, DWORD_NULL, DWORD_NULL, DWORD_NULL);

   return undef if $GetDiskFreeSpace->Call(
     $lpRootPathName, $lpSectorsPerCluster, $lpBytesPerSector,
     $lpNumberOfFreeClusters, $lpTotalNumberOfClusters
   ) == 0;

   ($lpSectorsPerCluster, $lpBytesPerSector,
    $lpNumberOfFreeClusters, $lpTotalNumberOfClusters) =
   (unpack ("L",$lpSectorsPerCluster),
    unpack ("L",$lpBytesPerSector),
    unpack ("L",$lpNumberOfFreeClusters),
    unpack ("L",$lpTotalNumberOfClusters));

   ($lpSectorsPerCluster, $lpBytesPerSector,
    $lpNumberOfFreeClusters, $lpTotalNumberOfClusters);
}

#==================
sub GetDiskFreeSpaceEx ($) {
#==================
   my $drive = shift;
   return undef unless $drive =~ s/^([a-z])(:(\\)?)?$/$1:\\/i ||
                       $drive =~ s/^(\\\\\w+\\\w+\$?)(\\)?$/$1\\/;

   $GetDiskFreeSpaceEx ||=
       new Win32::API("kernel32", "GetDiskFreeSpaceEx", ['P','P','P','P'], 'N') or return;

   my ($lpDirectoryName, $lpFreeBytesAvailableToCaller,
       $lpTotalNumberOfBytes, $lpTotalNumberOfFreeBytes) =
      ($drive, "\0"x8, "\0"x8, "\0"x8);

   return undef if $GetDiskFreeSpaceEx->Call(
     $lpDirectoryName, $lpFreeBytesAvailableToCaller,
     $lpTotalNumberOfBytes, $lpTotalNumberOfFreeBytes
   ) == 0;

   ($lpFreeBytesAvailableToCaller,
    $lpTotalNumberOfBytes,
    $lpTotalNumberOfFreeBytes) =
   (unpack_LARGE_INTEGER ($lpFreeBytesAvailableToCaller),
    unpack_LARGE_INTEGER ($lpTotalNumberOfBytes),
    unpack_LARGE_INTEGER ($lpTotalNumberOfFreeBytes));

   ($lpFreeBytesAvailableToCaller, $lpTotalNumberOfBytes,
    $lpTotalNumberOfFreeBytes);
}

#==========================
sub unpack_LARGE_INTEGER ($) {
  my ($b, $a) = unpack "LL", shift;
  $a*2**32+$b;
}

#==================
sub DriveType ($) {
#==================
   my $drive = shift;
   return undef unless $drive =~ s/^([a-z])(:(\\)?)?$/$1:\\/i ||
                       $drive =~ s/^(\\\\\w+\\\w+\$?)(\\)?$/$1\\/;

   $GetDriveType ||= new Win32::API("kernel32", "GetDriveType", ['P'], 'N') or return;

   my ($lpDirectoryName) = $drive;

   my $type = $GetDriveType->Call( $lpDirectoryName );
}

#==================
sub DriveSpace ($) {
#==================
  my $drive = shift;
  return undef unless $drive =~ s/^([a-z])(:(\\)?)?$/$1:\\/i ||
                      $drive =~ s/^(\\\\\w+\\\w+\$?)(\\)?$/$1\\/;

  my ($MajorVersion, $MinorVersion, $BuildNumber, $PlatformId, $BuildStr) = GetVersionEx();
  my ($FreeBytesAvailableToCaller, $TotalNumberOfBytes, $TotalNumberOfFreeBytes);

  my ($SectorsPerCluster, $BytesPerSector,
      $NumberOfFreeClusters, $TotalNumberOfClusters) = GetDiskFreeSpace($drive);

#  return undef if ! defined $BytesPerSector;

  if (Win32::IsWinNT()  || $MajorVersion > 4 ||
      $MinorVersion > 0 || $BuildNumber  > 1000) {
     ($FreeBytesAvailableToCaller,
      $TotalNumberOfBytes,
      $TotalNumberOfFreeBytes) = GetDiskFreeSpaceEx($drive);

  } elsif (defined $BytesPerSector) {
     ($FreeBytesAvailableToCaller,
      $TotalNumberOfBytes,
      $TotalNumberOfFreeBytes) = (
      $SectorsPerCluster * $BytesPerSector * $NumberOfFreeClusters,
      $SectorsPerCluster * $BytesPerSector * $TotalNumberOfClusters,
      $SectorsPerCluster * $BytesPerSector * $NumberOfFreeClusters );
  }

  ($SectorsPerCluster, $BytesPerSector,
   $NumberOfFreeClusters, $TotalNumberOfClusters,
   $FreeBytesAvailableToCaller, $TotalNumberOfBytes,
   $TotalNumberOfFreeBytes);
}

#===========================
sub DrivesInUse () {
#===========================
   my (@dr, $i);
   $GetLogicalDrives ||= new Win32::API("kernel32", "GetLogicalDrives", [], 'N') or return;

   my $bitmask = $GetLogicalDrives->Call;
   for $i(0..25) {
     push (@dr, chr(ord("A")+$i)) if $bitmask & 2**$i;
   }
   @dr;
}

#===========================
sub FreeDriveLetters () {
#===========================
   my (@dr, $i);
   $GetLogicalDrives ||= new Win32::API("kernel32", "GetLogicalDrives", [], 'N') or return;

   my $bitmask = $GetLogicalDrives->Call;
   for $i(0..25) {
     push (@dr, (A..Z)[$i]) unless $bitmask & 2**$i;
   }
   @dr;
}

#==================
sub IsReady ($) {
#==================
   my $drive = shift;
   return undef unless $drive =~ s/^([a-z])(:(\\)?)?$/$1:\\/i ||
                       $drive =~ s/^(\\\\\w+\\\w+\$?)(\\)?$/$1\\/;
   my $dir = cwd;
   my $rc  = chdir $drive;
   chdir $dir;
   $rc;
}

#==================
sub VolumeInfo ($) {
#==================
   my $drive = shift;
   return undef unless $drive =~ s/^([a-z])(:(\\)?)?$/$1:\\/i;

   $GetVolumeInformation ||=
    new Win32::API("kernel32", "GetVolumeInformation", ['P','P','N','P','P','P','P','N'], 'N') or return;

   my ($lpRootPathName, $lpVolumeNameBuffer, $nVolumeNameSize,
       $lpVolumeSerialNumber, $lpMaximumComponentLength, $lpFileSystemFlags,
       $lpFileSystemNameBuffer, $nFileSystemNameSize) =
       ($drive, "\0"x256, 256, DWORD_NULL, DWORD_NULL, DWORD_NULL, "\0"x256, 256);

   return undef if $GetVolumeInformation->Call(
     $lpRootPathName, $lpVolumeNameBuffer, $nVolumeNameSize,
     $lpVolumeSerialNumber, $lpMaximumComponentLength, $lpFileSystemFlags,
     $lpFileSystemNameBuffer, $nFileSystemNameSize
   ) == 0;

   ($lpVolumeSerialNumber, $lpMaximumComponentLength, $lpFileSystemFlags) =
   (unpack ("L",$lpVolumeSerialNumber),
    unpack ("L",$lpMaximumComponentLength),
    unpack ("L",$lpFileSystemFlags));

   $lpVolumeNameBuffer     =~ s/\0.*$//;
   $lpFileSystemNameBuffer =~ s/\0.*$//;

   if ($lpVolumeSerialNumber) {
     $lpVolumeSerialNumber = uc sprintf "%08x", $lpVolumeSerialNumber;
     $lpVolumeSerialNumber =~ s/(....)(....)/$1:$2/;
   } else {
     $lpVolumeSerialNumber = "";
   }

   my @attr;
   if ($lpFileSystemFlags & FS_CASE_IS_PRESERVED      () ) { push @attr, 1 }
   if ($lpFileSystemFlags & FS_CASE_SENSITIVE         () ) { push @attr, 2 }
   if ($lpFileSystemFlags & FS_UNICODE_STORED_ON_DISK () ) { push @attr, 3 }
   if ($lpFileSystemFlags & FS_PERSISTENT_ACLS        () ) { push @attr, 4 }
   if ($lpFileSystemFlags & FS_VOL_IS_COMPRESSED      () ) { push @attr, 5 }
   if ($lpFileSystemFlags & FS_FILE_COMPRESSION       () ) { push @attr, 6 }


   ($lpVolumeNameBuffer, $lpVolumeSerialNumber,
    $lpMaximumComponentLength, $lpFileSystemNameBuffer, @attr);
}

sub FS_CASE_IS_PRESERVED      { 0x00000002 }
sub FS_CASE_SENSITIVE         { 0x00000001 }
sub FS_UNICODE_STORED_ON_DISK { 0x00000004 }
sub FS_PERSISTENT_ACLS        { 0x00000008 }
sub FS_VOL_IS_COMPRESSED      { 0x00008000 }
sub FS_FILE_COMPRESSION       { 0x00000010 }


1;

__END__