| @@ -16,13 +16,16 @@ type | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | ||||
| TutlMessageThread = class(TThread, IUnknown) | TutlMessageThread = class(TThread, IUnknown) | ||||
| public type | public type | ||||
| TMessageProgressCallback = procedure(const aMsg: TutlMessage) of Object; | |||||
| TMessageQueue = class(specialize TutlSyncQueue<TutlMessage>) | TMessageQueue = class(specialize TutlSyncQueue<TutlMessage>) | ||||
| private | private | ||||
| fEvent: TSimpleEvent; | fEvent: TSimpleEvent; | ||||
| public | public | ||||
| procedure Push(const aItem: T); override; | procedure Push(const aItem: T); override; | ||||
| function Pop(out aItem: T): Boolean; override; | function Pop(out aItem: T): Boolean; override; | ||||
| function WaitForMessages(const aWaitTime: Cardinal = INFINITE): Boolean; | function WaitForMessages(const aWaitTime: Cardinal = INFINITE): Boolean; | ||||
| function ProcessMessages(const aProgressCallback: TMessageProgressCallback): Boolean; | |||||
| constructor Create(const aOwnsObjects: Boolean = true); | constructor Create(const aOwnsObjects: Boolean = true); | ||||
| destructor Destroy; override; | destructor Destroy; override; | ||||
| @@ -179,6 +182,44 @@ begin | |||||
| raise EWait.Create('Error while waiting for messages', wr); | raise EWait.Create('Error while waiting for messages', wr); | ||||
| end; | end; | ||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.TMessageQueue.ProcessMessages(const aProgressCallback: TMessageProgressCallback): Boolean; | |||||
| var | |||||
| m: TutlMessage; | |||||
| empty: Boolean; | |||||
| begin | |||||
| empty := false; | |||||
| result := false; | |||||
| if not Assigned(aProgressCallback) then | |||||
| exit; | |||||
| repeat | |||||
| try | |||||
| if Pop(m) then begin | |||||
| result := true; | |||||
| try | |||||
| aProgressCallback(m); | |||||
| finally | |||||
| if (m is TutlSynchronousMessage) then | |||||
| (m as TutlSynchronousMessage).Finish | |||||
| else | |||||
| FreeAndNil(m); | |||||
| end; | |||||
| end else | |||||
| empty := true; | |||||
| except | |||||
| on e: Exception do begin | |||||
| utlLogger.Error(self, 'error while progressing message %s(ID: %d; wParam: %s; lParam: %s): %s - %s', [ | |||||
| m.ClassName, | |||||
| m.ID, | |||||
| IntToHex(m.wParam, SizeOf(m.wParam) div 4), | |||||
| IntToHex(m.wParam, SizeOf(m.wParam) div 4), | |||||
| e.ClassName, | |||||
| e.Message]); | |||||
| end; | |||||
| end; | |||||
| until empty; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | ||||
| constructor TutlMessageThread.TMessageQueue.Create(const aOwnsObjects: Boolean); | constructor TutlMessageThread.TMessageQueue.Create(const aOwnsObjects: Boolean); | ||||
| begin | begin | ||||
| @@ -263,38 +304,8 @@ end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | ||||
| function TutlMessageThread.ProcessMessages: Boolean; | function TutlMessageThread.ProcessMessages: Boolean; | ||||
| var | |||||
| m: TutlMessage; | |||||
| empty: Boolean; | |||||
| begin | begin | ||||
| empty := false; | |||||
| result := false; | |||||
| repeat | |||||
| try | |||||
| if fMessages.Pop(m) then begin | |||||
| result := true; | |||||
| try | |||||
| ProcessMessage(m); | |||||
| finally | |||||
| if (m is TutlSynchronousMessage) then | |||||
| (m as TutlSynchronousMessage).Finish | |||||
| else | |||||
| FreeAndNil(m); | |||||
| end; | |||||
| end else | |||||
| empty := true; | |||||
| except | |||||
| on e: Exception do begin | |||||
| utlLogger.Error(self, 'error while progressing message %s(ID: %d; wParam: %s; lParam: %s): %s - %s', [ | |||||
| m.ClassName, | |||||
| m.ID, | |||||
| IntToHex(m.wParam, SizeOf(m.wParam) div 4), | |||||
| IntToHex(m.wParam, SizeOf(m.wParam) div 4), | |||||
| e.ClassName, | |||||
| e.Message]); | |||||
| end; | |||||
| end; | |||||
| until empty; | |||||
| result := fMessages.ProcessMessages(@ProcessMessage); | |||||
| end; | end; | ||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | ||||