Kas Ob.

Here is the output of what seems working capture of all the events/actions from LB, though tested in one instance with text file Document loaded successfully Global event listener registered Document loaded. Press Enter to exit. Event: OnLayoutFinished Other event: OnLayoutFinished Event: OnTitleChanged Other event: OnTitleChanged Event: OnModifyChanged Other event: OnModifyChanged Event: OnLayoutFinished Other event: OnLayoutFinished Event: OnSave Save event detected! Event: OnCopyTo Other event: OnCopyTo Event: OnCopyToDone Other event: OnCopyToDone Captured data: Hi From Delphi !.1 Event: OnSaveFailed SaveFailed event detected! Event: OnModeChanged Other event: OnModeChanged Event: DialogExecute Other event: DialogExecute Event: OnModeChanged Other event: OnModeChanged Event: DialogClosed Other event: DialogClosed Event: OnLayoutFinished Other event: OnLayoutFinished Event: OnSave Save event detected! Event: OnCopyTo Other event: OnCopyTo Event: OnCopyToDone Other event: OnCopyToDone Captured data: Hi From Delphi !.13 Event: OnSaveFailed SaveFailed event detected! Event: OnModeChanged Other event: OnModeChanged Event: DialogExecute Other event: DialogExecute Event: OnModeChanged Other event: OnModeChanged Event: DialogClosed Other event: DialogClosed Event: OnPrepareViewClosing Other event: OnPrepareViewClosing Event: OnPrepareUnload Other event: OnPrepareUnload Event: OnModeChanged Other event: OnModeChanged Event: DialogExecute Other event: DialogExecute Event: OnModeChanged Other event: OnModeChanged Event: DialogClosed Other event: DialogClosed Event: OnViewClosed Other event: OnViewClosed Event: OnUnload Other event: OnUnload Event: OnUnfocus Other event: OnUnfocus Event: OnCloseApp Other event: OnCloseApp @Pierre le Riche i am DM my work, and can't guarantee it to be error/mistake free, yet it looks working and didn't dig more in the dialog handling, (like how to stop them ) and i expected the pipe for saving (output) is for one use.

Nice to hear and you are welcome. The good news is that i solved the GetFuncDesc, use it, it is working now fine function TDocumentEventListener.GetFuncDesc(index: Integer; out pfuncdesc: PFuncDesc): HResult; var FuncDesc: TFuncDesc; ElemDescList: PElemDescList; begin Writeln('EventListener GetFuncDesc: index=', index); if index in [0, 1] then begin FillChar(FuncDesc, SizeOf(TFuncDesc), 0); // Allocate array of one ElemDescList := CoTaskMemAlloc(SizeOf(TElemDesc)); FillChar(ElemDescList^, SizeOf(TElemDesc), 0); ElemDescList^[0].tdesc.vt := VT_VARIANT; ElemDescList^[0].paramdesc.wParamFlags := PARAMFLAG_FIN; if index = 0 then begin FuncDesc.memid := 1; FuncDesc.lprgelemdescParam := ElemDescList; FuncDesc.cParams := 1; end else begin FuncDesc.memid := 4; FuncDesc.lprgelemdescParam := ElemDescList; FuncDesc.cParams := 1; end; FuncDesc.funckind := FUNC_DISPATCH; FuncDesc.invkind := INVOKE_FUNC; FuncDesc.elemdescFunc.tdesc.vt := VT_HRESULT; pfuncdesc := CoTaskMemAlloc(SizeOf(TFuncDesc)); Move(FuncDesc, pfuncdesc^, SizeOf(TFuncDesc)); Result := S_OK; end else begin pfuncdesc := nil; Result := DISP_E_BADINDEX; end; end; I feel like i am implementing the whole UNO interface with this one 🤬 Anyway stopped at handling Invoke (as it is called now smoothly) and HandleDocumentEvent (my own field in the eventlister), HandleDocumentEvent is hell to handle, and can't find a real nice documentation for events and their parameters, its like shooting darts in the dark. ps still using two separated CoTaskMemAlloc and they can be merged in one by aligning the memory, as will be released together, yet not touching it for now.

I would leave this to the last, as from what i got once pipe is closed then it is closed and need replacing, but ... who knows. For few hours i also was trying to do the same, but the code is not working fully because i am stuck with again UNO layer, which is causing this, anyway you need to call ".addDocumentEventListener(EventListener as IDispatch);" on either 'com.sun.star.frame.GlobalEventBroadcaster' or LDocument, both working the same from what i see, yet the problem is in EventListener implementation It should be TDocumentEventListener = class(TInterfacedObject, IDispatch, ITypeInfo) And i see callbacks being triggering GetTypeInfo and GetFuncDesc, but filling and answering GetFuncDesc is really confusing, Invoke on other hand being called once at least but i thinkit is the one belongs to IDispathc, ... don't know what to say more, but hope that put you on the road and i might try again later but for today i am now in full hate mode for LibreOffice and its documentation, also its source, it is hard to read and follow. Also debugging is hard, on top of LB is crashing and stop responding, don't know if this happen with your setup, but after some crashes it stop to respond and i need full system restart to bring it up again, though it might be failure on OS side to clean OLE machine. I am stuck at GetFuncDesc, tried many things but it still causing AV, as it went all the way to execute Invoke, yet i am failing to point/pass/fill it right.

At last ! 😎 @Pierre le Riche found a solution, by using Pipe (com.sun.star.io.Pipe) instead of stream, one can get your needed result. https://api.libreoffice.org/docs/idl/ref/servicecom_1_1sun_1_1star_1_1io_1_1Pipe.html program LibreOfficeLoadingFromStream; {$APPTYPE CONSOLE} uses System.SysUtils, System.Win.ComObj, Winapi.ActiveX; procedure LoadWriterDocumentFromBytes(const ADocumentData: TBytes; const aFilterName: string = 'Text'; aFilterOptions: string = ''); var LServiceManager, LDesktop, LProperties: Variant; LPipe: Variant; LPropertyArray: TArray<Variant>; begin {Connect to LibreOffice} LServiceManager := CreateOleObject('com.sun.star.ServiceManager'); LDesktop := LServiceManager.createInstance('com.sun.star.frame.Desktop'); LPipe := LServiceManager.createInstance('com.sun.star.io.Pipe'); LPipe.writeBytes(Variant(ADocumentData)); LPipe.closeOutput; // Important: close output to signal end of data (adding and simulating EOF) SetLength(LPropertyArray, 2); LPropertyArray[0] := LServiceManager.Bridge_GetStruct('com.sun.star.beans.PropertyValue'); LPropertyArray[0].Name := 'InputStream'; LPropertyArray[0].Value := LPipe; LPropertyArray[1] := LServiceManager.Bridge_GetStruct('com.sun.star.beans.PropertyValue'); LPropertyArray[1].Name := 'FilterName'; LPropertyArray[1].Value := aFilterName; if aFilterOptions <> '' then begin SetLength(LPropertyArray, 3); LPropertyArray[2] := LServiceManager.Bridge_GetStruct('com.sun.star.beans.PropertyValue'); LPropertyArray[2].Name := 'FilterOptions'; LPropertyArray[2].Value := aFilterOptions; end; LProperties := LPropertyArray; LDesktop.loadComponentFromURL('private:stream', '_blank', 0, LProperties); end; const {(*} TXTData = 'Hi From Delphi !.'; HTMLData = '<!DOCTYPE html><html><body><h1>My First Heading</h1><p>My first paragraph.</p></body></html>'; // don't know how ! RTFData = ' {\rtf1\ansi{\fonttbl\f0\fswiss Helvetica;}\f0\pard This is some {\b bold} text.\par }'; // also still missing something CSVData = 'Name,Age,City,Country' + #13#10 + 'John Doe,30,New York,USA' + #13#10 + 'Jane Smith,25,London,UK' + #13#10 + 'Bob Johnson,35,Toronto,Canada' + #13#10 + 'Alice Brown,28,Sydney,Australia';{*)} CSVFilterOption = '44,34,76,1,1/5/2/1/3/5/4/5,0,true,true,true'; // for the above CSVData begin CoInitialize(nil); try LoadWriterDocumentFromBytes(BytesOf(TXTData)); //LoadWriterDocumentFromBytes(BytesOf(HTMLData),'HTML Document (Writer)'); // missing something may be //LoadWriterDocumentFromBytes(BytesOf(RTFData),'Rich Text'); // also LoadWriterDocumentFromBytes(BytesOf(CSVData), 'Text - txt - csv (StarCalc)', CSVFilterOption); // for some reason 'csv' is not enough except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; Writeln('Done.'); Readln; end. The result is smooth loading of two instances SWriter and SCalc Tried to load HML and RTF but didn't work, and i really got bored with this, and believe this is a solution for your obstacle for now. ps if you managed to make it load html or pdf, then please share ! extra info the opened instances has document named as "private:stream" but this is easy to rename the most complete supported filters is this https://help.libreoffice.org/25.2/en-US/text/shared/guide/convertfilters.html Good luck !

