unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&linux)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 13.05.2015
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad
// При компиляции под *nix в файле проекта до раздела USES вставить строку строку {$DEFINE UseCThreads}
{$IFDEF FPC}
{$mode objfpc}{$H+}
    {$IFDEF WINDOWS}
        {$DEFINE FPC_WIN}
        {$DEFINE ALL_WIN}
    {$ELSE}
        {$DEFINE FPC_NIX}
    {$ENDIF}
{$ELSE}
    {$DEFINE WIN}
    {$DEFINE ALL_WIN}
{$ENDIF}

// для передачи строк между потоками используется выделенная память
{$DEFINE ALLOC_STRING}
// добавлять отладочную информацию с использованием модуля wlog
{.$DEFINE WTHREAD_DEBUG_LOG}

interface

uses
    SysUtils,
    {$IFDEF WTHREAD_DEBUG_LOG}
     wlog,
    {$ENDIF}
    {$IFDEF UNIX} // добавить эти строки в модуль проекта при разработке не под windows
        //cthreads,
        //cmem,
    {$ENDIF}
    Classes
    {$IFNDEF FPC}
    ,Messages
    {$ENDIF}
    ,contnrs
    {$IFDEF ALL_WIN}
    ,Windows
    {$ENDIF}
    ,SyncObjs
    ;

