mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-15 18:29:09 +02:00
* disksize/diskfree return now a int64
This commit is contained in:
parent
f53621ffe2
commit
a8c87c6549
107
rtl/win32/dos.pp
107
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 DiskFree(drive: byte) : int64;
|
||||||
Function DiskSize(drive: byte) : longint;
|
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;
|
||||||
|
|
||||||
function diskfree(drive : byte) : longint;
|
var
|
||||||
|
GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
|
||||||
|
|
||||||
|
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
|
if assigned(GetDiskFreeSpaceEx) then
|
||||||
diskfree:=free*secs*bytes
|
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
|
if assigned(GetDiskFreeSpaceEx) then
|
||||||
disksize:=total*secs*bytes
|
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
|
||||||
}
|
}
|
||||||
|
Loading…
Reference in New Issue
Block a user