【轉】DELPHI 線程類

時間  2019-11-30
標籤 delphi 線程 欄目 Delphi 简体版
原文   原文鏈接

原文地址：http://yyimen.blog.163.com/blog/static/179784047201211811178223/編程

Delphi中有一個線程類TThread是用來實現多線程編程的，這個絕大多數Delphi書藉都有說到，但基本上都是對TThread類的幾個成員做一簡單介紹，再說明一下Execute的實現和Synchronize的用法就完了。然而這並非多線程編程的所有，我寫此文的目的在於對此做一個補充。
    線程本質上是進程中一段併發運行的代碼。一個進程至少有一個線程，即所謂的主線程。同時還能夠有多個子線程。當一個進程中用到超過一個線程時，就是所謂的「多線程」。
    那麼這個所謂的「一段代碼」是如何定義的呢？其實就是一個函數或過程（對Delphi而言）。
    若是用Windows API來建立線程的話，是經過一個叫作CreateThread的API函數來實現的，它的定義爲：windows

HANDLE CreateThread(
    LPSECURITY_ATTRIBUTES lpThreadAttributes, 
    DWORD dwStackSize, 
    LPTHREAD_START_ROUTINE lpStartAddress, 
    LPVOID lpParameter, 
    DWORD dwCreationFlags, 
    LPDWORD lpThreadId 
   );
 

    其各參數如它們的名稱所說，分別是：線程屬性（用於在NT下進行線程的安全屬性設置，在9X下無效），堆棧大小，起始地址，參數，建立標誌（用於設置線程建立時的狀態），線程ID，最後返回線程Handle。其中的起始地址就是線程函數的入口，直至線程函數結束，線程也就結束了。
    整個線程的執行過程以下圖所示：

    由於CreateThread參數不少，並且是Windows的API，因此在C Runtime Library裏提供了一個通用的線程函數（理論上能夠在任何支持線程的OS中使用）：
    unsigned long _beginthread(void (_USERENTRY *__start)(void *), unsigned __stksize, void *__arg);

    Delphi也提供了一個相同功能的相似函數：
    function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; var ThreadId: LongWord): Integer;

    這三個函數的功能是基本相同的，它們都是將線程函數中的代碼放到一個獨立的線程中執行。線程函數與通常函數的最大不一樣在於，線程函數一啓動，這三個線程啓動函數就返回了，主線程繼續向下執行，而線程函數在一個獨立的線程中執行，它要執行多久，何時返回，主線程是無論也不知道的。
    正常狀況下，線程函數返回後，線程就終止了。但也有其它方式：

Windows API：
VOID ExitThread( DWORD dwExitCode );
C Runtime Library：
void _endthread(void);
Delphi Runtime Library：
procedure EndThread(ExitCode: Integer);

    爲了記錄一些必要的線程數據（狀態/屬性等），OS會爲線程建立一個內部Object，如在Windows中那個Handle即是這個內部Object的Handle，因此在線程結束的時候還應該釋放這個Object。

    雖說用API或RTL(Runtime Library)已經能夠很方便地進行多線程編程了，可是仍是須要進行較多的細節處理，爲此Delphi在Classes單元中對線程做了一個較好的封裝，這就是VCL的線程類：TThread
    使用這個類也很簡單，大多數的Delphi書籍都有說，基本用法是：先從TThread派生一個本身的線程類（由於TThread是一個抽象類，不能生成實例），而後是Override抽象方法：Execute（這就是線程函數，也就是在線程中執行的代碼部分），若是須要用到可視VCL對象，還須要經過Synchronize過程進行。關於之方面的具體細節，這裏再也不贅述，請參考相關書籍。
    本文接下來要討論的是TThread類是如何對線程進行封裝的，也就是深刻研究一下TThread類的實現。由於只是真正地瞭解了它，才更好地使用它。
    下面是DELPHI7中TThread類的聲明（本文只討論在Windows平臺下的實現，因此去掉了全部有關Linux平臺部分的代碼）：數組

 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, 0, @ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID);
  if FHandle = 0 then
    raise EThread.CreateResFmt(@SThreadCreateError, [SysErrorMessage(GetLastError)]);

end;

    雖然這個構造函數沒有多少代碼，但卻能夠算是最重要的一個成員，由於線程就是在這裏被建立的。
在經過Inherited調用TObject.Create後，第一句就是調用一個過程：AddThread，其源碼以下：併發

