DELPHI 线程类(转,自己参考,版权归原作者)
Delphi中有一个线程类TThread是用来实现多线程编程的,这个绝大多数Delphi书藉都有说到,但基本上都是对TThread类的几个成员作一简单介绍,再说明一下Execute的实现和Synchronize的用法就完了。然而这并不是多线程编程的全部,我写此文的目的在于对此作一个补充。 HANDLE CreateThread( LPSECURITY_ATTRIBUTES lpThreadAttributes,DWORD dwStackSize,LPTHREAD_START_ROUTINE lpStartAddress,LPVOID lpParameter,DWORD dwCreationFlags,LPDWORD lpThreadId ); ? ? ? 其各参数如它们的名称所说,分别是:线程属性(用于在NT下进行线程的安全属性设置,在9X下无效),堆栈大小,起始地址,参数,创建标志(用于设置线程创建时的状态),线程ID,最后返回线程Handle。其中的起始地址就是线程函数的入口,直至线程函数结束,线程也就结束了。 TThread = class private FHandle: THandle; FThreadID: THandle; FCreateSuspended: Boolean; FTerminated: Boolean; FSuspended: Boolean; FFreeOnTerminate: Boolean; FFinished: Boolean; FReturnValue: Integer; FOnTerminate: TNotifyEvent; FSynchronize: TSynchronizeRecord; FFatalException: TObject; procedure CallOnTerminate; class procedure Synchronize(ASyncRec: PSynchronizeRecord); overload; function GetPriority: TThreadPriority; procedure SetPriority(Value: TThreadPriority); procedure SetSuspended(Value: Boolean); protected procedure CheckThreadError(ErrCode: Integer); overload; procedure CheckThreadError(Success: Boolean); overload; procedure DoTerminate; virtual; procedure Execute; virtual; abstract; procedure Synchronize(Method: TThreadMethod); overload; property ReturnValue: Integer read FReturnValue write FReturnValue; property Terminated: Boolean read FTerminated; public constructor Create(CreateSuspended: Boolean); destructor Destroy; override; procedure AfterConstruction; override; procedure Resume; procedure Suspend; procedure Terminate; function WaitFor: LongWord; class procedure Synchronize(AThread: TThread; AMethod: TThreadMethod); overload; class procedure StaticSynchronize(AThread: TThread; AMethod: TThreadMethod); property FatalException: TObject read FFatalException; property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate; property Handle: THandle read FHandle; property Priority: TThreadPriority read GetPriority write SetPriority; property Suspended: Boolean read FSuspended write SetSuspended; property ThreadID: THandle read FThreadID; property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate; end; ? TThread类在Delphi的RTL里算是比较简单的类,类成员也不多,类属性都很简单明白,本文将只对几个比较重要的类成员方法和唯一的事件:OnTerminate作详细分析。 ? ? 首先就是构造函数: constructor TThread.Create(CreateSuspended: Boolean); begin inherited Create; AddThread; FSuspended := CreateSuspended; FCreateSuspended := CreateSuspended; FHandle := BeginThread(nil,@ThreadProc,Pointer(Self),CREATE_SUSPENDED,FThreadID); if FHandle = 0 then raise EThread.CreateResFmt(@SThreadCreateError,[SysErrorMessage(GetLastError)]); end; ? ? 虽然这个构造函数没有多少代码,但却可以算是最重要的一个成员,因为线程就是在这里被创建的。 procedure AddThread; begin InterlockedIncrement(ThreadCount); end; //同样有一个对应的RemoveThread: procedure RemoveThread; begin InterlockedDecrement(ThreadCount); end; ? ? 它们的功能很简单,就是通过增减一个全局变量来统计进程中的线程数。只是这里用于增减变量的并不是常用的Inc/Dec过程,而是用了InterlockedIncrement/InterlockedDecrement这一对过程,它们实现的功能完全一样,都是对变量加一或减一。但它们有一个最大的区别,那就是InterlockedIncrement/InterlockedDecrement是线程安全的。即它们在多线程下能保证执行结果正确,而Inc/Dec不能。或者按操作系统理论中的术语来说,这是一对“原语”操作。 function ThreadProc(Thread: TThread): Integer; var FreeThread: Boolean; begin try if not Thread.Terminated then try Thread.Execute; except Thread.FFatalException := AcquireExceptionObject; end; finally FreeThread := Thread.FFreeOnTerminate; Result := Thread.FReturnValue; Thread.DoTerminate; Thread.FFinished := True; SignalSyncEvent; if FreeThread then Thread.Free; EndThread(Result); end; end; ? ? ? 虽然也没有多少代码,但却是整个TThread中最重要的部分,因为这段代码是真正在线程中执行的代码。下面对代码作逐行说明: destructor TThread.Destroy; begin if (FThreadID <> 0) and not FFinished then begin Terminate; if FCreateSuspended then Resume; WaitFor; end; if FHandle <> 0 then CloseHandle(FHandle); inherited Destroy; FFatalException.Free; RemoveThread; end; ? ? ? 在线程对象被释放前,首先要检查线程是否还在执行中,如果线程还在执行中(线程ID不为0,并且线程结束标志未设置),则调用Terminate过程结束线程。Terminate过程只是简单地设置线程类的Terminated标志,如下面的代码: procedure TThread.Synchronize(Method: TThreadMethod); begin FSynchronize.FThread := Self; FSynchronize.FSynchronizeException := nil; FSynchronize.FMethod := Method; Synchronize(@FSynchronize); end; // 其中FSynchronize是一个记录类型: PSynchronizeRecord = ^TSynchronizeRecord; TSynchronizeRecord = record FThread: TObject; FMethod: TThreadMethod; FSynchronizeException: TObject; end; ? ? 用于进行线程和主线程之间进行数据交换,包括传入线程类对象,同步方法及发生的异常。 class procedure TThread.Synchronize(ASyncRec: PSynchronizeRecord); var SyncProc: TSyncProc; begin if GetCurrentThreadID = MainThreadID then ASyncRec.FMethod else begin SyncProc.Signal := CreateEvent(nil,True,False,nil); try EnterCriticalSection(ThreadLock); try if SyncList = nil then SyncList := TList.Create; SyncProc.SyncRec := ASyncRec; SyncList.Add(@SyncProc); SignalSyncEvent; if Assigned(WakeMainThread) then WakeMainThread(SyncProc.SyncRec.FThread); LeaveCriticalSection(ThreadLock); try WaitForSingleObject(SyncProc.Signal,INFINITE); finally EnterCriticalSection(ThreadLock); end; finally LeaveCriticalSection(ThreadLock); end; finally CloseHandle(SyncProc.Signal); end; if Assigned(ASyncRec.FSynchronizeException) then raise ASyncRec.FSynchronizeException; end; end; ? ? 这段代码略多一些,不过也不算太复杂。 procedure TApplication.HookSynchronizeWakeup; begin Classes.WakeMainThread := WakeMainThread; end; procedure TApplication.UnhookSynchronizeWakeup; begin Classes.WakeMainThread := nil; end; ? ? 上面两个方法分别是在TApplication类的构造函数和析构函数中被调用。 procedure TApplication.WndProc(var Message: TMessage); … begin try … with Message do case Msg of … WM_NULL: CheckSynchronize; … except HandleException(Self); end; end; ? ? 其中的CheckSynchronize也是定义在Classes单元中的,由于它比较复杂,暂时不详细说明,只要知道它是具体处理Synchronize功能的部分就好,现在继续分析Synchronize的代码。 ? ? 在执行完WakeMainThread事件后,就退出临界区,然后调用WaitForSingleObject开始等待在进入临界区前创建的那个Event。这个Event的功能是等待这个同步方法的执行结束,关于这点,在后面分析CheckSynchronize时会再说明。 if Assigned(WakeMainThread) then WakeMainThread(SyncProc.SyncRec.FThread); WaitForSingleObject(SyncProc.Signal,INFINITE); finally LeaveCriticalSection(ThreadLock); end; ? ? 上面的代码和原来的代码最大的区别在于把WaitForSingleObject也纳入临界区的限制中了。看上去没什么影响,还使代码大大简化了,但真的可以吗? function CheckSynchronize(Timeout: Integer = 0): Boolean; var SyncProc: PSyncProc; LocalSyncList: TList; begin if GetCurrentThreadID <> MainThreadID then raise EThread.CreateResFmt(@SCheckSynchronizeError,[GetCurrentThreadID]); if Timeout > 0 then WaitForSyncEvent(Timeout) else ResetSyncEvent; LocalSyncList := nil; EnterCriticalSection(ThreadLock); try Integer(LocalSyncList) := InterlockedExchange(Integer(SyncList),Integer(LocalSyncList)); try Result := (LocalSyncList <> nil) and (LocalSyncList.Count > 0); if Result then begin while LocalSyncList.Count > 0 do begin SyncProc := LocalSyncList[0]; LocalSyncList.Delete(0); LeaveCriticalSection(ThreadLock); try try SyncProc.SyncRec.FMethod; except SyncProc.SyncRec.FSynchronizeException := AcquireExceptionObject; end; finally EnterCriticalSection(ThreadLock); end; SetEvent(SyncProc.signal); end; end; finally LocalSyncList.Free; end; finally LeaveCriticalSection(ThreadLock); end; end; ? ? 首先,这个方法必须在主线程中被调用(如前面通过消息传递到主线程),否则就抛出异常。 function TThread.WaitFor: LongWord; var H: array[0..1] of THandle; WaitResult: Cardinal; Msg: TMsg; begin H[0] := FHandle; if GetCurrentThreadID = MainThreadID then begin WaitResult := 0; H[1] := SyncEvent; repeat { This prevents a potential deadlock if the background thread does a SendMessage to the foreground thread } if WaitResult = WAIT_OBJECT_0 + 2 then PeekMessage(Msg,PM_NOREMOVE); WaitResult := MsgWaitForMultipleObjects(2,H,1000,QS_SENDMESSAGE); CheckThreadError(WaitResult <> WAIT_FAILED); if WaitResult = WAIT_OBJECT_0 + 1 then CheckSynchronize; until WaitResult = WAIT_OBJECT_0; end else WaitForSingleObject(H[0],INFINITE); CheckThreadError(GetExitCodeThread(H[0],Result)); end; ? ? 如果不是在主线程中执行WaitFor的话,很简单,只要调用WaitForSingleObject等待此线程的Handle为Signaled状态即可。 {----------------------------------------------------------------------------- Unit Name: uMsgThread Author: xwing eMail : [email?protected] ; MSN : [email?protected] Purpose: Thread with message Loop History: 2003-6-19,add function to Send Thread Message. ver 1.0 use Event List and waitforsingleObject your can use WindowMessage or ThreadMessage 2003-6-18,Change to create a window to Recving message 2003-6-17,Begin. -----------------------------------------------------------------------------} unit uMsgThread; interface {$WARN SYMBOL_DEPRECATED OFF} {$DEFINE USE_WINDOW_MESSAGE} uses Classes,windows,messages,forms,sysutils; type TMsgThread = class(TThread) private {$IFDEF USE_WINDOW_MESSAGE} FWinName : string; FMSGWin : HWND; {$ELSE} FEventList : TList; FCtlSect : TRTLCriticalSection; {$ENDIF} FException : Exception; fDoLoop : Boolean; FWaitHandle : THandle; {$IFDEF USE_WINDOW_MESSAGE} procedure MSGWinProc(var Message: TMessage); {$ELSE} procedure ClearSendMsgEvent; {$ENDIF} procedure SetDoLoop(const Value: Boolean); procedure WaitTerminate; protected Msg :tagMSG; procedure Execute; override; procedure HandleException; procedure DoHandleException;virtual; //Inherited the Method to process your own Message procedure DoProcessMsg(var Msg:TMessage);virtual; //if DoLoop = true then loop this procedure //Your can use the method to do some work needed loop. procedure DoMsgLoop;virtual; //Initialize Thread before begin message loop procedure DoInit;virtual; procedure DoUnInit;virtual; procedure PostMsg(Msg:Cardinal;wParam:Integer;lParam:Integer); //When Use SendMsg method Must not use Synchronize Method in ThreadLoop !!! //otherwise will caurse DeadLock procedure SendMsg(Msg:Cardinal;wParam:Integer;lParam:Integer); public constructor Create(Loop:Boolean=False;ThreadName: string=‘‘); destructor destroy;override; procedure AfterConstruction;override; //postMessage to Quit,and Free(if FreeOnTerminater = true) //can call this in thread loop,don‘t use terminate property. procedure QuitThread; //PostMessage to Quit and Wait,only call in MAIN THREAD procedure QuitThreadWait; //just like Application.processmessage. procedure ProcessMessage; //enable thread loop,no waitfor message property DoLoop: Boolean read fDoLoop Write SetDoLoop; end; implementation { TMsgThread } {//////////////////////////////////////////////////////////////////////////////} constructor TMsgThread.Create(Loop:Boolean;ThreadName:string); begin {$IFDEF USE_WINDOW_MESSAGE} if ThreadName <> ‘‘ then FWinName := ThreadName else FWinName := ‘Thread Window‘; {$ELSE} FEventList := TList.Create; InitializeCriticalSection(fCtlSect); {$ENDIF} FWaitHandle := CreateEvent(nil,nil); FDoLoop := Loop; //default disable thread loop inherited Create(False); //Create thread FreeOnTerminate := True; //Thread quit and free object //Call resume Method in Constructor Method Resume; //Wait until thread Message Loop started WaitForSingleObject(FWaitHandle,INFINITE); end; {------------------------------------------------------------------------------} procedure TMsgThread.AfterConstruction; begin end; {------------------------------------------------------------------------------} destructor TMsgThread.destroy; begin {$IFDEF USE_WINDOW_MESSAGE} {$ELSE} FEventList.Free; DeleteCriticalSection(FCtlSect); {$ENDIF} inherited; end; {//////////////////////////////////////////////////////////////////////////////} procedure TMsgThread.Execute; var mRet:Boolean; aRet:Boolean; {$IFNDEF USE_WINDOW_MESSAGE} uMsg:TMessage; {$ENDIF} begin {$IFDEF USE_WINDOW_MESSAGE} FMSGWin := CreateWindow(‘STATIC‘,PChar(FWinName),WS_POPUP,hInstance,nil); SetWindowLong(FMSGWin,GWL_WNDPROC,Longint(MakeObjectInstance(MSGWinProc))); {$ELSE} PeekMessage(Msg,WM_USER,PM_NOREMOVE); //Force system alloc a msgQueue {$ENDIF} //notify Conctructor can returen. SetEvent(FWaitHandle); CloseHandle(FWaitHandle); mRet := True; try DoInit; while mRet do //Message Loop begin if fDoLoop then begin aRet := PeekMessage(Msg,PM_REMOVE); if aRet and (Msg.message <> WM_QUIT) then begin {$IFDEF USE_WINDOW_MESSAGE} TranslateMessage(Msg); DispatchMessage(Msg); {$ELSE} uMsg.Msg := Msg.message; uMsg.wParam := Msg.wParam; uMsg.lParam := Msg.lParam; DoProcessMsg(uMsg); {$ENDIF} if Msg.message = WM_QUIT then mRet := False; end; {$IFNDEF USE_WINDOW_MESSAGE} ClearSendMsgEvent; //Clear SendMessage Event {$ENDIF} DoMsgLoop; end else begin mRet := GetMessage(Msg,0); if mRet then begin {$IFDEF USE_WINDOW_MESSAGE} TranslateMessage(Msg); DispatchMessage(Msg); {$ELSE} uMsg.Msg := Msg.message; uMsg.wParam := Msg.wParam; uMsg.lParam := Msg.lParam; DoProcessMsg(uMsg); ClearSendMsgEvent; //Clear SendMessage Event {$ENDIF} end; end; end; DoUnInit; {$IFDEF USE_WINDOW_MESSAGE} DestroyWindow(FMSGWin); FreeObjectInstance(Pointer(GetWindowLong(FMSGWin,GWL_WNDPROC))); {$ENDIF} except HandleException; end; end; {------------------------------------------------------------------------------} {$IFNDEF USE_WINDOW_MESSAGE} procedure TMsgThread.ClearSendMsgEvent; var aEvent:PHandle; begin EnterCriticalSection(FCtlSect); try if FEventList.Count <> 0 then begin aEvent := FEventList.Items[0]; if aEvent <> nil then begin SetEvent(aEvent^); CloseHandle(aEvent^); Dispose(aEvent); end; FEventList.Delete(0); end; finally LeaveCriticalSection(FCtlSect); end; end; {$ENDIF} {------------------------------------------------------------------------------} procedure TMsgThread.HandleException; begin FException := Exception(ExceptObject); //Get Current Exception object try if not (FException is EAbort) then inherited Synchronize(DoHandleException); finally FException := nil; end; end; {------------------------------------------------------------------------------} procedure TMsgThread.DoHandleException; begin if FException is Exception then Application.ShowException(FException) else SysUtils.ShowException(FException,nil); end; {//////////////////////////////////////////////////////////////////////////////} {$IFDEF USE_WINDOW_MESSAGE} procedure TMsgThread.MSGWinProc(var Message: TMessage); begin DoProcessMsg(Message); with Message do Result:=DefWindowProc(FMSGWin,Msg,wParam,lParam); end; {$ENDIF} {------------------------------------------------------------------------------} procedure TMsgThread.DoProcessMsg(var Msg:TMessage); begin end; {------------------------------------------------------------------------------} procedure TMsgThread.ProcessMessage; {$IFNDEF USE_WINDOW_MESSAGE} var uMsg:TMessage; {$ENDIF} begin while PeekMessage(Msg,PM_REMOVE) do if Msg.message <> WM_QUIT then begin {$IFDEF USE_WINDOW_MESSAGE} TranslateMessage(Msg); DispatchMessage(msg); {$ELSE} uMsg.Msg := Msg.message; uMsg.wParam := Msg.wParam; uMsg.lParam := Msg.lParam; DoProcessMsg(uMsg); {$ENDIF} end; end; {//////////////////////////////////////////////////////////////////////////////} procedure TMsgThread.DoInit; begin end; procedure TMsgThread.DoUnInit; begin end; procedure TMsgThread.DoMsgLoop; begin Sleep(1); end; {//////////////////////////////////////////////////////////////////////////////} procedure TMsgThread.QuitThread; begin {$IFDEF USE_WINDOW_MESSAGE} PostMessage(FMSGWin,WM_QUIT,0); {$ELSE} PostThreadMessage(ThreadID,0); {$ENDIF} end; {------------------------------------------------------------------------------} procedure TMsgThread.QuitThreadWait; begin QuitThread; WaitTerminate; end; {------------------------------------------------------------------------------} procedure TMsgThread.SetDoLoop(const Value: Boolean); begin if Value = fDoLoop then Exit; fDoLoop := Value; if fDoLoop then PostMsg(WM_USER,0); end; {------------------------------------------------------------------------------} //Can only call this method in MAIN Thread!! procedure TMsgThread.WaitTerminate; var xStart:Cardinal; begin xStart:=GetTickCount; try //EnableWindow(Application.Handle,False); while WaitForSingleObject(Handle,10) = WAIT_TIMEOUT do begin Application.ProcessMessages; if GetTickCount > (xStart + 4000) then begin TerminateThread(Handle,0); Beep; Break; end; end; finally //EnableWindow(Application.Handle,True); end; end; {------------------------------------------------------------------------------} procedure TMsgThread.PostMsg(Msg: Cardinal; wParam,lParam: Integer); begin {$IFDEF USE_WINDOW_MESSAGE} postMessage(FMSGWin,lParam); {$ELSE} EnterCriticalSection(FCtlSect); try FEventList.Add(nil); PostThreadMessage(ThreadID,lParam); finally LeaveCriticalSection(FCtlSect); end; {$ENDIF} end; {------------------------------------------------------------------------------} procedure TMsgThread.SendMsg(Msg: Cardinal; wParam,lParam: Integer); {$IFNDEF USE_WINDOW_MESSAGE} var aEvent:PHandle; {$ENDIF} begin {$IFDEF USE_WINDOW_MESSAGE} SendMessage(FMSGWin,lParam); {$ELSE} EnterCriticalSection(FCtlSect); try New(aEvent); aEvent^ := CreateEvent(nil,nil); FEventList.Add(aEvent); PostThreadMessage(ThreadID,lParam); finally LeaveCriticalSection(FCtlSect); end; WaitForSingleObject(aEvent^,INFINITE); {$ENDIF} end; end. 2003-6-22 10:56:00 查看评语??? 2003-6-22 11:02:24 我参考了一下msdn,还有windows核心编程. 写了一个类来封装这个功能,不知道对不对. 里面使用了两个方法,一个使用一个隐含窗体来处理消息 还有一个是直接使用thread的消息队列来处理,但是这个时候sendmessage无法工作,所以我自己设想了一个方法,虽然不完全达到了要求但是我简单测试了一下,好像还能工作. 切换两种工作方式要修改编译条件 {$DEFINE USE_WINDOW_MESSAGE} 使用隐含窗体来处理消息 {-$DEFINE USE_WINDOW_MESSAGE} 使用线程消息队列来处理消息 . 2003-6-22 11:02:54 还有我想要等待线程开始进行消息循环的时候create函数才返回.但是现在好像还没有这样(用一个事件来处理).只是开始进入了threadexecute函数,线程的create就返回了.可能会出问题. 2003-6-23 8:55:22 通过设置 DoLoop属性可以设定线程是否循环(不阻塞等待消息),这样派生类线程在循环做一些其他事情的同时还可以接受消息. 例如:派生类里面循环发送缓冲区的数据,还可以响应其他线程发送过来的消息(如停止,启动,退出,等等) 2003-8-4 10:21:18 重新修改了一下,现在用起来基本没有问题了。 {----------------------------------------------------------------------------- Unit Name: uMsgThread Author: xwing eMail : [email?protected] ; MSN : [email?protected] Purpose: Thread with message Loop History: 2003-7-15 Write thread class without use delphi own TThread. 2003-6-19,Begin. -----------------------------------------------------------------------------} unit uMsgThread; interface {$WARN SYMBOL_DEPRECATED OFF} {$DEFINE USE_WINDOW_MESSAGE} uses Classes,sysutils; const NM_EXECPROC = $8FFF; type EMsgThreadErr = class(Exception); TMsgThreadMethod = procedure of object; TMsgThread = class private SyncWindow : HWND; FMethod : TMsgThreadMethod; procedure SyncWindowProc(var Message: TMessage); private m_hThread : THandle; threadid : DWORD; {$IFDEF USE_WINDOW_MESSAGE} FWinName : string; FMSGWin : HWND; {$ELSE} FEventList : TList; FCtlSect : TRTLCriticalSection; {$ENDIF} FException : Exception; fDoLoop : Boolean; FWaitHandle : THandle; {$IFDEF USE_WINDOW_MESSAGE} procedure MSGWinProc(var Message: TMessage); {$ELSE} procedure ClearSendMsgEvent; {$ENDIF} procedure SetDoLoop(const Value: Boolean); procedure Execute; protected Msg :tagMSG; {$IFNDEF USE_WINDOW_MESSAGE} uMsg :TMessage; fSendMsgComp:THandle; {$ENDIF} procedure HandleException; procedure DoHandleException;virtual; //Inherited the Method to process your own Message procedure DoProcessMsg(var Msg:TMessage);virtual; //if DoLoop = true then loop this procedure //Your can use the method to do some work needed loop. procedure DoMsgLoop;virtual; //Initialize Thread before begin message loop procedure DoInit;virtual; procedure DoUnInit;virtual; procedure PostMsg(Msg:Cardinal;wParam:Integer;lParam:Integer); //When Use SendMsg method Must not use Synchronize Method in ThreadLoop !!! //otherwise will caurse DeadLock function SendMsg(Msg:Cardinal;wParam:Integer;lParam:Integer):Integer; public constructor Create(Loop:Boolean=False;ThreadName: string=‘‘); destructor destroy;override; // Return TRUE if the thread exists. FALSE otherwise function ThreadExists: BOOL; procedure Synchronize(syncMethod:TMsgThreadMethod); function WaitFor:Longword; function WaitTimeOut(timeout:DWORD=4000):Longword; //postMessage to Quit,don‘t use terminate property. procedure QuitThread; //just like Application.processmessage. procedure ProcessMessage; //enable thread loop,no waitfor message property DoLoop: Boolean read fDoLoop Write SetDoLoop; end; implementation function msgThdInitialThreadProc(pv:Pointer):DWORD;stdcall; var obj:TMsgThread; begin obj := TMsgThread(pv); obj.execute; Result := 0; end; { TMsgThread } {//////////////////////////////////////////////////////////////////////////////} constructor TMsgThread.Create(Loop:Boolean;ThreadName:string); begin {$IFDEF USE_WINDOW_MESSAGE} if ThreadName <> ‘‘ then FWinName := ThreadName else FWinName := ‘Thread Window‘; {$ELSE} FEventList := TList.Create; InitializeCriticalSection(fCtlSect); fSendMsgComp := CreateEvent(nil,nil); {$ENDIF} FDoLoop := Loop; //default disable thread loop //Create a Window for sync method SyncWindow := CreateWindow(‘STATIC‘,‘SyncWindow‘,nil); SetWindowLong(SyncWindow,Longint(MakeObjectInstance(SyncWindowProc))); FWaitHandle := CreateEvent(nil,nil); //Create Thread m_hThread := CreateThread(nil,@msgThdInitialThreadProc,Self,threadid); if m_hThread = 0 then raise EMsgThreadErr.Create(‘不能创建线程。‘); //Wait until thread Message Loop started WaitForSingleObject(FWaitHandle,INFINITE); end; {------------------------------------------------------------------------------} destructor TMsgThread.destroy; begin if m_hThread <> 0 then QuitThread; waitfor; //Free Sync Window DestroyWindow(SyncWindow); FreeObjectInstance(Pointer(GetWindowLong(SyncWindow,GWL_WNDPROC))); {$IFDEF USE_WINDOW_MESSAGE} {$ELSE} FEventList.Free; DeleteCriticalSection(FCtlSect); CloseHandle(fSendMsgComp); {$ENDIF} inherited; end; {//////////////////////////////////////////////////////////////////////////////} procedure TMsgThread.Execute; var mRet:Boolean; aRet:Boolean; begin {$IFDEF USE_WINDOW_MESSAGE} FMSGWin := CreateWindow(‘STATIC‘,PM_NOREMOVE); //Force system alloc a msgQueue {$ENDIF} mRet := True; try DoInit; //notify Conctructor can returen. SetEvent(FWaitHandle); CloseHandle(FWaitHandle); while mRet do //Message Loop begin if fDoLoop then begin aRet := PeekMessage(Msg,GWL_WNDPROC))); {$ENDIF} except HandleException; end; end; {------------------------------------------------------------------------------} {$IFNDEF USE_WINDOW_MESSAGE} procedure TMsgThread.ClearSendMsgEvent; var aEvent:PHandle; begin EnterCriticalSection(FCtlSect); try if FEventList.Count <> 0 then begin aEvent := FEventList.Items[0]; if aEvent <> nil then begin SetEvent(aEvent^); CloseHandle(aEvent^); Dispose(aEvent); WaitForSingleObject(fSendMsgComp,INFINITE); end; FEventList.Delete(0); end; finally LeaveCriticalSection(FCtlSect); end; end; {$ENDIF} {------------------------------------------------------------------------------} procedure TMsgThread.HandleException; begin FException := Exception(ExceptObject); //Get Current Exception object try if not (FException is EAbort) then Synchronize(DoHandleException); finally FException := nil; end; end; {------------------------------------------------------------------------------} procedure TMsgThread.DoHandleException; begin if FException is Exception then Application.ShowException(FException) else SysUtils.ShowException(FException,nil); end; {//////////////////////////////////////////////////////////////////////////////} {$IFDEF USE_WINDOW_MESSAGE} procedure TMsgThread.MSGWinProc(var Message: TMessage); begin DoProcessMsg(Message); if Message.Msg < wm_user then with Message do Result:=DefWindowProc(FMSGWin,lParam); end; {$ENDIF} {------------------------------------------------------------------------------} procedure TMsgThread.DoProcessMsg(var Msg:TMessage); begin end; {------------------------------------------------------------------------------} procedure TMsgThread.ProcessMessage; {$IFNDEF USE_WINDOW_MESSAGE} var uMsg:TMessage; {$ENDIF} begin while PeekMessage(Msg,PM_REMOVE) do if Msg.message <> WM_QUIT then begin {$IFDEF USE_WINDOW_MESSAGE} TranslateMessage(Msg); DispatchMessage(msg); {$ELSE} uMsg.Msg := Msg.message; uMsg.wParam := Msg.wParam; uMsg.lParam := Msg.lParam; DoProcessMsg(uMsg); {$ENDIF} end; end; {//////////////////////////////////////////////////////////////////////////////} procedure TMsgThread.DoInit; begin end; procedure TMsgThread.DoUnInit; begin end; procedure TMsgThread.DoMsgLoop; begin Sleep(0); end; {//////////////////////////////////////////////////////////////////////////////} function TMsgThread.ThreadExists: BOOL; begin if m_hThread = 0 then Result := false else Result := True; end; {------------------------------------------------------------------------------} procedure TMsgThread.QuitThread; begin {$IFDEF USE_WINDOW_MESSAGE} PostMessage(FMSGWin,0); {$ENDIF} end; {------------------------------------------------------------------------------} procedure TMsgThread.SetDoLoop(const Value: Boolean); begin if Value = fDoLoop then Exit; fDoLoop := Value; if fDoLoop then PostMsg(WM_USER,0); end; {------------------------------------------------------------------------------} function TMsgThread.WaitTimeOut(timeout:dword):Longword; var xStart:Cardinal; H: THandle; begin H := m_hThread; xStart:=GetTickCount; while WaitForSingleObject(h,10) = WAIT_TIMEOUT do begin Application.ProcessMessages; if GetTickCount > (xStart + timeout) then begin TerminateThread(h,0); Break; end; end; GetExitCodeThread(H,Result); end; {------------------------------------------------------------------------------} function TMsgThread.WaitFor: Longword; var Msg: TMsg; H: THandle; begin H := m_hThread; if GetCurrentThreadID = MainThreadID then while MsgWaitForMultipleObjects(1,INFINITE,QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do PeekMessage(Msg,PM_NOREMOVE) else WaitForSingleObject(H,INFINITE); GetExitCodeThread(H,Result); end; {------------------------------------------------------------------------------} procedure TMsgThread.PostMsg(Msg: Cardinal; wParam,lParam); finally LeaveCriticalSection(FCtlSect); end; {$ENDIF} end; {------------------------------------------------------------------------------} function TMsgThread.SendMsg(Msg: Cardinal; wParam,lParam: Integer):Integer; {$IFNDEF USE_WINDOW_MESSAGE} var aEvent:PHandle; {$ENDIF} begin {$IFDEF USE_WINDOW_MESSAGE} Result := SendMessage(FMSGWin,INFINITE); Result := uMsg.Result; SetEvent(fSendMsgComp); {$ENDIF} end; {------------------------------------------------------------------------------} procedure TMsgThread.Synchronize(syncMethod: TMsgThreadMethod); begin FMethod := syncMethod; SendMessage(SyncWindow,NM_EXECPROC,Longint(Self)); end; {------------------------------------------------------------------------------} procedure TMsgThread.SyncWindowProc(var Message: TMessage); begin case Message.Msg of NM_EXECPROC: with TMsgThread(Message.lParam) do begin Message.Result := 0; try FMethod; except raise EMsgThreadErr.Create(‘执行同步线程方法错误。‘); end; end; else Message.Result:=DefWindowProc(SyncWindow,Message.Msg,Message.wParam,Message.lParam); end; end; end. (编辑:李大同) 【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容! |