This is exactly what i do understand now, UNO only exist for Java and C++, and it is higher level abstraction, like there is no Initialize you tried to use in the API but it is only exist in UNO API. Also, the usage i mentioned about Input/Output is there, and it is confusing, as in my example above only Output can write and read, but the Input is to receive only. What get to mind, is the similarity between of this get/load from memory in Open/LibreOffice and embedded Internet Explorer, it doesn't allow to load/navigate to stream or memory data, but you should navigate to an blank then load the content form memory, this lead me now to this working example with SWriter program LibreOfficeFromDelphi; {$APPTYPE CONSOLE} {$R *.res} uses System.SysUtils, System.Win.ComObj, Winapi.ActiveX, Variants; procedure LoadSWriterDocumentFromTBytes(const ADocumentData: string); var LServiceManager, LDesktop, LDocument, LText, LTextCursor: Variant; begin {Connect to LibreOffice} LServiceManager := CreateOleObject('com.sun.star.ServiceManager'); LDesktop := LServiceManager.createInstance('com.sun.star.frame.Desktop'); LDocument := LDesktop.loadComponentFromURL('private:factory/swriter', '_blank', 0, VarArrayCreate([0, -1], varVariant)); LText := LDocument.Text; LTextCursor := LText.createTextCursor; LText.insertString(LTextCursor, ADocumentData, False); end; var SomeTextForWriter: string; begin CoInitialize(nil); try SomeTextForWriter := ' Hello, from Delphi'; LoadSWriterDocumentFromTBytes(SomeTextForWriter); except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; Writeln('Done.'); Readln; end. The result But the core is inserting text !, simple text, may be there is a way to insert formatted text !? And for SCalc, also opening blank is working fine, but there is no text but sheets and stuff. The whole thing is very similar to DOM, may be it is XComponent , but really can't find useful information here, all internet resources leads to the blocked road with UNO API.

This works fine program LibreOfficeLoadingFromStream; {$APPTYPE CONSOLE} uses System.SysUtils, System.Win.ComObj, Winapi.ActiveX; procedure LoadWriterDocumentFromStream(const ADocumentData: TBytes); var LServiceManager, LDesktop, LStream, LDocData, LProperties: Variant; LPropertyArray: TArray<Variant>; WrittenBytes: TBytes; begin {Connect to LibreOffice} LServiceManager := CreateOleObject('com.sun.star.ServiceManager'); LDesktop := LServiceManager.createInstance('com.sun.star.frame.Desktop'); {Instantiate in input stream to load the document data from} //LInputStream := LServiceManager.createInstance('com.sun.star.io.SequenceInputStream'); LStream := LServiceManager.createInstance('com.sun.star.io.SequenceOutputStream'); // <- {Populate the input stream with the document data} LDocData := ADocumentData; //LInputStream.createStreamFromSequence(LDocData); // <- error here LStream.writeBytes(LDocData); WrittenBytes := LStream.getWrittenBytes; Writeln(StringOf(WrittenBytes)); // test again Writeln('Test again'); LStream.writeBytes(Variant(BytesOf(#13#10'Another TExt'))); Writeln(StringOf(LStream.getWrittenBytes)); end; var LDocData: TBytes; begin CoInitialize(nil); //SetLength(LDocData, 10000); //In an actual application LDocData would contain the .odt document file content LDocData := BytesOf('Sample text 123!@#'); try LoadWriterDocumentFromStream(LDocData); except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; Readln; end. the output is The problem is in API naming and assumption of simple logical naming, it seems the Output/Input words (and meaning) are reversed in the whole SDK, so you should look at them in reverse (from the binary/exe perspective) https://api.libreoffice.org/docs/idl/ref/namespacecom_1_1sun_1_1star_1_1io.html and the one you need is https://api.libreoffice.org/docs/idl/ref/servicecom_1_1sun_1_1star_1_1io_1_1SequenceOutputStream.html

Yes i don't like seeing these on the call stack captured and reported by OS This interpreted as the exception handling did fail and returned to the OS, hence the shut down. I don't have any experience with JclHookExcept, never used it, and looking at its code https://github.com/bematech/jcl/blob/master/windows/JclHookExcept.pas#L383 leading to https://github.com/bematech/jcl/blob/master/windows/JclHookExcept.pas#L322 Now what, did you tried to resolve or access the custom exception ? may be trying to report some buffer, return values, or any thing was on a thread stack that might be already gone ? This is very plausible scenario.

1) Windows version 2) Confirm if this crash happen with the same exact addresses/parameters , specially the "Fault Offset", it is important. 3) How frequent this happen ? can you reproduce or predict the moment of this crash ? 4) Get the ProcDump with full dump like this "procdump -ma -e 1 -t MyStuff.exe MyStuffCrash.dmp" , this is loadable with WinDBG then try to understand what exist at 0xf0a79e3d with "!address" Theories: 1) That fault offset is not out of thin air, it might be coming from hidden WOW64, yet the looks like 32bit hence the unexplained address, these emulator DLLs are 64bit and loaded in 32bit, though impossible to see or interact with them from the process itself, only you see their exception when they raised, as always their exceptions are fatal. 2) handling the exception did in fact corrupt the stack and triggered cascade of problems in Windows trying to unwind , so i don't like these two calls appears on the call stack they looks the cause, just remove them and see if things changes, but this has to do with the extra information above (3) how the above will help, well, you can't solve such crash without pinpoint specific operation, those are (form my experience) a conflict in IO operation combined with stack usage for buffer (or some return values) from different thread, missing or forgetting about these return values, so review your code and make sure your local variable are not passed to different threads, or handling the exception itself triggered extra corruption.

Never used WSAConnectByList, i barely remember testing it, but blocking only without overlapped makes it usable only in specific cases. My suggestion is neither approaches, implement connect with multiple socket at the same time, one Select will do and can be used with up to 64 IPs, the first connect will be used the rest will be closed, this how i do it. lets say you resolved a host (they almost always returned in random order), i pair one IPv4 with IPv6 and connect to them both, the fastest kept and the other dropped without sending anyting. On side note; IPv6 sometimes outperform IPv4, but not always, my ISP doesn't provide IPv6 in my region, so i use 6in4 tunnels on my router, the tunnels from two providers http://tb.netassist.ua/ and https://tunnelbroker.net/ , the setting are on the router and have punch of end points, now; how they do perform is unpredictable, connecting to north America using NA is slow as turtle, and connecting to Asia using HE is slower then IPv4 by a lot like 2 seconds, yet with NA IPv6 to EU is faster than IPv4, this is just a suggestion to enhance the quality and the speed of the connection by selecting the faster SYN/ACK. Hope that help.