procedure AddThread;
begin
  InterlockedIncrement(ThreadCount);
end;

    //一樣有一個對應的RemoveThread：
procedure RemoveThread;
begin
  InterlockedDecrement(ThreadCount);
end;

    它們的功能很簡單，就是經過增減一個全局變量來統計進程中的線程數。只是這裏用於增減變量的並非經常使用的Inc/Dec過程，而是用了InterlockedIncrement/InterlockedDecrement這一對過程，它們實現的功能徹底同樣，都是對變量加一或減一。但它們有一個最大的區別，那就是InterlockedIncrement/InterlockedDecrement是線程安全的。即它們在多線程下能保證執行結果正確，而Inc/Dec不能。或者按操做系統理論中的術語來講，這是一對「原語」操做。
    以加一爲例來講明兩者實現細節上的不一樣：
    通常來講，對內存數據加一的操做分解之後有三個步驟：
    一、從內存中讀出數據
    二、數據加一
    三、存入內存
    如今假設在一個兩個線程的應用中用Inc進行加一操做可能出現的一種狀況：
    一、線程A從內存中讀出數據（假設爲3）  
    二、線程B從內存中讀出數據（也是3）
    三、線程A對數據加一（如今是4）
    四、線程B對數據加一（如今也是4）
    五、線程A將數據存入內存（如今內存中的數據是4）
    六、線程B也將數據存入內存（如今內存中的數據仍是4，但兩個線程都對它加了一，應該是5纔對，因此這裏出現了錯誤的結果）
    而用InterlockIncrement過程則沒有這個問題，由於所謂「原語」是一種不可中斷的操做，即操做系統能保證在一個「原語」執行完畢前不會進行線程切換。因此在上面那個例子中，只有當線程A執行完將數據存入內存後，線程B才能夠開始從中取數並進行加一操做，這樣就保證了即便是在多線程狀況下，結果也必定會是正確的。
    前面那個例子也說明一種「線程訪問衝突」的狀況，這也就是爲何線程之間須要「同步」（Synchronize），關於這個，在後面說到同步時還會再詳細討論。
    說到同步，有一個題外話：加拿大滑鐵盧大學的教授李明曾就Synchronize一詞在「線程同步」中被譯做「同步」提出過異議，我的認爲他說的其實頗有道理。在中文中「同步」的意思是「同時發生」，而「線程同步」目的就是避免這種「同時發生」的事情。而在英文中，Synchronize的意思有兩個：一個是傳統意義上的同步（To occur at the same time），另外一個是「協調一致」（To operate in unison）。在「線程同步」中的Synchronize一詞應該是指後面一種意思，即「保證多個線程在訪問同一數據時，保持協調一致，避免出錯」。不過像這樣譯得不許的詞在IT業還有不少，既然已是約定俗成了，本文也將繼續沿用，只是在這裏說明一下，由於軟件開發是一項細緻的工做，該弄清楚的，毫不能含糊。
    扯遠了，回到TThread的構造函數上，接下來最重要就是這句了：

FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID);

    這裏就用到了前面說到的Delphi RTL函數BeginThread，它有不少參數，關鍵的是第3、四兩個參數。第三個參數就是前面說到的線程函數，即在線程中執行的代碼部分。第四個參數則是傳遞給線程函數的參數，在這裏就是建立的線程對象（即Self）。其它的參數中，第五個是用於設置線程在建立後即掛起，不當即執行（啓動線程的工做是在AfterConstruction中根據CreateSuspended標誌來決定的），第六個是返回線程ID。
    如今來看TThread的核心：線程函數ThreadProc。有意思的是這個線程類的核心卻不是線程的成員，而是一個全局函數（由於BeginThread過程的參數約定只能用全局函數）。下面是它的代碼：

ide

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中最重要的部分，由於這段代碼是真正在線程中執行的代碼。下面對代碼做逐行說明：
    首先判斷線程類的Terminated標誌，若是未被標誌爲終止，則調用線程類的Execute方法執行線程代碼，由於TThread是抽象類，Execute方法是抽象方法，因此本質上是執行派生類中的Execute代碼。
    因此說，Execute就是線程類中的線程函數，全部在Execute中的代碼都須要看成線程代碼來考慮，如防止訪問衝突等。
    若是Execute發生異常，則經過AcquireExceptionObject取得異常對象，並存入線程類的FFatalException成員中。
    最後是線程結束前作的一些收尾工做。局部變量FreeThread記錄了線程類的FreeOnTerminated屬性的設置，而後將線程返回值設置爲線程類的返回值屬性的值。而後執行線程類的DoTerminate方法。
