unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&*nix)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2016, версия от 15.01.2016
//
// использование:
// 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_WTHREAD_BASE     = WM_USER + $110;
    WM_WTHREAD_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;
        {$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;
        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;
        {$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);
            // отправка сообщения из этого потока другому потоку (см. 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;
        // проверяет, что выполнение идет в этом (доп) потоке
        function ItsMe: boolean;
            // процедура для очистки памяти в сообщениях, которые остались в очереди сообщений
            // при уничтожении потока
        procedure FreeMessage(const Msg: Word; const WParam: Word; const LParam: NativeInt); virtual;
    public
        constructor Create(const AOwnerThread: TWThread; const AThreadName: string
        {$IFDEF WTHREAD_DEBUG_LOG}
                ; AUseDebugLog: Boolean
        {$ENDIF}
            ); overload;
        constructor Create(const AOwnerThread: TWThread; const AThreadName: string; CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
                , AUseDebugLog
        {$ENDIF}
                : Boolean); overload;
        constructor Create(CreateSuspended: boolean); overload;
        constructor Create(); 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

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

const
    WM_INTERNAL_BASE    = WM_USER+$100;
    WM_TIMEOUT          = WM_INTERNAL_BASE+1;
    {$IFNDEF FPC}
    WM_THREAD_READY     = WM_INTERNAL_BASE+2;
    {$ENDIF}

    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;
        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_WTHREAD_BASE)
                    and(FCurrentMessage.Message <= WM_WTHREAD_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;
    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(const AOwnerThread: TWThread; const AThreadName: string; CreateSuspended
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        : Boolean);
begin
    inherited Create(CreateSuspended);
    FOwnerWThread := AOwnerThread;
    {$IFDEF WTHREAD_DEBUG_LOG}
    FUseDebugLog := AUseDebugLog;
    {$ENDIF}
    if Length(AThreadName) = 0 then
        FThreadName := 'Thread'
    else
        FThreadName := AThreadName;
    {$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(const AOwnerThread: TWThread; const AThreadName: string
    {$IFDEF WTHREAD_DEBUG_LOG}
    ; AUseDebugLog: Boolean
    {$ENDIF}
    );
begin
    Create(AOwnerThread, AThreadName, false
        {$IFDEF WTHREAD_DEBUG_LOG}
        , AUseDebugLog
        {$ENDIF}
        );
end;

constructor TWThread.Create(CreateSuspended: boolean);
begin
    Create(nil, '', CreateSuspended
    {$IFDEF WTHREAD_DEBUG_LOG}
    , false
    {$ENDIF}
    );
end;

constructor TWThread.Create;
begin
    Create(false);
end;

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

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

function TWThread.ItsMe: boolean;
begin
    result := GetCurrentThreadId = ThreadID;
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('send to me msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
    {$ENDIF}
    FMessageEvent.WSetEvent;
    result := true;
{$ELSE}
begin
    if FQueueReady then begin
        // если очередь сообщений создана и поток инициализирован, то сразу отправляем
        result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
        {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('send to me msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
        {$ENDIF}
    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('cached to me msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
        {$ENDIF}
        result := True;
    end;
{$ENDIF}
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
{$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(not ItsMe) then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
{$ENDIF}
end;

procedure TWThread.FreeQueue;
{$IFDEF FPC}
var PMsg: PThreadMessage;
begin
    while FQueue.Count > 0 do begin
        PMsg := FQueue.Pop;
        FreeMessage(PMsg^.Message, PMsg^.WParam, PMsg^.LParam);
    end;
{$ELSE}
begin
{$ENDIF}
end;

procedure TWThread.Execute;
var
    internalTimeout, ms: Cardinal;
    busy: TDateTime;
{$IFDEF FPC}
    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_WTHREAD_BASE)
                            and (Message^.Message <= WM_WTHREAD_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_WTHREAD_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;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

    while not Terminated do begin
          if (not PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then begin
            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('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;
                    // выставляем новый интервал за минусом времени выполнения процедуры таймаута
                    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(msg.hwnd) then begin
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                // изменен таймаут
                FTimeOut := msg.wParam;
                busy := 0;
            end;
            WM_WTHREAD_BASE..WM_WTHREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                {$IFDEF WTHREAD_DEBUG_LOG}
                intPostToLog(Format('dispatch msg %d (0x%0:x).', [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}
{$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
{$IFDEF FPC}
    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
{$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
        {$IFDEF WTHREAD_DEBUG_LOG}
        intPostToLog(Format('send to receiver msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
        {$ENDIF}
    end
{$ENDIF}
    {$IFDEF WTHREAD_DEBUG_LOG}
    else
        intPostToLog(Format('cant send to receiver msg: %d (0x%0:x).', [Msg]), WLL_EXTRA);
    {$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
    {$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.WSetEvent;
    {$ELSE}
    SetLength(FQueueMessages, 0);
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
    {$ENDIF}
    {$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;

{$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_WTHREAD_BASE..WM_WTHREAD_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-2016, 19.01.2016
// multithread safe logging

interface

// log level
type
    TLogLevel = (
        WLL_MINIMUM     = 1,
        WLL_NORMAL      = 2,
        WLL_MAXIMUM     = 3,
        WLL_EXTRA       = 4
    );

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;
procedure EraseLog;

implementation

uses Windows, SysUtils, WThread;

const
    WM_LOG      = WM_WTHREAD_BASE + 1;
    WM_ERASE    = WM_WTHREAD_BASE + 2;

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

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

var
    LogThread: TLogThread;
    FirstLine: boolean;
    log: TextFile;
    FileOpened: 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;

procedure EraseLog;
begin
    LogThread.PostToThreadMessage(WM_ERASE, 0, 0);
end;

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

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

function OpenLog: boolean;
begin
    result := false;
    try
        AssignFile(log, WLogFileName);
        if (FileExists(WLogFileName))and(not WLogClearOnStart) then begin
            Append(log);
            if FirstLine then begin
                WriteLn(log);
                FirstLine := false;
            end;
        end else begin
            WLogClearOnStart := false;
            Rewrite(log);
        end;
        result := true;
    finally

    end;
end;

function CloseLog: boolean;
begin
    result := false;
    try
        CloseFile(log);
        result := true;
    finally

    end;
end;

function AddToLog(const DT: TDateTime; const Text: string): boolean;

    function ClearText(const AText: string): String;
    var i: integer;
    begin
        result := AText;
        for I := 1 to Length(result) do
            if CharInSet(result[i], [#0..#31]) then
                result[i] := '.';
    end;

begin
    result := false;
    try
        WriteLn(log, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss.zzz', DT), ClearText(Text)]));
        result := true;
    finally
    end;
end;

{ TLogThread }

procedure TLogThread.WMLog(var Msg: TThreadMessage);
var p: PLogRecord;
    m: TMsg;
begin
{$HINTS OFF}
    p := PLogRecord(Msg.LParam);
{$HINTS ON}
    if (not FileOpened) then
        FileOpened := OpenLog;
    if FileOpened then
        AddToLog(p^.DT, FreeString(p^.PString));
    if (not PeekMessage(m, Handle, WM_LOG, WM_LOG, PM_NOREMOVE)) or Terminated then
        FileOpened := not CloseLog;
    FreeMem(p);
end;

procedure TLogThread.WMErase(var Msg: TThreadMessage);
var f: File;
begin
    if FileOpened then
        FileOpened := not CloseLog;
    try
        if (not FileOpened) and (FileExists(WLogFileName)) then begin
            AssignFile(f, WLogFileName);
            Erase(f);
        end;
    finally

    end;
end;

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

finalization
    DoneLogs;

end.