Hi, Not really a clue but a guess reading the log above and the steps, the shut down triggered at 16kb of sending, i read this as clue, it looks like the pending response ( aka blocking request) translated into disconnect and wrongly handled as failure instead. So; 1) a question on side but might be important, were did these numbers 1476 and 1468 come from ?, did you calculate the MTU and decided it should be like that ? the lack of client side successful recv means the log entry wasn't from successful send event, track those, (but again of ICS have them, as i don't know) 2) i can't tell how ICS works for websocket, but i think Angus can tell if the blocking handled right in your version, yet he recommended that you update, then update, also reproducing such behavior should be fairly easy, @FrozenK if you can provide short project reproducing that shutdown trigger, then that behavior can be solved once and for all. 3) Have you missed around with TCP buffers sizes ? (namely sending buffer) , are you tweaking some socket options ? the default send buffer on Windows is 8kb, but this doesn't means you can't send more, it is just little more long story to explain. 4) Also, the problem in my opinion is that ACK hadn't been received and sending party reached some a limit around 16kb (limit but not receiving peer ACK), this triggered blocking request (pending), and this translated into error with lead to shut down, in other words handled, the socket is not checking if ready to send while handling WSAEWOULDBLOCK as fatal connection error, while it is not. Hope that helps.

It just hit me, Don't cache them all, as some DLL will never show in the stack, like never, even very common libraries like "AdvApi32.dll" or "Ws2_32.dll" will not be on stack call unless they used callback (used once), so if cached only the found ones you will end up with short list and sorted by importance and appearance.

Yes, it might be be slower, but the idea is even with your cache you will have to walk it, and if you re-refactored my code above it is really just loop over linked-list, In case you want to test it, then notice that PEB is immovable like its LdrData, so that part can be in initialization clause, this will leave the code close to function FindModuleByAddress(Address: Pointer): TModuleInfo; var ModuleEntry: PLDR_DATA_TABLE_ENTRY; CurrentEntry, FirstEntry: PLIST_ENTRY; ModuleBaseAddr, ModuleEndAddr: NativeUInt; FlinkPtr: PPointer; ProtCounter: Integer; // protection counter against looping over ring doubly linked list begin Result.IsValid := False; FlinkPtr := PPointer(NativeUInt(LdrData) + Flink_OFFSET); // Offset is 12 for 32bit and 24 for 64bit CurrentEntry := FlinkPtr^; if AddressViolateMemoryRange(CurrentEntry) then Exit; FirstEntry := CurrentEntry; // protection against endless looping over ring list ProtCounter := 0; // protection against endless looping over ring list in case FirstEntry is unloaded after the fact while Assigned(CurrentEntry) and (not AddressViolateMemoryRange(CurrentEntry)) and (CurrentEntry <> PList_Entry(NativeUInt(LdrData) + Flink_OFFSET)) do begin ModuleEntry := PLDR_DATA_TABLE_ENTRY(CurrentEntry); try if Assigned(ModuleEntry^.DllBase) then begin ModuleBaseAddr := NativeUInt(ModuleEntry^.DllBase); ModuleEndAddr := ModuleBaseAddr + ModuleEntry^.SizeOfImage; if (NativeUInt(Address) >= ModuleBaseAddr) and (NativeUInt(Address) < ModuleEndAddr) then begin // found module that have the address .. Result.IsValid := True; Exit; end; end; except // Ignore access violations, do not handle anything here end; if ProtCounter >= LOOPING_PROTECTION_LIMIT then Exit; Inc(ProtCounter); CurrentEntry := CurrentEntry^.Flink; if CurrentEntry = FirstEntry then Break; end; end; As for caching, i think you are the best one to decide if you want to cache few (may be 3 and that it) modules addresses that will be %90 of the times in any stack call, the EXE module itself and kernel and User32, saving these 3 will make the protection counter way better than random 1000, by comparing against loaded EXE address and trigger exit after second occurrence, this will prevent loop up to 1000. In all cases, you are welcome.

Here a more precise and protected version will less redundant code unit lcAddressToModule; interface uses Windows; type TModuleInfo = record ModuleBase: Pointer; ModuleSize: Cardinal; ModuleName: string; FullPath: string; EntryPoint: Pointer; IsValid: Boolean; end; function FindModuleByAddress(Address: Pointer): TModuleInfo; implementation const Flink_OFFSET = {$IFDEF CPUX64} 24 {$ELSE} 12 {$ENDIF}; // Offset is 12 for 32bit and 24 for 64bit LOOPING_PROTECTION_LIMIT = 1000; type PLIST_ENTRY = ^LIST_ENTRY; LIST_ENTRY = packed record Flink: PLIST_ENTRY; Blink: PLIST_ENTRY; end; PUNICODE_STRING = ^UNICODE_STRING; UNICODE_STRING = packed record Length: Word; MaximumLength: Word; {$IFDEF CPUX64} Padding: array[0..3] of Byte; // Align Buffer to 8 bytes {$ENDIF} Buffer: PWideChar; end; PLDR_DATA_TABLE_ENTRY = ^LDR_DATA_TABLE_ENTRY; LDR_DATA_TABLE_ENTRY = packed record InLoadOrderLinks: LIST_ENTRY; InMemoryOrderLinks: LIST_ENTRY; InInitializationOrderLinks: LIST_ENTRY; DllBase: Pointer; EntryPoint: Pointer; SizeOfImage: ULONG; {$IFDEF CPUX64} Padding: array[0..3] of Byte; // Align FullDllName to 60 {$ENDIF} FullDllName: UNICODE_STRING; BaseDllName: UNICODE_STRING; end; PPEB_LDR_DATA = ^PEB_LDR_DATA; PEB_LDR_DATA = packed record Length: ULONG; Initialized: Boolean; {$IFDEF CPUX64} Padding: array[0..2] of Byte; // Align SsHandle to 8 bytes {$ENDIF} SsHandle: Pointer; InLoadOrderModuleList: LIST_ENTRY; end; PPEB = ^PEB; PEB = packed record Reserved: array[0..2] of Byte; BeingDebugged: Byte; {$IFDEF CPUX64} Reserved2: array[0..11] of Byte; // Align Ldr to 24 {$ELSE} Reserved2: array[0..3] of Byte; // Align Ldr to 12 {$ENDIF} ImageBaseAddress: Pointer; Ldr: PPEB_LDR_DATA; end; function RtlGetCurrentPeb: Pointer; stdcall; external 'ntdll.dll'; function GetCurrentPEB: PPEB; begin Result := RtlGetCurrentPeb; end; function AddressViolateMemoryRange(Address: Pointer): Boolean; begin Result := (NativeUInt(Address) < $10000) or // always in user mode then it shold be above 64kb // $BFFFFFFF when (/3G) and/or IMAGE_FILE_LARGE_ADDRESS_AWARE is enabled, when disabled it should be $7FFFFFFF (NativeUInt(Address) > {$IFDEF CPUX64} $7FFFFFFFFFFFFFFF {$ELSE} $BFFFFFFF {$ENDIF}); end; function FindModuleByAddress(Address: Pointer): TModuleInfo; var PEB: PPEB; LdrData: PPEB_LDR_DATA; ModuleEntry: PLDR_DATA_TABLE_ENTRY; CurrentEntry, FirstEntry: PLIST_ENTRY; ModuleBaseAddr, ModuleEndAddr: NativeUInt; FlinkPtr: PPointer; ProtCounter: Integer; // protection counter against looping over ring doubly linked list begin FillChar(Result, SizeOf(Result), 0); Result.IsValid := False; if not Assigned(Address) or AddressViolateMemoryRange(Address) then Exit; PEB := GetCurrentPEB; if not Assigned(PEB) or not Assigned(PEB^.Ldr) then Exit; LdrData := PEB^.Ldr; if not LdrData^.Initialized then Exit; FlinkPtr := PPointer(NativeUInt(LdrData) + Flink_OFFSET); // Offset is 12 for 32bit and 24 for 64bit CurrentEntry := FlinkPtr^; if AddressViolateMemoryRange(CurrentEntry) then Exit; FirstEntry := CurrentEntry; // protection against endless looping over ring list ProtCounter := 0; // protection against endless looping over ring list in case FirstEntry is unloaded after the fact while Assigned(CurrentEntry) and (not AddressViolateMemoryRange(CurrentEntry)) and (CurrentEntry <> PList_Entry(NativeUInt(LdrData) + Flink_OFFSET)) do begin ModuleEntry := PLDR_DATA_TABLE_ENTRY(CurrentEntry); try if Assigned(ModuleEntry^.DllBase) then begin ModuleBaseAddr := NativeUInt(ModuleEntry^.DllBase); ModuleEndAddr := ModuleBaseAddr + ModuleEntry^.SizeOfImage; if (NativeUInt(Address) >= ModuleBaseAddr) and (NativeUInt(Address) < ModuleEndAddr) then begin // found module that have the address Result.ModuleBase := ModuleEntry^.DllBase; Result.ModuleSize := ModuleEntry^.SizeOfImage; Result.EntryPoint := ModuleEntry^.EntryPoint; if Assigned(ModuleEntry^.BaseDllName.Buffer) and (ModuleEntry^.BaseDllName.Length > 0) then Result.ModuleName := ModuleEntry^.BaseDllName.Buffer; if Assigned(ModuleEntry^.FullDllName.Buffer) and (ModuleEntry^.FullDllName.Length > 0) then Result.FullPath := ModuleEntry^.FullDllName.Buffer; Result.IsValid := True; Exit; end; end; except // Ignore access violations, do not handle anything here end; if ProtCounter >= LOOPING_PROTECTION_LIMIT then Exit; Inc(ProtCounter); CurrentEntry := CurrentEntry^.Flink; if CurrentEntry = FirstEntry then Break; end; end; end.