DoTerminate方法的代碼以下：

procedure TThread.DoTerminate;
begin
  if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
end;

    很簡單，就是經過Synchronize來調用CallOnTerminate方法，而CallOnTerminate方法的代碼以下，就是簡單地調用OnTerminate事件：

procedure TThread.CallOnTerminate;
begin
  if Assigned(FOnTerminate) then FOnTerminate(Self);
end;

    由於OnTerminate事件是在Synchronize中執行的，因此本質上它並非線程代碼，而是主線程代碼（具體見後面對Synchronize的分析）。
    執行完OnTerminate後，將線程類的FFinished標誌設置爲True。
    接下來執行SignalSyncEvent過程，其代碼以下：

procedure SignalSyncEvent;
begin
  SetEvent(SyncEvent);
end;

    也很簡單，就是設置一下一個全局Event：SyncEvent，關於Event的使用，本文將在後文詳述，而SyncEvent的用途將在WaitFor過程當中說明。
    而後根據FreeThread中保存的FreeOnTerminate設置決定是否釋放線程類，在線程類釋放時，還有一些些操做，詳見接下來的析構函數實現。
    最後調用EndThread結束線程，返回線程返回值。
    至此，線程徹底結束。
    說完構造函數，再來看析構函數：函數

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.Terminate;
begin
  FTerminated := True;
end;

    因此線程仍然必須繼續執行到正常結束後才行，而不是當即終止線程，這一點要注意。
    在這裏說一點題外話：不少人都問過我，如何才能「當即」終止線程（固然是指用TThread建立的線程）。結果固然是不行！終止線程的惟一辦法就是讓Execute方法執行完畢，因此通常來講，要讓你的線程可以儘快終止，必須在Execute方法中在較短的時間內不斷地檢查Terminated標誌，以便能及時地退出。這是設計線程代碼的一個很重要的原則！
    固然若是你必定要能「當即」退出線程，那麼TThread類不是一個好的選擇，由於若是用API強制終止線程的話，最終會致使TThread線程對象不能被正確釋放，在對象析構時出現Access Violation。這種狀況你只能用API或RTL函數來建立線程。
    若是線程處於啓動掛起狀態，則將線程轉入運行狀態，而後調用WaitFor進行等待，其功能就是等待到線程結束後才繼續向下執行。關於WaitFor的實現，將放到後面說明。
    線程結束後，關閉線程Handle（正常線程建立的狀況下Handle都是存在的），釋放操做系統建立的線程對象。
    而後調用TObject.Destroy釋放本對象，並釋放已經捕獲的異常對象，最後調用RemoveThread減少進程的線程數。
    其它關於Suspend/Resume及線程優先級設置等方面，不是本文的重點，再也不贅述。下面要討論的是本文的另兩個重點：Synchronize和WaitFor。
    可是在介紹這兩個函數以前，須要先介紹另外兩個線程同步技術：事件和臨界區。
    事件（Event）與Delphi中的事件有所不一樣。從本質上說，Event其實至關於一個全局的布爾變量。它有兩個賦值操做：Set和Reset，至關於把它設置爲True或False。而檢查它的值是經過WaitFor操做進行。對應在Windows平臺上，是三個API函數：SetEvent、ResetEvent、WaitForSingleObject（實現WaitFor功能的API還有幾個，這是最簡單的一個）。
    這三個都是原語，因此Event能夠實現通常布爾變量不能實現的在多線程中的應用。Set和Reset的功能前面已經說過了，如今來講一下WaitFor的功能：
    WaitFor的功能是檢查Event的狀態是不是Set狀態（至關於True），若是是則當即返回，若是不是，則等待它變爲Set狀態，在等待期間，調用WaitFor的線程處於掛起狀態。另外WaitFor有一個參數用於超時設置，若是此參數爲0，則不等待，當即返回Event的狀態，若是是INFINITE則無限等待，直到Set狀態發生，如果一個有限的數值，則等待相應的毫秒數後返回Event的狀態。
    當Event從Reset狀態向Set狀態轉換時，喚醒其它因爲WaitFor這個Event而掛起的線程，這就是它爲何叫Event的緣由。所謂「事件」就是指「狀態的轉換」。經過Event能夠在線程間傳遞這種「狀態轉換」信息。
    固然用一個受保護（見下面的臨界區介紹）的布爾變量也能實現相似的功能，只要用一個循環檢查此布爾值的代碼來代替WaitFor便可。從功能上說徹底沒有問題，但實際使用中就會發現，這樣的等待會佔用大量的CPU資源，下降系統性能，影響到別的線程的執行速度，因此是不經濟的，有的時候甚至可能會有問題。因此不建議這樣用。
    臨界區（CriticalSection）則是一項共享數據訪問保護的技術。它其實也是至關於一個全局的布爾變量。但對它的操做有所不一樣，它只有兩個操做：Enter和Leave，一樣能夠把它的兩個狀態看成True和False，分別表示如今是否處於臨界區中。這兩個操做也是原語，因此它能夠用於在多線程應用中保護共享數據，防止訪問衝突。
    用臨界區保護共享數據的方法很簡單：在每次要訪問共享數據以前調用Enter設置進入臨界區標誌，而後再操做數據，最後調用Leave離開臨界區。它的保護原理是這樣的：當一個線程進入臨界區後，若是此時另外一個線程也要訪問這個數據，則它會在調用Enter時，發現已經有線程進入臨界區，而後此線程就會被掛起，等待當前在臨界區的線程調用Leave離開臨界區，當另外一個線程完成操做，調用Leave離開後，此線程就會被喚醒，並設置臨界區標誌，開始操做數據，這樣就防止了訪問衝突。
    之前面那個InterlockedIncrement爲例，咱們用CriticalSection（Windows API）來實現它：

