Browse Source

* disksize/diskfree return now a int64

florian 25 years ago
parent
commit
a8c87c6549
1 changed files with 95 additions and 12 deletions
  1. 95 12
      rtl/win32/dos.pp

+ 95 - 12
rtl/win32/dos.pp

@@ -127,8 +127,8 @@ Procedure Exec(const path: pathstr; const comline: comstr);
 Function  DosExitCode: word;
 Function  DosExitCode: word;
 
 
 {Disk}
 {Disk}
-Function  DiskFree(drive: byte) : longint;
-Function  DiskSize(drive: byte) : longint;
+Function  DiskFree(drive: byte) : int64;
+Function  DiskSize(drive: byte) : int64;
 Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
 Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
 Procedure FindNext(var f: searchRec);
 Procedure FindNext(var f: searchRec);
 Procedure FindClose(Var f: SearchRec);
 Procedure FindClose(Var f: SearchRec);
@@ -169,6 +169,21 @@ Const
 
 
 implementation
 implementation
 uses strings;
 uses strings;
+type
+   OSVERSIONINFO = record
+        dwOSVersionInfoSize : DWORD;
+        dwMajorVersion : DWORD;
+        dwMinorVersion : DWORD;
+        dwBuildNumber : DWORD;
+        dwPlatformId : DWORD;
+        szCSDVersion : array[0..127] of char;
+     end;
+
+   LPOSVERSIONINFO = ^OSVERSIONINFO;
+
+var
+   versioninfo : OSVERSIONINFO;
+   kernel32dll : THandle;
 
 
 {******************************************************************************
 {******************************************************************************
                            --- Conversion ---
                            --- Conversion ---
@@ -426,12 +441,21 @@ end;
    function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
    function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
                              freeclusters,totalclusters:longint):longbool;
                              freeclusters,totalclusters:longint):longbool;
      external 'kernel32' name 'GetDiskFreeSpaceA';
      external 'kernel32' name 'GetDiskFreeSpaceA';
+type
+   TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,
+                             total,free):longbool;stdcall;
+
+var
+   GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
 
 
-function diskfree(drive : byte) : longint;
+function diskfree(drive : byte) : int64;
 var
 var
   disk : array[1..4] of char;
   disk : array[1..4] of char;
   secs,bytes,
   secs,bytes,
   free,total : longint;
   free,total : longint;
+  qwtotal,qwfree,qwcaller : int64;
+
+
 begin
 begin
   if drive=0 then
   if drive=0 then
    begin
    begin
@@ -445,18 +469,30 @@ begin
      disk[3]:='\';
      disk[3]:='\';
      disk[4]:=#0;
      disk[4]:=#0;
    end;
    end;
-  if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
-   diskfree:=free*secs*bytes
+  if assigned(GetDiskFreeSpaceEx) then
+    begin
+       if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
+         diskfree:=qwfree
+       else
+         diskfree:=-1;
+    end
   else
   else
-   diskfree:=-1;
+    begin
+       if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
+         diskfree:=free*secs*bytes
+       else
+         diskfree:=-1;
+    end;
 end;
 end;
 
 
 
 
-function disksize(drive : byte) : longint;
+function disksize(drive : byte) : int64;
 var
 var
   disk : array[1..4] of char;
   disk : array[1..4] of char;
   secs,bytes,
   secs,bytes,
   free,total : longint;
   free,total : longint;
+  qwtotal,qwfree,qwcaller : int64;
+
 begin
 begin
   if drive=0 then
   if drive=0 then
    begin
    begin
@@ -470,10 +506,20 @@ begin
      disk[3]:='\';
      disk[3]:='\';
      disk[4]:=#0;
      disk[4]:=#0;
    end;
    end;
-  if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
-   disksize:=total*secs*bytes
+  if assigned(GetDiskFreeSpaceEx) then
+    begin
+       if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
+         disksize:=qwtotal
+       else
+         disksize:=-1;
+    end
   else
   else
-   disksize:=-1;
+    begin
+       if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
+         disksize:=total*secs*bytes
+       else
+         disksize:=-1;
+    end;
 end;
 end;
 
 
 
 
@@ -848,11 +894,48 @@ Procedure setintvec(intno : byte;vector : pointer);
 Begin
 Begin
 End;
 End;
 
 
+function FreeLibrary(hLibModule : THANDLE) : longbool;
+  external 'kernel32' name 'FreeLibrary';
+function GetVersionEx(var VersionInformation:OSVERSIONINFO) : longbool;
+  external 'kernel32' name 'GetVersionExA';
+function LoadLibrary(lpLibFileName : pchar):THandle;
+  external 'kernel32' name 'LoadLibraryA';
+function GetProcAddress(hModule : THandle;lpProcName : pchar) : pointer;
+  external 'kernel32' name 'GetProcAddress';
 
 
+var
+   oldexitproc : pointer;
+
+procedure dosexitproc;
+
+  begin
+     exitproc:=oldexitproc;
+     if kernel32dll<>0 then
+       FreeLibrary(kernel32dll);
+  end;
+
+begin
+   oldexitproc:=exitproc;
+   exitproc:=@dosexitproc;
+   versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
+   GetVersionEx(versioninfo);
+   kernel32dll:=0;
+   GetDiskFreeSpaceEx:=nil;
+   if ((versioninfo.dwPlatformId=VER_PLATFORM_WIN32_WINDOWS) and
+     (versioninfo.dwBuildNUmber>=1000)) or
+     (versioninfo.dwPlatformId=VER_PLATFORM_WIN32_NT) then
+     begin
+        kernel32dll:=LoadLibrary('kernel32');
+        if kernel32dll<>0 then
+          GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
+     end;
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.30  2000-01-11 13:45:19  pierre
+  Revision 1.31  2000-01-24 21:57:56  florian
+    * disksize/diskfree return now a int64
+
+  Revision 1.30  2000/01/11 13:45:19  pierre
    * fsearch was still worng for multiple pathes
    * fsearch was still worng for multiple pathes
 
 
   Revision 1.29  2000/01/11 12:49:26  pierre
   Revision 1.29  2000/01/11 12:49:26  pierre
@@ -939,4 +1022,4 @@ end.
 
 
   Revision 1.2  1998/04/26 21:49:09  florian
   Revision 1.2  1998/04/26 21:49:09  florian
     + first compiling and working version
     + first compiling and working version
-}
+}