This may be better than using Assembly function RtlGetCurrentPeb: Pointer; stdcall; external 'ntdll.dll'; function GetCurrentPEB: PPEB; begin Result := RtlGetCurrentPeb; end;

@Pierre le Riche I searched for an article i read sometimes ago, scrapped few lines based on its idea, which is using PEB to walk the loaded modules, so no callback notification and no caching is needed, you can resolve on spot and when needed, also you can extract the table in-place to use per one stack walk operation. the article https://exploit-notes.hdks.org/exploit/reverse-engineering/debugger/windows-process-internals-with-windbg/ PEB structure https://www.geoffchappell.com/studies/windows/km/ntoskrnl/inc/api/pebteb/peb/index.htm PEB_LDR_DATA https://www.geoffchappell.com/studies/windows/km/ntoskrnl/inc/api/ntpsapi_x/peb_ldr_data.htm?tx=186 LDR_DATA_TABLE_ENTRY https://www.geoffchappell.com/studies/windows/km/ntoskrnl/inc/api/ntldr/ldr_data_table_entry/index.htm?ta=10&amp;tx=96,97,105,106,109,114,173,177,179,186,192,195 the unit unit lcAddressToModule; interface uses Windows; type PLIST_ENTRY = ^LIST_ENTRY; LIST_ENTRY = packed record Flink: PLIST_ENTRY; Blink: PLIST_ENTRY; end; PUNICODE_STRING = ^UNICODE_STRING; UNICODE_STRING = packed record Length: Word; MaximumLength: Word; {$IFDEF CPUX64} Padding: array[0..3] of Byte; // Align Buffer to 8 bytes {$ENDIF} Buffer: PWideChar; end; PLDR_DATA_TABLE_ENTRY = ^LDR_DATA_TABLE_ENTRY; LDR_DATA_TABLE_ENTRY = packed record InLoadOrderLinks: LIST_ENTRY; InMemoryOrderLinks: LIST_ENTRY; InInitializationOrderLinks: LIST_ENTRY; DllBase: Pointer; EntryPoint: Pointer; SizeOfImage: ULONG; {$IFDEF CPUX64} Padding: array[0..3] of Byte; // Align FullDllName to 60 {$ENDIF} FullDllName: UNICODE_STRING; BaseDllName: UNICODE_STRING; end; PPEB_LDR_DATA = ^PEB_LDR_DATA; PEB_LDR_DATA = packed record Length: ULONG; Initialized: Boolean; {$IFDEF CPUX64} Padding: array[0..2] of Byte; // Align SsHandle to 8 bytes {$ENDIF} SsHandle: Pointer; InLoadOrderModuleList: LIST_ENTRY; end; PPEB = ^PEB; PEB = packed record Reserved: array[0..2] of Byte; BeingDebugged: Byte; {$IFDEF CPUX64} Reserved2: array[0..11] of Byte; // Align Ldr to 24 {$ELSE} Reserved2: array[0..3] of Byte; // Align Ldr to 12 {$ENDIF} ImageBaseAddress: Pointer; Ldr: PPEB_LDR_DATA; end; TModuleInfo = record ModuleBase: Pointer; ModuleSize: ULONG; ModuleName: string; FullPath: string; EntryPoint: Pointer; IsValid: Boolean; end; function FindModuleByAddress(Address: Pointer): TModuleInfo; implementation function GetCurrentPEB: PPEB; asm {$IFDEF CPUX64} mov rax, gs:[$60] // PEB at offset 0x60 in TEB on x64 {$ELSE} mov eax, fs:[$30] // PEB at offset 0x30 in TEB on x86 {$ENDIF} end; function AddressViolateUpperRange(Address: Pointer): Boolean; begin Result := NativeUInt(Address) > {$IFDEF CPUX64} $7FFFFFFFFFFF {$ELSE} $7FFFFFFF {$ENDIF}; end; function AddressViolateLowerRange(Address: Pointer): Boolean; begin Result := NativeUInt(Address) < $10000; // always in user mode then it shold be above 64kb end; function FindModuleByAddress(Address: Pointer): TModuleInfo; var PEB: PPEB; LdrData: PPEB_LDR_DATA; ModuleEntry: PLDR_DATA_TABLE_ENTRY; CurrentEntry, FirstEntry: PLIST_ENTRY; ModuleBaseAddr, ModuleEndAddr: NativeUInt; FlinkPtr: PPointer; begin FillChar(Result, SizeOf(Result), 0); Result.IsValid := False; if not Assigned(Address) or AddressViolateLowerRange(Address) or AddressViolateUpperRange(Address) then Exit; PEB := GetCurrentPEB; if not Assigned(PEB) or not Assigned(PEB^.Ldr) then Exit; LdrData := PEB^.Ldr; if not LdrData^.Initialized then Exit; {$IFDEF CPUX64} FlinkPtr := PPointer(NativeUInt(LdrData) + 24); // InLoadOrderModuleList.Flink at offset 24 on x64 {$ELSE} FlinkPtr := PPointer(NativeUInt(LdrData) + 12); // InLoadOrderModuleList.Flink at offset 12 on x86 {$ENDIF} CurrentEntry := FlinkPtr^; if AddressViolateLowerRange(CurrentEntry) or AddressViolateUpperRange(CurrentEntry) then Exit; FirstEntry := CurrentEntry; while Assigned(CurrentEntry) and (CurrentEntry <> PList_Entry(NativeUInt(LdrData) + {$IFDEF CPUX64} 24 {$ELSE} 12 {$ENDIF})) do begin if AddressViolateLowerRange(CurrentEntry) or AddressViolateUpperRange(CurrentEntry) then Break; ModuleEntry := PLDR_DATA_TABLE_ENTRY(CurrentEntry); try if Assigned(ModuleEntry^.DllBase) then begin ModuleBaseAddr := NativeUInt(ModuleEntry^.DllBase); ModuleEndAddr := ModuleBaseAddr + ModuleEntry^.SizeOfImage; if (NativeUInt(Address) >= ModuleBaseAddr) and (NativeUInt(Address) < ModuleEndAddr) then begin Result.ModuleBase := ModuleEntry^.DllBase; Result.ModuleSize := ModuleEntry^.SizeOfImage; Result.EntryPoint := ModuleEntry^.EntryPoint; if Assigned(ModuleEntry^.BaseDllName.Buffer) then Result.ModuleName := ModuleEntry^.BaseDllName.Buffer else Result.ModuleName := ''; if Assigned(ModuleEntry^.FullDllName.Buffer) then Result.FullPath := ModuleEntry^.FullDllName.Buffer else Result.FullPath := ''; Result.IsValid := True; Exit; end; end; except // Ignore access violations end; CurrentEntry := CurrentEntry^.Flink; if (not Assigned(CurrentEntry)) or (CurrentEntry = FirstEntry) then Break; end; end; end. Test project for it program AddressToModuleTest; {$APPTYPE CONSOLE} {$R *.res} uses System.SysUtils, Windows, lcAddressToModule in 'lcAddressToModule.pas'; function PointerToHex(P: Pointer): string; begin Result := IntToHex(NativeUInt(P), 8); end; procedure FindModuleFromAddress(Address: Pointer); var ModuleInfo: TModuleInfo; begin Writeln('Resolving address : ' + PointerToHex(Address)); ModuleInfo := FindModuleByAddress(Address); if ModuleInfo.IsValid then begin Writeln(#9'Found module : ' + ModuleInfo.ModuleName); Writeln(#9'Full Path : ', ModuleInfo.FullPath); Writeln(#9'Base Address : ', PointerToHex(ModuleInfo.ModuleBase)); Writeln(#9'Module Size : ', ModuleInfo.ModuleSize); Writeln(#9'Entry Point : ', PointerToHex(ModuleInfo.EntryPoint)); end else begin Writeln('Failed to get module....'); end; Writeln; end; procedure ResolveAddressesIntoModules; var DLLHandle: HMODULE; Address: Pointer; begin Address := nil; FindModuleFromAddress(nil); FindModuleFromAddress(Addr(PointerToHex)); // address to local function FindModuleFromAddress(Addr(ResolveAddressesIntoModules)); // address to local function // test PsApi.dll DLLHandle := LoadLibrary('PsApi.dll'); if DLLHandle <> INVALID_HANDLE_VALUE then begin Address := GetProcAddress(DLLHandle, 'EnumProcessModules'); if Assigned(Address) then FindModuleFromAddress(Address); FreeLibrary(DLLHandle); end; // test Ws2_32.dll DLLHandle := LoadLibrary('Ws2_32.dll'); if DLLHandle <> INVALID_HANDLE_VALUE then begin Address := GetProcAddress(DLLHandle, 'WSAStartup'); if Assigned(Address) then FindModuleFromAddress(Address); FreeLibrary(DLLHandle); end; if Assigned(Address) then FindModuleFromAddress(Address); // should be "not module found" // invalid address FindModuleFromAddress(Pointer($DEADBEEF)); end; begin try ResolveAddressesIntoModules; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; Writeln('Done.'); Readln; end. the output for 64bit (also works for 32bit) Resolving address : 00000000 Failed to get module.... Resolving address : 00426640 Found module : AddressToModuleTest.exe Full Path : D:\Projects Delphi\PEBDemo\Win64\Debug\AddressToModuleTest.exe Base Address : 00400000 Module Size : 1531904 Entry Point : 00429FB0 Resolving address : 00426A30 Found module : AddressToModuleTest.exe Full Path : D:\Projects Delphi\PEBDemo\Win64\Debug\AddressToModuleTest.exe Base Address : 00400000 Module Size : 1531904 Entry Point : 00429FB0 Resolving address : 7FFFB7411010 Found module : PsApi.dll Full Path : C:\WINDOWS\System32\PsApi.dll Base Address : 7FFFB7410000 Module Size : 32768 Entry Point : 7FFFB7411110 Resolving address : 7FFFB762EB10 Found module : Ws2_32.dll Full Path : C:\WINDOWS\System32\Ws2_32.dll Base Address : 7FFFB7620000 Module Size : 438272 Entry Point : 7FFFB7634300 Resolving address : 7FFFB762EB10 Failed to get module.... Resolving address : DEADBEEF Failed to get module.... Done. Here i want to point that the above is tested on few OSs, i used and manipulated PEB so many times and i know for fact that Geoff Chappell documentation is very accurate have no errors and no mistake, and based on his documentation the above code should work from Windows 2000 till Windows 11. Hope you find that helpful or useful and thank you for your great contribution over so many years ! ps: the structures was big and it hit me for this specific use we don't the complexity of that structures so i cut them short, and i think they can be trimmed even more or removed in whole, leaving few offsets in their places.