Var
  InterlockedCrit : TRTLCriticalSection;
Procedure InterlockedIncrement( var aValue : Integer );
Begin
  EnterCriticalSection( InterlockedCrit );
  Inc( aValue );
  LeaveCriticalSection( InterlockedCrit );
End;

    如今再來看前面那個例子：
    1.線程A進入臨界區（假設數據爲3）
    2.線程B進入臨界區，由於A已經在臨界區中，因此B被掛起
    3.線程A對數據加一（如今是4）
    4.線程A離開臨界區，喚醒線程B（如今內存中的數據是4）
    5.線程B被喚醒，對數據加一（如今就是5了）
    6.線程B離開臨界區，如今的數據就是正確的了。
    臨界區就是這樣保護共享數據的訪問。
    關於臨界區的使用，有一點要注意：即數據訪問時的異常狀況處理。由於若是在數據操做時發生異常，將致使Leave操做沒有被執行，結果將使本應被喚醒的線程未被喚醒，可能形成程序的沒有響應。因此通常來講，以下面這樣使用臨界區纔是正確的作法：

EnterCriticalSection
Try
   //  操做臨界區數據
Finally
  LeaveCriticalSection
End;

    最後要說明的是，Event和CriticalSection都是操做系統資源，使用前都須要建立，使用完後也一樣須要釋放。如TThread類用到的一個全局Event：SyncEvent和全局CriticalSection：TheadLock，都是在InitThreadSynchronization和DoneThreadSynchronization中進行建立和釋放的，而它們則是在Classes單元的Initialization和Finalization中被調用的。
    因爲在TThread中都是用API來操做Event和CriticalSection的，因此前面都是以API爲例，其實Delphi已經提供了對它們的封裝，在SyncObjs單元中，分別是TEvent類和TCriticalSection類。用法也與前面用API的方法相差無幾。由於TEvent的構造函數參數過多，爲了簡單起見，Delphi還提供了一個用默認參數初始化的Event類：TSimpleEvent。
    順便再介紹一下另外一個用於線程同步的類：TMultiReadExclusiveWriteSynchronizer，它是在SysUtils單元中定義的。據我所知，這是Delphi RTL中定義的最長的一個類名，還好它有一個短的別名：TMREWSync。至於它的用處，我想光看名字就能夠知道了，我也就很少說了。
    有了前面對Event和CriticalSection的準備知識，能夠正式開始討論Synchronize和WaitFor了。
    咱們知道，Synchronize是經過將部分代碼放到主線程中執行來實現線程同步的，由於在一個進程中，只有一個主線程。先來看看Synchronize的實現：oop

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;

    用於進行線程和主線程之間進行數據交換，包括傳入線程類對象，同步方法及發生的異常。
    在Synchronize中調用了它的一個重載版本，並且這個重載版本比較特別，它是一個「類方法」。所謂類方法，是一種特殊的類成員方法，它的調用並不須要建立類實例，而是像構造函數那樣，經過類名調用。之因此會用類方法來實現它，是由於爲了能夠在線程對象沒有建立時也能調用它。不過實際中是用它的另外一個重載版本（也是類方法）和另外一個類方法StaticSynchronize。下面是這個Synchronize的代碼：

