unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&linux)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 23.04.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}

interface

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

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;

    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: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FQueueReady: boolean;
        FQueueMessages: array of TThreadMessage;
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        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; overload;
        constructor Create(CreateSuspended: 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;
    end;

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

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

implementation

{$IFNDEF FPC}
uses Windows;
{$ENDIF}

const
{$IFDEF ALL_WIN}
    WM_THREAD_READY     = WM_USER+$102;
{$ENDIF}
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);

    // константы из DateUtils
    OneHour             = 1 / 24;
    OneMinute           = 1 / MinsPerDay;
    OneSecond           = 1 / SecsPerDay;
    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
            p := GlobalLock(Result);
            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
        ps := GlobalLock(P);
        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
    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);
    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}

{$IFDEF FPC}
type

    { TGUIThread }

    TGUIThread = class(TThread)
    private
        FMessageEvent: TEvent;
        FTimeOut: Boolean;
        FOwner: TWThread;
        FQueue: TList;
        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 List: TList);
var i: integer;
begin
    for i := 0 to List.Count-1 do
        FreeMem(List[i]);
end;

procedure TGUIThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WaitFor(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[0];
                FQueue.Delete(0);
                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 := TEvent.Create(nil, False, False, '');
    FQueue := TList.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.Add(Msg);
    FSection.Leave;
    FMessageEvent.SetEvent;
end;

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

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
{$IFDEF FPC}
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    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;
begin
    Create(False);
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.SetEvent;
{$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.Add(PMsg);
    FSection.Leave;
    FMessageEvent.SetEvent;
    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;
        result := True;
    end;
{$ENDIF}
end;

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.SetEvent;
    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
    InitThread;
    internalTimeout := TimeOut;
    busy := 0;
    while not Terminated do begin
        wr := FMessageEvent.WaitFor(internalTimeout);
        busy := Now;
        if not Terminated then
            case WR of
                wrSignaled: while FQueue.Count > 0 do begin
                    FSection.Enter;
                    Message := FQueue[0];
                    FQueue.Delete(0);
                    FSection.Leave;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    internalTimeout := TimeOut;
                    if FTimeOutIsDirect then begin
                        DirectTimeOut;
                    end else begin
                        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
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, THandle(-1), WM_USER, WM_USER, PM_NOREMOVE);
    internalTimeout := TimeOut;
    busy := 0;
    InitThread;
    HandlesToWaitFor[0] := hCloseEvent;
    PostMessageFromThread(WM_THREAD_READY, 0, 0);

    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
                        DirectTimeOut;
                    end else begin
                        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;
                // ищем и вызываем 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;
end;

// отправка сообщения из этого потока для вызова обработчика OnThreadReceiveMessage
procedure TWThread.PostMessageFromThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
begin
{$IFDEF FPC}
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Msg, WParam, LParam);
{$ELSE}
    if FToolWindow <> 0 then begin
        PostMessage(FToolWindow, Msg, WParam, LParam);
    end;
{$ENDIF}
end;

// отправка любого сообщения В этот поток
procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$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.