It was a joke of cutting text out of context, and how this anything other than joke, (may be not funny though).

I don't know, but this sound like human trafficking.

I highly recommend using OID instead of NID, they are documented, there is so many internet resources and DB populate them, and most important you can find the needed entry by its OID from any certificate or CSR. In this page there is few lines on how to convert OID in its text formatted syntax into OBJ https://docs.openssl.org/1.0.2/man3/OBJ_nid2obj/#examples then use OBJ instead of NID, as there is the same equivalent APIs for each of them Also important note here, "Set" might not be acting as "Add" and i can't find details about this, but if there is Add then it should be used, and not depending on Set From translated code from C++, this code might work, i say might as i didn't test it, just translated it // Create ASN1_OBJECT for givenName OID 2.5.4.42 objGivenName := OBJ_txt2obj(PAnsiChar(AnsiString('2.5.4.42')), 1); if objGivenName = nil then raise Exception.Create('Failed to create ASN1_OBJECT for givenName(2.5.4.42)'); X509_NAME_add_entry_by_OBJ(name, objGivenName, MBSTRING_ASC, PBYTE(AnsiString('John')), -1, -1, 0); ASN1_OBJECT_free(objGivenName); Now as suggestions for Angus, it might be useful to add generic functions to this, this will be future proof, allowing any non essential entries or exotic objects to be added or enumerated, in other words allow customization in its purest way. It could use NID, Text and OID, implement once and can be used whenever request like this pop then the solution is easy, find the OID (or text) for the entry then add it or read it using the custom entry access givenName = 2.5.4.42 surname = 2.5.4.4 https://oid-base.com/cgi-bin/display?oid=2.5.4.4&amp;submit=Display&amp;action=display https://oid-base.com/cgi-bin/display?oid=2.5.4.42&amp;submit=Display&amp;action=display Using NID is also nice but only if it is already Known and declared in OpenSSL Pascal headers, so it will be limited.