post

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;

    這段代碼略多一些，不過也不算太複雜。
    首先是判斷當前線程是不是主線程，若是是，則簡單地執行同步方法後返回。
    若是不是主線程，則準備開始同步過程。
    經過局部變量SyncProc記錄線程交換數據（參數）和一個Event Handle，其記錄結構以下：

  TSyncProc = record
    SyncRec: PSynchronizeRecord;
    Signal: THandle;
  end;

    而後建立一個Event，接着進入臨界區（經過全局變量ThreadLock進行，由於同時只能有一個線程進入Synchronize狀態，因此能夠用全局變量記錄），而後就是把這個記錄數據存入SyncList這個列表中（若是這個列表不存在的話，則建立它）。可見ThreadLock這個臨界區就是爲了保護對SyncList的訪問，這一點在後面介紹CheckSynchronize時會再次看到。
    再接下就是調用SignalSyncEvent，其代碼在前面介紹TThread的構造函數時已經介紹過了，它的功能就是簡單地將SyncEvent做一個Set的操做。關於這個SyncEvent的用途，將在後面介紹WaitFor時再詳述。
    接下來就是最主要的部分了：調用WakeMainThread事件進行同步操做。WakeMainThread是一個TNotifyEvent類型的全局事件。這裏之因此要用事件進行處理，是由於Synchronize方法本質上是經過消息，將須要同步的過程放到主線程中執行，若是在一些沒有消息循環的應用中（如Console或DLL）是沒法使用的，因此要使用這個事件進行處理。
    而響應這個事件的是Application對象，下面兩個方法分別用於設置和清空WakeMainThread事件的響應（來自Forms單元）：

procedure TApplication.HookSynchronizeWakeup;
begin
  Classes.WakeMainThread := WakeMainThread;
end;

procedure TApplication.UnhookSynchronizeWakeup;
begin
  Classes.WakeMainThread := nil;
end;

    上面兩個方法分別是在TApplication類的構造函數和析構函數中被調用。
    這就是在Application對象中WakeMainThread事件響應的代碼，消息就是在這裏被髮出的，它利用了一個空消息來實現：

procedure TApplication.WakeMainThread(Sender: TObject);
begin
  PostMessage(Handle, WM_NULL, 0, 0);
