Delphi/delphimvcframework
1
0
Fork 0
mirror of https://github.com/danieleteti/delphimvcframework.git synced 2024-11-15 07:45:54 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity
master
delphimvcframework/lib/dmustache/mormot.core.os.windows.inc
Daniele Teti d743333741 Updated dmustache to version 2
2024-04-29 15:40:45 +02:00

5615 lines
170 KiB
PHP
Raw Permalink Blame History

{
This file is a part of the Open Source Synopse mORMot framework 2,
licensed under a MPL/GPL/LGPL three license - see LICENSE.md
Windows API calls for FPC/Delphi, as used by mormot.core.os.pas
}
{ ****************** Unicode, Time, File process }
const
/// Windows file APIs have hardcoded MAX_PATH = 260 :(
// - but more than 260 chars are possible with the \\?\..... prefix
// or by disabling the limitation in registry since Windows 10, version 1607
// https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation
// - extended-length path allows up to 32,767 widechars
// - but 2047 chars seems big enough in practice e.g. due to NTFS - POSIX uses 4096
W32_MAX = 2047;
type
/// 4KB stack buffer for no heap allocation during UTF-16 encoding or
// switch to extended-length path
TW32Temp = array[0..W32_MAX] of WideChar;
// W32() gets a PWideChar buffer from a TFileName using TW32Temp static buffer
// W32Copy() forces a temporary copy - as used by GetFileVersionInfo()
{$ifdef UNICODE}
function W32Copy(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
var
len: PtrInt;
begin
len := length(FileName) * 2 + 2; // +2 to include ending #0
if len > SizeOf(Temp) then
Temp[0] := #0 // avoid buffer overflow
else
MoveFast(pointer(FileName)^, Temp, len);
result := @Temp;
end;
// UnicodeString may need to be converted to extended-length path
function W32(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
var
U: pointer; // hold a UnicodeString but with no try..finally
begin
if (length(FileName) > MAX_PATH) and
(ord(FileName[1]) in [ord('A')..ord('Z'), ord('a')..ord('z')]) and
(FileName[2] = ':') then
begin
// convert to extended-length path
U := nil;
TFileName(U) := '\\?\' + FileName;
// move to TW32Temp stack buffer
result := W32Copy(TFileName(U), Temp);
// release temp memory and return the generated static buffer
TFileName(U) := '';
end
else
// no conversion nor allocation needed
result := pointer(FileName);
end;
{$else}
// AnsiString is converted to UTF-16, potentially with extended-length path
procedure W32Convert(const FileName: TFileName; var Temp: TW32Temp);
var
U: SynUnicode;
len: PtrInt;
begin
// identical to FPC RTL, which converts to UnicodeString before Wide API call
U := SynUnicode(FileName); // let the RTL + OS do the conversion
// switch to extended-length path if needed, allowing up to 32,767 widechars
len := length(U);
if (len > MAX_PATH) and
(FileName[1] in ['A'..'Z', 'a'..'z']) and
(FileName[2] = ':') then
U := '\\?\' + U;
// move to TW32Temp stack buffer
len := length(U) * 2 + 2; // +2 to include ending #0
if len > SizeOf(Temp) then
Temp[0] := #0 // avoid buffer overflow (rejected by Windows anyway)
else
MoveFast(pointer(U)^, Temp, len);
end;
function W32(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
var
i, len: PtrInt;
begin
len := length(FileName);
if len = 0 then
result := nil
else
begin
if (len < MAX_PATH) and
IsAnsiCompatible(pointer(FileName), len) then
// most common cases do not need any Unicode conversion
for i := 0 to len do // include trailing #0
PWordArray(@Temp)[i] := PByteArray(FileName)[i]
else
// use a temporary SynUnicode variable for complex UTF-16 conversion
// or if MAX_PATH is reached and \\?\ prefix is needed for extended length
W32Convert(FileName, Temp);
result := @Temp;
end;
end;
function W32Copy(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
begin
result := W32(FileName, Temp); // from AnsiString: name is always copied
end;
{$endif UNICODE}
function _fmt(const Fmt: string; const Args: array of const): RawUtf8; overload;
begin
result := RawUtf8(format(Fmt, Args)); // good enough (seldom called)
end;
procedure _fmt(const Fmt: string; const Args: array of const;
var result: RawUtf8); overload;
begin
result := RawUtf8(format(Fmt, Args)); // good enough (seldom called)
end;
procedure DoWin32PWideCharToUtf8(P: PWideChar; Len: PtrInt; var res: RawUtf8);
var
tmp: TSynTempBuffer;
begin
tmp.Init(Len * 3);
Len := UnicodeToUtf8(tmp.Buf, Len * 3, P, Len); // use RTL if complex
if Len > 0 then
dec(Len); // UnicodeToUtf8() result includes the null terminator
FastSetString(res, tmp.buf, Len);
tmp.Done;
end;
// local RTL wrapper functions to avoid linking mormot.core.unicode.pas
procedure Win32PWideCharToUtf8(P: PWideChar; Len: PtrInt; out res: RawUtf8);
var
i: PtrInt;
begin
if Len > 0 then
if IsAnsiCompatibleW(P, Len) then
begin
FastSetString(res, Len);
for i := 0 to Len - 1 do
PByteArray(res)[i] := PWordArray(P)[i]; // fast direct conversion
end
else
DoWin32PWideCharToUtf8(P, Len, res);
end;
procedure Win32PWideCharToUtf8(P: PWideChar; out res: RawUtf8);
begin
if P <> nil then
Win32PWideCharToUtf8(P, StrLenW(P), res);
end;
function Utf8ToWin32PWideChar(const Text: RawUtf8;
var dest: TSynTempBuffer): PWideChar;
var
TextLen, i: PtrInt;
begin
result := nil;
TextLen := length(Text);
dest.Init(TextLen * 2);
if dest.len = 0 then
exit;
result := dest.buf;
if IsAnsiCompatible(PAnsiChar(pointer(Text)), TextLen) then
begin
dest.len := TextLen;
for i := 0 to TextLen do // include trailing #0
PWordArray(result)[i] := PByteArray(Text)[i];
end
else
begin
dest.len := Utf8ToUnicode(result, dest.Len + 16, pointer(Text), TextLen);
if dest.len <= 0 then
dest.len := 0
else
begin
dec(dest.len); // Utf8ToUnicode() returned length includes trailing #0
result[dest.len] := #0; // missing on FPC
end;
end;
end;
const
DefaultCharVar: AnsiChar = '?';
function Unicode_AnsiToWide(A: PAnsiChar; W: PWideChar; LA, LW, CodePage: PtrInt): integer;
begin
result := MultiByteToWideChar(CodePage, MB_PRECOMPOSED, A, LA, W, LW);
end;
function Unicode_WideToAnsi(W: PWideChar; A: PAnsiChar; LW, LA, CodePage: PtrInt): integer;
begin
result := WideCharToMultiByte(CodePage, 0, W, LW, A, LA, @DefaultCharVar, nil);
end;
function LibraryOpen(const LibraryName: TFileName): TLibHandle;
var
tmp: TW32Temp;
err: DWord;
{$ifdef CPUX86}
x87cw: word;
{$endif CPUX86}
begin
// note: GetErrorMode() is not available on XP
err := SetErrorMode(SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS);
{$ifdef CPUX86}
asm
fnstcw x87cw // save x87 flags
end;
{$endif CPUX86}
result := Windows.LoadLibraryW(W32(LibraryName, tmp));
{$ifdef CPUX86}
asm
fnclex // clear pending x87 exceptions
fldcw x87cw // restore flags (Visual C++ librairies usually change them)
end;
{$endif CPUX86}
SetErrorMode(err);
end;
procedure LibraryClose(Lib: TLibHandle);
begin
if pointer(Lib) <> nil then
Windows.FreeLibrary(Lib);
end;
// Delphi Unicode has an ambiguous GetProcAddress() overload with PWideChar
function LibraryResolve(Lib: TLibHandle; ProcName: PAnsiChar): pointer;
external kernel32 name 'GetProcAddress'; // this is an Ansi-only API
function LibraryError: string;
begin
result := IntToStr(GetLastError); // enough for basic troubleshouting
end;
procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64);
{$ifdef HASINLINE} inline; {$endif}
begin
PInt64Rec(@I64)^.Lo := FT.dwLowDateTime; // Delphi 2007 bug with PInt64()
PInt64Rec(@I64)^.Hi := FT.dwHighDateTime;
end;
const
SecsPerFileTime = 10000000;
MilliSecsPerFileTime = 10000;
procedure UnixTimeToFileTime(I64: TUnixTime; out FT: TFileTime);
begin
I64 := (I64 * SecsPerFileTime) + UnixFileTimeDelta;
FT.dwLowDateTime := PInt64Rec(@I64)^.Lo; // Delphi 2007 bug with PInt64()
FT.dwHighDateTime := PInt64Rec(@I64)^.Hi;
end;
procedure UnixMSTimeToFileTime(I64: TUnixMSTime; out FT: TFileTime);
begin
I64 := (I64 * MilliSecsPerFileTime) + UnixFileTimeDelta;
FT.dwLowDateTime := PInt64Rec(@I64)^.Lo; // Delphi 2007 bug with PInt64()
FT.dwHighDateTime := PInt64Rec(@I64)^.Hi;
end;
procedure UnixTimeToLocalTime(I64: TUnixTime; out Local: TSystemTime);
var
ft, lt: TFileTime;
begin
UnixTimeToFileTime(I64, ft);
FileTimeToLocalFileTime(ft, lt);
FileTimeToSystemTime(lt, Local);
end;
function FileTimeToUnixTime(const FT: TFileTime): TUnixTime;
{$ifdef CPU64}
var
nano100: Int64; // TFileTime is in 100 ns unit
{$endif CPU64}
begin
if PInt64(@FT)^ = 0 then
begin
result := 0;
exit;
end;
{$ifdef CPU64}
FileTimeToInt64(ft, nano100);
result := (nano100 - UnixFileTimeDelta) div SecsPerFileTime;
{$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix
result := (PInt64(@ft)^ - UnixFileTimeDelta) div SecsPerFileTime;
{$endif CPU64}
end;
function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime;
{$ifdef CPU64}
var
nano100: Int64; // TFileTime is in 100 ns unit
{$endif CPU64}
begin
if PInt64(@FT)^ = 0 then
begin
result := 0;
exit;
end;
{$ifdef CPU64}
FileTimeToInt64(ft, nano100);
result := (nano100 - UnixFileTimeDelta) div MilliSecsPerFileTime;
{$else}
result := (PInt64(@ft)^ - UnixFileTimeDelta) div MilliSecsPerFileTime;
{$endif CPU64}
end;
function FileTimeToDateTime(const FT: TFileTime): TDateTime;
begin
if PInt64(@FT)^ = 0 then
result := 0
else // inlined UnixTimeToDateTime()
result := FileTimeToUnixMSTime(FT) / MSecsPerDay + UnixDateDelta;
end;
procedure DateTimeToFileTime(dt: TDateTime; out FT: TFileTime);
begin
if dt = 0 then
PInt64(@FT)^ := 0
else // inlined DateTimeToUnixTime()
UnixTimeToFileTime(Round((dt - UnixDateDelta) * SecsPerDay), FT);
end;
function UnixTimeUtc: TUnixTime;
var
ft: TFileTime;
begin
GetSystemTimeAsFileTime(ft); // fast (HW resolution is < TUnixTime second)
result := FileTimeToUnixTime(ft);
end;
var
// redirect to a slower but more accurate API available since Windows 8
// - points to GetSystemTimeAsFileTime() before Windows 8
GetSystemTimePreciseAsFileTime: procedure(var ft: TFILETIME); stdcall;
function UnixMSTimeUtc: TUnixMSTime;
var
ft: TFileTime;
begin
GetSystemTimePreciseAsFileTime(ft); // slower, but try to achieve ms resolution
result := FileTimeToUnixMSTime(ft);
end;
function UnixMSTimeUtcFast: TUnixMSTime;
var
ft: TFileTime;
begin
GetSystemTimeAsFileTime(ft); // faster, but with HW interupt resolution
result := FileTimeToUnixMSTime(ft);
end;
procedure GetSystemTime; external kernel32;
procedure GetLocalTime; external kernel32;
procedure InitializeCriticalSection; external kernel32;
procedure EnterCriticalSection; external kernel32;
procedure LeaveCriticalSection; external kernel32;
procedure DeleteCriticalSection; external kernel32;
function TryEnterCriticalSection; external kernel32;
function CloseHandle; external kernel32;
procedure FileClose; external kernel32 name 'CloseHandle';
function GetCurrentThreadId; external kernel32;
procedure SwitchToThread; external kernel32;
function GetCurrentProcessId; external kernel32;
function GetCurrentProcess; external kernel32;
function WaitForSingleObject; external kernel32;
function GetEnvironmentStringsW; external kernel32;
function FreeEnvironmentStringsW; external kernel32;
function RtlCaptureStackBackTrace; external kernel32;
function IsDebuggerPresent; external kernel32;
procedure SetEndOfFile; external kernel32;
procedure FlushFileBuffers; external kernel32;
function GetLastError; external kernel32;
procedure SetLastError; external kernel32;
function IocpCreate; external kernel32 name 'CreateIoCompletionPort';
function IocpGetQueuedStatus; external kernel32 name 'GetQueuedCompletionStatus';
function IocpPostQueuedStatus; external kernel32 name 'PostQueuedCompletionStatus';
function GetDesktopWindow; external user32;
function Unicode_InPlaceUpper; external user32 name 'CharUpperBuffW';
function Unicode_InPlaceLower; external user32 name 'CharLowerBuffW';
function HasConsole: boolean;
begin
if StdOut = 0 then
StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
result := (StdOut <> 0) and
(StdOut <> INVALID_HANDLE_VALUE);
end;
procedure AllocConsole;
begin
Windows.AllocConsole;
if (StdOut = 0) or
(StdOut = INVALID_HANDLE_VALUE) then
// force setup StdOut global variable
StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
end;
{$I-}
procedure DisplayFatalError(const title, msg: RawUtf8);
begin
// better than a MessageBox() especially for services
AllocConsole; // will create one black window console if none
if title <> '' then
begin
TextColor(ccWhite);
writeln(#13#10, title);
writeln(StringOfChar('-', length(title) + 1), #13#10);
TextColor(ccLightRed);
writeln(msg);
TextColor(ccLightGray);
end
else
writeln(msg);
ioresult;
end;
{$I+}
function IsSharedViolation(ErrorCode: integer): boolean;
begin
if ErrorCode = 0 then
ErrorCode := GetLastError;
result := ErrorCode in [ERROR_SHARING_VIOLATION, ERROR_LOCK_VIOLATION];
end;
function GetModuleHandle(lpModuleName: PChar): HMODULE;
begin
result := Windows.GetModuleHandle(lpModuleName); // call either A or W API
end;
function SetSystemTime(const utctime: TSystemTime): boolean;
var
privileges: TSynWindowsPrivileges;
begin
try
privileges.Init;
try
privileges.Enable(wspSystemTime); // ensure has SE_SYSTEMTIME_NAME
result := Windows.SetSystemTime(PSystemTime(@utctime)^);
finally
privileges.Done;
end;
if result then
PostMessage(HWND_BROADCAST, WM_TIMECHANGE, 0, 0); // notify the apps
except
result := false;
end;
end;
const
// https://learn.microsoft.com/en-us/windows/win32/debug/system-error-codes
ERROR_STANDARD1: array[0..39] of PUtf8Char = (
'SUCCESS', 'INVALID_FUNCTION', 'FILE_NOT_FOUND', 'PATH_NOT_FOUND',
'TOO_MANY_OPEN_FILES', 'ACCESS_DENIED', 'INVALID_HANDLE', 'ARENA_TRASHED',
'NOT_ENOUGH_MEMORY', 'INVALID_BLOCK', 'BAD_ENVIRONMENT', 'BAD_FORMAT',
'INVALID_ACCESS', 'INVALID_DATA', 'OUTOFMEMORY', 'INVALID_DRIVE',
'CURRENT_DIRECTORY', 'NOT_SAME_DEVICE', 'NO_MORE_FILES', 'WRITE_PROTECT',
'BAD_UNIT', 'NOT_READY', 'BAD_COMMAND', 'CRC', 'BAD_LENGTH', 'SEEK',
'NOT_DOS_DISK', 'SECTOR_NOT_FOUND', 'OUT_OF_PAPER', 'WRITE_FAULT',
'READ_FAULT', 'GEN_FAILURE', 'SHARING_VIOLATION', 'LOCK_VIOLATION',
'WRONG_DISK', '35', 'SHARING_BUFFER_EXCEEDED', '37', 'HANDLE_EOF',
'HANDLE_DISK_FULL');
ERROR_STANDARD2: array[50..55] of PUtf8Char = (
'NOT_SUPPORTED', 'REM_NOT_LIST', 'DUP_NAME', 'BAD_NETPATH',
'NETWORK_BUSY', 'DEV_NOT_EXIST');
ERROR_STANDARD3: array[80..89] of PUtf8Char = (
'FILE_EXISTS', '81', 'CANNOT_MAKE', 'FAIL_I24', 'OUT_OF_STRUCTURES',
'ALREADY_ASSIGNED', 'INVALID_PASSWORD', 'INVALID_PARAMETER',
'NET_WRITE_FAULT', 'NO_PROC_SLOTS');
ERROR_STANDARD4: array[108..129] of PUtf8Char = (
'DRIVE_LOCKED', 'BROKEN_PIPE', 'OPEN_FAILED', 'BUFFER_OVERFLOW',
'DISK_FULL', 'NO_MORE_SEARCH_HANDLES', 'INVALID_TARGET_HANDLE', '115',
'116', 'INVALID_CATEGORY', 'INVALID_VERIFY_SWITCH', 'BAD_DRIVER_LEVEL',
'CALL_NOT_IMPLEMENTED', 'SEM_TIMEOUT', 'INSUFFICIENT_BUFFER',
'INVALID_NAME', 'INVALID_LEVEL', 'NO_VOLUME_LABEL', 'MOD_NOT_FOUND',
'PROC_NOT_FOUND', 'WAIT_NO_CHILDREN', 'CHILD_NOT_COMPLETE');
ERROR_STANDARD5: array[995..1013] of PUtf8Char = (
'OPERATION_ABORTED', 'IO_INCOMPLETE', 'IO_PENDING', 'NOACCESS', 'SWAPERROR',
'1000', 'STACK_OVERFLOW', 'INVALID_MESSAGE', 'CAN_NOT_COMPLETE',
'INVALID_FLAGS', 'UNRECOGNIZED_VOLUME', 'FILE_INVALID', 'FULLSCREEN_MODE',
'NO_TOKEN', 'BADDB', 'BADKEY', 'CANTOPEN', 'CANTREAD', 'CANTWRITE');
ERROR_STANDARD6: array[1051..1079] of PUtf8Char = (
'DEPENDENT_SERVICES_RUNNING', 'INVALID_SERVICE_CONTROL',
'SERVICE_REQUEST_TIMEOUT', 'SERVICE_NO_THREAD', 'SERVICE_DATABASE_LOCKED',
'SERVICE_ALREADY_RUNNING', 'INVALID_SERVICE_ACCOUNT', 'SERVICE_DISABLED',
'CIRCULAR_DEPENDENCY', 'SERVICE_DOES_NOT_EXIST', 'SERVICE_CANNOT_ACCEPT_CTRL',
'SERVICE_NOT_ACTIVE', 'FAILED_SERVICE_CONTROLLER_CONNECT',
'EXCEPTION_IN_SERVICE', 'DATABASE_DOES_NOT_EXIST', 'SERVICE_SPECIFIC_ERROR',
'PROCESS_ABORTED', 'SERVICE_DEPENDENCY_FAIL', 'SERVICE_LOGON_FAILED',
'SERVICE_START_HANG', 'INVALID_SERVICE_LOCK', 'SERVICE_MARKED_FOR_DELETE',
'SERVICE_EXISTS', 'ALREADY_RUNNING_LKG', 'SERVICE_DEPENDENCY_DELETED',
'BOOT_ALREADY_ACCEPTED', 'SERVICE_NEVER_STARTED', 'DUPLICATE_SERVICE_NAME',
'DIFFERENT_SERVICE_ACCOUNT');
ERROR_STANDARD7: array[1200..1246] of PUtf8Char = (
'BAD_DEVICE', 'CONNECTION_UNAVAIL', 'DEVICE_ALREADY_REMEMBERED',
'NO_NET_OR_BAD_PATH', 'BAD_PROVIDER', 'CANNOT_OPEN_PROFILE', 'BAD_PROFILE',
'NOT_CONTAINER', 'EXTENDED_ERROR', 'INVALID_GROUPNAME', 'INVALID_COMPUTERNAME',
'INVALID_EVENTNAME', 'INVALID_DOMAINNAME', 'INVALID_SERVICENAME',
'INVALID_NETNAME', 'INVALID_SHARENAME', 'INVALID_PASSWORDNAME',
'INVALID_MESSAGENAME', 'INVALID_MESSAGEDEST', 'SESSION_CREDENTIAL_CONFLICT',
'REMOTE_SESSION_LIMIT_EXCEEDED', 'DUP_DOMAINNAME', 'NO_NETWORK', 'CANCELLED',
'USER_MAPPED_FILE', 'CONNECTION_REFUSED', 'GRACEFUL_DISCONNECT',
'ADDRESS_ALREADY_ASSOCIATED', 'ADDRESS_NOT_ASSOCIATED', 'CONNECTION_INVALID',
'CONNECTION_ACTIVE', 'NETWORK_UNREACHABLE', 'HOST_UNREACHABLE',
'PROTOCOL_UNREACHABLE', 'PORT_UNREACHABLE', 'REQUEST_ABORTED',
'CONNECTION_ABORTED', 'RETRY', 'CONNECTION_COUNT_LIMIT',
'LOGIN_TIME_RESTRICTION', 'LOGIN_WKSTA_RESTRICTION', 'INCORRECT_ADDRESS',
'ALREADY_REGISTERED', 'SERVICE_NOT_FOUND', 'NOT_AUTHENTICATED',
'NOT_LOGGED_ON', 'CONTINUE');
function WinErrorConstant(Code: cardinal): PUtf8Char;
begin
if Code <= high(ERROR_STANDARD1) then
result := ERROR_STANDARD1[Code]
else if Code in [low(ERROR_STANDARD2)..high(ERROR_STANDARD2)] then
result := ERROR_STANDARD2[Code]
else if Code in [low(ERROR_STANDARD3)..high(ERROR_STANDARD3)] then
result := ERROR_STANDARD3[Code]
else if Code in [low(ERROR_STANDARD4)..high(ERROR_STANDARD4)] then
result := ERROR_STANDARD4[Code]
else if (Code >= low(ERROR_STANDARD5)) and
(Code <= high(ERROR_STANDARD5)) then
result := ERROR_STANDARD5[Code]
else if (Code >= low(ERROR_STANDARD6)) and
(Code <= high(ERROR_STANDARD6)) then
result := ERROR_STANDARD6[Code]
else if (Code >= low(ERROR_STANDARD7)) and
(Code <= high(ERROR_STANDARD7)) then
result := ERROR_STANDARD7[Code]
else
case Code of
ERROR_ALREADY_EXISTS:
result := 'ALREADY_EXISTS';
ERROR_MORE_DATA:
result := 'MORE_DATA';
ERROR_NO_SYSTEM_RESOURCES:
result := 'NO_SYSTEM_RESOURCES';
ERROR_WINHTTP_CANNOT_CONNECT:
result := 'WINHTTP_CANNOT_CONNECT';
ERROR_WINHTTP_TIMEOUT:
result := 'WINHTTP_TIMEOUT';
ERROR_WINHTTP_INVALID_SERVER_RESPONSE:
result := 'WINHTTP_INVALID_SERVER_RESPONSE';
10014:
result := 'WSAEFAULT';
10022:
result := 'WSAEINVAL';
10024:
result := 'WSAEMFILE';
10035:
result := 'WSAEWOULDBLOCK';
10038:
result := 'WSAENOTSOCK';
10053:
result := 'WSAECONNABORTED';
10054:
result := 'WSAECONNRESET';
10055:
result := 'WSAENOBUFS';
10060:
result := 'WSAETIMEDOUT';
10061:
result := 'WSAECONNREFUSED';
11003:
result := 'WSATRY_AGAIN';
else
result := nil;
end;
end;
function WinErrorText(Code: cardinal; ModuleName: PChar): RawUtf8;
var
bak: integer;
flags, len: PtrUInt;
src: pointer;
cod: PUtf8Char;
tmp: array[0..511] of WideChar;
begin
bak := GetLastError;
src := nil;
flags := FORMAT_MESSAGE_FROM_SYSTEM;
if ModuleName = nil then
begin
// system error codes
cod := WinErrorConstant(Code);
if cod <> nil then
begin
// we can return directly the standard system error code constant
_fmt('ERROR_%s', [cod], result);
exit;
end;
end
else
begin
// module specific error codes
src := pointer(GetModuleHandle(ModuleName));
if src <> nil then
flags := FORMAT_MESSAGE_FROM_HMODULE;
end;
// first try if there is an English message version of this error code
len := FormatMessageW(flags, src, Code, ENGLISH_LANGID, @tmp, SizeOf(tmp), nil);
if len = 0 then
// typically ERROR_RESOURCE_LANG_NOT_FOUND or ERROR_MUI_FILE_NOT_FOUND
len := FormatMessageW(flags, src, Code, 0, @tmp, SizeOf(tmp), nil);
if (len = 0) and
(src <> nil) then
begin
// fallback to the system error message if this module as no such code
SetLastError(bak);
result := WinErrorText(Code, nil);
exit;
end;
while (len > 0) and
(ord(tmp[len - 1]) in [0..32, ord('.')]) do
dec(len); // trim right
Win32PWideCharToUtf8(@tmp, len, result);
SetLastError(bak);
end;
function GetErrorText(error: integer): RawUtf8;
begin
result := WinErrorText(error, nil);
end;
procedure RaiseLastModuleError(ModuleName: PChar; ModuleException: ExceptClass);
var
code: integer;
begin
code := GetLastError;
raise ModuleException.CreateFmt('%s error %x (%s)',
[ModuleName, code, string(WinErrorText(code, ModuleName))]);
end;
procedure RaiseLastError(const Context: shortstring; RaisedException: ExceptClass);
var
code: integer;
begin
code := GetLastError;
if RaisedException = nil then
RaisedException := EOSException;
raise RaisedException.CreateFmt('%s error %x (%s)',
[Context, code, string(WinErrorText(code, nil))])
end;
function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL;
begin
result := Windows.PostMessage(hWnd, Msg, wParam, lParam); // call either A or W API
end;
function ExpandEnvVars(const aStr: string): string;
// adapted from http://delphidabbler.com/articles?article=6
var
size: integer;
begin
// Get required buffer size
size := ExpandEnvironmentStrings(pointer(aStr), nil, 0);
if size > 0 then
begin
// Read expanded string into result string
SetString(result, nil, size - 1);
ExpandEnvironmentStrings(pointer(aStr), pointer(result), size);
end
else
result := aStr; // return the original file name
end;
function IsInitializedCriticalSection(var cs: TRTLCriticalSection): boolean;
begin
result := not IsZero(@cs, SizeOf(cs));
end;
var
// value is documented as stable after boot, so we get it at startup
_QueryPerformanceFrequency: QWord;
// from HyperV or if HPET disabled e.g. -> direct division
_QueryPerformanceFrequencyPer10: boolean;
procedure QueryPerformanceMicroSeconds(out Value: Int64);
var
v: Int64; // for proper alignment on some old Delphi revisions + Win32
begin
QueryPerformanceCounter(v);
if _QueryPerformanceFrequencyPer10 then
Value := QWord(v) div 10 // faster div by a constant (especially on FPC_64)
else
Value := QWord((QWord(v) * 1000000) div _QueryPerformanceFrequency);
end;
var
shlwapiDll: THandle; // lazy loading (only by TNetClientProtocolFile)
PathCreateFromUrl: function(pszUrl, pszPath: PChar; var pcchPath: cardinal;
dwFlags: cardinal): HRESULT; stdcall;
function GetFileNameFromUrl(const Uri: string): TFileName;
var
len: DWORD;
tmp: array[0..MAX_PATH] of char;
begin
result := '';
len := MAX_PATH;
if DelayedProc(PathCreateFromUrl, shlwapiDll, 'shlwapi.dll',
'PathCreateFromUrl' + _AW) and
(PathCreateFromUrl(pointer(Uri), @tmp, len, 0) = S_OK) then
result := tmp;
end;
const
faInvalidFile = faDirectory + faVolumeID{%H-} + faSysFile{%H-} + faHidden{%H-};
faDirectoryMask = faDirectory + faHidden{%H-};
function FileDateToDateTime(const FileDate: TFileAge): TDateTime;
begin
result := WindowsFileTimeToDateTime(FileDate);
end;
// some definitions missing on oldest Delphi
const
FILE_ATTRIBUTE_REPARSE_POINT = $0000400;
function FindFirstFileExW(lpfilename: PWideChar; fInfoLevelId: FINDEX_INFO_LEVELS;
lpFindFileData: pointer; fSearchOp: FINDEX_SEARCH_OPS;
lpSearchFilter: pointer = nil; dwAdditionalFlags: cardinal = 0): THandle;
stdcall; external kernel32;
// an alternative to GetFileAttributesExW() with fallback to FindFirstFileEx API
function GetFileAttributesRaw(fn: PWideChar;
out Attr: WIN32_FILE_ATTRIBUTE_DATA): boolean;
var
h: THandle;
fd: TWin32FindDataW;
begin
// this API is much faster than CreateFile/GetFileTime/GetFileSize/CloseHandle
result := GetFileAttributesExW(fn, GetFileExInfoStandard, @Attr);
if result or
(GetLastError in [ERROR_FILE_NOT_FOUND, ERROR_PATH_NOT_FOUND,
ERROR_INVALID_NAME, ERROR_INVALID_DRIVE, ERROR_NOT_READY,
ERROR_INVALID_PARAMETER, ERROR_BAD_PATHNAME, ERROR_BAD_NETPATH,
ERROR_BAD_NET_NAME]) then
exit;
// access denied, or locked file: fallback to slower but regular API
h := FindFirstFileExW(fn, FindExInfoStandard, @fd, FindExSearchNameMatch);
if not ValidHandle(h) then
exit;
windows.FindClose(h);
Attr.dwFileAttributes := fd.dwFileAttributes;
Attr.ftCreationTime := fd.ftCreationTime;
Attr.ftLastAccessTime := fd.ftLastAccessTime;
Attr.ftLastWriteTime := fd.ftLastWriteTime;
Attr.nFileSizeHigh := fd.nFileSizeHigh;
Attr.nFileSizeLow := fd.nFileSizeLow;
result := true;
end;
function GetFileAttributesInternal(const FileName: TFileName;
out Attr: WIN32_FILE_ATTRIBUTE_DATA; FollowLink: boolean = true): boolean;
var
fn: PWideChar;
h: THandle;
f: cardinal;
lp: TByHandleFileInformation;
tmp: TW32Temp;
begin
result := false;
if FileName = '' then
exit;
fn := W32(FileName, tmp);
result := GetFileAttributesRaw(fn, Attr);
if result and
FollowLink and
(Attr.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT <> 0) then
begin
// we need to follow a symbolic link
f := 0;
if Attr.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then
f := FILE_FLAG_BACKUP_SEMANTICS; // to access folder handle
FillCharFast(Attr, SizeOf(Attr), 0); // enough for FileExists()
// raw file access seems better than FileGetSymLinkTarget() in our case
// and it will be consistent on both FPC and Delphi (including pre-Unicode)
// - if we require file information, it is likely we would like to access it
// - note that FPC and Delphi RTL seems overcomplicated and non-consistent
// about symbolic links: mORMot will share this function everywhere
h := CreateFileW(fn, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, f, 0);
if ValidHandle(h) then
begin
if GetFileInformationByHandle(h, lp) then
begin
Attr.dwFileAttributes := lp.dwFileAttributes;
Attr.ftCreationTime := lp.ftCreationTime;
Attr.ftLastAccessTime := lp.ftLastAccessTime;
Attr.ftLastWriteTime := lp.ftLastWriteTime;
Attr.nFileSizeHigh := lp.nFileSizeHigh;
Attr.nFileSizeLow := lp.nFileSizeLow;
end
else
result := false;
CloseHandle(h);
end
else
result := IsSharedViolation;
end;
end;
function FileAgeToDateTime(const FileName: TFileName): TDateTime;
var
FA: WIN32_FILE_ATTRIBUTE_DATA;
ST, LT: TSystemTime;
begin
if (FileName <> '') and
GetFileAttributesInternal(FileName, FA) and
FileTimeToSystemTime({%H-}FA.ftLastWriteTime, ST) and
SystemTimeToTzSpecificLocalTime(nil, ST, LT) then
result := SystemTimeToDateTime(LT)
else
result := 0;
end;
function FileAgeToUnixTimeUtc(const FileName: TFileName; AllowDir: boolean): TUnixTime;
var
FA: WIN32_FILE_ATTRIBUTE_DATA;
begin
if (FileName <> '') and
GetFileAttributesInternal(FileName, FA) and
(AllowDir or ({%H-}FA.dwFileAttributes and faDirectory = 0)) then
result := FileTimeToUnixTime(FA.ftLastWriteTime) // no local time conversion
else
result := 0;
end;
function FileAgeToWindowsTime(const FileName: TFileName): integer;
var
FA: WIN32_FILE_ATTRIBUTE_DATA;
ft: TFileTime;
begin
result := 0;
if (FileName <> '') and
GetFileAttributesInternal(FileName, FA) and
({%H-}FA.dwFileAttributes and faDirectory = 0) and
FileTimeToLocalFileTime(FA.ftLastWriteTime, ft) and
not FileTimeToDosDateTime(ft, LongRec(result).Hi, LongRec(result).Lo) then
result := 0;
end;
function FileSetDateFromWindowsTime(const Dest: TFileName; WinTime: integer): boolean;
begin
result := FileSetDate(Dest, WinTime) = 0; // we already are on Windows
end;
function FileSetDateFromUnixUtc(const Dest: TFileName; Time: TUnixTime): boolean;
var
D: THandle;
ft: TFileTime;
begin
result := false;
if (Dest = '') or
(Time = 0) then
exit;
D := FileOpen(Dest, fmOpenWrite);
if not ValidHandle(D) then
exit;
UnixTimeToFileTime(Time, ft);
result := SetFileTime(D, nil, nil, @ft);
FileClose(D);
end;
function SearchRecToWindowsTime(const F: TSearchRec): integer;
begin
result := F.Time; // already in the expected legacy format
end;
function SearchRecToUnixTimeUtc(const F: TSearchRec): TUnixTime;
begin // return the search record timestamp with no local time conversion
result := FileTimeToUnixTime(F.FindData.ftLastWriteTime);
end;
function FileInfoByHandle(aFileHandle: THandle; FileId, FileSize: PInt64;
LastWriteAccess, FileCreateDateTime: PUnixMSTime): boolean;
var
mtime, atime, ctime: Int64;
lp: TByHandleFileInformation;
begin
result := GetFileInformationByHandle(aFileHandle, lp);
if not result then
exit;
if FileId <> nil then
begin
PInt64Rec(FileId)^.lo := lp.nFileIndexLow;
PInt64Rec(FileId)^.hi := lp.nFileIndexHigh;
end;
if FileSize <> nil then
begin
PInt64Rec(FileSize)^.lo := lp.nFileSizeLow;
PInt64Rec(FileSize)^.hi := lp.nFileSizeHigh;
end;
if (LastWriteAccess = nil) and
(FileCreateDateTime = nil) then
exit;
mtime := FileTimeToUnixMSTime(lp.ftLastWriteTime);
if LastWriteAccess <> nil then
LastWriteAccess^ := mtime;
if FileCreateDateTime = nil then
exit;
atime := FileTimeToUnixMSTime(lp.ftLastAccessTime);
ctime := FileTimeToUnixMSTime(lp.ftCreationTime);
if mtime <> 0 then
if (ctime = 0) or
(ctime > mtime) then
ctime := mtime;
if atime <> 0 then
if (ctime = 0) or
(ctime > atime) then
ctime := atime;
FileCreateDateTime^ := ctime;
end;
function FileIsExecutable(const FileName: TFileName): boolean;
var
h: THandle;
header: word;
begin
result := false;
h := FileOpen(FileName, fmOpenReadShared);
if not ValidHandle(h) then
exit;
result := (FileRead(h, header, 2) = 2) and
(header = $5A4D); // DOS Magic Number
FileClose(h);
end;
function GetModuleHandleExA(dwFlags: cardinal; lpModuleName: pointer;
var phModule: HMODULE): BOOL; stdcall; external kernel32;
const
GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT = $00000002;
GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS = $00000004;
function GetExecutableName(aAddress: pointer): TFileName;
var
tmp: array[byte] of WideChar;
hm: HMODULE;
begin
result := '';
FillcharFast(tmp, SizeOf(tmp), 0);
hm := 0;
if not GetModuleHandleExA(GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT or
GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, aAddress, hm) then
exit;
GetModuleFileNameW(hm, tmp, SizeOf(tmp));
result := string(SynUnicode(tmp));
end;
function FileIsWritable(const FileName: TFileName): boolean;
var
FA: WIN32_FILE_ATTRIBUTE_DATA;
begin
result := (FileName <> '') and
GetFileAttributesInternal(FileName, FA) and
(FA.dwFileAttributes and faReadOnly = 0);
end;
function FileExists(const FileName: TFileName; FollowLink, CheckAsDir: boolean): boolean;
var
FA: WIN32_FILE_ATTRIBUTE_DATA;
begin
result := (FileName <> '') and
GetFileAttributesInternal(FileName, FA, FollowLink) and
((FA.dwFileAttributes and faDirectory <> 0) = CheckAsDir);
end;
function DirectoryExists(const FileName: TFileName; FollowLink: boolean): boolean;
var
L: integer;
begin
L := length(FileName);
if L = 0 then
result := false
else if (L = 1) and
(FileName[1] = '.') then
result := true
else if FileName[L] <> '\' then
result := FileExists(FileName, FollowLink, {checkasdir=}true)
else
result := FileExists(copy(FileName, 1, L - 1), FollowLink, true);
end;
function FileSize(const FileName: TFileName): Int64;
var
FA: WIN32_FILE_ATTRIBUTE_DATA;
begin
if (FileName <> '') and
GetFileAttributesInternal(FileName, FA) and
(FA.dwFileAttributes and faDirectory = 0) then
result := Qword(FA.nFileSizeHigh) shl 32 + FA.nFileSizeLow
else
result := 0;
end;
function FileInfoByName(const FileName: TFileName; out FileSize: Int64;
out FileTimestampUtc: TUnixMSTime): boolean;
var
FA: WIN32_FILE_ATTRIBUTE_DATA;
begin
result := (FileName <> '') and
GetFileAttributesInternal(FileName, FA);
if not result then
exit;
PInt64Rec(@FileSize)^.Lo := FA.nFileSizeLow;
PInt64Rec(@FileSize)^.Hi := FA.nFileSizeHigh;
FileTimestampUtc := FileTimeToUnixMSTime(FA.ftLastWriteTime) // no local time
end;
function GetFileSizeEx(hFile: THandle; var FileSize: Int64): BOOL;
stdcall; external kernel32;
function FileSize(F: THandle): Int64;
begin
if (PtrInt(F) <= 0) or
not GetFileSizeEx(F, result) then
result := 0;
end;
function FileSeek64(Handle: THandle; const Offset: Int64;
Origin: cardinal): Int64;
var
r: TQWordRec;
begin
r.V := Offset;
r.L := SetFilePointer(Handle, r.L, @r.H, Origin);
if (r.Li = -1) and
(GetLastError <> 0) then
result := -1
else
result := r.V;
end;
function DeleteFile(const aFileName: TFileName): boolean;
var
tmp: TW32Temp;
begin
if aFileName = '' then
result := false
else
result := DeleteFileW(W32(aFileName, tmp));
end;
function FileShare(aMode: integer): DWord;
begin
case (aMode and $f0) of
fmShareRead: // = fmShareDenyWrite
result := FILE_SHARE_READ;
fmShareWrite: // = fmShareDenyRead
result := FILE_SHARE_WRITE;
fmShareReadWrite: // = fmShareDenyNone
result := FILE_SHARE_READ or FILE_SHARE_WRITE;
else
result := 0;
end;
end;
function FileCreate(const aFileName: TFileName; aMode, aRights: integer): THandle;
var
tmp: TW32Temp;
begin
// aRights parameter is just ignored on Windows
if aFileName = '' then
result := 0
else
result := CreateFileW(W32(aFileName, tmp), GENERIC_READ or GENERIC_WRITE,
FileShare(aMode), nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
end;
const
FILE_WRITE_ATTRIBUTES = $0100; // not defined on oldest Delphi
// W32() will support length > MAX_PATH even if aFileName is UnicodeString
function FileOpen(const aFileName: TFileName; aMode: integer): THandle;
const
ACCESS: array[0..2] of DWord = (
GENERIC_READ, // fmOpenRead = $0000
GENERIC_WRITE, // fmOpenWrite = $0001
GENERIC_READ or GENERIC_WRITE or FILE_WRITE_ATTRIBUTES); // fmOpenReadWrite
var
tmp: TW32Temp;
begin
if aFileName = '' then
result := 0
else
result := CreateFileW(W32(aFileName, tmp), ACCESS[aMode and 3],
FileShare(aMode), nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
end;
function FileSetDateFrom(const Dest: TFileName; SourceHandle: THandle): boolean;
var
FileTime: TFileTime;
D: THandle;
begin
if (Dest = '') or
not ValidHandle(SourceHandle) then
result := false
else
begin
D := FileOpen(Dest, fmOpenWrite);
if ValidHandle(D) then
begin
result := GetFileTime(SourceHandle, nil, nil, @FileTime) and
SetFileTime(D, nil, nil, @FileTime);
FileClose(D);
end
else
result := false;
end;
end;
function FileSetDateFrom(const Dest, Source: TFileName): boolean;
var
S: THandle;
begin
result := false;
if (Dest = '') or
(Source = '') then
exit;
S := FileOpen(Source, fmOpenReadShared);
if not ValidHandle(S) then
exit;
result := FileSetDateFrom(Dest, S);
FileClose(S);
end;
procedure FileSetAttr(const FileName: TFileName; Attr: integer);
var
tmp: TW32Temp;
begin
if FileName <> '' then
SetFileAttributesW(W32(FileName, tmp), Attr);
end;
procedure FileSetHidden(const FileName: TFileName; ReadOnly: boolean);
const
FLAGS: array[boolean] of integer = (
FILE_ATTRIBUTE_HIDDEN,
FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_READONLY);
begin
FileSetAttr(FileName, FLAGS[ReadOnly]);
end;
procedure FileSetSticky(const FileName: TFileName);
begin
FileSetAttr(FileName, FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_SYSTEM);
end;
function RenameFile(const OldName, NewName: TFileName): boolean;
var
o, n: TW32Temp;
begin
if (OldName = '') or
(NewName = '') then
result := false
else
result := MoveFileW(W32(OldName, o), W32(NewName, n));
end;
function FileSetTime(const FileName: TFileName;
const Created, Accessed, Written: Int64): boolean;
var
tmp: TW32Temp;
h: THandle;
pct, pat, pwt: pointer;
begin
result := false;
h := CreateFileW(W32(FileName, tmp), FILE_WRITE_ATTRIBUTES,
FILE_SHARE_READ, nil, OPEN_ALWAYS, 0, 0);
if ValidHandle(h) then
try
// some input code may not set all properties: use what we got
if Created <> 0 then
pct := @Created
else if Written <> 0 then
pct := @Written
else if Accessed <> 0 then
pct := @Accessed
else
exit;
if Accessed <> 0 then
pat := @Accessed
else if Written <> 0 then
pat := @Written
else
pat := @Created;
if Written <> 0 then
pwt := @Written
else if Created <> 0 then
pwt := @Created
else
pwt := @Accessed;
result := SetFileTime(h, pct, pat, pwt);
finally
CloseHandle(h);
end;
end;
function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean;
var
s, t: TW32Temp;
begin
if (Source = '') or
(Target = '') then
result := false
else
result := Windows.CopyFileW(W32(Source, s), W32(Target, t), FailIfExists);
end;
function ValidHandle(Handle: THandle): boolean;
begin
result := PtrInt(Handle) > 0;
end;
function FileOpenSequentialRead(const FileName: TFileName): integer;
var
tmp: TW32Temp;
begin
result := CreateFileW(W32(FileName, tmp), GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_FLAG_SEQUENTIAL_SCAN, 0);
end;
function FileIsReadable(const aFileName: TFileName): boolean;
var
tmp: TW32Temp;
h: THandle;
begin
h := CreateFileW(W32(aFileName, tmp), GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
result := ValidHandle(h);
if result then
CloseHandle(h);
end;
threadvar // mandatory: GetTickCount seems per-thread on XP :(
LastTickXP: TQWordRec;
function GetTickCount64ForXP: Int64; stdcall;
var
t32: cardinal;
p: PQWordRec;
begin
// warning: GetSystemTimeAsFileTime() is fast, but not monotonic!
t32 := Windows.GetTickCount; // we only have the 32-bit counter on XP
p := @LastTickXP;
inc(p^.H, ord(t32 < p^.L)); // wrap-up overflow after 49 days
p^.L := t32;
result := p^.V;
end; // warning: FPC's GetTickCount64 doesn't handle 49 days wrap on XP :(
procedure InitializeSRWLockForXP(var P: TOSLightMutex); stdcall;
begin
TLightLock(P).Init; // TLightLock is good enough on XP
end;
procedure AcquireSRWLockExclusiveForXP(var P: TOSLightMutex); stdcall;
begin
TLightLock(P).Lock;
end;
procedure ReleaseSRWLockExclusiveForXP(var P: TOSLightMutex); stdcall;
begin
TLightLock(P).UnLock;
end;
function GetUptimeSec: cardinal;
begin
result := GetTickCount64 div MSecsPerSec; // good enough
end;
procedure SleepHiRes(ms: cardinal);
begin
if ms <> 0 then
Windows.Sleep(ms) // follow the HW timer: typically up to 16ms on Windows
else
SwitchToThread;
end;
{ TOSLightLock }
procedure TOSLightLock.Init;
begin
fMutex := nil;
InitializeSRWLock(fMutex); // fallback to TLightLock on XP
end;
procedure TOSLightLock.Done;
begin // nothing needed
end;
procedure TOSLightLock.Lock;
begin
AcquireSRWLockExclusive(fMutex);
end;
procedure TOSLightLock.UnLock;
begin
ReleaseSRWLockExclusive(fMutex);
end;
{ TSynEvent }
constructor TSynEvent.Create;
begin
fHandle := pointer(CreateEvent(nil, false, false, nil));
end;
destructor TSynEvent.Destroy;
begin
CloseHandle(THandle(fHandle));
inherited Destroy;
end;
procedure TSynEvent.ResetEvent;
begin
Windows.ResetEvent(THandle(fHandle));
end;
procedure TSynEvent.SetEvent;
begin
Windows.SetEvent(THandle(fHandle));
end;
procedure TSynEvent.WaitFor(TimeoutMS: integer);
begin
WaitForSingleObject(THandle(fHandle), TimeoutMS);
end;
procedure TSynEvent.WaitForEver;
begin
WaitForSingleObject(THandle(fHandle), INFINITE);
end;
{$ifdef FPC}
{$define NOSETTHREADNAME} // only tested and supported on Delphi
{$endif FPC}
const
// see http://msdn.microsoft.com/en-us/library/xcb2z8hs
cSetThreadNameException = $406D1388;
{$ifdef NOSETTHREADNAME}
procedure RawSetThreadName(ThreadID: TThreadID; const Name: RawUtf8);
begin
end;
{$else}
procedure RawSetThreadName(ThreadID: TThreadID; const Name: RawUtf8);
var
s: AnsiString;
{$ifndef ISDELPHIXE2}
info: record
FType: LongWord; // must be 0x1000
FName: PAnsiChar; // pointer to name (in user address space)
FThreadID: LongWord; // thread ID (-1 indicates caller thread)
FFlags: LongWord; // reserved for future use, must be zero
end;
{$endif ISDELPHIXE2}
begin
if not IsDebuggerPresent then
exit;
s := AnsiString(Name);
{$ifdef ISDELPHIXE2}
TThread.NameThreadForDebugging(s, ThreadID); // use
{$else}
info.FType := $1000;
info.FName := pointer(s);
info.FThreadID := ThreadID;
info.FFlags := 0;
try
RaiseException(
cSetThreadNameException, 0, SizeOf(info) div SizeOf(LongWord), @info);
except
{ignore}
end;
{$endif ISDELPHIXE2}
end;
{$endif NOSETTHREADNAME}
function RawKillThread(Thread: TThread): boolean;
begin
result := (Thread <> nil) and
Windows.TerminateThread(Thread.Handle, 777);
end;
procedure ResetCpuSet(out CpuSet: TCpuSet);
begin
CpuSet := 0;
end;
function SetThreadMaskAffinity(Thread: TThread; const Mask: TCpuSet): boolean;
begin
result := (Thread <> nil) and
(Windows.SetThreadAffinityMask(Thread.Handle, Mask) <> 0);
end;
function GetProcessAffinityMask(hProcess: THandle;
var lpProcessAffinityMask, lpSystemAffinityMask: TCpuSet): BOOL;
stdcall; external kernel32; // redefined for Delphi 7 compatibility
function GetMaskAffinity(out CpuSet: TCpuSet): boolean;
var
process, thread: TCpuSet;
begin
result := GetProcessAffinityMask(GetCurrentProcess, process, thread);
if result then
CpuSet := process;
end;
type
// avoid linking of ComObj.pas just for EOleSysError
EOleSysError = class(Exception)
public
ErrorCode: cardinal;
end;
{$ifndef NOEXCEPTIONINTERCEPT}
const
// https://docs.microsoft.com/en-us/archive/blogs/yizhang/interpreting-hresults-returned-from-netclr-0x8013xxxx
// see also https://referencesource.microsoft.com/#mscorlib/system/__hresults.cs
DOTNET_EXCEPTIONNAME: array[0..91] of PUtf8Char = (
'Access', // $8013151A
'AmbiguousMatch', // $8000211D
'appdomainUnloaded', // $80131015
'Application', // $80131600
'Argument', // $80070057
'ArgumentNull', // $80004003
'ArgumentOutOfRange', // $80131502
'Arithmetic', // $80070216
'ArrayTypeMismatch', // $80131503
'BadImageFormat', // $8007000B
'CannotUnloadappdomain', // $80131015
'ContextMarshal', // $80090020
'Cryptographic', // $80004001
'CryptographicUnexpectedOperation', // $80131431
'CustomAttributeFormat', // $80131537
'DirectoryNotFound', // $80070003
'DirectoryNotFound', // $80030003
'DivideByZero', // $80020012
'DllNotFound', // $80131524
'DuplicateWaitObject', // $80131529
'EndOfStream', // $00801338
'EntryPointNotFound', // $80131522
'', // $80131500 - name is plain Exception
'ExecutionEngine', // $80131506
'External', // $80004005
'FieldAccess', // $80131507
'FileLoad', // $80131621
'FileLoad', // $80131018
'FileNotFound', // $80070002
'Format', // $80131537
'IndexOutOfRange', // $80131508
'InvalidCast', // $80004002
'InvalidComObject', // $80131527
'InvalidFilterCriteria', // $80131601
'InvalidOleVariantType', // $80131531
'InvalidOperation', // $80131509
'InvalidProgram', // $8013153A
'IO', // $80131620
'IsolatedStorage', // $80131450
'MarshalDirective', // $80131535
'MethodAccess', // $80131510
'MissingField', // $80131511
'MissingManifestResource', // $80131532
'MissingMember', // $80131512
'MissingMethod', // $80131513
'MulticastNotSupported', // $80131514
'NotFiniteNumber', // $80131528
'NotImplemented', // $80004001
'NotSupported', // $80131515
'NullReference', // $80004003
'OutOfMemory', // $8007000E
'Overflow', // $80131516
'PlatformNotSupported', // $80131539
'Policy', // $80131416
'Rank', // $80131517
'ReflectionTypeLoad', // $80131602
'Remoting', // $8013150B
'RemotingTimeout', // $8013150B
'SafeArrayTypeMismatch', // $80131533
'SafeArrayRankMismatch', // $80131538
'Security', // $8013150A
'SEH', // $80004005
'Serialization', // $8013150C
'Server', // $8013150E
'StackOverflow', // $800703E9
'SUDSGenerator', // $80131500
'SUDSParser', // $80131500
'SynchronizationLock', // $80131518
'System', // $80131501
'Target', // $80131603
'TargetInvocation', // $80131604
'TargetParameterCount', // $80138002
'ThreadAbort', // $80131530
'ThreadInterrupted', // $80131519
'ThreadState', // $80131520
'ThreadStop', // $80131521
'TypeInitialization', // $80131534
'TypeLoad', // $80131522
'TypeUnloaded', // $80131013
'UnauthorizedAccess', // $80070005
'InClassConstructor', // $80131543
'KeyNotFound', // $80131577
'InsufficientStack', // $80131578
'InsufficientMemory', // $8013153D
'Verification', // $8013150D
'HostProtection', // $80131640
'MinGrantFailed', // $80131417
'Crypto', // $80131430
'CryptoUnexOper', // $80131431
'Overflow', // $8002000a
'InvalidName', // $80131047
'TypeMismatch'); // $80028ca0
DOTNET_EXCEPTIONHRESULT: array[0..91] of cardinal = (
$8013151A,
$8000211D,
$80131015,
$80131600,
$80070057,
$80004003,
$80131502,
$80070216,
$80131503,
$8007000B,
$80131015,
$80090020,
$80004001,
$80131431,
$80131537,
$80070003,
$80030003,
$80020012,
$80131524,
$80131529,
$00801338,
$80131522,
$80131500,
$80131506,
$80004005,
$80131507,
$80131621,
$80131018,
$80070002,
$80131537,
$80131508,
$80004002,
$80131527,
$80131601,
$80131531,
$80131509,
$8013153A,
$80131620,
$80131450,
$80131535,
$80131510,
$80131511,
$80131532,
$80131512,
$80131513,
$80131514,
$80131528,
$80004001,
$80131515,
$80004003,
$8007000E,
$80131516,
$80131539,
$80131416,
$80131517,
$80131602,
$8013150B,
$8013150B,
$80131533,
$80131538,
$8013150A,
$80004005,
$8013150C,
$8013150E,
$800703E9,
$80131500,
$80131500,
$80131518,
$80131501,
$80131603,
$80131604,
$80138002,
$80131530,
$80131519,
$80131520,
$80131521,
$80131534,
$80131522,
$80131013,
$80070005,
$80131543,
$80131577,
$80131578,
$8013153D,
$8013150D,
$80131640,
$80131417,
$80131430,
$80131431,
$8002000a,
$80131047,
$80028ca0);
function ExceptionInheritsFrom(E: TClass; const Name: ShortString): boolean;
begin
result := true;
while (E <> nil) and
(E <> Exception) do
if PropNameEquals(PPointer(PtrInt(E) + vmtClassName)^, @Name) then
exit
else
E := GetClassParent(E);
result := false;
end;
function TSynLogExceptionContext.AdditionalInfo(
out ExceptionNames: TPUtf8CharDynArray): cardinal;
var
i: PtrInt;
begin
if ExceptionInheritsFrom(EClass, 'EOleSysError') then
begin
result := EOleSysError(EInstance).ErrorCode;
if result > $80000000 then
for i := 0 to high(DOTNET_EXCEPTIONHRESULT) do
// manual loop: the same error code can appear several times
if DOTNET_EXCEPTIONHRESULT[i] = result then
PtrArrayAdd(ExceptionNames, DOTNET_EXCEPTIONNAME[i]);
end
else
result := 0;
end;
var
_RawLogException: TOnRawLogException;
{$ifdef FPC}
{$ifdef WIN64}
{$define WITH_VECTOREXCEPT} // use AddVectoredExceptionHandler Win64 API
{$else}
{$ifdef FPC_USE_WIN32_SEH}
{$define WITH_VECTOREXCEPT} // new since FPC 3.2
{$else}
// Win32, Linux: intercept via the RaiseProc global variable
{$define WITH_RAISEPROC} // RaiseProc is set in main mormot.core.os.pas
{$endif FPC_USE_WIN32_SEH}
{$endif WIN64}
{$else}
{$ifdef CPU64}
{$define WITH_VECTOREXCEPT}
{$else}
{$define WITH_RTLUNWINDPROC} // use x86_64 asm -> Win32 only
{$endif CPU64}
{$endif FPC}
{$ifndef WITH_RAISEPROC}
type
PExceptionRecord = ^TExceptionRecord;
TExceptionRecord = record
ExceptionCode: DWord;
ExceptionFlags: DWord;
OuterException: PExceptionRecord;
ExceptionAddress: PtrUInt;
NumberParameters: integer;
case {IsOsException:} boolean of
true:
(ExceptionInformation: array[0..14] of PtrUInt);
false:
(ExceptAddr: PtrUInt;
ExceptObject: Exception);
end;
GetExceptionClass = function(const P: TExceptionRecord): ExceptClass;
const
{$ifdef FPC}
cRtlException = $E0465043; // $E0 F P C
{$else}
cRtlException = $0EEDFADE; // Delphi exception
{$endif FPC}
procedure LogExcept(stack: PPtrUInt; const Exc: TExceptionRecord);
var
ctxt: TSynLogExceptionContext;
backuplasterror: DWord;
backuphandler: TOnRawLogException;
begin
if Exc.ExceptionCode = cSetThreadNameException then
exit;
backuplasterror := GetLastError;
backuphandler := _RawLogException;
if Assigned(backuphandler) then // paranoid check (tested before calling)
try
_RawLogException := nil; // disable nested exception
ctxt.ECode := Exc.ExceptionCode;
if (Exc.ExceptionCode = cRtlException) and
(Exc.ExceptObject <> nil) then
begin
if Exc.ExceptObject.InheritsFrom(Exception) then
ctxt.EClass := PPointer(Exc.ExceptObject)^
else
ctxt.EClass := EExternalException;
ctxt.EInstance := Exc.ExceptObject;
ctxt.ELevel := sllException;
ctxt.EAddr := Exc.ExceptAddr;
end
else
begin
if Assigned(ExceptClsProc) then
ctxt.EClass := GetExceptionClass(ExceptClsProc)(Exc)
else
ctxt.EClass := EExternal;
ctxt.EInstance := nil;
ctxt.ELevel := sllExceptionOS;
ctxt.EAddr := Exc.ExceptionAddress;
end;
ctxt.EStack := pointer(stack);
ctxt.EStackCount := 0;
ctxt.ETimestamp := UnixTimeUtc; // fast API call
backuphandler(ctxt);
except
{ ignore any nested exception }
end;
_RawLogException := backuphandler;
SetLastError(backuplasterror); // code above could have changed this
end;
{$ifdef WITH_VECTOREXCEPT}
type
PExceptionInfo = ^TExceptionInfo;
TExceptionInfo = packed record
ExceptionRecord: PExceptionRecord;
ContextRecord: pointer;
end;
var
AddVectoredExceptionHandler: function(FirstHandler: cardinal;
VectoredHandler: pointer): PtrInt; stdcall;
function SynLogVectoredHandler(ExceptionInfo: PExceptionInfo): PtrInt; stdcall;
const
EXCEPTION_CONTINUE_SEARCH = 0;
begin
if Assigned(_RawLogException) then
LogExcept(nil, ExceptionInfo^.ExceptionRecord^);
result := EXCEPTION_CONTINUE_SEARCH;
end;
{$endif WITH_VECTOREXCEPT}
{$ifdef WITH_RTLUNWINDPROC}
var
OldUnWindProc: pointer;
procedure SynRtlUnwind(TargetFrame, TargetIp: pointer;
ExceptionRecord: PExceptionRecord; ReturnValue: Pointer); stdcall;
asm
cmp dword ptr _RawLogException, 0
jz @old
pushad
mov eax, TargetFrame
mov edx, ExceptionRecord
call LogExcept
popad
@old: pop ebp // hidden push ebp at asm level
jmp OldUnWindProc
end;
{$endif WITH_RTLUNWINDPROC}
{$endif WITH_RAISEPROC}
{$endif NOEXCEPTIONINTERCEPT}
{ TMemoryMap }
function TMemoryMap.DoMap(aCustomOffset: Int64): boolean;
begin
with PInt64Rec(@fFileSize)^ do
fMap := CreateFileMapping(fFile, nil, PAGE_READONLY, Hi, Lo, nil);
if fMap = 0 then
RaiseLastError('TMemoryMap.Map: CreateFileMapping');
with PInt64Rec(@aCustomOffset)^ do
fBuf := MapViewOfFile(fMap, FILE_MAP_READ, Hi, Lo, fBufSize);
if fBuf = nil then
begin
// Windows failed to find a contiguous VA space -> fall back on direct read
CloseHandle(fMap);
fMap := 0;
end;
result := fMap <> 0;
end;
procedure TMemoryMap.DoUnMap;
begin
if fMap <> 0 then
begin
UnmapViewOfFile(fBuf);
CloseHandle(fMap);
fMap := 0;
end;
end;
const
STUB_SIZE = 65536; // 16*4 KB (4 KB = memory granularity)
type
TProcessMemoryCounters = record
cb: DWord;
PageFaultCount: DWord;
PeakWorkingSetSize: PtrUInt;
WorkingSetSize: PtrUInt;
QuotaPeakPagedPoolUsage: PtrUInt;
QuotaPagedPoolUsage: PtrUInt;
QuotaPeakNonPagedPoolUsage: PtrUInt;
QuotaNonPagedPoolUsage: PtrUInt;
PagefileUsage: PtrUInt;
PeakPagefileUsage: PtrUInt;
end;
const
PROCESS_QUERY_LIMITED_INFORMATION = $1000;
var
// PROCESS_QUERY_INFORMATION (XP) / PROCESS_QUERY_LIMITED_INFORMATION (Vista+)
OpenProcessAccess: DWord;
// late-binding of Windows API entries not available on XP
GetSystemTimes: function(
var lpIdleTime, lpKernelTime, lpUserTime: TFileTime): BOOL; stdcall;
GetProcessTimes: function(hProcess: THandle;
var lpCreationTime, lpExitTime, lpKernelTime,
lpUserTime: TFileTime): BOOL; stdcall;
// Vista+/WS2008+ (use GetModuleFileNameEx on XP)
QueryFullProcessImageNameW: function(hProcess: THandle; dwFlags: DWord;
lpExeName: PWideChar; lpdwSize: PDWord): BOOL; stdcall;
// PSAPI API late-binding via DelayedProc()
GetProcessMemoryInfo: function(Process: THandle;
var ppsmemCounters: TProcessMemoryCounters; cb: DWord): BOOL; stdcall;
EnumProcesses: function(lpidProcess: PDWord; cb: DWord;
var cbNeeded: DWord): BOOL; stdcall;
GetModuleFileNameExW: function(hProcess: THandle; hModule: HMODULE;
lpBaseName: PWideChar; nSize: DWord): DWord; stdcall;
function DelayedProc(var api; var lib: THandle;
libname: PChar; procname: PAnsiChar): boolean;
var
proc: pointer;
begin
if pointer(api) = nil then
begin
proc := nil;
GlobalLock; // avoid race condition
if lib = 0 then
lib := Windows.LoadLibrary(libname);
if lib >= 32 then
proc := Windows.GetProcAddress(lib, procname)
else
lib := 1; // try to load the library once
if proc = nil then
proc := pointer(1); // mark non available
pointer(api) := proc; // set it last
GlobalUnLock;
end;
result := pointer(api) <> pointer(1);
end;
function GetNextItem(var P: PAnsiChar): RawUtf8;
var
S: PAnsiChar;
begin
result := '';
while P^ <= ' ' do
if P^ = #0 then
exit
else
inc(P);
S := P;
repeat
inc(P);
until P^ <= ' ';
FastSetString(result, S, P - S);
end;
const
PAGE_GUARD = $0100;
PAGE_VALID = $00e6; // PAGE_READONLY or PAGE_READWRITE or PAGE_EXECUTE or
// PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY
var
LastMemInfo: TMemoryBasicInformation; // simple cache
function SeemsRealPointer(p: pointer): boolean;
var
meminfo: TMemoryBasicInformation;
begin
result := false;
if PtrUInt(p) <= 65535 then
exit; // first 64KB is not a valid pointer by definition
if (LastMemInfo.State <> 0) and
(PtrUInt(p) - PtrUInt(LastMemInfo.BaseAddress) <=
PtrUInt(LastMemInfo.RegionSize)) then
result := true // reuse last memory region information if we can
else
begin
// VirtualQuery API is slow but better than raising an exception
// see https://stackoverflow.com/a/37547837/458259
FillCharFast(meminfo, SizeOf(meminfo), 0);
result := (VirtualQuery(p, meminfo, SizeOf(meminfo)) = SizeOf(meminfo)) and
(meminfo.RegionSize >= SizeOf(pointer)) and
(meminfo.State = MEM_COMMIT) and
(meminfo.Protect and PAGE_VALID <> 0) and
(meminfo.Protect and PAGE_GUARD = 0);
if result then
LastMemInfo := meminfo;
end;
end;
var
PsapiDll: THandle;
function EnumAllProcesses: TCardinalDynArray;
var
n, count: cardinal;
begin
result := nil;
if not DelayedProc(EnumProcesses, PsapiDll, 'Psapi.dll', 'EnumProcesses') then
exit;
count := 0;
n := 2048; // retrieve 2KB of IDs, i.e. 512 processes, by default
repeat
SetLength(result, n);
if EnumProcesses(pointer(result), n * 4, count) then
count := count shr 2 // from bytes to count
else
count := 0; // error
if count < n then
break;
// count=n if buffer was too small
inc(n, 1024);
until n > 8192;
if count = 0 then
result := nil // on error
else
DynArrayFakeLength(result, count); // no realloc
end;
function EnumProcessName(PID: cardinal): RawUtf8;
var
h: THandle;
len: DWord;
name: array[0..4095] of WideChar;
begin
result := '';
if PID = 0 then
exit;
h := OpenProcess(OpenProcessAccess, false, PID);
if h <> 0 then
try
if Assigned(QueryFullProcessImageNameW) then
begin
len := high(name);
if QueryFullProcessImageNameW(h, 0, name, @len) then
Win32PWideCharToUtf8(name, len, result);
end
else if DelayedProc(GetModuleFileNameExW, PsapiDll, 'Psapi.dll',
'GetModuleFileNameExW') and
(GetModuleFileNameExW(h, 0, name, high(name)) <> 0) then
Win32PWideCharToUtf8(name, result);
finally
CloseHandle(h);
end;
end;
// some definitions missing on Delphi and/or FPC
type
TProcessEntry32 = record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: PtrUInt;
th32ModuleID:DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: integer; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array [0..MAX_PATH - 1] of WideChar; // Path
end;
TThreadEntry32 = record
dwSize: DWord;
cntUsage: DWord;
th32ThreadID: DWord; // this thread
th32OwnerProcessID: DWord; // Process this thread is associated with
tpBasePri: integer;
tpDeltaPri: integer;
dwFlags: DWord;
end;
const
TH32CS_SNAPPROCESS = $00000002;
TH32CS_SNAPTHREAD = $00000004;
function AttachConsole(pid: cardinal): BOOL;
stdcall; external kernel32;
function GetConsoleWindow: HWND;
stdcall; external kernel32;
function CreateToolhelp32Snapshot(dwFlags, th32ProcessID: DWord): THandle;
stdcall; external kernel32;
function Process32FirstW(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL;
stdcall; external kernel32;
function Process32NextW(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL;
stdcall; external kernel32;
function Thread32First(hSnapshot: THandle; var lpte: TThreadEntry32): BOOL;
stdcall; external kernel32;
function Thread32Next(hSnapshot: THandle; var lpte: TThreadEntry32): BOOL;
stdcall; external kernel32;
function PostThreadMessage(idThread: DWord; Msg: UINT; wParam: WPARAM;
lParam: LPARAM): BOOL;
stdcall; external user32 name 'PostThreadMessageW';
function RawProcessInfo(pid: cardinal; var e: TProcessEntry32): boolean;
var
snap: THandle;
begin
result := false;
if integer(pid) <= 0 then
pid := GetCurrentProcessId;
snap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if snap <= 0 then
exit;
FillCharFast(e, SizeOf(e), 0);
e.dwSize := SizeOf(e);
result := true;
if Process32FirstW(snap, e) then // loop over all processes of the system
repeat
if e.th32ProcessID = pid then
exit;
until not Process32NextW(snap, e);
CloseHandle(snap);
result := false;
end;
function GetParentProcess(PID: cardinal): cardinal;
var
e: TProcessEntry32;
begin
if RawProcessInfo(PID, e) then
result := e.th32ParentProcessID
else
result := 0;
end;
function RetrieveSystemTimes(out IdleTime, KernelTime, UserTime: Int64): boolean;
var
ftidl, ftkrn, ftusr: TFileTime;
begin
result := Assigned(GetSystemTimes) and
GetSystemTimes(ftidl, ftkrn, ftusr);
if not result then
exit;
FileTimeToInt64(ftidl, IdleTime);
FileTimeToInt64(ftkrn, KernelTime);
FileTimeToInt64(ftusr, UserTime);
end;
function RetrieveLoadAvg: RawUtf8;
begin
result := ''; // call RetrieveSystemTimes() instead
end;
function DelayedGetProcessMemoryInfo: boolean;
begin
result:= DelayedProc(GetProcessMemoryInfo, PsapiDll, 'Psapi.dll',
'GetProcessMemoryInfo');
end;
function RetrieveProcessInfo(PID: cardinal; out KernelTime, UserTime: Int64;
out WorkKB, VirtualKB: cardinal): boolean;
var
h: THandle;
ftkrn, ftusr, ftp, fte: TFileTime;
mem: TProcessMemoryCounters;
begin
result := false;
if (not Assigned(GetProcessTimes)) or
(not DelayedGetProcessMemoryInfo) then
exit;
h := OpenProcess(OpenProcessAccess, false, PID);
if h = 0 then
exit;
try
if GetProcessTimes(h, ftp, fte, ftkrn, ftusr) then
begin
FileTimeToInt64(ftkrn, KernelTime);
FileTimeToInt64(ftusr, UserTime);
FillCharFast(mem, SizeOf(mem), 0);
mem.cb := SizeOf(mem);
if GetProcessMemoryInfo(h, mem, SizeOf(mem)) then
begin
WorkKB := mem.WorkingSetSize shr 10;
VirtualKB := mem.PagefileUsage shr 10;
end;
result := true;
end;
finally
CloseHandle(h);
end;
end;
function CoCreateGuid(out guid: THash128Rec): HRESULT;
stdcall; external 'ole32.dll';
procedure XorOSEntropy(var e: THash512Rec);
var
h: THash128Rec;
ft: packed record
krn, usr, p, e: TFileTime;
end;
mem: TProcessMemoryCounters;
begin
QueryPerformanceCounter(h.Lo); // e.h3 xored with raw timestamps
e.i[6] := e.i[6] xor h.Lo;
if Assigned(GetProcessTimes) then
GetProcessTimes(GetCurrentProcess, ft.p, ft.e, ft.krn, ft.usr);
DefaultHasher128(@e.h0, @ft, SizeOf(ft));
if Assigned(GetProcessMemoryInfo) then // may have been delayed
begin
mem.cb := SizeOf(mem);
GetProcessMemoryInfo(GetCurrentProcess, mem, SizeOf(mem));
DefaultHasher128(@e.h1, @mem, SizeOf(mem));
end;
if Assigned(GetSystemTimes) then
GetSystemTimes(ft.usr, ft.p, ft.e);
DefaultHasher128(@e.h2, @ft, SizeOf(ft));
CoCreateGuid(h); // very fast on Windows - used to obfuscate system info
e.i[0] := e.i[0] xor h.Lo;
e.i[1] := e.i[1] xor h.Hi;
CoCreateGuid(h);
e.i[2] := e.i[2] xor h.Lo;
e.i[3] := e.i[3] xor h.Hi;
CoCreateGuid(h);
e.i[4] := e.i[4] xor h.Lo;
e.i[5] := e.i[5] xor h.Hi;
CoCreateGuid(h);
e.i[6] := e.i[6] xor h.Lo;
e.i[7] := e.i[7] xor h.Hi;
QueryPerformanceCounter(h.Lo); // is likely to have changed in-between
e.i[7] := e.i[7] xor h.Lo; // e.h3 xored with raw timestamps
end;
function FillSystemRandom(Buffer: PByteArray; Len: integer;
AllowBlocking: boolean): boolean;
var
prov: HCRYPTPROV;
begin
result := false;
if Len <= 0 then
exit;
// warning: on some Windows versions, this could take up to 30 ms!
if CryptoApi.Available then
if CryptoApi.AcquireContextA(prov, nil, nil,
PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) then
begin
result := CryptoApi.GenRandom(prov, Len, Buffer);
CryptoApi.ReleaseContext(prov, 0);
end;
if not result then
// OS API call failed -> fallback to our Lecuyer's gsl_rng_taus2 generator
RandomBytes(pointer(Buffer), Len);
end;
function TProcessInfo.Init: boolean;
begin
FillCharFast(self, SizeOf(self), 0);
// no monitoring API available under oldest Windows
result := Assigned(GetSystemTimes) and
Assigned(GetProcessTimes) and
DelayedGetProcessMemoryInfo;
end;
function TProcessInfo.Start: boolean;
var
ftidl, ftkrn, ftusr: TFileTime;
sidl, skrn, susr: Int64;
begin
result := Assigned(GetSystemTimes) and
GetSystemTimes(ftidl, ftkrn, ftusr);
if not result then
exit;
FileTimeToInt64(ftidl, sidl);
FileTimeToInt64(ftkrn, skrn);
FileTimeToInt64(ftusr, susr);
fDiffIdle := sidl - fSysPrevIdle;
fDiffKernel := skrn - fSysPrevKernel;
fDiffUser := susr - fSysPrevUser;
fDiffTotal := fDiffKernel + fDiffUser; // kernel time also includes idle time
dec(fDiffKernel, fDiffIdle);
fSysPrevIdle := sidl;
fSysPrevKernel := skrn;
fSysPrevUser := susr;
end;
function TProcessInfo.PerProcess(PID: cardinal; Now: PDateTime;
out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean;
var
h: THandle;
ftkrn, ftusr, ftp, fte: TFileTime;
pkrn, pusr: Int64;
mem: TProcessMemoryCounters;
begin
result := false;
FillCharFast(Data, SizeOf(Data), 0);
h := OpenProcess(OpenProcessAccess, false, PID);
if h <> 0 then
try
if GetProcessTimes(h, ftp, fte, ftkrn, ftusr) then
begin
if Now <> nil then
Data.Timestamp := Now^;
FileTimeToInt64(ftkrn, pkrn);
FileTimeToInt64(ftusr, pusr);
if (PrevKernel <> 0) and
(fDiffTotal > 0) then
begin
Data.Kernel := ((pkrn - PrevKernel) * 100) / fDiffTotal;
Data.User := ((pusr - PrevUser) * 100) / fDiffTotal;
end;
PrevKernel := pkrn;
PrevUser := pusr;
FillCharFast(mem, SizeOf(mem), 0);
mem.cb := SizeOf(mem);
if GetProcessMemoryInfo(h, mem, SizeOf(mem)) then
begin
Data.WorkKB := mem.WorkingSetSize shr 10;
Data.VirtualKB := mem.PagefileUsage shr 10;
end;
result := true;
end;
finally
CloseHandle(h);
end;
end;
function TProcessInfo.PerSystem(out Idle, Kernel, User: single): boolean;
begin
if fDiffTotal <= 0 then
begin
Idle := 0;
Kernel := 0;
User := 0;
result := false;
end
else
begin
Kernel := {%H-}SimpleRoundTo2Digits((fDiffKernel * 100) / fDiffTotal);
User := {%H-}SimpleRoundTo2Digits((fDiffUser * 100) / fDiffTotal);
Idle := 100 - Kernel - User; // ensure sum is always 100%
result := true;
end;
end;
{$ifndef UNICODE} // 64-bit aware Windows API missing on FPC and oldest Delphi
type
TMemoryStatusEx = record
dwLength: DWord;
dwMemoryLoad: DWord;
ullTotalPhys: QWord;
ullAvailPhys: QWord;
ullTotalPageFile: QWord;
ullAvailPageFile: QWord;
ullTotalVirtual: QWord;
ullAvailVirtual: QWord;
ullAvailExtendedVirtual: QWord;
end;
// information about the system's current usage of both physical and virtual memory
function GlobalMemoryStatusEx(var lpBuffer: TMemoryStatusEx): BOOL;
stdcall; external kernel32;
{$endif UNICODE}
function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean;
{$ifdef WITH_FASTMM4STATS}
var
Heap: TMemoryManagerState;
sb: PtrInt;
{$endif WITH_FASTMM4STATS}
var
global: TMemoryStatusEx;
mem: TProcessMemoryCounters;
begin
FillCharFast(global, SizeOf(global), 0);
global.dwLength := SizeOf(global);
result := GlobalMemoryStatusEx(global);
info.percent := global.dwMemoryLoad;
info.memtotal := global.ullTotalPhys;
info.memfree := global.ullAvailPhys;
info.filetotal := global.ullTotalPageFile;
info.filefree := global.ullAvailPageFile;
info.vmtotal := global.ullTotalVirtual;
info.vmfree := global.ullAvailVirtual;
info.allocreserved := 0;
info.allocused := 0;
if not withalloc then
exit;
{$ifdef WITH_FASTMM4STATS} // override OS information by actual FastMM4
GetMemoryManagerState(Heap); // direct raw FastMM4 access
info.allocused := Heap.TotalAllocatedMediumBlockSize +
Heap.TotalAllocatedLargeBlockSize;
info.allocreserved := Heap.ReservedMediumBlockAddressSpace +
Heap.ReservedLargeBlockAddressSpace;
for sb := 0 to high(Heap.SmallBlockTypeStates) do
with Heap.SmallBlockTypeStates[sb] do
begin
inc(info.allocused, UseableBlockSize * AllocatedBlockCount);
inc(info.allocreserved, ReservedAddressSpace);
end;
{$else}
if not DelayedGetProcessMemoryInfo then
exit;
FillcharFast(mem, SizeOf(mem), 0);
mem.cb := SizeOf(mem);
GetProcessMemoryInfo(GetCurrentProcess, mem, SizeOf(mem));
info.allocreserved := mem.PeakWorkingSetSize;
info.allocused := mem.WorkingSetSize;
{$endif WITH_FASTMM4STATS}
end;
function GetDiskFreeSpaceExW(lpDirectoryName: PWideChar;
var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes,
lpTotalNumberOfFreeBytes: QWord): LongBool;
stdcall; external kernel32;
{
// DeviceIoControl(IOCTL_DISK_GET_PARTITION_INFO) requires root -> not used
function DeviceIoControl(hDevice: THandle; dwIoControlCode: DWord;
lpInBuffer: Pointer; nInBufferSize: DWord; lpOutBuffer: Pointer;
nOutBufferSize: DWord; var lpBytesReturned: DWord;
lpOverlapped: POverlapped): BOOL; stdcall; external kernel32;
}
function GetDiskInfo(var aDriveFolderOrFile: TFileName;
out aAvailableBytes, aFreeBytes, aTotalBytes: QWord;
aVolumeName: PSynUnicode): boolean;
var
tmp: array[0..MAX_PATH - 1] of WideChar;
dummy, flags: DWord;
dn: SynUnicode;
begin
if aDriveFolderOrFile = '' then
aDriveFolderOrFile := SysUtils.UpperCase(
ExtractFileDrive(Executable.ProgramFilePath));
dn := SynUnicode(aDriveFolderOrFile); // use RTL for UTF-16 conversion
if (dn <> '') and
(dn[2] = ':') and
(dn[3] = #0) then
dn := dn + '\';
if (aVolumeName <> nil) and
(aVolumeName^ = '') then
begin
tmp[0] := #0;
GetVolumeInformationW(pointer(dn), tmp, MAX_PATH, nil, dummy, flags, nil, 0);
aVolumeName^ := tmp;
end;
result := GetDiskFreeSpaceExW(pointer(dn),
aAvailableBytes, aTotalBytes, aFreeBytes);
end;
function GetDiskPartitions: TDiskPartitions;
var
drives, drive, m, n: integer;
fn: TFileName;
volume: SynUnicode;
av, fr, tot: QWord;
p: ^TDiskPartition;
begin
result := nil;
n := 0;
fn := '#:';
drives := GetLogicalDrives;
m := 1 shl 2; // bit 2 = drive C
for drive := 3 to 26 do
begin
// retrieve partitions mounted as C..Z drives
if drives and m <> 0 then
begin
fn[1] := char(64 + drive);
if GetDiskInfo(fn, av, fr, tot, @volume) then
begin
SetLength(result, n + 1);
p := @result[n];
Win32PWideCharToUtf8(pointer(volume), length(volume), p^.name);
p^.mounted := fn;
p^.size := tot;
volume := '';
inc(n);
end;
end;
m := m shl 1;
end;
end;
var
TextAttr: integer = ord(ccDarkGray);
procedure TextColor(Color: TConsoleColor);
var
oldAttr: integer;
begin
if not HasConsole then
exit;
oldAttr := TextAttr;
TextAttr := (TextAttr and $F0) or ord(Color);
if TextAttr <> oldAttr then
SetConsoleTextAttribute(StdOut, TextAttr);
end;
procedure TextBackground(Color: TConsoleColor);
var
oldAttr: integer;
begin
if not HasConsole then
exit;
oldAttr := TextAttr;
TextAttr := (TextAttr and $0F) or (ord(Color) shl 4);
if TextAttr <> oldAttr then
SetConsoleTextAttribute(StdOut, TextAttr);
end;
var
ConsoleCriticalSection: TOSLock;
procedure ConsoleWrite(const Text: RawUtf8; Color: TConsoleColor;
NoLineFeed, NoColor: boolean);
var
txt: RawByteString;
l: PtrInt;
written: cardinal;
begin
if not HasConsole then
exit;
txt := Utf8ToConsole(Text);
l := length(txt);
if not NoLineFeed then
begin
SetLength(txt, l + 2); // faster to reallocate than WriteFile() twice
PWord(@PByteArray(txt)[l])^ := $0a0d; // CRLF
inc(l, 2);
end;
ConsoleCriticalSection.Lock;
try
if not NoColor then
TextColor(Color);
WriteFile(StdOut, pointer(txt)^, l, written, nil);
// FlushFileBuffers(StdOut); // don't: would block until read on the pipe
finally
ConsoleCriticalSection.UnLock;
end;
end;
function ConsoleKeyPressed(ExpectedKey: Word): boolean;
var
events, read: DWord;
rec: TInputRecord;
h: THandle;
begin
result := false;
h := GetStdHandle(STD_INPUT_HANDLE);
events := 0;
GetNumberOfConsoleInputEvents(h, events);
if events <> 0 then
begin
PeekConsoleInput(h, rec, 1, read);
if read <> 0 then
if rec.EventType = KEY_EVENT then
if rec.Event.KeyEvent.bKeyDown and
((ExpectedKey = 0) or
(rec.Event.KeyEvent.wVirtualKeyCode = ExpectedKey)) then
result := true
else
FlushConsoleInputBuffer(h)
else
FlushConsoleInputBuffer(h);
end;
end;
type
TConsoleHandleCtrlC = class
private
class procedure HandleCtrlC;
end;
var
ConsoleHandleCtrlCPressed: boolean;
class procedure TConsoleHandleCtrlC.HandleCtrlC;
begin
ConsoleHandleCtrlCPressed := true;
end;
procedure ConsoleWaitForEnterKey;
var
msg: TMsg;
begin
ConsoleHandleCtrlCPressed := false;
HandleCtrlC(TConsoleHandleCtrlC.HandleCtrlC);
try
if GetCurrentThreadID = MainThreadID then
// process the messages from the main thread while waiting
while not ConsoleKeyPressed(VK_RETURN) and
not ConsoleHandleCtrlCPressed do
begin
if IsMultiThread then
CheckSynchronize{$ifndef DELPHI6OROLDER}(100){$endif}
else
Sleep(100);
while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
if msg.Message = WM_QUIT then
exit // stop waiting when the process is gracefully closing
else
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end
else
// just intercept any WM_QUIT message on this sub-thread
while not ConsoleKeyPressed(VK_RETURN) and
not ConsoleHandleCtrlCPressed do
begin
Sleep(100);
if PeekMessage(msg, 0, 0, 0, PM_REMOVE) then
if msg.Message = WM_QUIT then
exit; // nothing to dispatch with PostThreadMessage()
end;
finally
HandleCtrlC(nil);
end;
end;
{$I+}
{$ifdef ISDELPHI}
var
// Delphi doesn't define this global variable need by ConsoleReadBody
StdInputHandle: THandle;
{$endif ISDELPHI}
function ConsoleStdInputLen: integer;
begin
if StdInputHandle = 0 then
StdInputHandle := GetStdHandle(STD_INPUT_HANDLE);
if not PeekNamedPipe(StdInputHandle, nil, 0, nil, @result, nil) then
result := 0;
end;
procedure Utf8ToConsoleDoConv(const Utf8: RawUtf8; var Console: RawByteString);
var
tmp16, tmp: TSynTempBuffer;
begin
Utf8ToWin32PWideChar(Utf8, tmp16);
if tmp16.len = 0 then
begin
Console := Utf8; // input is not valid UTF-8 -> return without conversion
exit;
end;
tmp.Init(tmp16.len * 3);
CharToOemBuffW(tmp16.buf, tmp.buf, tmp16.len + 1); // +1 = ending #0
tmp16.Done;
FastSetStringCP(Console, tmp.buf, StrLen(tmp.buf), CP_OEMCP);
tmp.Done;
end;
function Utf8ToConsole(const S: RawUtf8): RawByteString;
begin
if IsAnsiCompatible(S) then
result := S // no conversion needed
else
Utf8ToConsoleDoConv(S, result);
end;
function TFileVersion.RetrieveInformationFromFileName: boolean;
var
Size, Size2: DWord;
Pt: Pointer;
Trans: PWordArray;
LanguageInfo: RawUtf8;
Info: ^TVSFixedFileInfo;
FileTime: TFILETIME;
SystemTime: TSYSTEMTIME;
tmp: TW32Temp;
function ReadResourceByName(const From: RawUtf8): RawUtf8;
var
StrValPt: pointer;
sz: DWord;
u: SynUnicode;
begin
u := Utf8Decode('\StringFileInfo\' + LanguageInfo + '\' + From);
VerQueryValueW(Pt, pointer(u), StrValPt, sz);
if sz > 0 then
Win32PWideCharToUtf8(StrValPt, result)
else
result := '';
end;
begin
result := false;
if fFileName = '' then
exit;
// GetFileVersionInfo() modifies the filename parameter data while parsing
// -> copy the FileName into local tmp buffer to create a writable copy
Size := GetFileVersionInfoSizeW(W32Copy(fFileName, tmp), Size2);
if Size > 0 then
begin
GetMem(Pt, Size);
try
if GetFileVersionInfoW(W32Copy(fFileName, tmp), 0, Size, Pt) then
begin
VerQueryValueW(Pt, '\', pointer(Info), Size2);
with Info^ do
begin
SetVersion({major=} dwFileVersionMS shr 16,
{minor=} word(dwFileVersionMS),
{release=} dwFileVersionLS shr 16,
{build=} word(dwFileVersionLS));
if (dwFileDateLS <> 0) and
(dwFileDateMS <> 0) then
begin
FileTime.dwLowDateTime := dwFileDateLS; // built date from version info
FileTime.dwHighDateTime := dwFileDateMS;
FileTimeToSystemTime(FileTime, SystemTime);
fBuildDateTime := EncodeDate(
SystemTime.wYear, SystemTime.wMonth, SystemTime.wDay);
end;
end;
VerQueryValueW(Pt, '\VarFileInfo\Translation', pointer(Trans), Size2);
if Size2 >= 4 then
begin
_fmt('%4.4x%4.4x', [Trans^[0], Trans^[1]], LanguageInfo);
CompanyName := ReadResourceByName('CompanyName');
FileDescription := ReadResourceByName('FileDescription');
FileVersion := ReadResourceByName('FileVersion');
InternalName := ReadResourceByName('InternalName');
LegalCopyright := ReadResourceByName('LegalCopyright');
OriginalFilename := ReadResourceByName('OriginalFilename');
ProductName := ReadResourceByName('ProductName');
ProductVersion := ReadResourceByName('ProductVersion');
Comments := ReadResourceByName('Comments');
end;
result := true;
end;
finally
Freemem(Pt);
end;
end;
end;
procedure GetUserHost(out User, Host: RawUtf8);
var
tmp: array[byte] of WideChar;
tmpsize: cardinal;
begin
tmpsize := SizeOf(tmp);
GetComputerNameW(tmp{%H-}, tmpsize);
Win32PWideCharToUtf8(@tmp, Host);
tmpsize := SizeOf(tmp);
GetUserNameW(tmp, tmpsize);
Win32PWideCharToUtf8(@tmp, User);
end;
var
SHFolderDll: THandle;
// avoid unneeded reference to ShlObj.pas
// - late binding is mandatory to be used on WinPE which does NOT have this dll
// - late binding also ensure that we load libraries only when needed
SHGetFolderPath: function(hwnd: hwnd; csidl: integer; hToken: THandle;
dwFlags: DWord; pszPath: PChar): HRESULT; stdcall;
const
CSIDL_PERSONAL = $0005;
CSIDL_LOCAL_APPDATA = $001C; // local non roaming user folder
CSIDL_COMMON_APPDATA = $0023;
CSIDL_COMMON_DOCUMENTS = $002E;
CSIDL: array[TSystemPath] of integer = (
CSIDL_COMMON_APPDATA, // spCommonData
// C:\ProgramData
CSIDL_LOCAL_APPDATA, // spUserData
// C:\Users\<user>\AppData\Local
CSIDL_COMMON_DOCUMENTS, // spCommonDocuments
// C:\Users\Public\Documents
CSIDL_PERSONAL, // spUserDocuments
// C:\Users\<user>\Documents
0, // spTemp
0); // spLog
// note: for SYSTEM user, got C:\Windows\System32\config\systemprofile\AppData
// or C:\Windows\SysWOW64\config\systemprofile\AppData (on Win32 over Win64)
procedure _ComputeSystemPath(kind: TSystemPath; var result: TFileName);
const
_ENV: array[TSystemPath] of TFileName = (
'ALLUSERSAPPDATA', // spCommonData
'LOCALAPPDATA', // spUserData
'', // spCommonDocuments
'', // spUserDocuments
'TEMP', // spTemp
''); // spLog
var
tmp: array[0..MAX_PATH] of char;
begin
result := '';
case kind of
spLog:
begin
// try <exepath>\log - without [idwExcludeWinSys] (writable is enough)
result := Executable.ProgramFilePath;
if not IsDirectoryWritable(result) then
// fallback to 'C:\Users\<user>\AppData\Local\<exename>-log'
result := format('%s%s-',
[GetSystemPath(spUserData), Executable.ProgramName]);
result := EnsureDirectoryExists(result + 'log');
if IsDirectoryWritable(result) then
exit; // found a folder able to receive new logs
// 'C:\Users\<user>\AppData\Local\Temp\<exename>-log'
result := EnsureDirectoryExists(format('%s%s-log',
[GetSystemPath(spTemp), Executable.ProgramName]));
end;
spTemp:
begin
// typically 'C:\Users\<user>\AppData\Local\Temp'
if GetTempPath(MAX_PATH, @tmp) <> 0 then
result := tmp; // retrieve from dedicated standard API
if result = '' then
result := GetEnvironmentVariable(_ENV[spTemp]); // fallback
end;
else
if (CSIDL[kind] <> 0) and
DelayedProc(SHGetFolderPath, SHFolderDll, 'SHFolder.dll',
'SHGetFolderPath' + _AW) and
(SHGetFolderPath(0, CSIDL[kind], 0, 0, @tmp) = S_OK) then
// retrieved from official CSIDL
result := tmp
else
begin
// fallback to environment variables (very unlikely)
result := GetEnvironmentVariable(_ENV[kind]);
if result = '' then
begin
result := GetEnvironmentVariable('APPDATA');
if result = '' then
result := Executable.ProgramFilePath;
end;
end;
end;
if result <> '' then
result := IncludeTrailingPathDelimiter(result); // no EnsureDirectoryExists
end;
procedure PatchCode(Old, New: pointer; Size: PtrInt; Backup: pointer;
LeaveUnprotected: boolean);
var
RestoreProtection, Ignore: DWord;
i: PtrInt;
begin
if VirtualProtect(Old, Size, PAGE_EXECUTE_READWRITE, RestoreProtection) then
begin
if Backup <> nil then
for i := 0 to Size - 1 do // do not use Move() here
PByteArray(Backup)^[i] := PByteArray(Old)^[i];
for i := 0 to Size - 1 do // do not use Move() here
PByteArray(Old)^[i] := PByteArray(New)^[i];
if not LeaveUnprotected then
VirtualProtect(Old, Size, RestoreProtection, Ignore);
FlushInstructionCache(GetCurrentProcess, Old, Size);
if not CompareMemFixed(Old, New, Size) then
raise Exception.Create('PatchCode?');
end;
end;
{ ****************** Operating System Specific Types (e.g. TWinRegistry) }
{ TWinRegistry }
const
_HKEY: array[TWinRegistryRoot] of HKEY = (
HKEY_CLASSES_ROOT,
HKEY_CURRENT_USER,
HKEY_LOCAL_MACHINE,
HKEY_USERS);
function TWinRegistry.ReadOpen(root: TWinRegistryRoot; const keyname: RawUtf8;
closefirst: boolean): boolean;
var
tmp: TSynTempBuffer;
begin
if closefirst then
Close;
key := 0;
result := RegOpenKeyExW(
_HKEY[root], Utf8ToWin32PWideChar(keyname, tmp), 0, KEY_READ, key) = 0;
tmp.Done;
end;
procedure TWinRegistry.Close;
begin
if key <> 0 then
RegCloseKey(key);
end;
function TWinRegistry.ReadString(const entry: SynUnicode; andtrim: boolean): RawUtf8;
var
rtype, rsize, res: DWord;
tmp: TSynTempBuffer;
begin
result := '';
rsize := {%H-}tmp.Init; // most of the time, a single call is enough
res := RegQueryValueExW(key, pointer(entry), nil, @rtype, tmp.buf, @rsize);
if res <> 0 then
if res = ERROR_MORE_DATA then
begin
tmp.Init(rsize); // more than 4KB of data (unlikely)
res := RegQueryValueExW(key, pointer(entry), nil, nil, tmp.buf, @rsize);
end
else
exit;
if res = 0 then
begin
case rtype of
REG_SZ,
REG_EXPAND_SZ,
REG_MULTI_SZ: // StrLen() will return the first value of REG_MULTI_SZ
Win32PWideCharToUtf8(tmp.buf, result);
end;
if andtrim then
TrimSelf(result);
end;
tmp.Done;
end;
function TWinRegistry.ReadData(const entry: SynUnicode): RawByteString;
var
rsize: DWord;
begin
result := '';
if RegQueryValueExW(key, pointer(entry), nil, nil, nil, @rsize) <> 0 then
exit;
SetLength(result, rsize);
if RegQueryValueExW(key, pointer(entry), nil, nil, pointer(result), @rsize) <> 0 then
result := '';
end;
function TWinRegistry.ReadDword(const entry: SynUnicode): cardinal;
begin
if not ReadBuffer(entry, @result, SizeOf(result)) then
result := 0;
end;
function TWinRegistry.ReadQword(const entry: SynUnicode): QWord;
begin
if not ReadBuffer(entry, @result, SizeOf(result)) then
result := 0;
end;
function TWinRegistry.ReadBuffer(const entry: SynUnicode;
Data: pointer; DataLen: DWord): boolean;
begin
result := RegQueryValueExW(key, pointer(entry), nil, nil, Data, @DataLen) = 0;
end;
function TWinRegistry.ReadSize(const entry: SynUnicode): integer;
begin
if RegQueryValueExW(key, pointer(entry), nil, nil, nil, @result) <> 0 then
result := -1;
end;
function TWinRegistry.ReadEnumEntries: TRawUtf8DynArray;
var
count, maxlen, i, len: DWord;
tmp: TSynTempBuffer;
begin
result := nil;
count := 0;
if (RegQueryInfoKeyW(key, nil, nil, nil, @count, @maxlen,
nil, nil, nil, nil, nil, nil) <> 0) or
(count = 0) then
exit;
SetLength(result, count);
inc(maxlen);
tmp.Init(maxlen * 2);
for i := 0 to count - 1 do
begin
len := maxlen;
if RegEnumKeyExW(key, i, tmp.buf, len, nil, nil, nil, nil) = 0 then
Win32PWideCharToUtf8(tmp.buf, len, result[i]);
end;
tmp.Done;
end;
const
_WSP: array[TWinSystemPrivilege] of string[32] = (
// note: string[32] to ensure there is a trailing #0 for all items
'SeCreateTokenPrivilege', // wspCreateToken
'SeAssignPrimaryTokenPrivilege', // wspAssignPrimaryToken
'SeLockMemoryPrivilege', // wspLockMemory
'SeIncreaseQuotaPrivilege', // wspIncreaseQuota
'SeUnsolicitedInputPrivilege', // wspUnsolicitedInput
'SeMachineAccountPrivilege', // wspMachineAccount
'SeTcbPrivilege', // wspTCP
'SeSecurityPrivilege', // wspSecurity
'SeTakeOwnershipPrivilege', // wspTakeOwnership
'SeLoadDriverPrivilege', // wspLoadDriver
'SeSystemProfilePrivilege', // wspSystemProfile
'SeSystemtimePrivilege', // wspSystemTime
'SeProfileSingleProcessPrivilege', // wspProfSingleProcess
'SeIncreaseBasePriorityPrivilege', // wspIncBasePriority
'SeCreatePagefilePrivilege', // wspCreatePageFile
'SeCreatePermanentPrivilege', // wspCreatePermanent
'SeBackupPrivilege', // wspBackup
'SeRestorePrivilege', // wspRestore
'SeShutdownPrivilege', // wspShutdown
'SeDebugPrivilege', // wspDebug
'SeAuditPrivilege', // wspAudit
'SeSystemEnvironmentPrivilege', // wspSystemEnvironment
'SeChangeNotifyPrivilege', // wspChangeNotify
'SeRemoteShutdownPrivilege', // wspRemoteShutdown
'SeUndockPrivilege', // wspUndock
'SeSyncAgentPrivilege', // wspSyncAgent
'SeEnableDelegationPrivilege', // wspEnableDelegation
'SeManageVolumePrivilege', // wspManageVolume
'SeImpersonatePrivilege', // wspImpersonate
'SeCreateGlobalPrivilege', // wspCreateGlobal
'SeTrustedCredManAccessPrivilege', // wspTrustedCredmanAccess
'SeRelabelPrivilege', // wspRelabel
'SeIncreaseWorkingSetPrivilege', // wspIncWorkingSet
'SeTimeZonePrivilege', // wspTimeZone
'SeCreateSymbolicLinkPrivilege'); // wspCreateSymbolicLink
_TokenVirtualizationEnabled = TTokenInformationClass(24); // for oldest Delphi
type
TOKEN_PRIVILEGES = packed record
PrivilegeCount : DWord;
Privileges : array[0..0] of LUID_AND_ATTRIBUTES;
end;
PTOKEN_PRIVILEGES = ^TOKEN_PRIVILEGES;
TOKEN_USER = record
User: SID_AND_ATTRIBUTES;
end;
PTOKEN_USER = ^TOKEN_USER;
TOKEN_GROUPS = record
GroupCount: DWord;
Groups: array [0..0] of SID_AND_ATTRIBUTES;
end;
PTOKEN_GROUPS = ^TOKEN_GROUPS;
function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWord;
var TokenHandle: THandle): BOOL;
stdcall; external advapi32;
function LookupPrivilegeValueA(lpSystemName, lpName: PAnsiChar;
var lpLuid: TLargeInteger): BOOL;
stdcall; external advapi32;
function LookupPrivilegeNameA(lpSystemName: PAnsiChar; var lpLuid: TLargeInteger;
lpName: PAnsiChar; var cbName: DWord): BOOL;
stdcall; external advapi32;
function LookupAccountSidW(lpSystemName: PWideChar; Sid: PSID; Name: PWideChar;
var cchName: DWord; ReferencedDomainName: PAnsiChar;
var cchReferencedDomainName: DWord; var peUse: DWord): BOOL;
stdcall; external advapi32;
function AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;
const NewState: TOKEN_PRIVILEGES; BufferLength: DWord;
PreviousState: PTokenPrivileges; ReturnLength: PDWord): BOOL;
stdcall; external advapi32;
function IsSystemFolder(const Folder: TFileName): boolean;
begin
if CompareText(copy(Folder, 2, 9), ':\windows') = 0 then
result := ord(Folder[11]) in [0, ord('\')]
else
result := (CompareText(copy(Folder, 2, 15), ':\program files') = 0) and
((ord(Folder[17]) in [0, ord('\')]) or
(CompareText(copy(Folder, 17, 6), ' (x86)') = 0));
end;
{$ifdef CPU32}
var
IsUacEnabled: (iueUntested, iueDisabled, iueEnabled);
function IsUacVirtualizationEnabled: boolean;
var
token: THandle;
enabled, len: DWORD;
begin
if IsUacEnabled = iueUntested then
if OSVersion < wVista then
IsUacEnabled := iueDisabled // no UAC on Windows XP
else
begin
IsUacEnabled := iueEnabled; // enabled by default
if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, token) then
begin
enabled := 1;
len := SizeOf(enabled);
if GetTokenInformation(token, _TokenVirtualizationEnabled,
@enabled, SizeOf(enabled), len) and
(enabled = 0) then
// returns enabled=0 if mormot.win.default.manifest.res is included
IsUacEnabled := iueDisabled;
CloseHandle(token);
end;
end;
result := IsUacEnabled = iueEnabled;
end;
function IsUacVirtualFolder(const Folder: TFileName): boolean;
begin
// note: IsUacVirtualizationEnabled returns false if our manifest is included
result := (OSVersion >= wVista) and // no UAC on Windows XP
IsUacVirtualizationEnabled and
IsSystemFolder(Folder);
end;
{$else}
function IsUacVirtualizationEnabled: boolean;
begin
result := false; // never enabled for a Win64 process
end;
function IsUacVirtualFolder(const Folder: TFileName): boolean;
begin
result := false; // never enabled for a Win64 process
end;
{$endif CPU32}
function RawTokenOpen(wtt: TWinTokenType; access: cardinal): THandle;
begin
if wtt = wttProcess then
begin
if not OpenProcessToken(GetCurrentProcess, access, result) then
RaiseLastError('OpenToken: OpenProcessToken');
end
else if not OpenThreadToken(GetCurrentThread, access, false, result) then
if GetLastError = ERROR_NO_TOKEN then
begin
// try to impersonate the thread
if not ImpersonateSelf(SecurityImpersonation) or
not OpenThreadToken(GetCurrentThread, access, false, result) then
RaiseLastError('OpenToken: ImpersonateSelf');
end
else
RaiseLastError('OpenToken: OpenThreadToken');
end;
function RawTokenGetInfo(tok: THandle; tic: TTokenInformationClass;
var buf: TSynTempBuffer): cardinal;
begin
buf.Init; // stack-allocated buffer (always enough)
result := 0; // error
if (tok = INVALID_HANDLE_VALUE) or
(tok = 0) or
GetTokenInformation(tok, tic, buf.buf, buf.len, result) then
exit; // we directly store the output buffer on buf stack
if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
begin
result := 0;
exit;
end;
buf.Done;
buf.Init(result); // we need a bigger buffer
if not GetTokenInformation(tok, tic, buf.buf, buf.len, result) then
result := 0;
end;
function RawTokenSid(tok: THandle; var buf: TSynTempBuffer): PSid;
begin
if RawTokenGetInfo(tok, TokenUser, buf) >= SizeOf(TOKEN_USER) then
result := PSid(PTOKEN_USER(buf.buf)^.User.Sid) // within buf.buf/len
else
result := nil;
end;
function CurrentSid(wtt: TWinTokenType; name, domain: PRawUtf8): RawUtf8;
var
sid: RawSid;
begin
CurrentRawSid(sid, wtt, name, domain);
result := RawSidToText(sid);
end;
procedure CurrentRawSid(out sid: RawSid; wtt: TWinTokenType;
name, domain: PRawUtf8);
var
h: THandle;
p: PSid;
n, d: RawUtf8;
tmp: TSynTempBuffer;
begin
h := RawTokenOpen(wtt, TOKEN_QUERY);
p := RawTokenSid(h, tmp);
if p <> nil then
begin
ToRawSid(p, sid);
if (name <> nil) or
(domain <> nil) then
begin
LookupSid(p, n, d);
if name <> nil then
name^ := n;
if domain <> nil then
domain^ := d;
end;
end;
tmp.Done;
CloseHandle(h);
end;
function ToText(p: TWinSystemPrivilege): PShortString;
begin
result := @_WSP[p];
end;
function RawTokenGroups(tok: THandle; var buf: TSynTempBuffer): PSids;
var
nfo: PTokenGroups;
i: PtrInt;
begin
result := nil;
if RawTokenGetInfo(tok, TokenGroups, buf) < SizeOf({%H-}nfo^) then
exit;
nfo := buf.buf;
if nfo.GroupCount = 0 then
exit;
SetLength(result, nfo.GroupCount);
for i := 0 to nfo.GroupCount - 1 do
result[i] := pointer(nfo.Groups[i].Sid); // within buf.buf/len
end;
function TokenGroupsText(tok: THandle): TRawUtf8DynArray;
var
tmp: TSynTempBuffer;
begin
result := SidsToText(RawTokenGroups(tok, tmp));
tmp.Done;
end;
function TokenHasGroup(tok: THandle; sid: PSid): boolean;
var
tmp: TSynTempBuffer;
i: PtrInt;
begin
result := false;
if (sid <> nil) and
(RawTokenGetInfo(tok, TokenGroups, tmp) <> 0) then
with PTokenGroups(tmp.buf)^ do
for i := 0 to GroupCount - 1 do
if SidCompare(pointer(Groups[i].Sid), sid) = 0 then
begin
result := true;
break;
end;
tmp.Done;
end;
function TokenHasAnyGroup(tok: THandle; const sid: RawSidDynArray): boolean;
var
tmp: TSynTempBuffer;
begin
result := HasAnySid(RawTokenGroups(tok, tmp), sid);
tmp.Done;
end;
function CurrentGroups(wtt: TWinTokenType; var tmp: TSynTempBuffer): PSids;
var
h: THandle;
begin
h := RawTokenOpen(wtt, TOKEN_QUERY);
result := RawTokenGroups(h, tmp);
CloseHandle(h);
end;
function CurrentGroupsSid(wtt: TWinTokenType): TRawUtf8DynArray;
var
tmp: TSynTempBuffer;
begin
result := SidsToText(CurrentGroups(wtt, tmp));
tmp.Done;
end;
function CurrentKnownGroups(wtt: TWinTokenType): TWellKnownSids;
var
tmp: TSynTempBuffer;
begin
result := SidToKnownGroups(CurrentGroups(wtt, tmp));
tmp.Done;
end;
function CurrentUserHasGroup(sid: PSid; wtt: TWinTokenType): boolean;
var
h: THandle;
begin
h := RawTokenOpen(wtt, TOKEN_QUERY);
result := TokenHasGroup(h, sid);
CloseHandle(h);
end;
function CurrentUserHasGroup(wks: TWellKnownSid; wtt: TWinTokenType): boolean;
begin
result := (wks <> wksNull) and
CurrentUserHasGroup(pointer(KnownRawSid(wks)), wtt);
end;
function CurrentUserHasGroup(const sid: RawUtf8; wtt: TWinTokenType): boolean;
var
s: TSid;
begin
result := TextToSid(pointer(sid), s) and
CurrentUserHasGroup(@s, wtt);
end;
function CurrentUserHasAnyGroup(const sid: RawSidDynArray; wtt: TWinTokenType): boolean;
var
tmp: TSynTempBuffer;
begin
result := HasAnySid(CurrentGroups(wtt, tmp), sid);
tmp.Done;
end;
function CurrentUserHasGroup(const name, domain, server: RawUtf8;
wtt: TWinTokenType): boolean;
var
i: PtrInt;
sids: PSids;
n, d: RawUtf8;
tmp: TSynTempBuffer;
begin
result := false;
sids := CurrentGroups(wtt, tmp);
for i := 0 to length(sids) - 1 do
if (SidToKnown(sids[i]) = wksNull) and
(LookupSid(sids[i], n, d, server) = stTypeGroup) then
if PropNameEquals(n, name) and
((domain = '') or
PropNameEquals(d, domain)) then
begin
result := true;
break;
end;
tmp.Done;
end;
function CurrentUserIsAdmin: boolean;
begin
result := CurrentUserHasGroup(wksBuiltinAdministrators);
end;
function LookupSid(sid: PSid; out name, domain: RawUtf8;
const server: RawUtf8): TSidType;
var
n, d: array[byte] of WideChar;
s: TSynTempBuffer;
nl, dl, use: cardinal;
begin
result := stUndefined;
if sid = nil then
exit;
nl := SizeOf(n);
dl := SizeOf(d);
if LookupAccountSidW(Utf8ToWin32PWideChar(server, s), sid, @n, nl, @d, dl, use) then
begin
Win32PWideCharToUtf8(@n, name);
Win32PWideCharToUtf8(@d, domain);
if use <= byte(high(TSidType)) then
result := TSidType(use);
end;
s.Done;
end;
function LookupSid(const sid: RawUtf8; out name, domain: RawUtf8;
const server: RawUtf8): TSidType;
var
s: TSid;
begin
if TextToSid(pointer(sid), s) then
result := LookupSid(@s, name, domain, server)
else
result := stUndefined;
end;
function LookupToken(tok: THandle; out name, domain: RawUtf8;
const server: RawUtf8): boolean;
var
tmp: TSynTempBuffer;
begin
result := LookupSid(RawTokenSid(tok, tmp) ,name, domain, server) <> stUndefined;
tmp.Done;
end;
function LookupToken(tok: THandle; const server: RawUtf8): RawUtf8;
var
name, domain: RawUtf8;
begin
if LookupToken(tok, name, domain, server) then
result := domain + '\' + name
else
result := '';
end;
{ TSynWindowsPrivileges }
procedure TSynWindowsPrivileges.Init(aTokenPrivilege: TWinTokenType;
aLoadPrivileges: boolean);
begin
fAvailable := [];
fEnabled := [];
fDefEnabled := [];
fToken := RawTokenOpen(aTokenPrivilege, TOKEN_QUERY or TOKEN_ADJUST_PRIVILEGES);
if aLoadPrivileges then
LoadPrivileges;
end;
procedure TSynWindowsPrivileges.Done(aRestoreInitiallyEnabled: boolean);
var
p: TWinSystemPrivilege;
new: TWinSystemPrivileges;
begin
if aRestoreInitiallyEnabled then
begin
new := fEnabled - fDefEnabled;
for p := low(p) to high(p) do
if p in new then
Disable(p);
end;
CloseHandle(fToken);
fToken := 0;
end;
function TSynWindowsPrivileges.Enable(aPrivilege: TWinSystemPrivilege): boolean;
begin
result := aPrivilege in fEnabled;
if result or
not (aPrivilege in fAvailable) or
not SetPrivilege(aPrivilege, true) then
exit;
Include(fEnabled, aPrivilege);
result := true;
end;
function TSynWindowsPrivileges.Disable(
aPrivilege: TWinSystemPrivilege): boolean;
begin
result := not (aPrivilege in fEnabled);
if result or
not (aPrivilege in fAvailable) or
not SetPrivilege(aPrivilege, false) then
exit;
Exclude(fEnabled, aPrivilege);
result := true;
end;
procedure TSynWindowsPrivileges.LoadPrivileges;
var
buf: TSynTempBuffer;
name: string[127];
tp: PTOKEN_PRIVILEGES;
i: PtrInt;
len: cardinal;
p: TWinSystemPrivilege;
priv: PLUIDANDATTRIBUTES;
begin
if Token = 0 then
raise EOSException.Create('LoadPriviledges: no token');
fAvailable := [];
fEnabled := [];
fDefEnabled := [];
try
if RawTokenGetInfo(Token, TokenPrivileges, buf) = 0 then
RaiseLastError('LoadPriviledges: GetTokenInformation');
tp := buf.buf;
priv := @tp.Privileges;
for i := 1 to tp.PrivilegeCount do
begin
len := high(name);
if not LookupPrivilegeNameA(nil, priv.Luid, @name[1], len) or
(len = 0) then
RaiseLastError('LoadPriviledges: LookupPrivilegeNameA');
name[0] := AnsiChar(len);
for p := low(p) to high(p) do
if not (p in fAvailable) and
PropNameEquals(PShortString(@name), PShortString(@_WSP[p])) then
begin
include(fAvailable, p);
if priv.Attributes and SE_PRIVILEGE_ENABLED <> 0 then
include(fDefEnabled, p);
break;
end;
inc(priv);
end;
fEnabled := fDefEnabled;
finally
buf.Done;
end;
end;
function TSynWindowsPrivileges.SetPrivilege(
wsp: TWinSystemPrivilege; on: boolean): boolean;
var
tp: TOKEN_PRIVILEGES;
id: TLargeInteger;
tpprev: TOKEN_PRIVILEGES;
cbprev: DWord;
begin
result := false;
if not LookupPrivilegeValueA(nil, @_WSP[wsp][1], id) then
exit;
tp.PrivilegeCount := 1;
tp.Privileges[0].Luid := PInt64(@id)^;
tp.Privileges[0].Attributes := 0;
cbprev := SizeOf(TOKEN_PRIVILEGES);
AdjustTokenPrivileges(
Token, false, tp, SizeOf(TOKEN_PRIVILEGES), @tpprev, @cbprev);
if GetLastError <> ERROR_SUCCESS then
exit;
tpprev.PrivilegeCount := 1;
tpprev.Privileges[0].Luid := PInt64(@id)^;
with tpprev.Privileges[0] do
if on then
Attributes := Attributes or SE_PRIVILEGE_ENABLED
else
Attributes := Attributes xor (SE_PRIVILEGE_ENABLED and Attributes);
AdjustTokenPrivileges(
Token, false, tpprev, cbprev, nil, nil);
if GetLastError <> ERROR_SUCCESS then
exit;
result := true;
end;
const
ntdll = 'NTDLL.DLL';
type
_PPS_POST_PROCESS_INIT_ROUTINE = ULONG;
PUNICODE_STRING = ^UNICODE_STRING;
UNICODE_STRING = packed record
Length: word;
MaximumLength: word;
{$ifdef CPUX64}
_align: array[0..3] of byte;
{$endif CPUX64}
Buffer: PWideChar;
end;
PMS_PEB_LDR_DATA = ^MS_PEB_LDR_DATA;
MS_PEB_LDR_DATA = packed record
Reserved1: array[0..7] of byte;
Reserved2: array[0..2] of pointer;
InMemoryOrderModuleList: LIST_ENTRY;
end;
PMS_RTL_USER_PROCESS_PARAMETERS = ^MS_RTL_USER_PROCESS_PARAMETERS;
MS_RTL_USER_PROCESS_PARAMETERS = packed record
Reserved1: array[0..15] of byte;
Reserved2: array[0..9] of pointer;
ImagePathName: UNICODE_STRING;
CommandLine: UNICODE_STRING ;
end;
PMS_PEB = ^MS_PEB;
MS_PEB = packed record
Reserved1: array[0..1] of byte;
BeingDebugged: BYTE;
Reserved2: array[0..0] of byte;
{$ifdef CPUX64}
_align1: array[0..3] of byte;
{$endif CPUX64}
Reserved3: array[0..1] of pointer;
Ldr: PMS_PEB_LDR_DATA;
ProcessParameters: PMS_RTL_USER_PROCESS_PARAMETERS;
Reserved4: array[0..103] of byte;
Reserved5: array[0..51] of pointer;
PostProcessInitRoutine: _PPS_POST_PROCESS_INIT_ROUTINE;
Reserved6: array[0..127] of byte;
{$ifdef CPUX64}
_align2: array[0..3] of byte;
{$endif CPUX64}
Reserved7: array[0..0] of pointer;
SessionId: ULONG;
{$ifdef CPUX64}
_align3: array[0..3] of byte;
{$endif CPUX64}
end;
PMS_PROCESS_BASIC_INFORMATION = ^MS_PROCESS_BASIC_INFORMATION;
MS_PROCESS_BASIC_INFORMATION = packed record
ExitStatus: integer;
{$ifdef CPUX64}
_align1: array[0..3] of byte;
{$endif CPUX64}
PebBaseAddress: PMS_PEB;
AffinityMask: PtrUInt;
BasePriority: integer;
{$ifdef CPUX64}
_align2: array[0..3] of byte;
{$endif CPUX64}
UniqueProcessId: PtrUInt;
InheritedFromUniqueProcessId: PtrUInt;
end;
{$Z4}
PROCESSINFOCLASS = (
ProcessBasicInformation = 0,
ProcessDebugPort = 7,
ProcessWow64Information = 26,
ProcessImageFileName = 27,
ProcessBreakOnTermination = 29,
ProcessSubsystemInformation = 75);
{$Z1}
NTSTATUS = integer;
PVOID = pointer;
PPVOID = ^PVOID;
OBJECT_ATTRIBUTES = record
Length: ULONG;
RootDirectory: THandle;
ObjectName: PUNICODE_STRING;
Attributes: ULONG;
SecurityDescriptor: Pointer; // Points to type SECURITY_DESCRIPTOR
SecurityQualityOfService: Pointer; // Points to type SECURITY_QUALITY_OF_SERVICE
end;
POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES;
var
// low-level (undocumented) ntdll.dll functions - accessed via late-binding
NtQueryInformationProcess: function(ProcessHandle: THandle;
ProcessInformationClass: PROCESSINFOCLASS; ProcessInformation: pointer;
ProcessInformationLength: ULONG; ReturnLength: PULONG): NTSTATUS; stdcall;
RtlInitUnicodeString: function(var DestinationString: UNICODE_STRING;
const SourceString: PWideChar): NTSTATUS; stdcall;
NtOpenSection: function (SectionHandle: PHANDLE; DesiredAccess: ACCESS_MASK;
ObjectAttributes: POBJECT_ATTRIBUTES): NTSTATUS; stdcall;
NtMapViewOfSection: function (SectionHandle, ProcessHandle: THandle;
BaseAddress: PPVOID; ZeroBits: ULONG; CommitSize: ULONG;
var SectionOffset: TLargeInteger; ViewSize: PULONG; InheritDisposition: DWord;
AllocationType: ULONG; Protect: ULONG): NTSTATUS; stdcall;
NtUnmapViewOfSection: function (ProcessHandle: THandle;
BaseAddress: PVOID): NTSTATUS; stdcall;
function ReadSystemMemory(address, size: PtrUInt): RawByteString;
var
memfile: UNICODE_STRING;
att: OBJECT_ATTRIBUTES;
mem: THandle;
add: TLargeInteger;
virt: pointer;
begin
result := '';
if (size <= 4 shl 20) and // map up to 4MB
Assigned(RtlInitUnicodeString) and
Assigned(NtOpenSection) and
Assigned(NtMapViewOfSection) and
Assigned(NtUnmapViewOfSection) then
begin
RtlInitUnicodeString(memfile, '\device\physicalmemory');
FillCharFast(att, SizeOf(att), 0);
att.Length := SizeOf(att);
att.ObjectName := @memfile;
att.Attributes := $40; // OBJ_CASE_INSENSITIVE
if NtOpenSection(@mem, SECTION_MAP_READ, @att) <> 0 then
exit;
add := address;
virt := nil;
if NtMapViewOfSection(mem, INVALID_HANDLE_VALUE, @virt, 0, size, add, @size,
1, 0, PAGE_READONLY) = 0 then
begin
FastSetRawByteString(result, virt, size);
NtUnmapViewOfSection(INVALID_HANDLE_VALUE, virt);
end;
CloseHandle(mem);
end;
end;
function ReadProcessMemory(hProcess: THandle; const lpBaseAddress: Pointer;
lpBuffer: Pointer; nSize: PtrUInt; var lpNumberOfBytesRead: PtrUInt): BOOL;
stdcall; external kernel32;
function InternalGetProcessInfo(aPID: DWord; out aInfo: TWinProcessInfo): boolean;
var
bytesread: PtrUInt;
sizeneeded: DWord;
pbi: MS_PROCESS_BASIC_INFORMATION;
peb: MS_PEB;
peb_upp: MS_RTL_USER_PROCESS_PARAMETERS;
prochandle: THandle;
begin
result := false;
Finalize(aInfo);
FillCharFast(aInfo, SizeOf(aInfo), 0);
if (APID = 0) and
Assigned(NtQueryInformationProcess) then
exit;
prochandle := OpenProcess(
PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, aPid);
if prochandle = INVALID_HANDLE_VALUE then
exit;
Include(aInfo.AvailableInfo, wpaiPID);
aInfo.PID := aPid;
try
// read PBI (Process Basic Information)
sizeneeded := 0;
FillCharFast(pbi, SizeOf(pbi), 0);
if NtQueryInformationProcess(prochandle, ProcessBasicInformation,
@pbi, Sizeof(pbi), @sizeneeded) < 0 then
exit;
with aInfo do
begin
Include(AvailableInfo, wpaiBasic);
PID := pbi.UniqueProcessId;
ParentPID := pbi.InheritedFromUniqueProcessId;
BasePriority := pbi.BasePriority;
ExitStatus := pbi.ExitStatus;
PEBBaseAddress := pbi.PebBaseAddress;
AffinityMask := pbi.AffinityMask;
end;
// read PEB (Process Environment Block)
if not Assigned(pbi.PebBaseAddress) then
exit;
bytesread := 0;
FillCharFast(peb, SizeOf(peb), 0);
if not ReadProcessMemory(prochandle, pbi.PebBaseAddress,
@peb, SizeOf(peb), bytesread) then
exit;
Include(aInfo.AvailableInfo, wpaiPEB);
aInfo.SessionID := peb.SessionId;
aInfo.BeingDebugged := peb.BeingDebugged;
FillCharFast(peb_upp, SizeOf(MS_RTL_USER_PROCESS_PARAMETERS), 0);
bytesread := 0;
if not ReadProcessMemory(prochandle, peb.ProcessParameters,
@peb_upp, SizeOf(MS_RTL_USER_PROCESS_PARAMETERS), bytesread) then
exit;
// command line info
if peb_upp.CommandLine.Length > 0 then
begin
SetLength(aInfo.CommandLine, peb_upp.CommandLine.Length shr 1);
bytesread := 0;
if not ReadProcessMemory(prochandle, peb_upp.CommandLine.Buffer,
pointer(aInfo.CommandLine), peb_upp.CommandLine.Length, bytesread) then
exit;
Include(aInfo.AvailableInfo, wpaiCommandLine);
end;
// image info
if peb_upp.ImagePathName.Length > 0 then
begin
SetLength(aInfo.ImagePath, peb_upp.ImagePathName.Length shr 1);
bytesread := 0;
if not ReadProcessMemory(prochandle, peb_upp.ImagePathName.Buffer,
pointer(aInfo.ImagePath), peb_upp.ImagePathName.Length, bytesread) then
exit;
Include(aInfo.AvailableInfo, wpaiImagePath);
end;
result := true;
finally
CloseHandle(prochandle);
end;
end;
procedure GetProcessInfo(aPid: cardinal; out aInfo: TWinProcessInfo);
var
privileges: TSynWindowsPrivileges;
begin
privileges.Init(wttThread);
try
privileges.Enable(wspDebug);
InternalGetProcessInfo(aPid, aInfo);
finally
privileges.Done;
end;
end;
procedure GetProcessInfo(const aPidList: TCardinalDynArray;
out aInfo: TWinProcessInfoDynArray);
var
privileges: TSynWindowsPrivileges;
i: PtrInt;
begin
SetLength(aInfo, Length(aPidList));
privileges.Init(wttThread);
try
privileges.Enable(wspDebug);
for i := 0 to High(aPidList) do
InternalGetProcessInfo(aPidList[i], aInfo[i]);
finally
privileges.Done;
end;
end;
function ReadRegString(Key: THandle; const Path, Value: string): string;
var
siz, typ: DWord;
tmp: array[byte] of char;
k: HKey;
begin
result := '';
if RegOpenKeyEx(Key, pointer(Path), 0, KEY_QUERY_VALUE, k) <> ERROR_SUCCESS then
exit;
siz := 250;
typ := REG_SZ;
if RegQueryValueEx(k, pointer(Value), nil, @typ, @tmp, @siz) = ERROR_SUCCESS then
result := tmp;
RegCloseKey(k);
end;
{ TWinCryptoApi }
function TWinCryptoApi.Available: boolean;
begin
if not Tested then
Resolve;
result := Assigned(AcquireContextA);
end;
procedure TWinCryptoApi.Resolve;
const
NAMES: array[0..7] of PAnsiChar = (
'CryptAcquireContextA',
'CryptReleaseContext',
'CryptImportKey',
'CryptSetKeyParam',
'CryptDestroyKey',
'CryptEncrypt',
'CryptDecrypt',
'CryptGenRandom');
var
P: PPointer;
i: PtrInt;
begin
Tested := true;
Handle := GetModuleHandle('advapi32.dll');
if Handle <> 0 then
begin
P := @@AcquireContextA;
for i := 0 to high(NAMES) do
begin
P^ := LibraryResolve(Handle, NAMES[i]);
if P^ = nil then
begin
PPointer(@@AcquireContextA)^ := nil;
break;
end;
inc(P);
end;
end;
// note: CryptSignMessage and CryptVerifyMessageSignature are in crypt32.dll
end;
type
{$ifdef FPC}
{$packrecords C} // mandatory under Win64
{$endif FPC}
DATA_BLOB = record
cbData: DWord;
pbData: PAnsiChar;
end;
PDATA_BLOB = ^DATA_BLOB;
{$ifdef FPC}
{$packrecords DEFAULT}
{$endif FPC}
const
crypt32 = 'Crypt32.dll';
CRYPTPROTECT_UI_FORBIDDEN = 1;
CRYPT_STRING_BASE64HEADER = 0; // = PEM textual format
function CryptProtectData(const DataIn: DATA_BLOB; szDataDescr: PWideChar;
OptionalEntropy: PDATA_BLOB; Reserved, PromptStruct: Pointer; dwFlags: DWord;
var DataOut: DATA_BLOB): BOOL;
stdcall; external crypt32;
function CryptUnprotectData(const DataIn: DATA_BLOB; szDataDescr: PWideChar;
OptionalEntropy: PDATA_BLOB; Reserved, PromptStruct: Pointer; dwFlags: DWord;
var DataOut: DATA_BLOB): BOOL;
stdcall; external crypt32;
function CryptDataForCurrentUserDPAPI(const Data, AppSecret: RawByteString;
Encrypt: boolean): RawByteString;
var
src, dst, ent: DATA_BLOB;
e: PDATA_BLOB;
ok: boolean;
begin
src.pbData := pointer(Data);
src.cbData := length(Data);
if AppSecret <> '' then
begin
ent.pbData := pointer(AppSecret);
ent.cbData := length(AppSecret);
e := @ent;
end
else
e := nil;
if Encrypt then
ok := CryptProtectData(
src, nil, e, nil, nil, CRYPTPROTECT_UI_FORBIDDEN, dst)
else
ok := CryptUnprotectData(
src, nil, e, nil, nil, CRYPTPROTECT_UI_FORBIDDEN, dst);
if ok then
begin
FastSetRawByteString(result, dst.pbData, dst.cbData);
LocalFree(HLOCAL(dst.pbData));
end
else
result := '';
end;
function CertOpenSystemStoreW(hProv: HCRYPTPROV;
szSubsystemProtocol: PWideChar): HCERTSTORE ;
stdcall; external crypt32;
function CertEnumCertificatesInStore(hCertStore: HCERTSTORE;
pPrevCertContext: PCCERT_CONTEXT): PCCERT_CONTEXT;
stdcall; external crypt32;
function CryptBinaryToStringA(pBinary: PByte; cbBinary, dwFlags: DWord;
pszString: PAnsiChar; var pchString: DWord): BOOL;
stdcall; external crypt32;
function CertCloseStore(hCertStore: HCERTSTORE; dwFlags: DWord): BOOL;
stdcall; external crypt32;
function _GetSystemStoreAsPem(CertStore: TSystemCertificateStore): RawUtf8;
var
store: HCERTSTORE;
ctx: PCCERT_CONTEXT;
resultlen, certlen: DWord;
tmp: TSynTempBuffer;
begin
// call the Windows API to retrieve the System certificates
result := '';
resultlen := 0;
store := CertOpenSystemStoreW(nil, WINDOWS_CERTSTORE[CertStore]);
try
ctx := CertEnumCertificatesInStore(store, nil);
while ctx <> nil do
begin
certlen := 0;
if not CryptBinaryToStringA(ctx^.pbCertEncoded, ctx^.cbCertEncoded,
CRYPT_STRING_BASE64HEADER, nil, certlen) then
break;
tmp.Init(certlen); // a PEM is very likely to be < 8KB so will be on stack
if CryptBinaryToStringA(ctx^.pbCertEncoded, ctx^.cbCertEncoded,
CRYPT_STRING_BASE64HEADER, tmp.buf, certlen) then
begin
SetLength(result, resultlen + certlen);
MoveFast(tmp.buf^, PByteArray(result)[resultlen], certlen);
inc(resultlen, certlen);
end;
tmp.Done;
ctx := CertEnumCertificatesInStore(store, ctx); // next certificate
end;
finally
CertCloseStore(store, 0);
end;
end;
function SearchSmbios(const mem: RawByteString; var info: TRawSmbiosInfo): PtrUInt;
forward; // implemented later in mormot.core.os.pas
const
_RSMB_ = $52534D42;
// potential location of the SMBIOS buffer pointers within a 64KB fixed frame
SMB_START = $000f0000;
SMB_STOP = $00100000;
function _GetRawSmbios(var info: TRawSmbiosInfo): boolean;
var
siz: DWord;
tmp: RawByteString;
addr: PtrUInt;
get: function(sig, id: DWord; buf: pointer; siz: DWord): PtrUInt; stdcall;
begin
// first try to use Vista+ API which supports EFI
get := GetProcAddress(GetModuleHandle(kernel32), 'GetSystemFirmwareTable');
if Assigned(get) then
begin
siz := get(_RSMB_, 0, nil, 0); // first call to retrieve the full size
if siz > SizeOf(info) then
begin
FastNewRawByteString(tmp, siz);
get(_RSMB_, 0, pointer(tmp), siz);
PInt64(@info)^ := PInt64(tmp)^; // header fields = 64-bit
FastSetRawByteString(info.data, @PInt64Array(tmp)[1], siz - SizeOf(Int64));
result := true;
exit;
end;
end;
// on XP, read directly from physical memory via ntdll.dll low-level API
result := false;
tmp := ReadSystemMemory(SMB_START, SMB_STOP - SMB_START);
if tmp = '' then
exit;
addr := SearchSmbios(tmp, info);
if addr = 0 then
exit;
info.data := ReadSystemMemory(addr, info.Length);
result := info.data <> '';
end;
procedure DirectSmbiosInfo(out info: TSmbiosBasicInfos);
begin
// not needed - GetRawSmbios() is likely to work with no administrator rights
end;
threadvar // do not publish for compilation within Delphi packages
CoInitCounter: integer;
// avoid including ActiveX unit
function CoInitialize(_para1: pointer): HRESULT;
stdcall; external 'ole32.dll';
procedure CoUninitialize;
stdcall; external 'ole32.dll';
procedure CoInit;
begin
inc(CoInitCounter); // is a threadvar: no InterlockedIncrement() needed
if CoInitCounter = 1 then
CoInitialize(nil);
end;
procedure CoUninit;
begin
if CoInitCounter <= 0 then
raise EOleSysError.Create('You should call TOleDBConnection.Free from the same ' +
'thread which called its Create: i.e. call MyProps.EndCurrentThread from an ' +
'THttpServerGeneric.OnHttpThreadTerminate event - see ticket 213544b2f5');
dec(CoInitCounter);
if CoInitCounter = 0 then
CoUninitialize;
end;
{ ****************** Unix Daemon and Windows Service Support }
function OpenServiceManager(const TargetComputer, DatabaseName: RawUtf8;
dwDesiredAccess: cardinal): SC_HANDLE;
var
t1, t2: TSynTempBuffer;
begin
result := OpenSCManagerW(
Utf8ToWin32PWideChar(TargetComputer, t1),
Utf8ToWin32PWideChar(DatabaseName, t2), dwDesiredAccess);
t1.Done;
t2.Done;
end;
function OpenServiceInstance(hSCManager: SC_HANDLE; const ServiceName: RawUtf8;
dwDesiredAccess: cardinal): SC_HANDLE;
var
t: TSynTempBuffer;
begin
result := OpenServiceW(
hSCManager, Utf8ToWin32PWideChar(ServiceName, t), dwDesiredAccess);
t.Done;
end;
{ TServiceController }
type
EService = class(Exception);
constructor TServiceController.CreateNewService(const TargetComputer,
DatabaseName, Name, DisplayName: RawUtf8; const Path: TFileName;
const OrderGroup: RawUtf8; const Dependencies: RawUtf8;
const Username: RawUtf8; const Password: RawUtf8; DesiredAccess: cardinal;
ServiceType: cardinal; StartType: cardinal; ErrorControl: cardinal);
var
exeName: TFileName;
exeNameW: SynUnicode;
depW: PWideChar;
i: PtrInt;
t0, t1, t2, t3, t4, t5: TSynTempBuffer;
begin
inherited Create;
if Path = '' then
begin
TService.DoLog(sllError,
'CreateNewService(''%'',''%'') with no Path', [Name, DisplayName], self);
exit;
end;
if TargetComputer = '' then
if GetDriveType(pointer(ExtractFileDrive(Path))) = DRIVE_REMOTE then
begin
exeName := ExpandUNCFileName(Path);
if (copy(exeName, 1, 12) <> '\\localhost\') or
(exeName[14] <> '$') then
raise EService.CreateFmt(
'%s.CreateNewService(''%s'',''%s'') on remote drive: Path=%s is %s',
[ClassNameShort(self)^, Name, DisplayName, Path, exeName]);
system.delete(exeName, 1, 12); // \\localhost\c$\... -> c:\...
exeName[2] := ':';
end
else
exeName := Path;
exeNameW := SynUnicode(exeName); // use RTL for TFileName to UTF-16
fName := Name;
fSCHandle := OpenServiceManager(
TargetComputer, DatabaseName, SC_MANAGER_ALL_ACCESS);
if fSCHandle = 0 then
RaiseLastError('TServiceController.CreateService: OpenServiceManager', EService);
depW := Utf8ToWin32PWideChar(Dependencies, t0);
if depW <> nil then
begin
for i := 0 to t0.len - 1 do
if depW[i] = ';' then
depW[i] := #0; // as expected by CreateServiceW() API
depW[t0.len + 1] := #0; // should end with #0#0
end;
fHandle := CreateServiceW(fSCHandle,
Utf8ToWin32PWideChar(Name, t1), Utf8ToWin32PWideChar(DisplayName, t2),
DesiredAccess, ServiceType, StartType,
ErrorControl, pointer(exeNameW), Utf8ToWin32PWideChar(OrderGroup, t3),
nil, depW, Utf8ToWin32PWideChar(Username, t4),
Utf8ToWin32PWideChar(Password, t5));
t0.Done;
t1.Done;
t2.Done;
t3.Done;
t4.Done;
t5.Done;
if fHandle = 0 then
RaiseLastError('TServiceController.CreateService:', EService);
TService.DoLog(sllInfo,
'CreateService(''%'',''%'',''%'')', [Name, DisplayName, exeName], self);
end;
constructor TServiceController.CreateOpenService(
const TargetComputer, DataBaseName, Name: RawUtf8; DesiredAccess: cardinal);
begin
inherited Create;
fName := RawUtf8(Name);
fSCHandle := OpenServiceManager(TargetComputer, DataBaseName, GENERIC_READ);
if fSCHandle = 0 then
begin
TService.DoLog(sllLastError, 'OpenSCManager(''%'',''%'') for [%]',
[TargetComputer, DataBaseName, fName], self);
exit;
end;
fHandle := OpenServiceInstance(fSCHandle, Name, DesiredAccess);
if fHandle = 0 then
TService.DoLog(sllLastError, 'OpenService(%)', [Name], self);
end;
function TServiceController.Delete: boolean;
begin
result := false;
if fHandle <> 0 then
if DeleteService(fHandle) then
begin
result := CloseServiceHandle(fHandle);
fHandle := 0;
end
else
TService.DoLog(sllLastError, 'DeleteService(%)', [fName], self);
end;
destructor TServiceController.Destroy;
begin
if fHandle <> 0 then
begin
CloseServiceHandle(fHandle);
fHandle := 0;
end;
if fSCHandle <> 0 then
begin
CloseServiceHandle(fSCHandle);
fSCHandle := 0;
end;
inherited;
end;
function TServiceController.GetState: TServiceState;
begin
if (self = nil) or
(fSCHandle = 0) or
(fHandle = 0) then
result := ssNotInstalled
else
result := CurrentStateToServiceState(GetStatus.dwCurrentState);
TService.DoLog(sllTrace, 'GetState(%)=%', [fName, ToText(result)^], self);
end;
function TServiceController.GetStatus: TServiceStatus;
begin
FillCharFast(fStatus, SizeOf(fStatus), 0);
QueryServiceStatus(fHandle, fStatus);
result := fStatus;
end;
function TServiceController.Pause: boolean;
begin
if fHandle = 0 then
result := false
else
result := ControlService(fHandle, SERVICE_CONTROL_PAUSE, fStatus);
end;
function TServiceController.Refresh: boolean;
begin
if fHandle = 0 then
result := false
else
result := ControlService(fHandle, SERVICE_CONTROL_INTERROGATE, fStatus);
end;
function TServiceController.Resume: boolean;
begin
if fHandle = 0 then
result := false
else
result := ControlService(fHandle, SERVICE_CONTROL_CONTINUE, fStatus);
end;
function TServiceController.Shutdown: boolean;
begin
if fHandle = 0 then
result := false
else
result := ControlService(fHandle, SERVICE_CONTROL_SHUTDOWN, fStatus);
end;
function TServiceController.Start(const Args: array of PWideChar): boolean;
begin
TService.DoLog(sllDebug, 'Start(%) Args=% Handle=%',
[fName, length(Args), fHandle], self);
if fHandle = 0 then
begin
TService.DoLog(sllError, 'Start(%): no Service', [fName], self);
result := false;
exit;
end;
if length(Args) = 0 then
result := StartServiceW(fHandle, 0, nil)
else
result := StartServiceW(fHandle, length(Args), @Args[0]);
if not result then
TService.DoLog(sllLastError, 'Start(%) failed', [fName], self);
end;
function TServiceController.Stop: boolean;
begin
if fHandle = 0 then
result := false
else
result := ControlService(fHandle, SERVICE_CONTROL_STOP, fStatus);
end;
function TServiceController.SetDescription(const Description: RawUtf8): boolean;
var
sd: TServiceDescription;
t: TSynTempBuffer;
begin
if Description = '' then
begin
result := false;
exit;
end;
sd.lpDestription := Utf8ToWin32PWideChar(Description, t);
result := ChangeServiceConfig2W(fHandle, SERVICE_CONFIG_DESCRIPTION, @sd);
t.Done;
end;
class procedure TServiceController.CheckParameters(
const ExeFileName: TFileName; const ServiceName, DisplayName,
Description: RawUtf8; const Dependencies: RawUtf8);
var
param: string;
i: integer;
procedure ShowError(Msg: RawUtf8);
begin
Msg := _fmt('%s: "%s" failed for %s', [ServiceName, Msg, param]);
TService.DoLog(sllLastError, '%', [Msg], nil);
ConsoleWrite(Msg, ccLightRed);
end;
begin
for i := 1 to ParamCount do
begin
param := SysUtils.LowerCase(paramstr(i));
TService.DoLog(sllInfo,
'Controling % with command [%]', [ServiceName, param], nil);
if param = '/install' then
TServiceController.Install(
ServiceName, DisplayName, Description, true, ExeFileName, Dependencies)
else
with TServiceController.CreateOpenService('', '', ServiceName) do
try
if State = ssErrorRetrievingState then
ShowError('State')
else if param = '/uninstall' then
begin
if not Stop then
ShowError('Stop');
if not Delete then
ShowError('Delete');
end
else if param = '/stop' then
begin
if not Stop then
ShowError('Stop');
end
else if param = '/start' then
begin
if not Start([]) then
ShowError('Start');
end;
finally
Free;
end;
end;
end;
class function TServiceController.Install(
const Name, DisplayName, Description: RawUtf8; AutoStart: boolean;
ExeName: TFileName; const Dependencies, Username, Password: RawUtf8): TServiceState;
var
ctrl: TServiceController;
start: cardinal;
begin
if AutoStart then
start := SERVICE_AUTO_START
else
start := SERVICE_DEMAND_START;
if ExeName = '' then
ExeName := Executable.ProgramFileName;
ctrl := TServiceController.CreateNewService(
'', '', Name, DisplayName, ExeName, '', Dependencies, UserName, Password,
SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS, start);
try
result := ctrl.State;
if result <> ssNotInstalled then
ctrl.SetDescription(Description);
TService.DoLog(sllDebug,
'Install(%)=%', [Name, ToText(result)^], ctrl);
finally
ctrl.Free;
end;
end;
class function TServiceController.CurrentState(const Name: RawUtf8): TServiceState;
begin
try
with CreateOpenService('', '', Name, SERVICE_QUERY_STATUS) do
try
result := GetState;
finally
Free;
end;
except
result := ssErrorRetrievingState;
end;
end;
{ TService }
class procedure TService.DoLog(Level: TSynLogLevel; const Fmt: RawUtf8;
const Args: array of const; Instance: TObject);
begin
if Assigned(WindowsServiceLog) then
WindowsServiceLog(Level, Fmt, Args, Instance);
end;
constructor TService.Create(const aServiceName, aDisplayName: RawUTf8);
begin
fServiceName := aServiceName;
if aDisplayName = '' then
fDisplayName := aServiceName
else
fDisplayName := aDisplayName;
fServiceType := SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS;
fStartType := SERVICE_AUTO_START;
fStatusRec.dwServiceType := fServiceType;
fStatusRec.dwCurrentState := SERVICE_STOPPED;
fStatusRec.dwControlsAccepted := 31;
fStatusRec.dwWin32ExitCode := NO_ERROR;
DoLog(sllDebug, 'Create: % (%) running as [%]',
[ServiceName, aDisplayName, Executable.ProgramFullSpec], self);
end;
procedure TService.CtrlHandle(Code: cardinal);
begin
DoCtrlHandle(Code);
end;
const
_CMD: array[0.. 5] of string[11] = (
'UNKNOWN', 'STOP', 'PAUSE', 'CONTINUE', 'INTERROGATE', 'SHUTDOWN');
procedure TService.DoCtrlHandle(Code: cardinal);
var
c: PShortString;
begin
if Code <= high(_CMD) then
c := @_CMD[Code]
else
c := @_CMD[0];
DoLog(sllTrace, '% DoCtrlHandle(SERVICE_CONTROL_%=%)',
[ServiceName, c^, Code], self);
try
case Code of
SERVICE_CONTROL_STOP:
begin
ReportStatus(SERVICE_STOP_PENDING, NO_ERROR, 0);
try
if Assigned(fOnStop) then
fOnStop(Self);
ReportStatus(SERVICE_STOPPED, NO_ERROR, 0);
except
ReportStatus(SERVICE_STOPPED, ERROR_CAN_NOT_COMPLETE, 0);
end;
end;
SERVICE_CONTROL_PAUSE:
begin
ReportStatus(SERVICE_PAUSE_PENDING, NO_ERROR, 0);
try
if Assigned(fOnPause) then
fOnPause(Self);
ReportStatus(SERVICE_PAUSED, NO_ERROR, 0)
except
ReportStatus(SERVICE_PAUSED, ERROR_CAN_NOT_COMPLETE, 0)
end;
end;
SERVICE_CONTROL_CONTINUE:
begin
ReportStatus(SERVICE_CONTINUE_PENDING, NO_ERROR, 0);
try
if Assigned(fOnResume) then
fOnResume(Self);
ReportStatus(SERVICE_RUNNING, NO_ERROR, 0);
except
ReportStatus(SERVICE_RUNNING, ERROR_CAN_NOT_COMPLETE, 0);
end;
end;
SERVICE_CONTROL_SHUTDOWN:
begin
if Assigned(fOnShutdown) then
fOnShutdown(Self);
Code := 0;
end;
SERVICE_CONTROL_INTERROGATE:
begin
SetServiceStatus(fStatusHandle, fStatusRec);
if Assigned(fOnInterrogate) then
fOnInterrogate(Self);
end;
end;
if Assigned(fOnControl) then
fOnControl(Self, Code);
except
end;
DoLog(sllTrace, '% DoCtrlHandle(SERVICE_CONTROL_%=%) finished',
[ServiceName, c^, Code], self);
end;
procedure TService.Execute;
begin
try
if Assigned(fOnStart) then
fOnStart(Self);
ReportStatus(SERVICE_RUNNING, NO_ERROR, 0);
if Assigned(fOnExecute) then
fOnExecute(Self);
except
ReportStatus(SERVICE_RUNNING, ERROR_CAN_NOT_COMPLETE, 0);
end;
DoLog(sllTrace, '% Execute finished', [ServiceName], self);
end;
function TService.GetArgCount: Integer;
begin
result := length(fArgsList);
end;
function TService.GetArgs(Idx: Integer): RawUtf8;
begin
if cardinal(Idx) > cardinal(high(fArgsList)) then
result := ''
else
// avoid GPF
result := fArgsList[Idx];
end;
function TService.GetControlHandler: TServiceControlHandler;
begin
result := fControlHandler;
if not Assigned(result) then
DoLog(sllError, '% GetControlHandler=nil: use TServiceSingle or ' +
'assign a custom ControlHandler', [ServiceName], self);
end;
function TService.GetInstalled: boolean;
begin
with TServiceController.CreateOpenService(
'', '', fServiceName, SERVICE_QUERY_STATUS) do
try
result := Handle <> 0;
finally
Free;
end;
end;
function TService.Install(const Params: TFileName): boolean;
var
schService: SC_HANDLE;
schSCManager: SC_HANDLE;
ServicePath: TFileName;
p: SynUnicode;
t1, t2: TSynTempBuffer;
begin
result := false;
if installed then
exit;
ServicePath := Executable.ProgramFileName;
if Params <> '' then
ServicePath := ServicePath + ' ' + Params;
p := SynUnicode(ServicePath); // use RTL for TFileName to UTF-16 conversion
schSCManager := OpenSCManagerW(nil, nil, SC_MANAGER_ALL_ACCESS);
if schSCManager <= 0 then
exit;
schService := CreateServiceW(schSCManager,
Utf8ToWin32PWideChar(fServiceName, t1),
Utf8ToWin32PWideChar(fDisplayName, t2),
SERVICE_ALL_ACCESS, fServiceType, fStartType, SERVICE_ERROR_NORMAL,
pointer(p), nil, nil, nil, nil, nil);
t1.Done;
t2.Done;
if schService > 0 then
begin
result := true;
CloseServiceHandle(schService);
end;
CloseServiceHandle(schSCManager);
end;
procedure TService.Remove;
begin
with TServiceController.CreateOpenService(
'', '', fServiceName, SERVICE_ALL_ACCESS) do
try
if Handle = 0 then
exit;
Stop;
Delete;
finally
Free;
end;
end;
function TService.ReportStatus(dwState, dwExitCode, dwWait: cardinal): BOOL;
var
status: PShortString;
begin
status := ToText(CurrentStateToServiceState(dwState));
DoLog(sllTrace, '% ReportStatus(%=%,%)=%', [ServiceName,
WinErrorConstant(dwExitCode), dwExitCode, dwWait, status^], self);
if dwState = SERVICE_START_PENDING then
fStatusRec.dwControlsAccepted := 0
else
fStatusRec.dwControlsAccepted := 31;
fStatusRec.dwCurrentState := dwState;
fStatusRec.dwWin32ExitCode := dwExitCode;
fStatusRec.dwWaitHint := dwWait;
if (dwState = SERVICE_RUNNING) or
(dwState = SERVICE_STOPPED) then
fStatusRec.dwCheckPoint := 0
else
inc(fStatusRec.dwCheckPoint);
result := SetServiceStatus(fStatusHandle, fStatusRec);
if not result then
DoLog(sllLastError, '% ReportStatus(%,%)=% SetServiceStatus() failed',
[ServiceName, dwExitCode, dwWait, status^], self);
end;
procedure TService.SetControlHandler(const Value: TServiceControlHandler);
begin
fControlHandler := Value;
end;
procedure TService.SetStatus(const Value: TServiceStatus);
begin
fStatusRec := Value;
if fStatusHandle <> 0 then
SetServiceStatus(fStatusHandle, fStatusRec);
end;
procedure TService.Start;
begin
with TServiceController.CreateOpenService(
'', '', fServiceName, SERVICE_ALL_ACCESS) do
try
Start([]);
finally
Free;
end;
end;
procedure TService.Stop;
begin
with TServiceController.CreateOpenService(
'', '', fServiceName, SERVICE_ALL_ACCESS) do
try
Stop;
finally
Free;
end;
end;
procedure TService.ServiceProc(ArgCount: integer; Args: PPWideChar);
var
i: PtrInt;
t: TSynTempBuffer;
begin
SetCurrentThreadName('ServiceProc');
DoLog(sllTrace, 'ServiceProc: ArgCount=% ServiceSingle=%',
[ArgCount, self], self);
if self = nil then
exit;
dec(ArgCount); // first argument is the service name to be ignored
if (Args = nil) or
(ArgCount <= 0) then
fArgsList := nil // no argument
else
begin
SetLength(fArgsList, ArgCount);
for i := 0 to ArgCount - 1 do
begin
inc(Args); // first was service name
Win32PWideCharToUtf8(Args^, fArgsList[i]); // to string
end;
end;
fStatusHandle := RegisterServiceCtrlHandlerW(
Utf8ToWin32PWideChar(fServiceName, t), @ControlHandler);
t.Done;
if fStatusHandle = 0 then
begin
ReportStatus(SERVICE_STOPPED, GetLastError, 0);
exit;
end;
ReportStatus(SERVICE_START_PENDING, 0, 0);
Execute;
end;
function CurrentStateToServiceState(CurrentState: cardinal): TServiceState;
begin
case CurrentState of
SERVICE_STOPPED:
result := ssStopped;
SERVICE_START_PENDING:
result := ssStarting;
SERVICE_STOP_PENDING:
result := ssStopping;
SERVICE_RUNNING:
result := ssRunning;
SERVICE_CONTINUE_PENDING:
result := ssResuming;
SERVICE_PAUSE_PENDING:
result := ssPausing;
SERVICE_PAUSED:
result := ssPaused;
else
// e.g. SERVICE_CONTROL_SHUTDOWN
result := ssNotInstalled;
end;
end;
function GetServicePid(const aServiceName: RawUtf8;
aServiceState: PServiceState): cardinal;
var
ss: TServiceState;
st: TServiceStatus;
ssp: TServiceStatusProcess;
scm: THandle;
svc: THandle;
size: cardinal;
begin
result := 0;
ss := ssErrorRetrievingState;
scm := OpenSCManagerW(nil, nil, SC_MANAGER_CONNECT);
if scm <> 0 then
try
svc := OpenServiceInstance(scm, aServiceName, SERVICE_QUERY_STATUS);
if svc <> 0 then
try
if QueryServiceStatusEx(svc, SC_STATUS_PROCESS_INFO,
@ssp, SizeOf(TServiceStatusProcess), size) then
begin
result := ssp.dwProcessId;
if aServiceState <> nil then
begin
FillCharFast(st, SizeOf(st), 0);
QueryServiceStatus(svc, st);
ss := CurrentStateToServiceState(st.dwCurrentState);
end;
end
else
TService.DoLog(sllLastError, 'GetServicePid(%)', [aServiceName], nil);
finally
CloseServiceHandle(svc);
end
else
ss := ssNotInstalled;
finally
CloseServiceHandle(scm);
end;
if aServiceState <> nil then
aServiceState^ := ss;
end;
{ function that a service process specifies as the entry point function
of a particular service. The function can have any application-defined name
- Args points to an array of pointers that point to null-terminated
argument strings. The first argument in the array is the name of the service,
and subsequent arguments are any strings passed to the service by the process
that called the StartService function to start the service. Args can
be nil if there are no arguments. }
procedure ServiceProc(ArgCount: cardinal; Args: PPWideChar); stdcall;
begin
ServiceSingle.ServiceProc(ArgCount, Args);
end;
function ServiceSingleRun: boolean;
var
S: array[0..1] of TServiceTableEntry;
t: TSynTempBuffer;
begin
if ServiceSingle = nil then
begin
result := false;
exit;
end;
S[0].lpServiceName := Utf8ToWin32PWideChar(ServiceSingle.ServiceName, t);
S[0].lpServiceProc := ServiceProc;
S[1].lpServiceName := nil;
S[1].lpServiceProc := nil;
{ TODO : disable EExternal exception logging in ServicesSingleRun? }
result := StartServiceCtrlDispatcherW(@S);
t.Done;
end;
{ TServiceSingle }
procedure SingleServiceControlHandler(Opcode: LongWord); stdcall;
begin
if ServiceSingle <> nil then
ServiceSingle.DoCtrlHandle(Opcode);
end;
constructor TServiceSingle.Create(const aServiceName, aDisplayName: RawUtf8);
begin
if ServiceSingle <> nil then
raise EOSException.Create('Only one TServiceSingle is allowed at a time');
inherited Create(aServiceName, aDisplayName);
ServiceSingle := self;
SetControlHandler(SingleServiceControlHandler);
end;
destructor TServiceSingle.Destroy;
begin
try
inherited;
finally
if ServiceSingle = self then
ServiceSingle := nil;
end;
end;
function WaitProcess(pid: cardinal; waitseconds: integer): boolean;
var
ph: THandle;
begin
result := false;
ph := OpenProcess(SYNCHRONIZE, false, pid);
if ph = 0 then
exit;
result := WaitForSingleObject(ph, waitseconds * 1000) = WAIT_OBJECT_0;
CloseHandle(ph);
end;
function CancelProcess(pid: cardinal; waitseconds: integer): boolean;
begin
result := false;
if integer(pid) <= 0 then
exit;
if GetConsoleWindow <> 0 then // can attach to a single console
FreeConsole;
if not AttachConsole(pid) then // attach to the pid console
exit;
SetConsoleCtrlHandler(nil, true); // nil=ignore the event ourself
GenerateConsoleCtrlEvent(CTRL_C_EVENT, 0); // send Ctrl+C event
FreeConsole; // detach
SetConsoleCtrlHandler(nil, false); // remove our nil=ignore handler
result := WaitProcess(pid, waitseconds);
end;
function QuitProcess(pid: cardinal; waitseconds: integer): boolean;
var
snap: THandle;
e: TThreadEntry32;
begin
result := false;
if integer(pid) <= 0 then
exit;
snap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if snap <= 0 then
exit;
FillCharFast(e, SizeOf(e), 0);
e.dwSize := SizeOf(e);
if Thread32First(snap, e) then // loop over all threads of the system
repeat
if e.th32OwnerProcessID = pid then
if PostThreadMessage(e.th32ThreadID, WM_QUIT, 0, 0) then
result := true; // at least one thread found
until not Thread32Next(snap, e);
CloseHandle(snap);
if result and
(waitseconds <> 0) then
result := WaitProcess(pid, waitseconds);
end;
function KillProcess(pid: cardinal; waitseconds: integer): boolean;
var
ph: THandle;
begin
result := false;
if integer(pid) <= 0 then
exit;
ph := OpenProcess(PROCESS_TERMINATE or SYNCHRONIZE, false, pid);
if ph = 0 then
exit;
result := TerminateProcess(ph, 0) and
(WaitForSingleObject(ph, waitseconds * 1000) <> WAIT_TIMEOUT);
CloseHandle(ph);
end;
var
OnHandleCtrlC: TThreadMethod;
function ConsoleCtrlHandler(typ : dword) : BOOL; stdcall;
begin
result := false;
if Assigned(OnHandleCtrlC) then
case typ of
CTRL_C_EVENT,
CTRL_CLOSE_EVENT,
CTRL_LOGOFF_EVENT,
CTRL_SHUTDOWN_EVENT:
begin
OnHandleCtrlC();
result := true;
end;
end;
end;
function HandleCtrlC(const OnClose: TThreadMethod): boolean;
begin
result := SetConsoleCtrlHandler(@ConsoleCtrlHandler, Assigned(OnClose));
if result then
OnHandleCtrlC := OnClose;
end;
function DropPriviledges(const UserName: RawUtf8): boolean;
begin
result := false;
end;
function ChangeRoot(const FolderName: RawUtf8): boolean;
begin
result := false;
end;
type
TJobObjectInfoClass = (
BasicLimitInformation = 2,
JobObjectBasicProcessIdList = 3,
BasicUIRestrictions = 4,
SecurityLimitInformation = 5,
EndOfJobTimeInformation = 6,
AssociateCompletionPortInformation = 7,
ExtendedLimitInformation = 9,
GroupInformation = 11);
TJobObjectBasicLimitInformation = record
PerProcessUserTimeLimit: LARGE_INTEGER;
PerJobUserTimeLimit: LARGE_INTEGER;
LimitFlags: DWord;
MinimumWorkingSetSize: PtrUInt;
MaximumWorkingSetSize: PtrUInt;
ActiveProcessLimit: DWord;
Affinity: PtrUInt;
PriorityClass: DWord;
SchedulingClass: DWord;
end;
TIOCounter = record
ReadOperationCount: QWord;
WriteOperationCount: QWord;
OtherOperationCount: QWord;
ReadTransferCount: QWord;
WriteTransferCount: QWord;
OtherTransferCount: QWord;
end;
TJobObjectExtendedLimitInformation = record
BasicLimitInformation: TJobObjectBasicLimitInformation;
IoInfo: TIOCounter;
ProcessMemoryLimit: PtrUInt;
JobMemoryLimit: PtrUInt;
PeakProcessMemoryUsed: PtrUInt;
PeakJobMemoryUsed: PtrUInt;
end;
const
// to create a child process in a new job object
// https://learn.microsoft.com/en-us/windows/win32/procthread/job-objects
CREATE_BREAKAWAY_FROM_JOB = $1000000;
JOB_OBJECT_LIMIT_PROCESS_MEMORY = $00000100;
JOB_OBJECT_LIMIT_JOB_MEMORY = $00000200;
JOB_OBJECT_LIMIT_DIE_ON_UNHANDLED_EXCEPTION = $00000400;
JOB_OBJECT_LIMIT_BREAKAWAY_OK = $00000800;
JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK = $00001000;
JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE = $00002000;
function CreateJobObjectA(lpJobAttributes: PSecurityAttributes;
lpName: PWideChar): THandle;
stdcall; external kernel32;
function SetInformationJobObject(hJob: THandle;
JobObjectInformationClass: TJobObjectInfoClass; lpJobObjectInformation: pointer;
cbJobObjectInformationLength: DWord): BOOL;
stdcall; external kernel32;
function AssignProcessToJobObject(hJob, hProcess: THandle): BOOL;
stdcall; external kernel32;
// redefined here so that we can share code with FPC and Delphi
function CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar;
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
bInheritHandles: BOOL; dwCreationFlags: cardinal; lpEnvironment: Pointer;
lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfo;
out lpProcessInformation: TProcessInformation): BOOL;
stdcall; external kernel32;
function GetExitCodeProcess(hProcess: THandle; out lpExitCode: cardinal): BOOL;
stdcall; external kernel32;
function CreateJobToClose(parentpid: cardinal): THandle;
var
security: TSecurityAttributes;
limits: TJobObjectExtendedLimitInformation;
jobname: RawUtf8;
begin
security.nLength := SizeOf(security);
security.bInheritHandle := false; // should be false
security.lpSecurityDescriptor := nil;
_fmt('AutoCloseChild%d', [parentpid], jobname);
result := CreateJobObjectA(@security, pointer(jobname));
if result = 0 then
exit;
FillCharFast(limits, SizeOf(limits), 0);
limits.BasicLimitInformation.LimitFlags :=
JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE or
JOB_OBJECT_LIMIT_BREAKAWAY_OK;
if SetInformationJobObject(result, ExtendedLimitInformation,
@limits, SizeOf(limits)) then
exit;
CloseHandle(result); // error initializing the job (too old or too new OS?)
result := 0;
end;
function AssignJobToProcess(job, process: THandle; const ctxt: ShortString): boolean;
begin
result := (job <> 0) and
AssignProcessToJobObject(job, process);
if result then
TService.DoLog(sllTrace, 'RunCommand: % AssignProcessToJobObject success',
[ctxt], nil)
else
TService.DoLog(sllDebug, 'RunCommand: % AssignProcessToJobObject failed % %',
[ctxt, GetLastError, WinErrorConstant(GetLastError)], nil);
end;
function RunProcess(const path, arg1: TFileName; waitfor: boolean;
const arg2, arg3, arg4, arg5, env: TFileName; options: TRunOptions): integer;
begin
result := RunCommand(Format('"%s" %s %s %s %s %s',
[path, arg1, arg2, arg3, arg4, arg5]), waitfor, env, options);
end;
var
EnvironmentCache: SynUnicode;
EnvironmentCacheLock: TLightLock; // just set once
procedure GetEnvironmentCache;
var
e, p: PWideChar;
begin
EnvironmentCacheLock.Lock;
if EnvironmentCache = '' then
begin
e := GetEnvironmentStringsW;
p := e;
while p^ <> #0 do
inc(p, StrLenW(p) + 1); // go to name=value#0 pairs end
SetString(EnvironmentCache, e, (PtrUInt(p) - PtrUInt(e)) shr 1);
FreeEnvironmentStringsW(e);
end;
EnvironmentCacheLock.UnLock;
end;
function RunCommand(const cmd: TFileName; waitfor: boolean; const env: TFileName;
options: TRunOptions; waitfordelayms: cardinal; processhandle: PHandle;
redirected: PRawByteString; const onoutput: TOnRedirect;
const wrkdir: TFileName): integer;
var
startupinfo: TStartupInfo; // _STARTUPINFOW or _STARTUPINFOA is equal here
processinfo: TProcessInformation;
security: TSecurityAttributes;
exe, path: TFileName;
rd, wr, job: THandle;
// CreateProcess can alter the strings -> use local SynUnicode temp variables
wcmd, wenv, wpath: SynUnicode;
endtix: Int64;
flags, exitcode, res: cardinal;
ram: TRunAbortMethods;
created, terminated: boolean;
i, l: PtrInt;
procedure RedirectOutput(flush: boolean);
var
new: RawByteString;
pending, n: cardinal;
tmp: TSynTempBuffer;
begin
repeat
pending := 0;
if not PeekNamedPipe(rd, nil, 0, nil, @pending, nil) or
(pending = 0) then
begin
if (not flush) and
Assigned(onoutput) and
onoutput('', processinfo.dwProcessId) then
exitcode := WAIT_OBJECT_0; // onoutput() returned true to abort
break;
end;
if pending > SizeOf(tmp) then
pending := SizeOf(tmp);
n := 0;
Win32Check(ReadFile(rd, tmp, pending, n, nil));
if n <= 0 then
break;
if redirected <> nil then
begin
SetLength(redirected^, l + PtrInt(n));
MoveFast(tmp, PByteArray(redirected^)[l], n); // append without convert
inc(l, n);
end;
if Assigned(onoutput) then
begin
SetString(new, PAnsiChar(@tmp), n);
if onoutput(new, processinfo.dwProcessId) then // notify new content
// onoutput() callback returned true to stop the execution
if not flush then
begin
exitcode := WAIT_OBJECT_0;
break;
end;
end;
until false;
end;
begin
// https://support.microsoft.com/en-us/help/175986/info-understanding-createprocess-and-command-line-arguments
result := -1;
// extract path and exe from cmd input
if cmd = '' then
exit;
if cmd[1] = '"' then
begin
exe := copy(cmd, 2, maxInt);
i := Pos('"', exe);
if i = 0 then
exit;
SetLength(exe, i - 1); // unquote "exe" string
end
else
begin
i := Pos(' ', cmd);
if i = 0 then
exe := cmd // no parameter
else
exe := copy(cmd, 1, i - 1); // split exe and parameter(s)
end;
path := wrkdir;
if (path = '') and
(exe <> '') then
path := ExtractFilePath(ExpandFileName(exe));
if (path = '') and
FileExists(Executable.ProgramFilePath + exe) then
path := Executable.ProgramFilePath; // prefers the current folder
// prepare the CreateProcess arguments
wcmd := SynUnicode(cmd);
UniqueString(wcmd);
wpath := SynUnicode(path);
if env <> '' then
begin
wenv := SynUnicode(env);
if roEnvAddExisting in options then
begin
if EnvironmentCache = '' then
GetEnvironmentCache;
wenv := EnvironmentCache + wenv;
end
else
UniqueString(wenv);
end;
security.nLength := SizeOf(security);
security.bInheritHandle := true;
security.lpSecurityDescriptor := nil;
// launch the process
FillCharFast(startupinfo, SizeOf(startupinfo), 0);
startupinfo.cb := SizeOf(startupinfo);
ram := RunAbortMethods;
l := 0;
rd := 0;
job := 0;
if Assigned(onoutput) or
(redirected <> nil) then
if CreatePipe(rd, wr, @security, 0) then
begin
SetHandleInformation(rd, HANDLE_FLAG_INHERIT, 0);
startupinfo.wShowWindow := SW_HIDE;
startupinfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
startupinfo.hStdOutput := wr;
startupinfo.hStdError := wr;
startupinfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
if redirected <> nil then
redirected^ := '';
exclude(ram, ramCtrlC); // not compatible with redirection
end
else
rd := 0;
// https://docs.microsoft.com/en-en/windows/desktop/ProcThread/process-creation-flags
FillCharFast(processinfo, SizeOf(processinfo), 0);
flags := CREATE_UNICODE_ENVIRONMENT or CREATE_DEFAULT_ERROR_MODE;
if not (roWinNoProcessDetach in options) then
flags := flags or (DETACHED_PROCESS or CREATE_NEW_PROCESS_GROUP);
if roWinJobCloseChildren in options then
// create the child process in a new job object
flags := flags or CREATE_BREAKAWAY_FROM_JOB;
// actually create the new process
created := CreateProcessW(nil, pointer(wcmd), @security, @security, true,
flags, pointer({%H-}wenv), pointer(wpath), startupinfo, processinfo);
if (not created) and
(flags and CREATE_BREAKAWAY_FROM_JOB <> 0) then
begin
TService.DoLog(sllTrace,
'RunCommand: unsupported CREATE_BREAKAWAY_FROM_JOB = % %',
[GetLastError, WinErrorConstant(GetLastError)], nil);
flags := flags and (not CREATE_BREAKAWAY_FROM_JOB);
wcmd := SynUnicode(cmd); // CreateProcesW() modified wcmd content: recreate
UniqueString(wcmd);
created := CreateProcessW(nil, pointer(wcmd), @security, @security, true,
flags, pointer({%H-}wenv), pointer(wpath), startupinfo, processinfo);
end;
if not created then
begin
result := -GetLastError; // returns CreateProcessW() error as negative
TService.DoLog(sllTrace, 'RunCommand: CreateProcess = % %',
[-result, WinErrorConstant(-result)], nil);
exit;
end;
// setup the newly created process
if processhandle <> nil then
processhandle^ := processinfo.hProcess;
if flags and CREATE_BREAKAWAY_FROM_JOB <> 0 then
begin
job := CreateJobToClose(processinfo.dwProcessID);
if (job <> 0) and
not AssignJobToProcess(job, processinfo.hProcess, 'CloseChildren') then
begin
CloseHandle(job);
job := 0;
end;
end;
if Assigned(onoutput) then
onoutput('', processinfo.dwProcessId);
// main wait (and redirect) until the process is finished (or not)
if rd <> 0 then
begin
// wait and redirect - see https://stackoverflow.com/a/25725197/458259
CloseHandle(wr);
if waitfordelayms = INFINITE then
endtix := 0
else
endtix := GetTickCount64 + waitfordelayms;
repeat
exitcode := WaitForSingleObject(processinfo.hProcess, 50);
// note: WaitForMultipleObjects() with rd burns 100% of one core :(
Win32Check(exitcode <> WAIT_FAILED);
RedirectOutput({flush=}false);
until (exitcode = WAIT_OBJECT_0) or
((endtix <> 0) and
(GetTickCount64 > endtix));
if GetExitCodeProcess(processinfo.hProcess, exitcode) and
(exitcode <> STILL_ACTIVE) then
result := exitcode // process ended from natural death -> return code
else
begin
result := -GetLastError; // not able to retrieve exit code
// e.g. -STILL_ACTIVE if aborted by onoutput()=true above
terminated := false;
if RunAbortTimeoutSecs > 0 then
begin
if ramCtrlC in ram then // try Ctrl+C (disabled above)
begin
terminated := CancelProcess(processinfo.dwProcessId, RunAbortTimeoutSecs);
TService.DoLog(sllTrace, 'RunCommand: CancelProcess(%)=%',
[processinfo.dwProcessId, ord(terminated)], nil);
end;
if (not terminated) and
(ramQuit in ram) then
begin // try WM_QUIT
terminated := QuitProcess(processinfo.dwProcessId, 0);
TService.DoLog(sllTrace, 'RunCommand: QuitProcess(%)=%',
[processinfo.dwProcessId, ord(terminated)], nil);
if terminated then
begin
endtix := GetTickCount64 + RunAbortTimeoutSecs * 1000; // wait ended
repeat
res := WaitForSingleObject(processinfo.hProcess, 10);
RedirectOutput({flush=}true); // mandatory to unlock pipe
until (res <> WAIT_TIMEOUT) or
(GetTickCount64 > endtix);
terminated := res = WAIT_OBJECT_0;
end;
end;
end;
RedirectOutput({flush=}true); // ensure there is no pending data
if terminated and
// gracefully ended -> try to retrieve the exit code
GetExitCodeProcess(processinfo.hProcess, exitcode) then
result := exitcode
else
begin
TerminateProcess(processinfo.hProcess, result); // forced kill
TService.DoLog(sllTrace, 'RunCommand: TerminateProcess(%)=%',
[processinfo.dwProcessId, result], nil);
end;
end;
end
else if waitfor then
if WaitForSingleObject(processinfo.hProcess, waitfordelayms) = WAIT_FAILED then
if waitfordelayms <> INFINITE then
result := -1 // still runing after waitfordelayms
else
result := -GetLastError // failed to wait
else if GetExitCodeProcess(processinfo.hProcess, exitcode) then
result := exitcode // waited for process to end -> return code
else
result := -GetLastError // was not able to retrieve exit code
else
// waitfor is false: asynchronous process launch
result := 0;
// release the handles created for this process
CloseHandle(processinfo.hProcess);
CloseHandle(processinfo.hThread);
if rd <> 0 then // CloseHandle(wr) has already be done
CloseHandle(rd);
if job <> 0 then
CloseHandle(job);
end;
function RunRedirect(const cmd: TFileName; exitcode: PInteger;
const onoutput: TOnRedirect; waitfordelayms: cardinal; setresult: boolean;
const env, wrkdir: TFileName; options: TRunOptions): RawByteString;
var
res: integer;
redir: PRawByteString;
begin
result := '';
if setresult then
redir := @result
else
redir := nil;
res := RunCommand(cmd, true, env, options, waitfordelayms, nil,
redir, onoutput, wrkdir);
if exitcode <> nil then
exitcode^ := res;
end;
{ ****************** Gather Operating System Information }
const
// lpMinimumApplicationAddress retrieved from Windows is very low ($10000)
// - i.e. maximum number of ID per table would be 65536 in TOrm.GetID
// - so we'll force an higher and almost "safe" value as 1,048,576
// (real value from runnning Windows is greater than $400000)
MIN_PTR_VALUE = $100000;
// see http://msdn.microsoft.com/en-us/library/ms724833(v=vs.85).aspx
VER_NT_WORKSTATION = 1;
VER_NT_DOMAIN_CONTROLLER = 2;
VER_NT_SERVER = 3;
SM_SERVERR2 = 89;
PROCESSOR_ARCHITECTURE_AMD64 = 9;
type
TSystemLogicalProcessorRelation = (
RelationProcessorCore,
RelationNumaNode,
RelationCache,
RelationProcessorPackage,
RelationGroup);
TSystemLogicalProcessorCache = (
CacheUnified,
CacheInstruction,
CacheData,
CacheTrace);
{$ifdef CPU64}
{$A8}
{$else}
{$A4}
{$endif CPU64}
TSystemLogicalProcessorInformation = record
ProcessorMask: PtrUInt;
case Relationship: TSystemLogicalProcessorRelation of
RelationProcessorCore: (
ProcessorCoreFlags: BYTE);
RelationNumaNode: (
NumaNodeNumber: DWord);
RelationCache: (
Cache: record
Level: BYTE;
Associativity: BYTE;
LineSize: WORD;
Size: DWord;
CacheType: TSystemLogicalProcessorCache;
end);
RelationGroup: (
Reserved: array [0..1] of QWord); // to define the actual struct size
end;
{$A+}
{$ifndef UNICODE}
function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL;
stdcall; external kernel32 name 'GetVersionExA';
{$endif UNICODE}
function GetLocalTimeOffset: Integer; // not defined in oldest Delphi
var
tzi: TTimeZoneInformation;
begin
case GetTimeZoneInformation(tzi) of
TIME_ZONE_ID_UNKNOWN:
result := tzi.Bias;
TIME_ZONE_ID_STANDARD:
result := tzi.Bias + tzi.StandardBias;
TIME_ZONE_ID_DAYLIGHT:
result := tzi.Bias + tzi.DaylightBias;
else
result := 0;
end;
end;
function UUID_CACHE: TFileName;
begin // where to cache our computed UUID as a local file
result := GetSystemPath(spCommonData) + 'synopse.uuid';
end;
procedure InitializeSpecificUnit;
var
h: THandle;
IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall;
GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall;
GetLogicalProcessorInformation: function(
var Info: TSystemLogicalProcessorInformation; Len: PDWord): BOOL; stdcall;
wine_get_version: function: PAnsiChar; stdcall;
mem: TMemoryStatusEx;
Res: BOOL;
P: pointer;
Vers: TWindowsVersion;
cpu, manuf, prod, prodver: RawUtf8;
reg: TWinRegistry;
proc: array of TSystemLogicalProcessorInformation;
i: integer;
siz: DWord;
begin
{$ifdef ASMX86}
{$ifndef HASNOSSE2}
if not (cfSSE2 in CpuFeatures) then
begin
// avoid illegal opcode in MoveFast() and SynLZ functions
{$ifdef ISDELPHI} // FPC_X86 already redirect to FastCode RTL Move()
RedirectCode(@MoveFast, @System.Move);
{$endif ISDELPHI}
RedirectCode(@SynLZcompress1, @SynLZcompress1Pas);
RedirectCode(@SynLZdecompress1, @SynLZdecompress1Pas);
ConsoleWrite('WARNING: too old CPU - recompile with HASNOSSE2', ccLightRed);
// note: FillCharFast is handled by mormot.core.base via ERMSB
// and Byte/Word/IntegerScanIndex() are likely to GPF at runtime
end;
{$endif HASNOSSE2}
{$endif ASMX86}
// late-binding of newest Windows APIs
h := GetModuleHandle(kernel32);
GetTickCount64 := GetProcAddress(h, 'GetTickCount64');
if not Assigned(GetTickCount64) then // WinXP+
GetTickCount64 := @GetTickCount64ForXP;
GetSystemTimePreciseAsFileTime :=
GetProcAddress(h, 'GetSystemTimePreciseAsFileTime');
if not Assigned(GetSystemTimePreciseAsFileTime) then // Win8+
GetSystemTimePreciseAsFileTime := @GetSystemTimeAsFileTime;
{$ifdef WITH_VECTOREXCEPT}
AddVectoredExceptionHandler :=
GetProcAddress(h, 'AddVectoredExceptionHandler');
{$endif WITH_VECTOREXCEPT}
QueryPerformanceFrequency(PInt64(@_QueryPerformanceFrequency)^);
if _QueryPerformanceFrequency = 0 then
raise Exception.Create('QueryPerformanceFrequency=0'); // paranoid
_QueryPerformanceFrequencyPer10 := _QueryPerformanceFrequency = 10000000;
IsWow64Process := GetProcAddress(h, 'IsWow64Process');
Res := false;
IsWow64 := Assigned(IsWow64Process) and
IsWow64Process(GetCurrentProcess, Res) and
Res;
if IsWow64 then
// see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx
GetNativeSystemInfo := GetProcAddress(h, 'GetNativeSystemInfo')
else
@GetNativeSystemInfo := nil;
GetSystemTimes := GetProcAddress(h, 'GetSystemTimes');
GetProcessTimes := GetProcAddress(h, 'GetProcessTimes');
QueryFullProcessImageNameW := GetProcAddress(h, 'QueryFullProcessImageNameW');
GetLogicalProcessorInformation := GetProcAddress(h, 'GetLogicalProcessorInformation');
InitializeSRWLock := GetProcAddress(h, 'InitializeSRWLock');
AcquireSRWLockExclusive := GetProcAddress(h, 'AcquireSRWLockExclusive');
ReleaseSRWLockExclusive := GetProcAddress(h, 'ReleaseSRWLockExclusive');
if not Assigned(InitializeSRWLock) or
not Assigned(AcquireSRWLockExclusive) or
not Assigned(ReleaseSRWLockExclusive) then
begin // SRW was introduced with Vista: on XP, fallback to our TLightLock
InitializeSRWLock := @InitializeSRWLockForXP;
AcquireSRWLockExclusive := @AcquireSRWLockExclusiveForXP;
ReleaseSRWLockExclusive := @ReleaseSRWLockExclusiveForXP;
end;
// retrieve system information
TimeZoneLocalBias := -GetLocalTimeOffset;
FillcharFast(SystemInfo, SizeOf(SystemInfo), 0);
if Assigned(GetNativeSystemInfo) then
GetNativeSystemInfo(SystemInfo)
else
Windows.GetSystemInfo(SystemInfo);
GetMem(P, 10); // ensure that using MIN_PTR_VALUE won't break anything
if (PtrUInt(P) > MIN_PTR_VALUE) and
(PtrUInt(SystemInfo.lpMinimumApplicationAddress) <= MIN_PTR_VALUE) then
PtrUInt(SystemInfo.lpMinimumApplicationAddress) := MIN_PTR_VALUE;
Freemem(P);
FillCharFast(mem, SizeOf(mem), 0);
mem.dwLength := SizeOf(mem);
if GlobalMemoryStatusEx(mem) then
SystemMemorySize := mem.ullTotalPhys;
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
GetVersionEx(OSVersionInfo);
Vers := wUnknown;
with OSVersionInfo do
// see https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833
case dwMajorVersion of
5:
case dwMinorVersion of
0:
Vers := w2000;
1:
Vers := wXP;
2:
if (wProductType = VER_NT_WORKSTATION) and
(SystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64) then
Vers := wXP_64
else if GetSystemMetrics(SM_SERVERR2) = 0 then
Vers := wServer2003
else
Vers := wServer2003_R2;
end;
6:
case dwMinorVersion of
0:
Vers := wVista;
1:
Vers := wSeven;
2:
Vers := wEight;
3:
Vers := wEightOne;
4:
Vers := wTen;
end;
10:
Vers := wTen;
end;
if Vers >= wVista then
begin
// see https://en.wikipedia.org/wiki/List_of_Microsoft_Windows_versions
if OSVersionInfo.wProductType <> VER_NT_WORKSTATION then
begin
// Server edition
inc(Vers, 2); // e.g. wEight -> wServer2012
if Vers = wServer2016 then
// we identify only LTSC server versions
if OSVersionInfo.dwBuildNumber >= 17763 then
if OSVersionInfo.dwBuildNumber >= 20285 then // released as 20348
Vers := wServer2022_64
else
Vers := wServer2019_64;
end
else if (Vers = wTen) and
(OSVersionInfo.dwBuildNumber >= 22000) then
// Windows 11 has always 22000.###
Vers := wEleven;
if (SystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64) and
(Vers < wServer2019_64) then
inc(Vers); // e.g. wEight -> wEight64
end;
OSVersion := Vers;
OpenProcessAccess := PROCESS_QUERY_LIMITED_INFORMATION;
if Vers < wVista then
OpenProcessAccess := PROCESS_QUERY_INFORMATION or PROCESS_VM_READ;
OSVersion32.os := osWindows;
OSVersion32.win := Vers;
OSVersion32.winbuild := OSVersionInfo.dwBuildNumber;
h := GetModuleHandle(ntdll);
if h > 0 then
begin
wine_get_version := GetProcAddress(h, 'wine_get_version');
if Assigned(wine_get_version) then
begin
OSVersionInfoEx := wine_get_version;
OSVersionInfoEx := TrimU('Wine ' + TrimU(OSVersionInfoEx));
end;
NtQueryInformationProcess := GetProcAddress(h, 'NtQueryInformationProcess');
RtlInitUnicodeString := GetProcAddress(h, 'RtlInitUnicodeString');
NtOpenSection := GetProcAddress(h, 'NtOpenSection');
NtMapViewOfSection := GetProcAddress(h, 'NtMapViewOfSection');
NtUnmapViewOfSection := GetProcAddress(h, 'NtUnmapViewOfSection');
end;
// retrieve Software/Hardware information from Registry
if reg.ReadOpen(wrLocalMachine, 'Software\Microsoft\Windows NT\CurrentVersion') then
begin
WindowsUbr := reg.ReadDword('UBR');
WindowsProductName := reg.ReadString('ProductName');
WindowsDisplayVersion := reg.ReadString('DisplayVersion');
end;
with OSVersionInfo do
begin
_fmt('Windows %s (%d.%d.%d)', [WINDOWS_NAME[Vers],
dwMajorVersion, dwMinorVersion, dwBuildNumber], OSVersionText);
if wServicePackMajor <> 0 then
insert(_fmt('SP%d ', [wServicePackMajor]), OSVersionText, PosExChar('(', OSVersionText));
end;
if WindowsUbr <> 0 then
insert(_fmt('.%d', [WindowsUbr]), OSVersionText, length(OSVersionText));
if WindowsDisplayVersion <> '' then
insert(WindowsDisplayVersion + ' ', OSVersionText, PosExChar('(', OSVersionText));
if OSVersionInfoEx <> '' then
OSVersionText := OSVersionText + ' - ' + OSVersionInfoEx;
if reg.ReadOpen(wrLocalMachine, 'Hardware\Description\System\CentralProcessor\0', true) then
begin
cpu := reg.ReadString('ProcessorNameString');
if cpu = '' then
cpu := reg.ReadString('Identifier');
end;
if reg.ReadOpen(wrLocalMachine, 'Hardware\Description\System\BIOS', true) then
begin
manuf := reg.ReadString('SystemManufacturer');
if manuf <> '' then
manuf := manuf + ' ';
prod := reg.ReadString('SystemProductName');
prodver := reg.ReadString('SystemVersion');
if prodver = '' then
prodver := reg.ReadString('BIOSVersion');
end;
if ({%H-}prod = '') or
({%H-}prodver = '') then
begin
if reg.ReadOpen(wrLocalMachine, 'Hardware\Description\System', true) then
begin
if prod = '' then
prod := reg.ReadString('SystemBiosVersion');
if prodver = '' then
prodver := reg.ReadString('VideoBiosVersion');
end;
end;
reg.Close;
BiosInfoText := manuf{%H-} + prod;
if prodver <> '' then
BiosInfoText := BiosInfoText + ' ' + prodver;
if {%H-}cpu = '' then
cpu := RawUtf8(GetEnvironmentVariable('PROCESSOR_IDENTIFIER'));
if Assigned(GetLogicalProcessorInformation) then
begin
SetLength(proc, 1024);
siz := SizeOf(proc[0]) * length(proc);
if GetLogicalProcessorInformation(proc[0], @siz) then
begin
for i := 0 to (siz div SizeOf(proc[0])) - 1 do
with proc[i] do
case Relationship of
RelationProcessorPackage: // physical processor socket
AddPtrUInt(TPtrUIntDynArray(CpuSocketsMask), CpuSockets, ProcessorMask);
RelationCache: // raw cache information
if Cache.CacheType in [CacheUnified, CacheData] then
if (Cache.Level >= low(CpuCache)) and
(Cache.Level <= high(CpuCache)) then
with CpuCache[Cache.Level] do
if (Count = 0) or
(Cache.CacheType <> CacheUnified) then
begin
inc(Count);
Size := Cache.Size;
LineSize := Cache.LineSize;
end;
end;
for i := high(CpuCache) downto low(CpuCache) do
begin
CpuCacheSize := CpuCache[i].Size;
if CpuCacheSize <> 0 then // append the biggest level Cache size
begin
cpu := _fmt('%s [%s]', [cpu, _oskb(CpuCacheSize)]);
break;
end;
end;
for i := low(CpuCache) to high(CpuCache) do
with CpuCache[i] do
if Count <> 0 then
if Count = 1 then
CpuCacheText :=
_fmt('%s L%d=%s ', [CpuCacheText, i, _oskb(Size)])
else
CpuCacheText :=
_fmt('%s L%d=%d*%s ', [CpuCacheText, i, Count, _oskb(Size)]);
TrimSelf(CpuCacheText);
end;
end;
if CpuSockets = 0 then
CpuSockets := 1; // e.g. on XP prior to SP3
_fmt('%d x %s (' + CPU_ARCH_TEXT + ')',
[SystemInfo.dwNumberOfProcessors, cpu], CpuInfoText);
// writeln(CpuInfoText); writeln(CpuCacheText);
end;
procedure FinalizeSpecificUnit;
begin
if CryptoApi.Handle <> 0 then
Windows.FreeLibrary(CryptoApi.Handle);
if CoInitCounter <> 0 then
ConsoleWrite('Missing CoUninit (e.g. TOleDBConnection.Destroy call)');
end;
Reference in New Issue View Git Blame Copy Permalink