I remember i already shared here in the forum a way to hook compiler messages, not OTA nor NTA, but good old fashion hooking. interacting might be hard to very hard to pin, but getting compiler message(s) is doable, well, tested on few old IDEs, up to XE8, if that will help then i can search for that fun project and try to adjust it for you.

Here another and simpler example, try this interface with the above function TInterfacedObjectFooBar = class(TInterfacedObject, IBar, IFoo) procedure DoSomething; end; TInterfacedObjectFooBarEx = class(TInterfacedObjectFooBar, IBar, IFoo) procedure DoSomething; end; And its result Implemented interfaces in TInterfacedObjectFooBar 0. GUID = {11111111-0000-0000-0000-000000000001} VMT addr: 004D3160 offest: 12 1. GUID = {22222222-0000-0000-0000-000000000002} VMT addr: 004D3170 offest: 16 Implemented interfaces in TInterfacedObject 0. GUID = {00000000-0000-0000-C000-000000000046} VMT addr: 00402358 offest: 8 Implemented interfaces in TInterfacedObjectFooBarEx 0. GUID = {11111111-0000-0000-0000-000000000001} VMT addr: 004D32F8 offest: 20 1. GUID = {22222222-0000-0000-0000-000000000002} VMT addr: 004D3308 offest: 24 Implemented interfaces in TInterfacedObjectFooBar 0. GUID = {11111111-0000-0000-0000-000000000001} VMT addr: 004D3160 offest: 12 1. GUID = {22222222-0000-0000-0000-000000000002} VMT addr: 004D3170 offest: 16 Implemented interfaces in TInterfacedObject 0. GUID = {00000000-0000-0000-C000-000000000046} VMT addr: 00402358 offest: 8 So make sure you are looking at the right VMT, remember that TObject VMT order is irrelevant with its interfaces VMTs structure and order.

It is right. OK, hold your horses here for second, and i want you to check if you are checking the VMT for the interfaces or something else like TObject, also are they named (with TGUID attached) ? I recommend that you go to this blog post and and read this very article and study the output carefully, try to get how interface inheritance and their VMT works. Here a modified example from the blog program Project6; {$APPTYPE CONSOLE} uses Classes, SysUtils, TypInfo, ComObj; type IFoo = interface ['{11111111-0000-0000-0000-000000000001}'] procedure DoSomething; end; IBar = interface ['{22222222-0000-0000-0000-000000000002}'] procedure DoSomething; end; TFooBar = class(TObject, IUnknown, IFoo, IBar) function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; procedure DoSomething; end; TBarFoo = class(TObject, IBar, IFoo, IUnknown) function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; procedure DoSomething; end; TFooBarOnly = class(TObject, IFoo, IBar) function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; procedure DoSomething; end; TBarFooOnly = class(TObject, IBar, IFoo) function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; procedure DoSomething; end; procedure DumpInterfaces(AClass: TClass); var i: integer; InterfaceTable: PInterfaceTable; InterfaceEntry: PInterfaceEntry; begin while Assigned(AClass) do begin InterfaceTable := AClass.GetInterfaceTable; if Assigned(InterfaceTable) then begin writeln('Implemented interfaces in ', AClass.ClassName); for i := 0 to InterfaceTable.EntryCount - 1 do begin InterfaceEntry := @InterfaceTable.Entries[i]; Write(Format('%d. GUID = %s', [i, GUIDToString(InterfaceEntry.IID)])); Writeln(' VMT addr: ', IntToHex(Cardinal(InterfaceEntry.VTable), SizeOf(Pointer) * 2), ' offest: ', InterfaceEntry.IOffset); end; end; AClass := AClass.ClassParent; end; writeln; end; { TFooBar } procedure TFooBar.DoSomething; begin end; function TFooBar.QueryInterface(const IID: TGUID; out Obj): HResult; begin end; function TFooBar._AddRef: Integer; begin end; function TFooBar._Release: Integer; begin end; { TBarFoo } procedure TBarFoo.DoSomething; begin end; function TBarFoo.QueryInterface(const IID: TGUID; out Obj): HResult; begin end; function TBarFoo._AddRef: Integer; begin end; function TBarFoo._Release: Integer; begin end; { TBarFooOnly } procedure TBarFooOnly.DoSomething; begin end; function TBarFooOnly.QueryInterface(const IID: TGUID; out Obj): HResult; begin end; function TBarFooOnly._AddRef: Integer; begin end; function TBarFooOnly._Release: Integer; begin end; { TFooBarOnly } procedure TFooBarOnly.DoSomething; begin end; function TFooBarOnly.QueryInterface(const IID: TGUID; out Obj): HResult; begin end; function TFooBarOnly._AddRef: Integer; begin end; function TFooBarOnly._Release: Integer; begin end; begin DumpInterfaces(TComponent); DumpInterfaces(TComObject); DumpInterfaces(TComObjectFactory); DumpInterfaces(TFooBar); DumpInterfaces(TBarFoo); DumpInterfaces(TFooBarOnly); DumpInterfaces(TBarFooOnly); readln; end. The output from my XE8 Implemented interfaces in TComponent 0. GUID = {E28B1858-EC86-4559-8FCD-6B4F824151ED} VMT addr: 0048C71C offest: 56 1. GUID = {00000000-0000-0000-C000-000000000046} VMT addr: 0048C72C offest: 60 Implemented interfaces in TComObject 0. GUID = {DF0B3D60-548F-101B-8E65-08002B2BD119} VMT addr: 004CF25C offest: 24 1. GUID = {00000000-0000-0000-C000-000000000046} VMT addr: 004CF26C offest: 28 Implemented interfaces in TComObjectFactory 0. GUID = {B196B28F-BAB4-101A-B69C-00AA00341D07} VMT addr: 004CF93C offest: 72 1. GUID = {00000001-0000-0000-C000-000000000046} VMT addr: 004CF93C offest: 72 2. GUID = {00000000-0000-0000-C000-000000000046} VMT addr: 004CF93C offest: 72 Implemented interfaces in TFooBar 0. GUID = {22222222-0000-0000-0000-000000000002} VMT addr: 004D2880 offest: 4 1. GUID = {11111111-0000-0000-0000-000000000001} VMT addr: 004D2890 offest: 8 2. GUID = {00000000-0000-0000-C000-000000000046} VMT addr: 004D2880 offest: 4 Implemented interfaces in TBarFoo 0. GUID = {00000000-0000-0000-C000-000000000046} VMT addr: 004D2AC4 offest: 4 1. GUID = {11111111-0000-0000-0000-000000000001} VMT addr: 004D2AC4 offest: 4 2. GUID = {22222222-0000-0000-0000-000000000002} VMT addr: 004D2AD4 offest: 8 Implemented interfaces in TFooBarOnly 0. GUID = {22222222-0000-0000-0000-000000000002} VMT addr: 004D2D08 offest: 4 1. GUID = {11111111-0000-0000-0000-000000000001} VMT addr: 004D2D18 offest: 8 Implemented interfaces in TBarFooOnly 0. GUID = {11111111-0000-0000-0000-000000000001} VMT addr: 004D2F34 offest: 4 1. GUID = {22222222-0000-0000-0000-000000000002} VMT addr: 004D2F44 offest: 8 Now to simplify your miss understanding, if what you said about off by 3 then the position of the interface (order) in the declaration will matter, and that can't be, right ?