end;

    而這個消息的響應也是在Application對象中，見下面的代碼（刪除無關的部分）：

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時會再說明。
    注意在WaitForSingleObject以後又從新進入臨界區，但沒有作任何事就退出了，彷佛沒有意義，但這是必須的！
    由於臨界區的Enter和Leave必須嚴格的一一對應。那麼是否能夠改爲這樣呢：

        if Assigned(WakeMainThread) then
          WakeMainThread(SyncProc.SyncRec.FThread);
        WaitForSingleObject(SyncProc.Signal, INFINITE);
      finally
        LeaveCriticalSection(ThreadLock);
      end;

    上面的代碼和原來的代碼最大的區別在於把WaitForSingleObject也歸入臨界區的限制中了。看上去沒什麼影響，還使代碼大大簡化了，但真的能夠嗎？
    事實上是不行！
    由於咱們知道，在Enter臨界區後，若是別的線程要再進入，則會被掛起。而WaitFor方法則會掛起當前線程，直到等待別的線程SetEvent後纔會被喚醒。若是改爲上面那樣的代碼的話，若是那個SetEvent的線程也須要進入臨界區的話，死鎖（Deadlock）就發生了（關於死鎖的理論，請自行參考操做系統原理方面的資料）。
    死鎖是線程同步中最須要注意的方面之一！
    最後釋放開始時建立的Event，若是被同步的方法返回異常的話，還會在這裏再次拋出異常。
    回到前面CheckSynchronize，見下面的代碼：

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;

    首先，這個方法必須在主線程中被調用（如前面經過消息傳遞到主線程），不然就拋出異常。
    接下來調用ResetSyncEvent（它與前面SetSyncEvent對應的，之因此不考慮WaitForSyncEvent的狀況，是由於只有在Linux版下才會調用帶參數的CheckSynchronize，Windows版下都是調用默認參數0的CheckSynchronize）。
    如今能夠看出SyncList的用途了：它是用於記錄全部未被執行的同步方法的。由於主線程只有一個，而子線程可能有不少個，當多個子線程同時調用同步方法時，主線程可能一時沒法處理，因此須要一個列表來記錄它們。
    在這裏用一個局部變量LocalSyncList來交換SyncList，這裏用的也是一個原語：InterlockedExchange。一樣，這裏也是用臨界區將對SyncList的訪問保護起來。
    只要LocalSyncList不爲空，則經過一個循環來依次處理累積的全部同步方法調用。最後把處理完的LocalSyncList釋放掉，退出臨界區。
    再來看對同步方法的處理：首先是從列表中移出（取出並從列表中刪除）第一個同步方法調用數據。而後退出臨界區（緣由固然也是爲了防止死鎖）。
    接着就是真正的調用同步方法了。
    若是同步方法中出現異常，將被捕獲後存入同步方法數據記錄中。
    從新進入臨界區後，調用SetEvent通知調用線程，同步方法執行完成了（詳見前面Synchronize中的WaitForSingleObject調用）。
    至此，整個Synchronize的實現介紹完成。
    最後來講一下WaitFor，它的功能就是等待線程執行結束。其代碼以下：

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, 0, 0, 0, PM_NOREMOVE);
      WaitResult := MsgWaitForMultipleObjects(2, H, False, 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狀態便可。
若是是在主線程中執行WaitFor則比較麻煩。首先要在Handle數組中增長一個SyncEvent，而後循環等待，直到線程結束（即MsgWaitForMultipleObjects返回WAIT_OBJECT_0，詳見MSDN中關於此API的說明）。
    在循環等待中做以下處理：若是有消息發生，則經過PeekMessage取出此消息（但並不把它從消息循環中移除），而後調用MsgWaitForMultipleObjects來等待線程Handle或SyncEvent出現Signaled狀態，同時監聽消息（QS_SENDMESSAGE參數，詳見MSDN中關於此API的說明）。能夠把此API看成一個能夠同時等待多個Handle的WaitForSingleObject。若是是SyncEvent被SetEvent（返回WAIT_OBJECT_0 + 1），則調用CheckSynchronize處理同步方法。
    爲何在主線程中調用WaitFor必須用MsgWaitForMultipleObjects，而不能用WaitForSingleObject等待線程結束呢？由於防止死鎖。因爲在線程函數Execute中可能調用Synchronize處理同步方法，而同步方法是在主線程中執行的，若是用WaitForSingleObject等待的話，則主線程在這裏被掛起，同步方法沒法執行，致使線程也被掛起，因而發生死鎖。
    而改用WaitForMultipleObjects則沒有這個問題。首先，它的第三個參數爲False，表示只要線程Handle或SyncEvent中只要有一個Signaled便可使主線程被喚醒，至於加上QS_SENDMESSAGE是由於Synchronize是經過消息傳到主線程來的，因此還要防止消息被阻塞。這樣，當線程中調用Synchronize時，主線程就會被喚醒並處理同步調用，在調用完成後繼續進入掛起等待狀態，直到線程結束。
    至此，對線程類TThread的分析能夠告一個段落了，對前面的分析做一個總結：
    一、線程類的線程必須按正常的方式結束，即Execute執行結束，因此在其中的代碼中必須在適當的地方加入足夠多的對Terminated標誌的判斷，並及時退出。若是必需要「當即」退出，則不能使用線程類，而要改用API或RTL函數。
    二、對可視VCL的訪問要放在Synchronize中，經過消息傳遞到主線程中，由主線程處理。
    三、線程共享數據的訪問應該用臨界區進行保護（固然用Synchronize也行）。
    四、線程通訊能夠採用Event進行（固然也能夠用Suspend/Resume）。
    五、當在多線程應用中使用多種線程同步方式時，必定要當心防止出現死鎖。
    六、等待線程結束要用WaitFor方法。

  



2003-12-11 15:37:00    
 發表評語???     

 2003-12-11 15:37:50    


 發表評語???     

Delphi的TThread類使用很方便,可是有時候咱們須要在線程類中使用消息循環,delphi沒有提供.花了兩天的事件研究了一下win32的消息系統,寫了一個線程內消息循環的測試.可是沒有具體應用過,貼出來給有這方面需求的DFW參考一下.
但願你們和我討論.

{-----------------------------------------------------------------------------
 Unit Name: uMsgThread
 Author:    xwing
 eMail :    xwing@263.net ; MSN : xwing1979@hotmail.com
 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, True, False, 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,0,0,0,0,0,0,hInstance,nil);
    SetWindowLong(FMSGWin, GWL_WNDPROC, Longint(MakeObjectInstance(MSGWinProc)));
{$ELSE}
    PeekMessage(Msg,0,WM_USER,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,0,0,0,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,0,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,0,0,0,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,0);
    {$ELSE}
    PostThreadMessage(ThreadID,WM_QUIT,0,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,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,Msg,wParam,lParam);
    {$ELSE}
    EnterCriticalSection(FCtlSect);
    try
        FEventList.Add(nil);
        PostThreadMessage(ThreadID,Msg,wParam,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,Msg,wParam,lParam);
    {$ELSE}
    EnterCriticalSection(FCtlSect);
    try
        New(aEvent);
        aEvent^ := CreateEvent(nil, True, False, nil);
        FEventList.Add(aEvent);
        PostThreadMessage(ThreadID,Msg,wParam,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 :    xwing@263.net ; MSN : xwing1979@hotmail.com
 Purpose:   Thread with message Loop
 History:

 2003-7-15  Write thread class without use delphi own TThread.
 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;

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,and Free(if FreeOnTerminater = true)
        //can call this in thread loop, 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, True, False, nil);
    {$ENDIF}

    FDoLoop := Loop;            //default disable thread loop

    //Create a Window for sync method
    SyncWindow := CreateWindow('STATIC','SyncWindow',WS_POPUP,0,0,0,0,0,0,hInstance,nil);
    SetWindowLong(SyncWindow, GWL_WNDPROC, Longint(MakeObjectInstance(SyncWindowProc)));


    FWaitHandle := CreateEvent(nil, True, False, nil);
    //Create Thread
    m_hThread := CreateThread(nil,0,@msgThdInitialThreadProc,Self,0,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',PChar(FWinName),WS_POPUP,0,0,0,0,0,0,hInstance,nil);
    SetWindowLong(FMSGWin, GWL_WNDPROC, Longint(MakeObjectInstance(MSGWinProc)));
{$ELSE}
    PeekMessage(Msg,0,WM_USER,WM_USER,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,0,0,0,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,0,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);
                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,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,0,0,0,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,WM_QUIT,0,0);
    {$ELSE}
    PostThreadMessage(ThreadID,WM_QUIT,0,0);
    {$ENDIF}
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.SetDoLoop(const Value: Boolean);
begin
    if Value = fDoLoop then Exit;
    fDoLoop := Value;
    if fDoLoop then
        PostMsg(WM_USER,0,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, H, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
            PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
    else
        WaitForSingleObject(H, INFINITE);
    GetExitCodeThread(H, Result);
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.PostMsg(Msg: Cardinal; wParam, lParam: Integer);
begin
    {$IFDEF USE_WINDOW_MESSAGE}
    postMessage(FMSGWin,Msg,wParam,lParam);
    {$ELSE}
    EnterCriticalSection(FCtlSect);
    try
        FEventList.Add(nil);
        PostThreadMessage(ThreadID,Msg,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,Msg,wParam,lParam);
    {$ELSE}
    EnterCriticalSection(FCtlSect);
    try
        New(aEvent);
        aEvent^ := CreateEvent(nil, True, False, nil);
        FEventList.Add(aEvent);
        PostThreadMessage(ThreadID,Msg,wParam,lParam);
    finally
        LeaveCriticalSection(FCtlSect);
    end;
    WaitForSingleObject(aEvent^,INFINITE);
    Result := uMsg.Result;
    SetEvent(fSendMsgComp);
    {$ENDIF}
end;

{------------------------------------------------------------------------------}
procedure TMsgThread.Synchronize(syncMethod: TMsgThreadMethod);
begin
    FMethod := syncMethod;
    SendMessage(SyncWindow,NM_EXECPROC,0,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.
相關文章
相關標籤/搜索
每日一句
    每一个你不满意的现在，都有一个你没有努力的曾经。
本站公眾號
   歡迎關注本站公眾號,獲取更多信息
聯繫我們 最近搜索 最新文章 沪ICP备13005482号-10 MyBatis教程 SQL 教程 MySQL教程 Java 教程 Thymeleaf 教程 Hibernate教程 Spring教程 Redis教程