const
    {$IFDEF FPC}
    //INFINITE            = Cardinal($FFFFFFFF);
    {$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $300;

type
    PThreadMessage = ^TThreadMessage;
    TThreadMessage = record
        {$IFDEF FPC}
        Message: DWord;
        {$ELSE}
        Message: Word;
        {$ENDIF}
        WParam: Word;
        LParam: NativeInt;
    end;

    TWEvent = class(TEvent)
    protected
        FWHandle: THandle;
    public
        constructor Create; overload;
        destructor Destroy; override;
        procedure WSetEvent;
        function WWaitFor(const TimeOut: Cardinal): TWaitResult;
    end;


    TWThread = class;

        // событие на получение сообщения из потока
    TWThreadReceiveMessage = procedure(Sender: TWThread; var Msg: TThreadMessage) of object;
        // событие из потока на таймаут
    TWThreadTimeOut = procedure(Sender: TWThread) of object;

    { TWThread }

    TWThread = class(TThread)
    private
        {$IFDEF FPC}
        FQueue: TQueue;
        FSection: TCriticalSection;
        FMessageEvent: TWEvent;
        FGUIThread: TThread;
        {$ELSE}
        FQueueReady: boolean;
        FQueueMessages: array of TThreadMessage;
        FToolWindow: THandle;
        hCloseEvent: THandle;
        {$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        {$IFDEF WTHREAD_DEBUG_LOG}
        FUseDebugLog: boolean;
        function intPostToLog(const Text: string): boolean; overload;
        function intPostToLog(const Text: string; const Level: TLogLevel): boolean; overload;
        {$ENDIF}
        function GetMsFromDateTime(const Value: TDateTime): Cardinal;
        procedure SetTimeOut(const Value: Cardinal);
    protected
        FTimeOut: Cardinal;
        {$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
        procedure GetWindow;
        procedure FreeWindow;
        {$ENDIF}
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
    public
        constructor Create
        {$IFDEF WTHREAD_DEBUG_LOG}
                (AUseDebugLog: Boolean)
        {$ENDIF}
            ; overload;
        constructor Create(CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
                , AUseDebugLog
        {$ENDIF}
                : Boolean); overload;
        destructor Destroy; override;
            // Две процедуры, которые выполняются в контексте потока. В начале и в конце.
        procedure InitThread; virtual;
        procedure DoneThread; virtual;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut write SetTimeOut default INFINITE;
            // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
        {$IFDEF WTHREAD_DEBUG_LOG}
        property UseDebugLog: boolean read FUseDebugLog write FUseDebugLog default false;
        {$ENDIF}
    end;

    // подготовка строки к обмену между потоками
function NewString(const Text: string): NativeInt;

    // возвращение строки к привычному виду после приема из другого потока
function FreeString(var P: NativeInt): String;

implementation

{$IFNDEF UNIX}
//uses Windows;
{$ENDIF}

const
    {$IFNDEF FPC}
    WM_THREAD_READY     = WM_USER+$102;
    {$ENDIF}
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);

    // константы из DateUtils
    OneMillisecond      = 1 / MSecsPerDay;

{$IFDEF ALLOC_STRING}
{$IFDEF ALL_WIN}
// для передачи строки между программами
function GlobalNewString(const Text: string): NativeInt;
var l: Integer;
    p: pointer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := GlobalAlloc(GHND, l+SizeOfChar);
        if LongBool(Result) then begin
            {$HINTS OFF}
            p := GlobalLock(Result);
            {$HINTS ON}
            Move(Pointer(Text)^, Pointer(p)^, l);
            GlobalUnlock(Result);
        end
    end else
        Result := 0;
end;

// для передачи строки между программами
function GlobalFreeString(var P: NativeInt): String;
var ps: pointer;
begin
    if LongBool(P) then begin
        {$HINTS OFF}
        ps := GlobalLock(P);
        {$HINTS ON}
        SetLength(Result, Length(PChar(ps)));
        Move(Pointer(ps)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        GlobalUnlock(P);
        P := GlobalFree(P);
    end;
end;
{$ENDIF}

// для передачи строки в пределах одной программы
function FreeString(var P: NativeInt): String;
begin
    {$HINTS OFF}
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        {$IFDEF ALL_WIN}
        P := LocalFree(HLOCAL(P));
        {$ELSE}
        P := FreeMem(Pointer(P));
        {$ENDIF}
    end;
end;

// для передачи строки в пределах одной программы
function NewString(const Text: string): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        {$IFDEF ALL_WIN}
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        {$ELSE}
        Pointer(Result) := AllocMem(l+SizeOfChar);
        {$ENDIF}
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
        {$HINTS ON}
    end else
        Result := 0;
end;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    Result := '';
    NativeInt(Result) := P;
end;
{$ENDIF}

constructor TWEvent.Create;
begin
    {$IFDEF WINCE}
    FWHandle := CreateEvent(nil, false, false, nil);
    {$ELSE}
    inherited Create(nil, false, false, '');
    {$ENDIF}
end;

destructor TWEvent.Destroy;
begin
    {$IFDEF WINCE}
    CloseHandle(FWHandle);
    {$ELSE}
    inherited Create(nil, false, false, '');
    {$ENDIF}
end;

procedure TWEvent.WSetEvent;
begin
    {$IFDEF WINCE}
    Windows.SetEvent(FWHandle);
    {$ELSE}
    inherited SetEvent;
    {$ENDIF}
end;

function TWEvent.WWaitFor(const TimeOut: Cardinal): TWaitResult;
{$IFDEF WINCE}
var
    dw: DWord;
begin
    dw := WaitForSingleObject(FWHandle, TimeOut);
    case dw of
        WAIT_ABANDONED: result := wrAbandoned;
        WAIT_OBJECT_0: result := wrSignaled;
        WAIT_TIMEOUT: result := wrTimeout;
    else
        Result := wrError;
    end;
{$ELSE}
begin
    result := WaitFor(TimeOut);
{$ENDIF}
end;

{$IFDEF FPC}
type

    { TGUIThread }

    TGUIThread = class(TThread)
    private
        FMessageEvent: TWEvent;
        FTimeOut: Boolean;
        FOwner: TWThread;
        FQueue: TQueue;
        FSection: TCriticalSection;
        FCurrentMessage: TThreadMessage;
    protected
        procedure Execute; override;
        procedure CallGUIThread;
    public
        constructor Create(AOwner: TWThread); overload;
        destructor Destroy; override;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure FreeQueue(const Queue: TQueue);
begin
    while Queue.Count > 0 do
        Queue.Pop;
end;

procedure TGUIThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WWaitFor(INFINITE);
        if (not Terminated) and (wr = wrSignaled) then begin
            if FTimeOut then begin
                FTimeOut := False;
                if Assigned(FOwner.FOnTimeOut) then
                    FOwner.FOnTimeOut(FOwner);
            end;
            while FQueue.Count > 0 do begin
                FSection.Enter;
                Message := FQueue.Pop;
                FSection.Leave;
                FCurrentMessage := Message^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
end;

constructor TGUIThread.Create(AOwner: TWThread);
begin
    inherited Create(False);
    FMessageEvent := TWEvent.Create;
    FQueue := TQueue.Create;
    FSection := TCriticalSection.Create;
    FOwner := AOwner;
end;

destructor TGUIThread.Destroy;
begin
    FreeQueue(FQueue);
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
var Msg: PThreadMessage;
begin
    GetMem(Msg, SizeOf(TThreadMessage));
    Msg^.Message := Message;
    Msg^.WParam := WParam;
    Msg^.LParam := LParam;
    FSection.Enter;
    FQueue.Push(Msg);
    FSection.Leave;
    FMessageEvent.WSetEvent;
end;

procedure TGUIThread.StopThread;
begin
    Terminate;
    FMessageEvent.WSetEvent;
end;
{$ENDIF}

{ TWThread }

constructor TWThread.Create(CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        : Boolean);
begin
    inherited Create(CreateSuspended);
    {$IFDEF WTHREAD_DEBUG_LOG}
    FUseDebugLog := AUseDebugLog;
    {$ENDIF}
    {$IFDEF FPC}
    FQueue := TQueue.Create;
    FMessageEvent := TWEvent.Create;
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
    {$ELSE}
    hCloseEvent := CreateEvent(nil, false, false, nil);
    GetWindow;
    FWindowHandle := 0;
    FQueueReady := False;
    {$ENDIF}
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

constructor TWThread.Create
    {$IFDEF WTHREAD_DEBUG_LOG}
    (AUseDebugLog: Boolean)
    {$ENDIF}
    ;
begin
    Create(false
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        );
end;

destructor TWThread.Destroy;
begin
    {$IFDEF FPC}
    FMessageEvent.Free;
    FreeQueue(FQueue);
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
    {$ELSE}
    CloseHandle(hCloseEvent);
    {$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

// Процедура, выполняющая в контексте этого потока перед запуском очереди сообщений (в начале работы потока).
procedure TWThread.InitThread;
begin
    // empty
end;

// Процедура, выполняющая в контексте этого потока после отработки очереди сообщений (в конце работы потока).
procedure TWThread.DoneThread;
begin
    // empty
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
    {$IFDEF FPC}
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.WSetEvent;
    {$ELSE}
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
    {$ENDIF}
end;

// отправка любого сообщения В этот поток
function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word;
    const LParam: NativeInt): Boolean;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Push(PMsg);
    FSection.Leave;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : send TO thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
    {$ENDIF}
    FMessageEvent.WSetEvent;
    result := true;
{$ELSE}
begin
    if FQueueReady then begin
        // если очередь сообщений создана и поток инициализирован, то сразу отправляем
        result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
    end else begin
        // иначе кэшируем
        SetLength(FQueueMessages, Length(FQueueMessages)+1);
        FQueueMessages[High(FQueueMessages)].Message := Msg;
        FQueueMessages[High(FQueueMessages)].WParam := WParam;
        FQueueMessages[High(FQueueMessages)].LParam := LParam;
        {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('Thread %d : send TO thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
        {$ENDIF}
        result := True;
    end;
{$ENDIF}
end;

{$IFDEF WTHREAD_DEBUG_LOG}
{$B-}
function TWThread.intPostToLog(const Text: string): boolean;
begin
    result := FUseDebugLog and PostToLog(Text);
end;

function TWThread.intPostToLog(const Text: string; const Level: TLogLevel): boolean;
begin
    result := FUseDebugLog and PostToLog(Text, Level);
end;
{$ENDIF}

function TWThread.GetMsFromDateTime(const Value: TDateTime): Cardinal;
begin
    Result := Round((Now - Value) / OneMillisecond);
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
    {$IFDEF FPC}
    if FTimeOut <> Value then begin
        if (Value = 0) then
            FTimeOut := INFINITE
        else
            FTimeOut := Value;
        if not Suspended then
            FMessageEvent.WSetEvent;
    end;
    {$ELSE}
    if FTimeOut <> Value then begin
        if (Value = 0) then
            FTimeOut := INFINITE
        else
            FTimeOut := Value;
        if (not Suspended)and(GetCurrentThreadId <> ThreadID) then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
    {$ENDIF}
end;

procedure TWThread.Execute;
var
    internalTimeout, ms: Cardinal;
    busy: TDateTime;
{$IFDEF FPC}
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : started.', [Handle]));
    {$ENDIF}
    InitThread;
    internalTimeout := TimeOut;
    busy := 0;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : main loop started.', [Handle]), WLL_EXTRA);
    {$ENDIF}
    while not Terminated do begin
        wr := FMessageEvent.WWaitFor(internalTimeout);
        busy := Now;
        if not Terminated then
            case WR of
                wrSignaled: begin
                    {$IFDEF WTHREAD_DEBUG_LOG}
                    intPostToLog(Format('Thread %d : got signal (queue cnt: %d).', [Handle, Integer(wr), FQueue.Count]), WLL_EXTRA);
                    {$ENDIF}
                    while FQueue.Count > 0 do begin
                        FSection.Enter;
                        Message := FQueue.Pop;
                        FSection.Leave;
                        if (Message^.message >= WM_THREAD_BASE)
                            and (Message^.Message <= WM_THREAD_MAX) then begin
                                {$IFDEF WTHREAD_DEBUG_LOG}
                                intPostToLog(Format('Thread %d : dispatch msg %d (%1:x).', [Handle, Message^.Message]), WLL_EXTRA);
                                {$ENDIF}
                                Dispatch(Message^);
                            end;
                        FreeMem(Message);
                    end;
                end;
                wrTimeout: begin
                    internalTimeout := TimeOut;
                    if FTimeOutIsDirect then begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : DirectTimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        DirectTimeOut;
                    end else begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : Sent TimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                        // сообщение не занимает много времени, на точность не влияет
                        busy := 0;
                    end;
                end;
            end;
        // корректируем интервал таймаута на время выполнения кода выше
        if (busy <> 0) then begin
            ms := GetMsFromDateTime(busy);
            if (ms > TimeOut) then
                internalTimeout := 0
            else
                internalTimeout := TimeOut - ms;
        end else begin
            internalTimeout := TimeOut;
        end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

begin
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : started.', [Handle]));
    {$ENDIF}
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    {$HINTS OFF}
    PeekMessage(msg, THandle(-1), WM_USER, WM_USER, PM_NOREMOVE);
    {$HINTS ON}
    internalTimeout := TimeOut;
    busy := 0;
    InitThread;
    HandlesToWaitFor[0] := hCloseEvent;
    PostMessageFromThread(WM_THREAD_READY, 0, 0);

    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : main loop started.', [Handle]), WLL_EXTRA);
    {$ENDIF}
    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_USER, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_USER, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, internalTimeout, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, internalTimeout, QS_ALLEVENTS);
            busy := Now;
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    if not FreeOnTerminate then
                        Terminate;
                    break;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    Continue;
                end;
                WAIT_TIMEOUT: begin
                    if FTimeOutIsDirect then begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : DirectTimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        DirectTimeOut;
                    end else begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : Sent TimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                        // сообщение не занимает много времени, на точность не влияет
                        busy := 0;
                    end;
                    // выставляем новый интервал за минусом времени выполнения процедуры таймаута
                    if (busy <> 0) then begin
                        ms := GetMsFromDateTime(busy);
                        if (ms > TimeOut) then
                            internalTimeout := 0
                        else
                            internalTimeout := TimeOut - ms;
                    end else begin
                        internalTimeout := TimeOut;
                    end;
                    Continue;
                end;
            end;
        end;

        if Terminated then break;

        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                // изменен таймаут
                FTimeOut := msg.wParam;
                busy := 0;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                {$IFDEF WTHREAD_DEBUG_LOG}
                intPostToLog(Format('Thread %d : dispatch msg %d (%1:x).', [Handle, Message^.Message]), WLL_EXTRA);
                {$ENDIF}
                // ищем и вызываем procedure of object message
                Dispatch(message);
            end;
        end;

        // корректируем интервал таймаута на время выполнения кода выше
        if (busy <> 0) then begin
            ms := GetMsFromDateTime(busy);
            if (ms > TimeOut) then
                internalTimeout := 0
            else
                internalTimeout := TimeOut - ms;
        end else begin
            internalTimeout := TimeOut;
        end;
    end;
{$ENDIF}
    DoneThread;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : main loop stoped.', [Handle]), WLL_EXTRA);
    {$ENDIF}
end;

// отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then begin
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
    {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('Thread %d : send FROM thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
    {$ENDIF}
    end
    {$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
        {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('Thread %d : send FROM thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
        {$ENDIF}
    end
{$ENDIF}
    {$IFDEF WTHREAD_DEBUG_LOG}
    else
        intPostToLog(Format('Thread %d : cant send FROM thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
    {$ENDIF}
end;

// отправка любого сообщения В этот поток
procedure TWThread.StopThread;
begin
    {$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.WSetEvent;
    {$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
    {$ENDIF}
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : stop signal.', [Handle]));
    {$ENDIF}
end;

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

{$IFNDEF FPC}

procedure TWThread.WWindowProc(var Msg: TMessage);
var i: integer;
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        end;
        WM_THREAD_READY: begin
            FQueueReady := true;
            // поток готов, отправляем ему все закэшированные сообщения
            if Length(FQueueMessages) > 0 then for i := Low(FQueueMessages) to High(FQueueMessages) do
                PostToThreadMessage(FQueueMessages[i].Message, FQueueMessages[i].WParam, FQueueMessages[i].LParam);
            SetLength(FQueueMessages, 0);
        end;
        WM_THREAD_BASE..WM_THREAD_MAX: begin
            DoThreadReceiveMessage(Msg.Msg, Msg.WParam, Msg.LParam);
            Msg.Result := 1;
        end
    else  if LongBool(FToolWindow) then
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

procedure TWThread.GetWindow;
begin
    FToolWindow := AllocateHWnd(WWindowProc);
end;

procedure TWThread.FreeWindow;
begin
    DeallocateHWnd(FToolWindow);
    FToolWindow := 0;
end;

{$ENDIF}

end.

unit wlog;
// wlog (c) wadman, 2015, 13.05.2015
// multithread safe logging

interface

// log level
type
    TLogLevel = (WLL_MINIMUM, WLL_NORMAL, WLL_MAXIMUM, WLL_EXTRA);

var WLogFileName: string;
    WLogEnabled: boolean;
    WLogLevel: TLogLevel;

function PostToLog(const Text: string): boolean; overload; // with WLL_NORMAL
function PostToLog(const Text: string; const Level: TLogLevel): boolean; overload;

implementation

uses SysUtils, WThread;

const
    WM_LOG      = WM_THREAD_BASE + 1;

type
    PLogRecord = ^TLogRecord;
    TLogRecord = record
        DT: TDateTime;
        PString: NativeInt;
    end;

    TLogThread = class(TWThread)
    private
        procedure WMLog(var Msg: TThreadMessage); message WM_LOG;
    end;

var
    LogThread: TLogThread;
    FirstLine: boolean;

function PostToLog(const Text: string): boolean;
begin
    result := PostToLog(Text, WLL_NORMAL);
end;

function PostToLog(const Text: string; const Level: TLogLevel): boolean;
var p: PLogRecord;
    d: TDateTime;
begin
    if SmallInt(Level) <= SmallInt(WLogLevel) then begin
        result := WLogEnabled and LongBool(LogThread);
        if result then begin
            d := Now;
            p := AllocMem(SizeOf(TLogRecord));
            p^.DT := d;
            p^.PString := NewString(Text);
{$HINTS OFF}
            result := LogThread.PostToThreadMessage(WM_LOG, 0, NativeInt(p));
{$HINTS ON}
            if not result then begin
                FreeString(p^.PString);
                FreeMem(p);
            end;
        end;
    end else
        Result := true;
end;

function InitLogs: boolean;
begin
    WLogFileName := ChangeFileExt(ParamStr(0), '.log');
    LogThread := TLogThread.Create(false);
    result := LongBool(LogThread);
end;

procedure DoneLogs;
begin
    if LongBool(LogThread) then begin
        LogThread.StopThread;
        LogThread.Free;
    end;
end;

function AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, WLogFileName);
        if (FileExists(WLogFileName)) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss.zzz', DT), Text]));
        CloseFile(t);
        result := true;
    finally
    end;
end;

{ TLogThread }

procedure TLogThread.WMLog(var Msg: TThreadMessage);
var p: PLogRecord;
begin
{$HINTS OFF}
    p := PLogRecord(Msg.LParam);
{$HINTS ON}
    AddToLog(p^.DT, FreeString(p^.PString));
    FreeMem(p);
end;

initialization
    WLogLevel := WLL_NORMAL;
    WLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&linux)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 14.05.2015
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad
// При компиляции под *nix в файле проекта до раздела USES вставить строку {$DEFINE UseCThreads}
{$IFDEF FPC}
{$mode objfpc}{$H+}
    {$IFDEF WINDOWS}
        {$DEFINE FPC_WIN}
        {$DEFINE ALL_WIN}
    {$ELSE}
        {$DEFINE FPC_NIX}
    {$ENDIF}
{$ELSE}
    {$DEFINE WIN}
    {$DEFINE ALL_WIN}
{$ENDIF}

// для передачи строк между потоками используется выделенная память
{$DEFINE ALLOC_STRING}
// добавлять отладочную информацию с использованием модуля wlog
{.$DEFINE WTHREAD_DEBUG_LOG}

interface

uses
    SysUtils,
    {$IFDEF WTHREAD_DEBUG_LOG}
     wlog,
    {$ENDIF}
    {$IFDEF UNIX} // добавить эти строки в модуль проекта при разработке не под windows
        //cthreads,
        //cmem,
    {$ENDIF}
    Classes
    {$IFNDEF FPC}
    ,Messages
    {$ENDIF}
    ,contnrs
    {$IFDEF ALL_WIN}
    ,Windows
    {$ENDIF}
    ,SyncObjs
    ;

const
    {$IFDEF FPC}
    //INFINITE            = Cardinal($FFFFFFFF);
    {$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $300;

type
    PThreadMessage = ^TThreadMessage;
    TThreadMessage = record
        {$IFDEF FPC}
        Message: DWord;
        {$ELSE}
        Message: Word;
        {$ENDIF}
        WParam: Word;
        LParam: NativeInt;
    end;

    TWEvent = class(TEvent)
    protected
        FWHandle: THandle;
    public
        constructor Create; overload;
        destructor Destroy; override;
        procedure WSetEvent;
        procedure WResetEvent;
        function WWaitFor(const TimeOut: Cardinal): TWaitResult;
    end;


    TWThread = class;

        // событие на получение сообщения из потока
    TWThreadReceiveMessage = procedure(Sender: TWThread; var Msg: TThreadMessage) of object;
        // событие из потока на таймаут
    TWThreadTimeOut = procedure(Sender: TWThread) of object;

    { TWThread }

    TWThread = class(TThread)
    private
        {$IFDEF FPC}
        FQueue: TQueue;
        FSection: TCriticalSection;
        FMessageEvent: TWEvent;
        FGUIThread: TThread;
        {$ELSE}
        FQueueReady: boolean;
        FQueueMessages: array of TThreadMessage;
        FToolWindow: THandle;
        hCloseEvent: THandle;
        {$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        {$IFDEF WTHREAD_DEBUG_LOG}
        FUseDebugLog: boolean;
        function intPostToLog(const Text: string): boolean; overload;
        function intPostToLog(const Text: string; const Level: TLogLevel): boolean; overload;
        {$ENDIF}
        function GetMsFromDateTime(const Value: TDateTime): Cardinal;
        procedure SetTimeOut(const Value: Cardinal);
    protected
        FTimeOut: Cardinal;
        {$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
        procedure GetWindow;
        procedure FreeWindow;
        {$ENDIF}
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
    public
        constructor Create
        {$IFDEF WTHREAD_DEBUG_LOG}
                (AUseDebugLog: Boolean)
        {$ENDIF}
            ; overload;
        constructor Create(CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
                , AUseDebugLog
        {$ENDIF}
                : Boolean); overload;
        destructor Destroy; override;
            // Две процедуры, которые выполняются в контексте потока. В начале и в конце.
        procedure InitThread; virtual;
        procedure DoneThread; virtual;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut write SetTimeOut default INFINITE;
            // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
        {$IFDEF WTHREAD_DEBUG_LOG}
        property UseDebugLog: boolean read FUseDebugLog write FUseDebugLog default false;
        {$ENDIF}
    end;

    // подготовка строки к обмену между потоками
function NewString(const Text: string): NativeInt;

    // возвращение строки к привычному виду после приема из другого потока
function FreeString(var P: NativeInt): String;

implementation

{$IFNDEF UNIX}
//uses Windows;
{$ENDIF}

const
    {$IFNDEF FPC}
    WM_THREAD_READY     = WM_USER+$102;
    {$ENDIF}
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);

    // константы из DateUtils
    OneMillisecond      = 1 / MSecsPerDay;

{$IFDEF ALLOC_STRING}
{$IFDEF ALL_WIN}
// для передачи строки между программами
function GlobalNewString(const Text: string): NativeInt;
var l: Integer;
    p: pointer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := GlobalAlloc(GHND, l+SizeOfChar);
        if LongBool(Result) then begin
            {$HINTS OFF}
            p := GlobalLock(Result);
            {$HINTS ON}
            Move(Pointer(Text)^, Pointer(p)^, l);
            GlobalUnlock(Result);
        end
    end else
        Result := 0;
end;

// для передачи строки между программами
function GlobalFreeString(var P: NativeInt): String;
var ps: pointer;
begin
    if LongBool(P) then begin
        {$HINTS OFF}
        ps := GlobalLock(P);
        {$HINTS ON}
        SetLength(Result, Length(PChar(ps)));
        Move(Pointer(ps)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        GlobalUnlock(P);
        P := GlobalFree(P);
    end;
end;
{$ENDIF}

// для передачи строки в пределах одной программы
function FreeString(var P: NativeInt): String;
begin
    {$HINTS OFF}
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        {$IFDEF ALL_WIN}
        P := LocalFree(HLOCAL(P));
        {$ELSE}
        P := FreeMem(Pointer(P));
        {$ENDIF}
    end;
end;

// для передачи строки в пределах одной программы
function NewString(const Text: string): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        {$IFDEF ALL_WIN}
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        {$ELSE}
        Pointer(Result) := AllocMem(l+SizeOfChar);
        {$ENDIF}
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
        {$HINTS ON}
    end else
        Result := 0;
end;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    Result := '';
    NativeInt(Result) := P;
end;
{$ENDIF}

constructor TWEvent.Create;
begin
    {$IFDEF WINCE}
    FWHandle := CreateEvent(nil, false, false, nil);
    {$ELSE}
    inherited Create(nil, false, false, '');
    {$ENDIF}
end;

destructor TWEvent.Destroy;
begin
    {$IFDEF WINCE}
    CloseHandle(FWHandle);
    {$ELSE}
    inherited;
    {$ENDIF}
end;

procedure TWEvent.WResetEvent;
begin
    {$IFDEF WINCE}
    Windows.ResetEvent(FWHandle);
    {$ELSE}
    inherited ResetEvent;
    {$ENDIF}
end;

procedure TWEvent.WSetEvent;
begin
    {$IFDEF WINCE}
    Windows.SetEvent(FWHandle);
    {$ELSE}
    inherited SetEvent;
    {$ENDIF}
end;

function TWEvent.WWaitFor(const TimeOut: Cardinal): TWaitResult;
{$IFDEF WINCE}
var
    dw: DWord;
begin
    dw := WaitForSingleObject(FWHandle, TimeOut);
    case dw of
        WAIT_ABANDONED: result := wrAbandoned;
        WAIT_OBJECT_0: result := wrSignaled;
        WAIT_TIMEOUT: result := wrTimeout;
    else
        Result := wrError;
    end;
{$ELSE}
begin
    result := WaitFor(TimeOut);
{$ENDIF}
end;

{$IFDEF FPC}
type

    { TGUIThread }

    TGUIThread = class(TThread)
    private
        FMessageEvent: TWEvent;
        FTimeOut: Boolean;
        FOwner: TWThread;
        FQueue: TQueue;
        FSection: TCriticalSection;
        FCurrentMessage: TThreadMessage;
    protected
        procedure Execute; override;
        procedure CallGUIThread;
    public
        constructor Create(AOwner: TWThread); overload;
        destructor Destroy; override;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure FreeQueue(const Queue: TQueue);
begin
    while Queue.Count > 0 do
        Queue.Pop;
end;

procedure TGUIThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WWaitFor(INFINITE);
        if (not Terminated) and (wr = wrSignaled) then begin
            if FTimeOut then begin
                FTimeOut := False;
                if Assigned(FOwner.FOnTimeOut) then
                    FOwner.FOnTimeOut(FOwner);
            end;
            while FQueue.Count > 0 do begin
                FSection.Enter;
                Message := FQueue.Pop;
                FSection.Leave;
                FCurrentMessage := Message^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
end;

constructor TGUIThread.Create(AOwner: TWThread);
begin
    inherited Create(False);
    FMessageEvent := TWEvent.Create;
    FQueue := TQueue.Create;
    FSection := TCriticalSection.Create;
    FOwner := AOwner;
end;

destructor TGUIThread.Destroy;
begin
    FreeQueue(FQueue);
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
var Msg: PThreadMessage;
begin
    GetMem(Msg, SizeOf(TThreadMessage));
    Msg^.Message := Message;
    Msg^.WParam := WParam;
    Msg^.LParam := LParam;
    FSection.Enter;
    FQueue.Push(Msg);
    FSection.Leave;
    FMessageEvent.WSetEvent;
end;

procedure TGUIThread.StopThread;
begin
    Terminate;
    FMessageEvent.WSetEvent;
end;
{$ENDIF}

{ TWThread }

constructor TWThread.Create(CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        : Boolean);
begin
    inherited Create(CreateSuspended);
    {$IFDEF WTHREAD_DEBUG_LOG}
    FUseDebugLog := AUseDebugLog;
    {$ENDIF}
    {$IFDEF FPC}
    FQueue := TQueue.Create;
    FMessageEvent := TWEvent.Create;
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
    {$ELSE}
    hCloseEvent := CreateEvent(nil, false, false, nil);
    GetWindow;
    FWindowHandle := 0;
    FQueueReady := False;
    {$ENDIF}
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

constructor TWThread.Create
    {$IFDEF WTHREAD_DEBUG_LOG}
    (AUseDebugLog: Boolean)
    {$ENDIF}
    ;
begin
    Create(false
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        );
end;

destructor TWThread.Destroy;
begin
    {$IFDEF FPC}
    FMessageEvent.Free;
    FreeQueue(FQueue);
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
    {$ELSE}
    CloseHandle(hCloseEvent);
    {$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

// Процедура, выполняющая в контексте этого потока перед запуском очереди сообщений (в начале работы потока).
procedure TWThread.InitThread;
begin
    // empty
end;

// Процедура, выполняющая в контексте этого потока после отработки очереди сообщений (в конце работы потока).
procedure TWThread.DoneThread;
begin
    // empty
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
    {$IFDEF FPC}
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.WSetEvent;
    {$ELSE}
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
    {$ENDIF}
end;

// отправка любого сообщения В этот поток
function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word;
    const LParam: NativeInt): Boolean;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Push(PMsg);
    FSection.Leave;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : send TO thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
    {$ENDIF}
    FMessageEvent.WSetEvent;
    result := true;
{$ELSE}
begin
    if FQueueReady then begin
        // если очередь сообщений создана и поток инициализирован, то сразу отправляем
        result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
    end else begin
        // иначе кэшируем
        SetLength(FQueueMessages, Length(FQueueMessages)+1);
        FQueueMessages[High(FQueueMessages)].Message := Msg;
        FQueueMessages[High(FQueueMessages)].WParam := WParam;
        FQueueMessages[High(FQueueMessages)].LParam := LParam;
        {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('Thread %d : send TO thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
        {$ENDIF}
        result := True;
    end;
{$ENDIF}
end;

{$IFDEF WTHREAD_DEBUG_LOG}
{$B-}
function TWThread.intPostToLog(const Text: string): boolean;
begin
    result := FUseDebugLog and PostToLog(Text);
end;

function TWThread.intPostToLog(const Text: string; const Level: TLogLevel): boolean;
begin
    result := FUseDebugLog and PostToLog(Text, Level);
end;
{$ENDIF}

function TWThread.GetMsFromDateTime(const Value: TDateTime): Cardinal;
begin
    Result := Round((Now - Value) / OneMillisecond);
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
    {$IFDEF FPC}
    if FTimeOut <> Value then begin
        if (Value = 0) then
            FTimeOut := INFINITE
        else
            FTimeOut := Value;
        if not Suspended then
            FMessageEvent.WSetEvent;
    end;
    {$ELSE}
    if FTimeOut <> Value then begin
        if (Value = 0) then
            FTimeOut := INFINITE
        else
            FTimeOut := Value;
        if (not Suspended)and(GetCurrentThreadId <> ThreadID) then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
    {$ENDIF}
end;

procedure TWThread.Execute;
var
    internalTimeout, ms: Cardinal;
    busy: TDateTime;
{$IFDEF FPC}
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : started.', [Handle]));
    {$ENDIF}
    InitThread;
    internalTimeout := TimeOut;
    busy := 0;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : main loop started.', [Handle]), WLL_EXTRA);
    {$ENDIF}
    while not Terminated do begin
        wr := FMessageEvent.WWaitFor(internalTimeout);
        busy := Now;
        if not Terminated then
            case WR of
                wrSignaled: begin
                    {$IFDEF WTHREAD_DEBUG_LOG}
                    intPostToLog(Format('Thread %d : got signal (queue cnt: %d).', [Handle, Integer(wr), FQueue.Count]), WLL_EXTRA);
                    {$ENDIF}
                    while FQueue.Count > 0 do begin
                        FSection.Enter;
                        Message := FQueue.Pop;
                        FSection.Leave;
                        if (Message^.message >= WM_THREAD_BASE)
                            and (Message^.Message <= WM_THREAD_MAX) then begin
                                {$IFDEF WTHREAD_DEBUG_LOG}
                                intPostToLog(Format('Thread %d : dispatch msg %d (%1:x).', [Handle, Message^.Message]), WLL_EXTRA);
                                {$ENDIF}
                                Dispatch(Message^);
                            end;
                        FreeMem(Message);
                    end;
                end;
                wrTimeout: begin
                    internalTimeout := TimeOut;
                    if FTimeOutIsDirect then begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : DirectTimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        DirectTimeOut;
                    end else begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : Sent TimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                        // сообщение не занимает много времени, на точность не влияет
                        busy := 0;
                    end;
                end;
            end;
        // корректируем интервал таймаута на время выполнения кода выше
        if (busy <> 0) then begin
            ms := GetMsFromDateTime(busy);
            if (ms > TimeOut) then
                internalTimeout := 0
            else
                internalTimeout := TimeOut - ms;
        end else begin
            internalTimeout := TimeOut;
        end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

begin
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : started.', [Handle]));
    {$ENDIF}
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    {$HINTS OFF}
    PeekMessage(msg, THandle(-1), WM_USER, WM_USER, PM_NOREMOVE);
    {$HINTS ON}
    internalTimeout := TimeOut;
    busy := 0;
    InitThread;
    HandlesToWaitFor[0] := hCloseEvent;
    PostMessageFromThread(WM_THREAD_READY, 0, 0);

    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : main loop started.', [Handle]), WLL_EXTRA);
    {$ENDIF}
    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_USER, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_USER, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, internalTimeout, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, internalTimeout, QS_ALLEVENTS);
            busy := Now;
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    if not FreeOnTerminate then
                        Terminate;
                    break;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    Continue;
                end;
                WAIT_TIMEOUT: begin
                    if FTimeOutIsDirect then begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : DirectTimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        DirectTimeOut;
                    end else begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog(Format('Thread %d : Sent TimeOut.', [Handle]), WLL_EXTRA);
                        {$ENDIF}
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                        // сообщение не занимает много времени, на точность не влияет
                        busy := 0;
                    end;
                    // выставляем новый интервал за минусом времени выполнения процедуры таймаута
                    if (busy <> 0) then begin
                        ms := GetMsFromDateTime(busy);
                        if (ms > TimeOut) then
                            internalTimeout := 0
                        else
                            internalTimeout := TimeOut - ms;
                    end else begin
                        internalTimeout := TimeOut;
                    end;
                    Continue;
                end;
            end;
        end;

        if Terminated then break;

        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                // изменен таймаут
                FTimeOut := msg.wParam;
                busy := 0;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                {$IFDEF WTHREAD_DEBUG_LOG}
                intPostToLog(Format('Thread %d : dispatch msg %d (%1:x).', [Handle, Message.Message]), WLL_EXTRA);
                {$ENDIF}
                // ищем и вызываем procedure of object message
                Dispatch(message);
            end;
        end;

        // корректируем интервал таймаута на время выполнения кода выше
        if (busy <> 0) then begin
            ms := GetMsFromDateTime(busy);
            if (ms > TimeOut) then
                internalTimeout := 0
            else
                internalTimeout := TimeOut - ms;
        end else begin
            internalTimeout := TimeOut;
        end;
    end;
{$ENDIF}
    DoneThread;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : main loop stoped.', [Handle]), WLL_EXTRA);
    {$ENDIF}
end;

// отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then begin
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
    {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('Thread %d : send FROM thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
    {$ENDIF}
    end
    {$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
        {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('Thread %d : send FROM thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
        {$ENDIF}
    end
{$ENDIF}
    {$IFDEF WTHREAD_DEBUG_LOG}
    else
        intPostToLog(Format('Thread %d : cant send FROM thread msg: %d (%1:x).', [Handle, Msg]), WLL_EXTRA);
    {$ENDIF}
end;

// отправка любого сообщения В этот поток
procedure TWThread.StopThread;
begin
    {$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.WSetEvent;
    {$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
    {$ENDIF}
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('Thread %d : stop signal.', [Handle]));
    {$ENDIF}
end;

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

{$IFNDEF FPC}

procedure TWThread.WWindowProc(var Msg: TMessage);
var i: integer;
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        end;
        WM_THREAD_READY: begin
            FQueueReady := true;
            // поток готов, отправляем ему все закэшированные сообщения
            if Length(FQueueMessages) > 0 then for i := Low(FQueueMessages) to High(FQueueMessages) do
                PostToThreadMessage(FQueueMessages[i].Message, FQueueMessages[i].WParam, FQueueMessages[i].LParam);
            SetLength(FQueueMessages, 0);
        end;
        WM_THREAD_BASE..WM_THREAD_MAX: begin
            DoThreadReceiveMessage(Msg.Msg, Msg.WParam, Msg.LParam);
            Msg.Result := 1;
        end
    else  if LongBool(FToolWindow) then
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

procedure TWThread.GetWindow;
begin
    FToolWindow := AllocateHWnd(WWindowProc);
end;

procedure TWThread.FreeWindow;
begin
    DeallocateHWnd(FToolWindow);
    FToolWindow := 0;
end;

{$ENDIF}

end.

unit wlog;
// wlog (c) wadman, 2015, 13.05.2015
// multithread safe logging

interface

// log level
type
    TLogLevel = (WLL_MINIMUM, WLL_NORMAL, WLL_MAXIMUM, WLL_EXTRA);

var WLogFileName: string;
    WLogEnabled: boolean;
    WLogLevel: TLogLevel;

function PostToLog(const Text: string): boolean; overload; // with WLL_NORMAL
function PostToLog(const Text: string; const Level: TLogLevel): boolean; overload;

implementation

uses SysUtils, WThread;

const
    WM_LOG      = WM_THREAD_BASE + 1;

type
    PLogRecord = ^TLogRecord;
    TLogRecord = record
        DT: TDateTime;
        PString: NativeInt;
    end;

    TLogThread = class(TWThread)
    private
        procedure WMLog(var Msg: TThreadMessage); message WM_LOG;
    end;

var
    LogThread: TLogThread;
    FirstLine: boolean;

function PostToLog(const Text: string): boolean;
begin
    result := PostToLog(Text, WLL_NORMAL);
end;

function PostToLog(const Text: string; const Level: TLogLevel): boolean;
var p: PLogRecord;
    d: TDateTime;
begin
    if SmallInt(Level) <= SmallInt(WLogLevel) then begin
        result := WLogEnabled and LongBool(LogThread);
        if result then begin
            d := Now;
            p := AllocMem(SizeOf(TLogRecord));
            p^.DT := d;
            p^.PString := NewString(Text);
{$HINTS OFF}
            result := LogThread.PostToThreadMessage(WM_LOG, 0, NativeInt(p));
{$HINTS ON}
            if not result then begin
                FreeString(p^.PString);
                FreeMem(p);
            end;
        end;
    end else
        Result := true;
end;

function InitLogs: boolean;
begin
    WLogFileName := ChangeFileExt(ParamStr(0), '.log');
    LogThread := TLogThread.Create(false);
    result := LongBool(LogThread);
end;

procedure DoneLogs;
begin
    if LongBool(LogThread) then begin
        LogThread.StopThread;
        LogThread.Free;
    end;
end;

function AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, WLogFileName);
        if (FileExists(WLogFileName)) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss.zzz', DT), Text]));
        CloseFile(t);
        result := true;
    finally
    end;
end;

{ TLogThread }

procedure TLogThread.WMLog(var Msg: TThreadMessage);
var p: PLogRecord;
begin
{$HINTS OFF}
    p := PLogRecord(Msg.LParam);
{$HINTS ON}
    AddToLog(p^.DT, FreeString(p^.PString));
    FreeMem(p);
end;

initialization
    WLogLevel := WLL_NORMAL;
    WLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&*nix)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 14.05.2015
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad
// При компиляции под *nix в файле проекта до раздела USES вставить строку {$DEFINE UseCThreads}
{$IFDEF FPC}
{$mode objfpc}{$H+}
    {$IFDEF WINDOWS}
        {$DEFINE FPC_WIN}
        {$DEFINE ALL_WIN}
    {$ELSE}
        {$DEFINE FPC_NIX}
    {$ENDIF}
{$ELSE}
    {$DEFINE WIN}
    {$DEFINE ALL_WIN}
{$ENDIF}

// для передачи строк между потоками используется выделенная память
{$DEFINE ALLOC_STRING}
// добавлять отладочную информацию с использованием модуля wlog
// для сборки демки необходимо включить (убрать точку)
{.$DEFINE WTHREAD_DEBUG_LOG}

interface

uses
    SysUtils,
    {$IFDEF WTHREAD_DEBUG_LOG}
     wlog,
    {$ENDIF}
    {$IFDEF UNIX} // добавить эти строки в модуль проекта при разработке не под windows
        //cthreads,
        //cmem,
    {$ENDIF}
    Classes
    {$IFNDEF FPC}
    ,Messages
    {$ENDIF}
    ,contnrs
    {$IFDEF ALL_WIN}
    ,Windows
    {$ENDIF}
    ,SyncObjs
    ;

const
    {$IFDEF FPC}
    //INFINITE            = Cardinal($FFFFFFFF);
    {$ENDIF}
    WM_USER             = $400;
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $300;

type
    PThreadMessage = ^TThreadMessage;
    TThreadMessage = record
        {$IFDEF FPC}
        Message: DWord;
        {$ELSE}
        Message: Word;
        {$ENDIF}
        WParam: Word;
        LParam: NativeInt;
    end;

    TWEvent = class(TEvent)
    protected
        FWHandle: THandle;
    public
        constructor Create; overload;
        destructor Destroy; override;
        procedure WSetEvent;
        procedure WResetEvent;
        function WWaitFor(const TimeOut: Cardinal): TWaitResult;
    end;


    TWThread = class;

        // событие на получение сообщения из потока
    TWThreadReceiveMessage = procedure(Sender: TWThread; var Msg: TThreadMessage) of object;
        // событие из потока на таймаут
    TWThreadTimeOut = procedure(Sender: TWThread) of object;

    { TWThread }

    TWThread = class(TThread)
    private
        FOwnerWThread: TWThread;
        FQueue: TQueue;
        FSection: TCriticalSection;
        FMessageEvent: TWEvent;
        FGUIThread: TThread;
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        FThreadName: string;
        {$IFDEF WTHREAD_DEBUG_LOG}
        FUseDebugLog: boolean;
        function intPostToLog(const Text: string): boolean; overload;
        function intPostToLog(const Text: string; const Level: TLogLevel): boolean; overload;
        {$ENDIF}
        function GetMsFromDateTime(const Value: TDateTime): Cardinal;
        procedure SetTimeOut(const Value: Cardinal);
        procedure FreeQueue;
    protected
        FTimeOut: Cardinal;
            // отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
        procedure PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
            // отправка сообщения из этого потока другому потоку (см. OwnerWThread)
        procedure PostMessageToWThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
        procedure DoTimeout;
        procedure Execute; override;
        function GetTimeOut: Cardinal; virtual;
            // процедура для очистки памяти в сообщениях, которые остались в очереди сообщений
            // при уничтожении потока
        procedure FreeMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt); virtual;
    public
        constructor Create(const AThreadName: string
        {$IFDEF WTHREAD_DEBUG_LOG}
                ; AUseDebugLog: Boolean
        {$ENDIF}
            ); overload;
        constructor Create(const AThreadName: string; CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
                , AUseDebugLog
        {$ENDIF}
                : Boolean); overload;
        destructor Destroy; override;
            // Две процедуры, которые выполняются в контексте потока. В начале и в конце.
        procedure InitThread; virtual;
        procedure DoneThread; virtual;
            // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
            // отправка любого сообщения В этот поток
        function PostToThreadMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt): Boolean;
            // остановка потока по феншую
        procedure StopThread;
            // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
            // доп.поток, которому отправляются сообщения с помощью PostMessageToWThread
        property OwnerWThread: TWThread read FOwnerWThread write FOwnerWThread;
            // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
            // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read GetTimeOut write SetTimeOut default INFINITE;
            // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
        {$IFDEF WTHREAD_DEBUG_LOG}
        property UseDebugLog: boolean read FUseDebugLog write FUseDebugLog default false;
        {$ENDIF}
        property ThreadName: string read FThreadName;
    end;

    // подготовка строки к обмену между потоками
function NewString(const Text: string): NativeInt;

    // возвращение строки к привычному виду после приема из другого потока
function FreeString(var P: NativeInt): String;

implementation

const
    WM_INTERNAL_BASE    = WM_USER+$100;
    WM_TIMEOUT          = WM_INTERNAL_BASE+1;

    SizeOfChar          = SizeOf(Char);

    // константы из DateUtils
    OneMillisecond      = 1 / MSecsPerDay;

{$IFDEF ALLOC_STRING}
{$IFDEF ALL_WIN}
// для передачи строки между программами
function GlobalNewString(const Text: string): NativeInt;
var l: Integer;
    p: pointer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := GlobalAlloc(GHND, l+SizeOfChar);
        if LongBool(Result) then begin
            {$HINTS OFF}
            p := GlobalLock(Result);
            {$HINTS ON}
            Move(Pointer(Text)^, Pointer(p)^, l);
            GlobalUnlock(Result);
        end
    end else
        Result := 0;
end;

// для передачи строки между программами
function GlobalFreeString(var P: NativeInt): String;
var ps: pointer;
begin
    if LongBool(P) then begin
        {$HINTS OFF}
        ps := GlobalLock(P);
        {$HINTS ON}
        SetLength(Result, Length(PChar(ps)));
        Move(Pointer(ps)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        GlobalUnlock(P);
        P := GlobalFree(P);
    end;
end;
{$ENDIF}

// для передачи строки в пределах одной программы
function FreeString(var P: NativeInt): String;
begin
    {$HINTS OFF}
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        {$IFDEF ALL_WIN}
        P := LocalFree(HLOCAL(P));
        {$ELSE}
        P := FreeMem(Pointer(P));
        {$ENDIF}
    end;
end;

// для передачи строки в пределах одной программы
function NewString(const Text: string): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        {$IFDEF ALL_WIN}
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        {$ELSE}
        Pointer(Result) := AllocMem(l+SizeOfChar);
        {$ENDIF}
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
        {$HINTS ON}
    end else
        Result := 0;
end;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    Result := '';
    NativeInt(Result) := P;
end;
{$ENDIF}

constructor TWEvent.Create;
begin
    {$IFDEF WINCE}
    FWHandle := CreateEvent(nil, false, false, nil);
    {$ELSE}
    inherited Create(nil, false, false, '');
    {$ENDIF}
end;

destructor TWEvent.Destroy;
begin
    {$IFDEF WINCE}
    CloseHandle(FWHandle);
    {$ELSE}
    inherited;
    {$ENDIF}
end;

procedure TWEvent.WResetEvent;
begin
    {$IFDEF WINCE}
    Windows.ResetEvent(FWHandle);
    {$ELSE}
    inherited ResetEvent;
    {$ENDIF}
end;

procedure TWEvent.WSetEvent;
begin
    {$IFDEF WINCE}
    Windows.SetEvent(FWHandle);
    {$ELSE}
    inherited SetEvent;
    {$ENDIF}
end;

function TWEvent.WWaitFor(const TimeOut: Cardinal): TWaitResult;
{$IFDEF WINCE}
var
    dw: DWord;
begin
    dw := WaitForSingleObject(FWHandle, TimeOut);
    case dw of
        WAIT_ABANDONED: result := wrAbandoned;
        WAIT_OBJECT_0: result := wrSignaled;
        WAIT_TIMEOUT: result := wrTimeout;
    else
        Result := wrError;
    end;
{$ELSE}
begin
    result := WaitFor(TimeOut);
{$ENDIF}
end;

type

    { TGUIThread }

    TGUIThread = class(TThread)
    private
        FMessageEvent: TWEvent;
        FTimeOut: Boolean;
        FOwner: TWThread;
        FQueue: TQueue;
        FSection: TCriticalSection;
        FCurrentMessage: TThreadMessage;
        procedure FreeQueue;
    protected
        procedure Execute; override;
        procedure CallGUIThread;
    public
        constructor Create(AOwner: TWThread); overload;
        destructor Destroy; override;
        procedure PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
        procedure StopThread;
    end;

{ TGUIThread }

procedure TGUIThread.FreeQueue;
var PMsg: PThreadMessage;
begin
    while FQueue.Count > 0 do begin
        PMsg := FQueue.Pop;
        FOwner.FreeMessage(PMsg^.Message, PMsg^.WParam, PMsg^.LParam);
    end;
end;

procedure TGUIThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WWaitFor(INFINITE);
        if (not Terminated) and (wr = wrSignaled) then begin
            if FTimeOut then begin
                FTimeOut := False;
                if Assigned(FOwner.FOnTimeOut) then
                    FOwner.FOnTimeOut(FOwner);
            end;
            while FQueue.Count > 0 do begin
                FSection.Enter;
                Message := FQueue.Pop;
                FSection.Leave;
                FCurrentMessage := Message^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    {$IFDEF FPC}
                    Synchronize(@CallGUIThread);
                    {$ELSE}
                    Synchronize(CallGUIThread);
                    {$ENDIF}
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.DoThreadReceiveMessage(FCurrentMessage.Message, FCurrentMessage.WParam, FCurrentMessage.LParam);
end;

constructor TGUIThread.Create(AOwner: TWThread);
begin
    inherited Create(False);
    FMessageEvent := TWEvent.Create;
    FQueue := TQueue.Create;
    FSection := TCriticalSection.Create;
    FOwner := AOwner;
end;

destructor TGUIThread.Destroy;
begin
    FreeQueue;
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

procedure TGUIThread.PostMessage(const Message: DWord; const WParam: Word; const LParam: NativeInt);
var Msg: PThreadMessage;
begin
    GetMem(Msg, SizeOf(TThreadMessage));
    Msg^.Message := Message;
    Msg^.WParam := WParam;
    Msg^.LParam := LParam;
    FSection.Enter;
    FQueue.Push(Msg);
    FSection.Leave;
    FMessageEvent.WSetEvent;
end;

procedure TGUIThread.StopThread;
begin
    Terminate;
    FMessageEvent.WSetEvent;
end;

{ TWThread }

constructor TWThread.Create(const AThreadName: string; CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        : Boolean);
begin
    inherited Create(CreateSuspended);
    {$IFDEF WTHREAD_DEBUG_LOG}
    FUseDebugLog := AUseDebugLog;
    {$ENDIF}
    if Length(AThreadName) = 0 then
        FThreadName := 'Thread'
    else
        FThreadName := AThreadName;
    FQueue := TQueue.Create;
    FMessageEvent := TWEvent.Create;
    FSection := TCriticalSection.Create;
    FGUIThread := TGUIThread.Create(Self);
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

constructor TWThread.Create(const AThreadName: string
    {$IFDEF WTHREAD_DEBUG_LOG}
    ; AUseDebugLog: Boolean
    {$ENDIF}
    );
begin
    Create(AThreadName, false
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        );
end;

destructor TWThread.Destroy;
begin
    FMessageEvent.Free;
    FreeQueue;
    FQueue.Free;
    FGUIThread.Free;
    FSection.Free;
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

// Процедура, выполняющая в контексте этого потока перед запуском очереди сообщений (в начале работы потока).
procedure TWThread.InitThread;
begin
    // empty
end;

// Процедура, выполняющая в контексте этого потока после отработки очереди сообщений (в конце работы потока).
procedure TWThread.DoneThread;
begin
    // empty
end;

procedure TWThread.DoThreadReceiveMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
var ThreadMsg: TThreadMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Message := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
end;

procedure TWThread.DoTimeout;
begin
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.WSetEvent;
end;

// отправка любого сообщения В этот поток
function TWThread.PostToThreadMessage(const Msg: Word; const WParam: Word;
    const LParam: NativeInt): Boolean;
var PMsg: PThreadMessage;
begin
    GetMem(PMsg, SizeOf(TThreadMessage));
    PMsg^.Message := Msg;
    PMsg^.WParam := WParam;
    PMsg^.LParam := LParam;
    FSection.Enter;
    FQueue.Push(PMsg);
    FSection.Leave;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog(Format('send to me msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
    {$ENDIF}
    FMessageEvent.WSetEvent;
    result := true;
end;

{$IFDEF WTHREAD_DEBUG_LOG}
{$B-}
function TWThread.intPostToLog(const Text: string): boolean;
begin
    result := intPostToLog(Text, WLL_NORMAL);
end;

function TWThread.intPostToLog(const Text: string; const Level: TLogLevel): boolean;
begin
    result := FUseDebugLog and PostToLog(Format('%s(%d) : %s', [FThreadName, Handle, Text]), Level);
end;
{$ENDIF}

function TWThread.GetMsFromDateTime(const Value: TDateTime): Cardinal;
begin
    Result := Round((Now - Value) / OneMillisecond);
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
    if FTimeOut <> Value then begin
        if (Value = 0) then
            FTimeOut := INFINITE
        else
            FTimeOut := Value;
        if not Suspended then
            FMessageEvent.WSetEvent;
    end;
end;

procedure TWThread.FreeQueue;
var PMsg: PThreadMessage;
begin
    while FQueue.Count > 0 do begin
        PMsg := FQueue.Pop;
        FreeMessage(PMsg^.Message, PMsg^.WParam, PMsg^.LParam);
    end;
end;

procedure TWThread.Execute;
var
    internalTimeout, ms: Cardinal;
    busy: TDateTime;
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog('started.');
    {$ENDIF}
    InitThread;
    internalTimeout := TimeOut;
    busy := 0;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog('main loop started.', WLL_EXTRA);
    {$ENDIF}
    while not Terminated do begin
        wr := FMessageEvent.WWaitFor(internalTimeout);
        busy := Now;
        if not Terminated then
            case WR of
                wrSignaled: begin
                    {$IFDEF WTHREAD_DEBUG_LOG}
                    intPostToLog(Format('got signal (queue cnt: %d).', [FQueue.Count]), WLL_EXTRA);
                    {$ENDIF}
                    while FQueue.Count > 0 do begin
                        FSection.Enter;
                        Message := FQueue.Pop;
                        FSection.Leave;
                        if (Message^.message >= WM_THREAD_BASE)
                            and (Message^.Message <= WM_THREAD_MAX) then begin
                                {$IFDEF WTHREAD_DEBUG_LOG}
                                intPostToLog(Format('dispatch msg %d (0x%0:x).', [Message^.Message]), WLL_EXTRA);
                                {$ENDIF}
                                Dispatch(Message^);
                            end else if (Message^.message >= WM_INTERNAL_BASE)
                                and (Message^.Message <= WM_THREAD_BASE) then begin // внутренние сообщения
                            end;
                        FreeMem(Message);
                    end;
                end;
                wrTimeout: begin
                    internalTimeout := TimeOut;
                    if FTimeOutIsDirect then begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog('DirectTimeOut.', WLL_EXTRA);
                        {$ENDIF}
                        DirectTimeOut;
                    end else begin
                        {$IFDEF WTHREAD_DEBUG_LOG}
                        intPostToLog('Sent TimeOut.', WLL_EXTRA);
                        {$ENDIF}
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                        // сообщение не занимает много времени, на точность не влияет
                        busy := 0;
                    end;
                end;
            end;
        // корректируем интервал таймаута на время выполнения кода выше
        if (busy <> 0) then begin
            ms := GetMsFromDateTime(busy);
            if (ms > TimeOut) then
                internalTimeout := 0
            else
                internalTimeout := TimeOut - ms;
        end else begin
            internalTimeout := TimeOut;
        end;
    end;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog('main loop stoped.', WLL_EXTRA);
    {$ENDIF}
    DoneThread;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog('stoped.', WLL_EXTRA);
    {$ENDIF}
end;

// отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
    if Assigned(FGUIThread) then begin
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
    {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('send to receiver msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
    {$ENDIF}
    end
    {$IFDEF WTHREAD_DEBUG_LOG}
    else begin
        intPostToLog(Format('cant send to receiver msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
    end;
    {$ENDIF}
end;

procedure TWThread.PostMessageToWThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
    if Assigned(FOwnerWThread) then begin
        FOwnerWThread.PostToThreadMessage(Msg, WParam, LParam);
   {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('send to %s(%d) msg: %d (0x%2:x).', [FOwnerWThread.FThreadName, FOwnerWThread.Handle, Msg]), WLL_EXTRA);
    end else begin
        intPostToLog(Format('cant send to other wthread msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
    {$ENDIF}
    end;
end;

// отправка любого сообщения В этот поток
procedure TWThread.StopThread;
begin
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.WSetEvent;
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog('stop signal.');
    {$ENDIF}
end;

function TWThread.GetTimeOut: Cardinal;
begin
    Result := FTimeOut;
end;

procedure TWThread.FreeMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
    // эту процедуру необходимо перекрыть для освобождения памяти, которая была выделена и
    // передана через очередь в этот или из этого потока (через GUIThread)
    // исп. в FreeQueue
end;

end.

unit wlog;
// wlog (c) wadman, 2015, 15.05.2015
// multithread safe logging

interface

// log level
type
    TLogLevel = (WLL_MINIMUM, WLL_NORMAL, WLL_MAXIMUM, WLL_EXTRA);

var // имя лог-файла (по ум. имя исполняемого файла с расширением log
    WLogFileName: string;
    // логирование включено (по ум. да)
    WLogEnabled: boolean;
    // очищать лог при каждом запуске (по ум. да)
    WLogClearOnStart: boolean;
    // уровень логирования по ум. см TLogLevel (по ум. WLL_NORMAL, т.е. MAXIMUM и EXTRA не будут логироваться)
    WLogLevel: TLogLevel;

function PostToLog(const Text: string): boolean; overload; // with WLL_NORMAL
function PostToLog(const Text: string; const Level: TLogLevel): boolean; overload;

implementation

uses SysUtils, WThread;

const
    WM_LOG      = WM_THREAD_BASE + 1;

type
    PLogRecord = ^TLogRecord;
    TLogRecord = record
        DT: TDateTime;
        PString: NativeInt;
    end;

    TLogThread = class(TWThread)
    private
        procedure WMLog(var Msg: TThreadMessage); message WM_LOG;
    end;

var
    LogThread: TLogThread;
    FirstLine: boolean;

function PostToLog(const Text: string): boolean;
begin
    result := PostToLog(Text, WLL_NORMAL);
end;

function PostToLog(const Text: string; const Level: TLogLevel): boolean;
var p: PLogRecord;
    d: TDateTime;
begin
    if SmallInt(Level) <= SmallInt(WLogLevel) then begin
        result := WLogEnabled and LongBool(LogThread);
        if result then begin
            d := Now;
            p := AllocMem(SizeOf(TLogRecord));
            p^.DT := d;
            p^.PString := NewString(Text);
{$HINTS OFF}
            result := LogThread.PostToThreadMessage(WM_LOG, 0, NativeInt(p));
{$HINTS ON}
            if not result then begin
                FreeString(p^.PString);
                FreeMem(p);
            end;
        end;
    end else
        Result := true;
end;

function InitLogs: boolean;
begin
    WLogFileName := ChangeFileExt(ParamStr(0), '.log');
    LogThread := TLogThread.Create('LogThread', false);
    result := LongBool(LogThread);
end;

procedure DoneLogs;
begin
    if LongBool(LogThread) then begin
        LogThread.StopThread;
        LogThread.Free;
    end;
end;

function AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, WLogFileName);
        if (FileExists(WLogFileName))and(not WLogClearOnStart) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            WLogClearOnStart := false;
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss.zzz', DT), Text]));
        CloseFile(t);
        result := true;
    finally
    end;
end;

{ TLogThread }

procedure TLogThread.WMLog(var Msg: TThreadMessage);
var p: PLogRecord;
begin
{$HINTS OFF}
    p := PLogRecord(Msg.LParam);
{$HINTS ON}
    AddToLog(p^.DT, FreeString(p^.PString));
    FreeMem(p);
end;

initialization
    WLogLevel := WLL_NORMAL;
    WLogEnabled := InitLogs;
    FirstLine := true;
    WLogClearOnStart := false;

finalization
    DoneLogs;

end.

unit main;

{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}

interface

uses
    Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
    wthread, wlog;

const
    WM_START_SEARCH     = WM_THREAD_BASE + 1;
    WM_FILE_FOUND       = WM_THREAD_BASE + 2;
    WM_JOB_START        = WM_THREAD_BASE + 3;
    WM_JOB_DONE         = WM_THREAD_BASE + 4;

type

    // этот поток ищет файлы

    { TSearchThread }

    TSearchThread = class(TWThread)
        // ищет файлы по указанному пути и маске
        procedure WMStartSearch(var Msg: TThreadMessage); message WM_START_SEARCH;
    end;

    // этот поток обрабатывает файл

    { TJobThread }

    TJobThread = class(TWThread)
    private
        FIsBusy: boolean;
        procedure WMJobStart(var Msg: TThreadMessage); message WM_JOB_START;
        procedure DoneThread; override;
    public
        property IsBusy: boolean read FIsBusy write FIsBusy;
    end;

    // менеджер потоков

    { TManageThread }

    TManageThread = class(TWThread)
        // поток для поиска файлов
        FSearchThread: TSearchThread;
        // потоки для обработки файлов
        FJobThreads: array [0..3] of TJobThread;
        // найденные файлы
        FFoundFiles: TStringList;
        // запускает поток, который будет искать нужные файлы
        procedure WMStartSearch(var Msg: TThreadMessage); message WM_START_SEARCH;
        // запускает поток на обработку
        procedure WMFileFound(var Msg: TThreadMessage); message WM_FILE_FOUND;
        // обработка файла закончена: отдаем потоку следующий файл, если есть в FFoundFiles
        procedure WMJobDone(var Msg: TThreadMessage); message WM_JOB_DONE;
        // инициализация потока
        procedure InitThread; override;
        // деинициализация потока
        procedure DoneThread; override;
        // возвращает свободный поток для обработки
        function GetFreeJobThread: TJobThread;
    end;

type

    { TForm1 }

    TForm1 = class(TForm)
        Button1: TButton;
        procedure Button1Click(Sender: TObject);
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
    private
        FManageThread: TManageThread;
        procedure StartManager;
        procedure StopManager;
    public
    end;

var
    Form1: TForm1;

implementation

{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}

{ TManageThread }

procedure TManageThread.WMStartSearch(var Msg: TThreadMessage);
begin
    // 3) отдаем команду потоку искать файлы по пути и маске
    FSearchThread.PostToThreadMessage(WM_START_SEARCH, 0, Msg.LParam);
end;

procedure TManageThread.WMFileFound(var Msg: TThreadMessage);
var job: TJobThread;
begin
    // 7) найден файл: ищем свободный поток для его обработки
    job := GetFreeJobThread;
    if Assigned(job) then begin
        // 8) свободный поток найден: запускаем обработку, передав ему имя файла напрямую
        job.IsBusy := true;
        job.PostToThreadMessage(WM_JOB_START, 0, Msg.LParam);
    end else begin
        // 9) свободный поток не найден: запоминаем его для последующей обработки по сообщению WM_JOB_DONE
        FFoundFiles.Add(FreeString(Msg.LParam));
    end;
end;

procedure TManageThread.WMJobDone(var Msg: TThreadMessage);
var job: TJobThread;
begin
    // освободившийся поток
    job := TJobThread(Msg.LParam);
    // 11) поток обработчик освободился
    if FFoundFiles.Count > 0 then begin
        // 12) есть не обработанные файлы
        job.PostToThreadMessage(WM_JOB_START, 0, NewString(FFoundFiles[0]));
        FFoundFiles.Delete(0);
    end else begin
        // файлов на обработку нет: выставляем флаг незанятости
        job.IsBusy := false;
    end;
    // если файлов на обработку нет, то поток "засыпает" до следующей команды
end;

procedure TManageThread.InitThread;
var i: integer;
begin
    // эта процедура выполняется в контексте доп. потока
    // здесь происходит инициализация объекто/потоков
    FFoundFiles := TStringList.Create;
    FSearchThread := TSearchThread.Create('SearchThread', false, true);
    FSearchThread.OwnerWThread := Self;
    for i := Low(FJobThreads) to High(FJobThreads) do begin
        FJobThreads[i] := TJobThread.Create(FOrmat('JobThread-%d', [i]), false, true);
        FJobThreads[i].OwnerWThread := Self;
    end;
end;

procedure TManageThread.DoneThread;
var i: integer;
begin
    // эта процедура выполняется в контексте доп. потока
    // здесь мы останавливаем другие потоки и подчищаем за собой
    FSearchThread.StopThread;
    FSearchThread.Free;
    for i := Low(FJobThreads) to High(FJobThreads) do begin
        FJobThreads[i].StopThread;
        FJobThreads[i].Free;
    end;
    FFoundFiles.Free;
end;

function TManageThread.GetFreeJobThread: TJobThread;
var i: integer;
begin
    for i := Low(FJobThreads) to High(FJobThreads) do begin
        if not FJobThreads[i].IsBusy then
            exit(FJobThreads[i]);
    end;
    result := nil;
end;

{ TJobThread }

procedure TJobThread.WMJobStart(var Msg: TThreadMessage);
var fileName: string;
begin
    // 10) симулируем долгую, трудную обработку файла
    fileName := FreeString(Msg.LParam);
    PostToLog(Format('Job: %s', [fileName]));
    //Sleep(1000);
    // отправляем имя обработанного файла потоку-менеджеру.
    PostMessageToWThread(WM_JOB_DONE, 0, NativeInt(Self));
end;

procedure TJobThread.DoneThread;
begin
end;

{ TSearchThread }

procedure TSearchThread.WMStartSearch(var Msg: TThreadMessage);
var path_and_mask: string;
    path, mask: string;

  procedure Search(const APath, AMask: string);
  var sr: TSearchRec;
      i: integer;
      ar: TStringList;
  begin
      ar := TStringList.Create;
      ar.Delimiter := ';';
      ar.DelimitedText := AMask;
      for i := 0 to ar.Count-1 do
          if (not Terminated) and (FindFirst(APath + Trim(ar[i]), faReadOnly or faArchive, sr) = 0) then begin
              // 6) сообщаем менеджеру о найденном файле
              PostMessageToWThread(WM_FILE_FOUND, 0, NewString(IncludeTrailingBackslash(APath) + sr.Name));
              break;
          end else
              FindClose(sr);
      FindClose(sr);
      if FindFirst(APath + '*', faDirectory, sr) = 0 then begin
          // ищем во всем подпапках / рекурсивный поиск
          repeat
              if LongBool((sr.Attr and faDirectory)) then begin
                  if (sr.Name <> '.') and (sr.Name <> '..') then
                      Search(IncludeTrailingBackslash(APath+sr.Name), AMask);
              end;
          until Terminated or LongBool(FindNext(sr));
          FindClose(sr);
      end;
      ar.free;
  end;

begin
    // 4) получаем строку, переданную на шаге 2
    path_and_mask := FreeString(Msg.LParam);
    path := Copy(path_and_mask, 1, Pos('|', path_and_mask)-1);
    mask := Copy(path_and_mask, Pos('|', path_and_mask)+1, 255);
    // 5) запускаем рекурсивный поиск
    Search(path, mask);
end;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
    StopManager;
    StartManager;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    // устанавливаем максимульную детальность лога
    WLogLevel := WLL_EXTRA;
    // лог очищается при каждом запуске
    WLogClearOnStart := true;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    StopManager;
end;

procedure TForm1.StartManager;
begin
    // 1) запускаем поток менеджер
    FManageThread := TManageThread.Create('ManageThread', false, true);
    // 2) отдаем ему команду на начало поиска по пути и маске. | - разделитель между путем и масками, ; - разделитель между масками
    FManageThread.PostToThreadMessage(WM_START_SEARCH, 0, NewString('D:\|*.pas;*.inc'));
end;

procedure TForm1.StopManager;
begin
    if Assigned(FManageThread) then begin
        // если поток создан, то останавливаем его и уничтожаем
        FManageThread.StopThread;
        FManageThread.Free;
        FManageThread := nil;
    end;
end;

end.

unit main;

{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}

interface

uses
    Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
    wthread, wlog;

const
    WM_START_SEARCH     = WM_THREAD_BASE + 1;
    WM_FILE_FOUND       = WM_THREAD_BASE + 2;
    WM_JOB_START        = WM_THREAD_BASE + 3;
    WM_JOB_DONE         = WM_THREAD_BASE + 4;

type

    // этот поток ищет файлы

    { TSearchThread }

    TSearchThread = class(TWThread)
        // ищет файлы по указанному пути и маске
        procedure WMStartSearch(var Msg: TThreadMessage); message WM_START_SEARCH;
    end;

    // этот поток обрабатывает файл

    { TJobThread }

    TJobThread = class(TWThread)
    private
        FIsBusy: boolean;
        procedure WMJobStart(var Msg: TThreadMessage); message WM_JOB_START;
        procedure FreeMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt); override;
    public
        property IsBusy: boolean read FIsBusy write FIsBusy;
    end;

    // менеджер потоков

    { TManageThread }

    TManageThread = class(TWThread)
        // поток для поиска файлов
        FSearchThread: TSearchThread;
        // потоки для обработки файлов
        FJobThreads: array [0..3] of TJobThread;
        // найденные файлы
        FFoundFiles: TStringList;
        // запускает другие потоки, которые будут искать и обрабатывать файлы
        procedure WMStartSearch(var Msg: TThreadMessage); message WM_START_SEARCH;
        // запускает поток на обработку
        procedure WMFileFound(var Msg: TThreadMessage); message WM_FILE_FOUND;
        // обработка файла закончена: отдаем потоку следующий файл, если есть в FFoundFiles
        procedure WMJobDone(var Msg: TThreadMessage); message WM_JOB_DONE;
        // инициализация потока
        procedure InitThread; override;
        // деинициализация потока
        procedure DoneThread; override;
        // возвращает свободный поток для обработки
        function GetFreeJobThread: TJobThread;
        procedure FreeMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt); override;
    end;

type

    { TForm1 }

    TForm1 = class(TForm)
        Button1: TButton;
        procedure Button1Click(Sender: TObject);
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
    private
        FManageThread: TManageThread;
        procedure StartManager;
        procedure StopManager;
    public
    end;

var
    Form1: TForm1;

implementation

{$IFDEF FPC}
{$R *.lfm}
{$ElSE}
{$R *.dfm}
{$ENDIF}

{ TManageThread }

procedure TManageThread.WMStartSearch(var Msg: TThreadMessage);
begin
    // 3) отдаем команду потоку искать файлы по пути и маске
    FSearchThread.PostToThreadMessage(WM_START_SEARCH, 0, Msg.LParam);
end;

procedure TManageThread.WMFileFound(var Msg: TThreadMessage);
var job: TJobThread;
begin
    // 7) найден файл: ищем свободный поток для его обработки
    job := GetFreeJobThread;
    if Assigned(job) then begin
        // 8) свободный поток найден: запускаем обработку, передав ему имя файла напрямую
        job.IsBusy := true;
        job.PostToThreadMessage(WM_JOB_START, 0, Msg.LParam);
    end else begin
        // 9) свободный поток не найден: запоминаем его для последующей обработки по сообщению WM_JOB_DONE
        FFoundFiles.Add(FreeString(Msg.LParam));
    end;
end;

procedure TManageThread.WMJobDone(var Msg: TThreadMessage);
var job: TJobThread;
begin
    // освободившийся поток
    job := TJobThread(Msg.LParam);
    // 11) поток обработчик освободился
    if FFoundFiles.Count > 0 then begin
        // 12) есть не обработанные файлы
        job.PostToThreadMessage(WM_JOB_START, 0, NewString(FFoundFiles[0]));
        FFoundFiles.Delete(0);
    end else begin
        // файлов на обработку нет: выставляем флаг незанятости
        job.IsBusy := false;
    end;
    // если файлов на обработку нет, то поток "засыпает" до следующей команды
end;

procedure TManageThread.InitThread;
var i: integer;
begin
    // эта процедура выполняется в контексте доп. потока
    // здесь происходит инициализация объекто/потоков
    FFoundFiles := TStringList.Create;
    FSearchThread := TSearchThread.Create(Self, 'SearchThread', false, true);
    for i := Low(FJobThreads) to High(FJobThreads) do begin
        FJobThreads[i] := TJobThread.Create(Self, Format('JobThread-%d', [i]), false, true);
    end;
end;

procedure TManageThread.DoneThread;
var i: integer;
begin
    // эта процедура выполняется в контексте доп. потока
    // здесь мы останавливаем другие потоки и подчищаем за собой
    FSearchThread.StopThread;
    FSearchThread.Free;
    for i := Low(FJobThreads) to High(FJobThreads) do begin
        FJobThreads[i].StopThread;
        FJobThreads[i].Free;
    end;
    FFoundFiles.Free;
end;

procedure TManageThread.FreeMessage(const Msg, WParam: Word; const LParam: NativeInt);
var P: NativeInt;
begin
    P := LParam;
    FreeString(P);
end;

function TManageThread.GetFreeJobThread: TJobThread;
var i: integer;
begin
    for i := Low(FJobThreads) to High(FJobThreads) do begin
        if not FJobThreads[i].IsBusy then
            exit(FJobThreads[i]);
    end;
    result := nil;
end;

{ TJobThread }

procedure TJobThread.FreeMessage(const Msg, WParam: Word; const LParam: NativeInt);
var P: NativeInt;
begin
    P := LParam;
    FreeString(P);
end;

procedure TJobThread.WMJobStart(var Msg: TThreadMessage);
var fileName: string;
begin
    // 10) симулируем долгую, трудную обработку файла
    fileName := FreeString(Msg.LParam);
    PostToLog(Format('Job: %s', [fileName]));
    //Sleep(1000);
    // отправляем имя обработанного файла потоку-менеджеру.
    PostMessageToWThread(WM_JOB_DONE, 0, NativeInt(Self));
end;

{ TSearchThread }

procedure TSearchThread.WMStartSearch(var Msg: TThreadMessage);
var path_and_mask: string;
    path, mask: string;

  procedure Search(const APath, AMask: string);
  var sr: TSearchRec;
      i: integer;
      ar: TStringList;
  begin
      ar := TStringList.Create;
      ar.Delimiter := ';';
      ar.DelimitedText := AMask;
      for i := 0 to ar.Count-1 do
          if (not Terminated) and (FindFirst(APath + Trim(ar[i]), faAnyFile and (not faDirectory), sr) = 0) then begin
              repeat
                  // 6) сообщаем менеджеру о найденном файле
                  PostMessageToWThread(WM_FILE_FOUND, 0, NewString(IncludeTrailingBackslash(APath) + sr.Name));
              until Terminated or LongBool(FindNext(sr));
              break;
          end else
              FindClose(sr);
      FindClose(sr);
      if FindFirst(APath + '*', faDirectory, sr) = 0 then begin
          // ищем во всем подпапках / рекурсивный поиск
          repeat
              if LongBool((sr.Attr and faDirectory)) then begin
                  if (sr.Name <> '.') and (sr.Name <> '..') then
                      Search(IncludeTrailingBackslash(APath+sr.Name), AMask);
              end;
          until Terminated or LongBool(FindNext(sr));
          FindClose(sr);
      end;
      ar.free;
  end;

begin
    // 4) получаем строку, переданную на шаге 2
    path_and_mask := FreeString(Msg.LParam);
    path := Copy(path_and_mask, 1, Pos('|', path_and_mask)-1);
    mask := Copy(path_and_mask, Pos('|', path_and_mask)+1, 255);
    // 5) запускаем рекурсивный поиск
    Search(path, mask);
end;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
    StopManager;
    StartManager;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    // устанавливаем максимульную детальность лога
    WLogLevel := WLL_EXTRA;
    WLogClearOnStart := true;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    StopManager;
end;

procedure TForm1.StartManager;
begin
    // 1) запускаем поток менеджер
    FManageThread := TManageThread.Create(nil, 'ManageThread', false, true);
    // 2) отдаем ему команду на начало поиска по пути и маске. | - разделитель между путем и масками, ; - разделитель между масками
    FManageThread.PostToThreadMessage(WM_START_SEARCH, 0, NewString('D:\!\|*.pas'));
end;

procedure TForm1.StopManager;
begin
    if Assigned(FManageThread) then begin
        // если поток создан, то останавливаем его и уничтожаем
        FManageThread.StopThread;
        FManageThread.Free;
        FManageThread := nil;
    end;
end;

end.