Hi, VMT is not a problem here, VMT for such interfaces are different beast from VMT for objects/classes, VMT tables with COM interfaces (interfaces with GUID which i like to call "named interfaces" or "IDed interfaces") are separated into their own tables identified by their GUID, even for one object/interface, so VMT will be alright no matter what inheritance is there, also VMT for each interface are agnostic for other GUID declaration. As for the interfaces you listed IInterface and IUnknown, this might be a problem as they declared with the same GUID (TGUID) hence they will compete to replace one another, they are identical in structure but different in parameters (declaration), so they will work unless the compiler will complain about stuff like Integer vs Cardinal or TGUID vs PGUID..., the problem here is how compiler see them and when. I might be wrong here, but the fix should be removing Windows.Foundation.IUnknown , in other words, the already known interfaces should not be redeclared/generated.

Also i can't help here, but have question; Are these repositories referring to the same QuickJS ? https://github.com/mengmo/QuickJS-Windows-Build https://github.com/Coldzer0/QuickJS-Pascal

No sure i do understand that, but lets say on single core the test will yield similar result to the article, meaning Sleep(0) is magnitude slower than Sleep(1) and SwitchToThread, then that OS should not be working at all ! and if worked then it will be slower than computer in 70s and 80s, i mean less than 10Mhz CPU.

Spent two hours trying to reproduce anything close to that mentioned article https://joeduffyblog.com/2006/08/22/priorityinduced-starvation-why-sleep1-is-better-than-sleep0-and-the-windows-balance-set-manager/ I read that article years ago, many years, yet i couldn't reproduce anything even small hint if that is the case with Sleep(0) vs Sleep(1) vs SwitchToThread, So i just wrote two tests, one is mimicking the starvation pointed and presented in the article producer/consumer, and the other just how efficient these three method. Also to be clear, i am not saying the article is misleading or wrong, but it is most likely testing different thing completely (namely the efficiency of ThreadPool in C# in 2006), or the test is happening is single core CPU belongs to past and gone era, know this Sleep(1) by definition can't perform less than OS timer granularity which is by default 1000/64 seconds almost 15-16 ms, and in best case scenario it will be 1 ms, this is guaranteed by the OS, so the article result is irrelevant today. First test program ThreadIterationTest; {$APPTYPE CONSOLE} uses System.SysUtils, System.Classes, Winapi.Windows; {$WARN SYMBOL_PLATFORM OFF} type TSwitchMethod = (smSleep0, smSleep1, smSwitchToThread); TCounterThread = class(TThread) private FSwitchMethod: TSwitchMethod; FIterationCount: Int64; FDuration: Integer; procedure Execute; override; public constructor Create(SwitchMethod: TSwitchMethod; Duration: Integer; Priority: TThreadPriority); property IterationCount: Int64 read FIterationCount; property SwitchMethod: TSwitchMethod read FSwitchMethod; end; constructor TCounterThread.Create(SwitchMethod: TSwitchMethod; Duration: Integer; Priority: TThreadPriority); begin inherited Create(True); // Create suspended FSwitchMethod := SwitchMethod; FDuration := Duration; FIterationCount := 0; Self.Priority := Priority; FreeOnTerminate := True; end; procedure TCounterThread.Execute; var StartTick, Duration: Cardinal; begin Duration := FDuration * 1000; StartTick := GetTickCount; while (GetTickCount - StartTick) < Duration do begin Inc(FIterationCount); case FSwitchMethod of {(*} smSleep0: Sleep(0); smSleep1: Sleep(1); smSwitchToThread: SwitchToThread; {*)} end; end; end; function ThPriorityToString(ThProirity: TThreadPriority): string; var P: Integer; begin case ThProirity of {(*} tpIdle: Result:= 'Idle'; tpLowest: Result:= 'Lowest'; tpLower: Result:= 'Lower'; tpNormal: Result:= 'Normal'; tpHigher: Result:= 'Higher'; tpHighest: Result:= 'Highest'; tpTimeCritical: Result:= 'TimeCritical'; {*)} else Result := 'Unknown'; end; Result := Result + '('; case ThProirity of {(*} tpIdle: P:= THREAD_PRIORITY_IDLE; tpLowest: P:= THREAD_PRIORITY_LOWEST; tpLower: P:= THREAD_PRIORITY_BELOW_NORMAL; tpNormal: P:= THREAD_PRIORITY_NORMAL; tpHigher: P:= THREAD_PRIORITY_ABOVE_NORMAL; tpHighest: P:= THREAD_PRIORITY_HIGHEST; tpTimeCritical: P:= THREAD_PRIORITY_TIME_CRITICAL; {*)} else P := 999; end; Result := Result + IntToStr(P) + ')'; end; procedure RunTest(Duration: Integer; Priority1, Priority2, Priority3: TThreadPriority); var Thread1, Thread2, Thread3: TCounterThread; begin Writeln('Starting test with duration: ', Duration, ' seconds'); Writeln('Thread priorities: Sleep(0)=', ThPriorityToString(Priority1), ', Sleep(1)=', ThPriorityToString(Priority2), ', SwitchToThread=', ThPriorityToString(Priority3)); Thread1 := TCounterThread.Create(smSleep0, Duration, Priority1); Thread2 := TCounterThread.Create(smSleep1, Duration, Priority2); Thread3 := TCounterThread.Create(smSwitchToThread, Duration, Priority3); Thread1.Start; Thread2.Start; Thread3.Start; WaitForSingleObject(Thread1.Handle, INFINITE); WaitForSingleObject(Thread2.Handle, INFINITE); WaitForSingleObject(Thread3.Handle, INFINITE); Writeln('Results:'); Writeln('Sleep(0) iterations: ', Thread1.IterationCount); Writeln('Sleep(1) iterations: ', Thread2.IterationCount); Writeln('SwitchToThread iterations: ', Thread3.IterationCount); Writeln; end; begin try Writeln('Test 1: All threads with normal priority'); RunTest(3, tpNormal, tpNormal, tpNormal); Writeln('Test 1.1: All threads with normal priority'); RunTest(1, tpNormal, tpNormal, tpNormal); Writeln('Test 1.5: All threads with normal priority'); RunTest(5, tpNormal, tpNormal, tpNormal); Writeln('Test 2: Different priorities'); RunTest(5, tpHigher, tpNormal, tpLower); Writeln('Test 3: Different priorities'); RunTest(5, tpLowest, tpHighest, tpNormal); Writeln('Test 4: Different priorities'); RunTest(5, tpLowest, tpLowest, tpLowest); Writeln('Done.'); Readln; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; end. Its result on my device Test 1: All threads with normal priority Starting test with duration: 3 seconds Thread priorities: Sleep(0)=Normal(0), Sleep(1)=Normal(0), SwitchToThread=Normal(0) Results: Sleep(0) iterations: 15700875 Sleep(1) iterations: 175 SwitchToThread iterations: 19869985 Test 1.1: All threads with normal priority Starting test with duration: 1 seconds Thread priorities: Sleep(0)=Normal(0), Sleep(1)=Normal(0), SwitchToThread=Normal(0) Results: Sleep(0) iterations: 5266693 Sleep(1) iterations: 60 SwitchToThread iterations: 6658333 Test 1.5: All threads with normal priority Starting test with duration: 5 seconds Thread priorities: Sleep(0)=Normal(0), Sleep(1)=Normal(0), SwitchToThread=Normal(0) Results: Sleep(0) iterations: 26351894 Sleep(1) iterations: 269 SwitchToThread iterations: 33344803 Test 2: Different priorities Starting test with duration: 5 seconds Thread priorities: Sleep(0)=Higher(1), Sleep(1)=Normal(0), SwitchToThread=Lower(-1) Results: Sleep(0) iterations: 26332342 Sleep(1) iterations: 299 SwitchToThread iterations: 33324362 Test 3: Different priorities Starting test with duration: 5 seconds Thread priorities: Sleep(0)=Lowest(-2), Sleep(1)=Highest(2), SwitchToThread=Normal(0) Results: Sleep(0) iterations: 26220753 Sleep(1) iterations: 299 SwitchToThread iterations: 33216074 Test 4: Different priorities Starting test with duration: 5 seconds Thread priorities: Sleep(0)=Lowest(-2), Sleep(1)=Lowest(-2), SwitchToThread=Lowest(-2) Results: Sleep(0) iterations: 26350390 Sleep(1) iterations: 291 SwitchToThread iterations: 33374685 Done. Sleep(1) is in the expected range of 60-64 per second Now different test to emulate the article example, not using Delphi RTL thread pool and anonymous thread, because i never trust them on my XE8. program ThreadStarvationTest; {$APPTYPE CONSOLE} uses System.SysUtils, System.Classes, Winapi.Windows; {$WARN SYMBOL_PLATFORM OFF} type TYieldMethod = (ymSleep0, ymSleep1, ymSwitchToThread); TStarvationThread = class(TThread) private FYieldMethod: TYieldMethod; FIsProducer: Boolean; FDuration: Cardinal; procedure Execute; override; public constructor Create(YieldMethod: TYieldMethod; IsProducer: Boolean; Priority: TThreadPriority); property Duration: Cardinal read FDuration; end; var x: Integer = 0; constructor TStarvationThread.Create(YieldMethod: TYieldMethod; IsProducer: Boolean; Priority: TThreadPriority); begin inherited Create(True); FYieldMethod := YieldMethod; FIsProducer := IsProducer; Self.Priority := Priority; //FreeOnTerminate := True; // don't care, irrelevant FDuration := 0; end; procedure TStarvationThread.Execute; var StartTick: Cardinal; begin // run threads on one core, core 0 SetThreadAffinityMask(GetCurrentThread, 1); if FIsProducer then begin //Sleep(50); // Sleep(500); // Sleep(1500); x := 1; // Producer sets x end else begin StartTick := GetTickCount; while x = 0 do begin case FYieldMethod of ymSleep0: Sleep(0); ymSleep1: Sleep(1); ymSwitchToThread: SwitchToThread; end; end; FDuration := GetTickCount - StartTick; end; end; function ThPriorityToString(ThPriority: TThreadPriority): string; var P: Integer; begin case ThPriority of {(*} tpIdle: Result := 'Idle'; tpLowest: Result := 'Lowest'; tpLower: Result := 'Lower'; tpNormal: Result := 'Normal'; tpHigher: Result := 'Higher'; tpHighest: Result := 'Highest'; tpTimeCritical: Result := 'TimeCritical'; {*)} else Result := 'Unknown'; end; Result := Result + '('; case ThPriority of {(*} tpIdle: P := THREAD_PRIORITY_IDLE; tpLowest: P := THREAD_PRIORITY_LOWEST; tpLower: P := THREAD_PRIORITY_BELOW_NORMAL; tpNormal: P := THREAD_PRIORITY_NORMAL; tpHigher: P := THREAD_PRIORITY_ABOVE_NORMAL; tpHighest: P := THREAD_PRIORITY_HIGHEST; tpTimeCritical: P := THREAD_PRIORITY_TIME_CRITICAL; {*)} else P := 999; end; Result := Result + IntToStr(P) + ')'; end; function YieldMethodToStr(YieldMethod:TYieldMethod):string; begin case YieldMethod of {(*} ymSleep0: Result := 'Sleep(0)'; ymSleep1: Result := 'Sleep(1)'; ymSwitchToThread: Result := 'SwitchToThread'; {*)} end; end; procedure RunStarvationTest(YieldMethod: TYieldMethod; ConsumerPriority, ProducerPriority: TThreadPriority); var Consumer, Producer: TStarvationThread; begin Writeln('Starting starvation test with ', YieldMethodToStr(YieldMethod), ', Consumer=', ThPriorityToString(ConsumerPriority), ', Producer=', ThPriorityToString(ProducerPriority)); x := 0; Consumer := TStarvationThread.Create(YieldMethod, False, ConsumerPriority); Producer := TStarvationThread.Create(YieldMethod, True, ProducerPriority); Consumer.Start; Producer.Start; Consumer.WaitFor; Producer.WaitFor; Writeln('Result: ', YieldMethodToStr(YieldMethod), ' time: ', Consumer.Duration, ' ms'); Writeln; end; begin try // Test Sleep(0) with equal priorities RunStarvationTest(ymSleep0, tpNormal, tpNormal); // Test Sleep(0) with different priorities RunStarvationTest(ymSleep0, tpNormal, tpLower); // Test Sleep(0) with different priorities RunStarvationTest(ymSleep0, tpLower, tpNormal); // Test Sleep(1) with equal priorities RunStarvationTest(ymSleep1, tpNormal, tpNormal); // Test Sleep(1) with different priorities RunStarvationTest(ymSleep1, tpNormal, tpLower); // Test Sleep(1) with different priorities RunStarvationTest(ymSleep1, tpLower, tpNormal); // Test SwitchToThread with equal priorities RunStarvationTest(ymSwitchToThread, tpNormal, tpNormal); // Test SwitchToThread with different priorities RunStarvationTest(ymSwitchToThread, tpNormal, tpLower); // Test SwitchToThread with different priorities RunStarvationTest(ymSwitchToThread, tpLower, tpNormal); Writeln('Done.'); Readln; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; end. Its result with and without delaying the producer by uncommenting the Sleep(50).. no starvation observed at all and the result is consistent with the delay introduced being Sleep(50), Sleep(500) or Sleep(1500) Starting starvation test with Sleep(0), Consumer=Normal(0), Producer=Normal(0) Result: Sleep(0) time: 0 ms Starting starvation test with Sleep(0), Consumer=Normal(0), Producer=Lower(-1) Result: Sleep(0) time: 0 ms Starting starvation test with Sleep(0), Consumer=Lower(-1), Producer=Normal(0) Result: Sleep(0) time: 0 ms Starting starvation test with Sleep(1), Consumer=Normal(0), Producer=Normal(0) Result: Sleep(1) time: 0 ms Starting starvation test with Sleep(1), Consumer=Normal(0), Producer=Lower(-1) Result: Sleep(1) time: 15 ms Starting starvation test with Sleep(1), Consumer=Lower(-1), Producer=Normal(0) Result: Sleep(1) time: 0 ms Starting starvation test with SwitchToThread, Consumer=Normal(0), Producer=Normal(0) Result: SwitchToThread time: 0 ms Starting starvation test with SwitchToThread, Consumer=Normal(0), Producer=Lower(-1) Result: SwitchToThread time: 0 ms Starting starvation test with SwitchToThread, Consumer=Lower(-1), Producer=Normal(0) Result: SwitchToThread time: 0 ms Done. True, there is no silver bullet, but Sleep(1) is better for completely different reason and it is impossible to be less than 1ms delay, unless with my vivid imagination your PC has no other threads running, like the OS has nothing else to do, so it will be faced with either 1) put the CPU/core to sleep, i mean really sleep signal and reduce the power for the core. 2) ignore the delay continue, even in this case, the article result can't be reproduce because we have two threads not one, hence the producer will execute releasing the consumer. ps: these tests are for specific measurement, and i know they are not very helpful in real life, but they are accurate in the delays and shows how SwitchToThread is faster then Sleep(0), due the reduced context switch with threads from different processes, as for mixing the priorities, well this is way different subject and longer, but even so as tests shows it is irrelevant with Windows 10 and modern CPU, my CPU is Sandy Bridge so around 15 years old. I would love to see result form modern and different CPUs, just for general information, also from different Windows versions, that would be nice, the discussion of how much relevant the test in real life doesn't concern me, as i am trying to replicate that article strange result.