Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Delphi Новый топик    Ответить
Топик располагается на нескольких страницах: Ctrl  назад   1 2 3 [4] 5 6 7 8 9 10 .. 19   вперед  Ctrl
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Док
Member

Откуда: Казань
Сообщений: 6287
wadman
почему, хэлп ответит

т.е. у тебя еще и шкатулка с секретом?

Тогда нафиг, сам себе напишу
12 окт 13, 11:47    [14960158]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
Пока что самая последняя версия.

Модуль:
+
unit WThread;
// модуль для работы с доп.потоками
// позволяет "общаться" дополнительному и основному потокам посредством системной очереди сообщений
// без вызова синхронизации
// (c) wadman 2013

// использование:
// 1. Создать наследника с объявленными обработчиками сообщений между WM_THREAD_BASE и WM_THREAD_MAX
//     пример: procedure WMTestProc(var Msg: TMessage); message WM_TEST_PROC;
// 2. Присвоить обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
// Для обмена строками рекомендууется использовать функции NewString и FreeString

interface

uses
    Classes,
    Windows,
    Messages,
    SysUtils;

const
    WM_THREAD_BASE      = WM_USER + $110;
    WM_THREAD_MAX       = WM_USER + $7FFF;

type
    TWThread = class;

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

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
        procedure WWindowProc(var Msg: TMessage);
        // отправка сообщения из этого потока для вызова обрабочика OnThreadReceiveMessage
        procedure SendMessageFromMe(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
        procedure DoThreadReceiveMessage(var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
        procedure DoTimeout;
        procedure Execute; override;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
        // см TimeOutIsDirect, при true - перекрыть следующую процедуру
        procedure DirectTimeOut; virtual;
        // отправка любого сообщения В этот поток
        function SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // остановка потока по феншую
        function StopThread: boolean;
        // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
        // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
        // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read FTimeOut write SetTimeOut default INFINITE;
        // true = Будет вызван DirectTimeOut из этого потока, false = вызвано событие OnTimeOut в основном потоке.
        property TimeOutIsDirect: boolean read FTimeOutIsDirect write FTimeOutIsDirect default false;
    end;

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

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

implementation

const
    WM_MSG              = WM_USER+$100;
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);

function NewString(const Text: string): LPARAM;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: LPARAM): String;
begin
    LPARAM(Result) := P;
end;

{function FreeString(var P: LPARAM): String;
begin
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): LPARAM;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > 0 then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;    }

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited;
    FToolWindow := AllocateHWnd(WWindowProc);
    hCloseEvent := CreateEvent(nil, true, false, nil);
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
end;

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

destructor TWThread.Destroy;
begin
    CloseHandle(hCloseEvent);
    DeallocateHWnd(FToolWindow);
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
end;

procedure TWThread.DoThreadReceiveMessage(var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
begin
    if Assigned(FOnThreadReceiveMessage) then
        FOnThreadReceiveMessage(Self, Msg, WParam, LParam);
end;

procedure TWThread.DoTimeout;
begin
    if Assigned(FOnTimeOut) then
        FOnTimeOut(Self);
end;

function TWThread.SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
begin
    result := (not Suspended)and(PostThreadMessage(ThreadID, AMsg, wParam, lParam));
end;

procedure TWThread.SetTimeOut(const Value: Cardinal);
begin
    if FTimeOut <> Value then begin
        FTimeOut := Value;
        if not Suspended then
            PostThreadMessage(ThreadID, WM_TIMEOUT, Value, 0);
    end;
end;

procedure TWThread.Execute;
var
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;
    message: TMessage;

    MSWait: Cardinal;
Label
    EndOfThread;
begin
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    //SleepEx(20, true);

    MSWait := FTimeOut; // изменяя кол-во миллисекунд в MSWait можно организовать событие-таймер, см WAIT_TIMEOUT
                        // в данном случае установлено бесконечное ожидание любого события

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    if not FreeOnTerminate then
                        Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    Continue;
                end;
                WAIT_TIMEOUT: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        SendMessageFromMe(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if msg.hwnd <> 0 then begin
            TranslateMessage(msg);
            DispatchMessage(msg);
            Continue;
        end;
        case msg.message of
            WM_QUIT, WM_CLOSE, WM_DESTROY: begin // оконные сообщения тоже получаем
                if not FreeOnTerminate then
                    Terminate;
                goto EndOfThread;
            end;
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end
            else begin
                message.Msg := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

procedure TWThread.SendMessageFromMe(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, Msg, WParam, LParam);
end;

function TWThread.StopThread: boolean;
begin
    SetEvent(hCloseEvent);
    SleepEx(1, false);
    Result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
end;

procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        end;
        WM_THREAD_BASE..WM_USER+WM_THREAD_MAX: begin
            DoThreadReceiveMessage(Msg.Msg, Msg.WParam, Msg.LParam);
            Msg.Result := 1;
        end
    else
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

end.


Пример использования:
+
unit ThreadTestMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, WThread;

const
    WM_STRING   = WM_THREAD_BASE + 1;

type
    TMyThread = class(TWThread)
    private
        procedure ReceiveString(var Msg: TMessage); message WM_STRING;
    end;

  TfrmWThreadTest = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FThread: TMyThread;
    procedure ReceiveMsg(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
    procedure StartThread;
    procedure StopThread;
  public
  end;

var
  frmWThreadTest: TfrmWThreadTest;

implementation

{$R *.dfm}

procedure TfrmWThreadTest.Button1Click(Sender: TObject);
begin
    if LongBool(FThread) then
        StopThread
    else
        StartThread;
end;

procedure TfrmWThreadTest.Button2Click(Sender: TObject);
var s: string;
begin
    if LongBool(FThread) and InputQuery('Input', 'Enter text', s) then begin
        // отправляем введенную строку в доп. поток
        Memo1.Lines.Add(Format('-> %s', [s]));
        FThread.SendToThreadMessage(WM_STRING, 0, NewString(s));
        s := '';
    end;
end;

procedure TfrmWThreadTest.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    if LongBool(FThread) then
        StopThread;
end;

procedure TfrmWThreadTest.ReceiveMsg(Sender: TWThread; var Msg: Cardinal; var WParam: WPARAM; var LParam: LPARAM);
begin
    case Msg of
        WM_STRING: begin
            Memo1.Lines.Add(Format('<- %s', [FreeString(LParam)]));
        end;
    end;
end;

procedure TfrmWThreadTest.StartThread;
begin
    if not LongBool(FThread) then begin
        FThread := TMyThread.Create(false);
        FThread.OnThreadReceiveMessage := ReceiveMsg;
    end;
end;

procedure TfrmWThreadTest.StopThread;
begin
    if LongBool(FThread) then begin
        if not FThread.StopThread then
            MessageDlg('You dont kill me!', mtError, [mbOk], 0);
        FThread.Free;
        FThread := nil;
    end;
end;

{ TMyThread }

procedure TMyThread.ReceiveString(var Msg: TMessage);
var s: string;
begin
    s := FreeString(Msg.LParam);
    // отправляем полученную строку обратно главному потоку
    SendMessageFromMe(Msg.Msg, Msg.WParam, NewString(s));
    sleep(5000);
    SendMessageFromMe(Msg.Msg, Msg.WParam, NewString(s));
end;

end.
17 окт 13, 10:11    [14983758]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
fd00ch
Member

Откуда: Нижний Новгород
Сообщений: 5913
wadman, а что произойдет с сообщениями, которые были отправлены ToolWindow в конце Execute, если след.командой будет вызов деструктора, где проиходит уничтожение этого самого ToolWindow?
17 окт 13, 14:12    [14985468]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
fd00ch
а что произойдет с сообщениями

Улетят в пустоту. Так же как и те, которые будут отправлены в поток до создания очереди сообщений для него, т.к. очередь для потока создается с небольшой задержкой.
17 окт 13, 15:00    [14985824]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Gator
Member

Откуда: Москва
Сообщений: 14535
wadman, Вы ChangeLog ведёте? Скрываете? :)
17 окт 13, 23:36    [14988437]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
Gator
wadman, Вы ChangeLog ведёте? Скрываете? :)

Таки нет. Впечатление, что такие мелочи не требуют соблюдения формальностей. На вопросы "что как и почему" отвечаю.
18 окт 13, 09:05    [14995425]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
Поколение Next: Delphi&Lazarus. В виду отсутствия некоторых приятностей в Лазарусе пришлось немного извернуться. Для коммуникации доп. потока с основным прикрутил еще один поток.

Модуль:
+
unit WThread;

// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013

// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//     пример: procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
// 2. Присвоить обработчика(ов) события OnThreadReceiveMessage, OnTimeOut - при необходимости
// Для обмена строками рекомендууется использовать функции NewString и FreeString

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

interface

uses
    Classes, SyncObjs, Variants;

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

    TWThread = class;

    TWThreadReceiveMessage = procedure(Sender: TWThread; Msg: TThreadMessage) of object;
    TWThreadTimeOut = procedure(Sender: TWThread) of object;

    { TWThread }

    TWThread = class(TThread)
    private
        FMessageEvent: TEvent;
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FQueue: TList;
        FSection: TCriticalSection;
        FTimeOut: Cardinal;
        FTimeOutIsDirect: boolean;
        FGUIThread: TThread;
        procedure SetTimeOut(AValue: Cardinal);
        procedure DoTimeOut;
    protected
        procedure Execute; override;
        {$IFDEF FPC}
        procedure SendGUIMessage(Message: DWord; WParam: Word; LParam: NativeInt);
        {$ELSE}
        procedure SendGUIMessage(Message: Word; WParam: Word; LParam: NativeInt);
        {$ENDIF}
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
        procedure DirectTimeOut; virtual;
        {$IFDEF FPC}
        procedure PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
        {$ELSE}
        procedure PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
        {$ENDIF}
        procedure StopThread;
        // событие на получение данных ИЗ этого потока, вызывается в основном потоке
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
        // событие, возникающее при превышении интервала ожидания
        property OnTimeOut: TWThreadTimeOut read FOnTimeOut write FOnTimeOut;
        // интервал ожидания в мс, по-умолчанию - бесконечно
        property TimeOut: Cardinal read FTimeOut 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

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;
        {$IFDEF FPC}
        procedure PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
        {$ELSE}
        procedure PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
        {$ENDIF}
        procedure StopThread;
    end;

function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;

{function FreeString(var P: LPARAM): String;
begin
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): LPARAM;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > 0 then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        if LongBool(Result) then
            Move(Pointer(Text)^, Pointer(Result)^, l);
    end else
        Result := 0;
end;    }

{ TGUIThread }

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^;
                //Move(Message^, FCurrentMessage, SizeOf(FCurrentMessage));
                FreeMem(Message);
                {$IFDEF FPC}
                Synchronize(@CallGUIThread);
                {$ELSE}
                Synchronize(CallGUIThread);
                {$ENDIF}
            end;
        end;
    end;
end;

procedure TGUIThread.CallGUIThread;
begin
    if Assigned(FOwner) then
        FOwner.OnThreadReceiveMessage(FOwner, FCurrentMessage);
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
    FSection.Free;
    FQueue.Free;
    FMessageEvent.Free;
    inherited Destroy;
end;

{$IFDEF FPC}
procedure TGUIThread.PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
{$ELSE}
procedure TGUIThread.PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
{$ENDIF}
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;

{ TWThread }

procedure TWThread.SetTimeOut(AValue: Cardinal);
begin
    if FTimeOut = AValue then Exit;
    FTimeOut := AValue;
    if not Suspended then
        FMessageEvent.SetEvent;
end;

procedure TWThread.DoTimeOut;
begin
    TGUIThread(FGUIThread).FTimeOut := true;
    TGUIThread(FGUIThread).FMessageEvent.SetEvent;
end;

procedure TWThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WaitFor(FTimeOut);
        if not Terminated then
            case WR of
                wrSignaled: while FQueue.Count > 0 do begin
                    FSection.Enter;
                    Message := FQueue[0];
                    FQueue.Delete(0);
                    FSection.Leave;
                    Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        DoTimeOut;
                end;
            end;
    end;
end;

{$IFDEF FPC}
procedure TWThread.SendGUIMessage(Message: DWord; WParam: Word; LParam: NativeInt);
{$ELSE}
procedure TWThread.SendGUIMessage(Message: Word; WParam: Word; LParam: NativeInt);
{$ENDIF}
begin
    if Assigned(FGUIThread) then
        TGUIThread(FGUIThread).PostMessage(Message, WParam, LParam);
end;

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

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
    FQueue := TList.Create;
    FMessageEvent := TEvent.Create(nil, False, False, '');
    FSection := TCriticalSection.Create;
    FTimeOut := INFINITE;
    FTimeOutIsDirect := False;
    FGUIThread := TGUIThread.Create(Self);
end;

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

{$IFDEF FPC}
procedure TWThread.PostMessage(Message: DWord; WParam: Word; LParam: NativeInt);
{$ELSE}
procedure TWThread.PostMessage(Message: Word; WParam: Word; LParam: NativeInt);
{$ENDIF}
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 TWThread.StopThread;
begin
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
end;

end.


Проект под Lazarus:
+
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, wthread,
  Messages, ExtCtrls, StdCtrls;

const
  WM_STRING = WM_USER+$120;

type

  { TMyThread }

  TMyThread = class(TWThread)
  private
      procedure ReceiveString(var Msg: TThreadMessage); message WM_STRING;
  end;

  { TForm1 }

  TForm1 = class(TForm)
      Button1: TButton;
      Button2: TButton;
      Memo1: TMemo;
      procedure Button1Click(Sender: TObject);
      procedure Button2Click(Sender: TObject);
      procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
  private
      FThread: TMyThread;
      procedure StartThread;
      procedure StopThread;
  public
      procedure ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  if LongBool(FThread) then
      StopThread
  else
      StartThread;
end;

procedure TForm1.Button2Click(Sender: TObject);
var s: string;
begin
    s := '';
    if LongBool(FThread) and InputQuery('Input', 'Enter text', s) then begin
        // отправляем введенную строку в доп. поток
        Memo1.Lines.Add(Format('-> %s', [s]));
        FThread.PostMessage(WM_STRING, 0, NewString(s));
        s := '';
    end;
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
    if LongBool(FThread) then
        StopThread;
end;

procedure TForm1.ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
begin
    if Msg.Message = WM_STRING then
        Memo1.Lines.Add(Format('<- %s', [FreeString(Msg.LParam)]));
end;

procedure TForm1.StartThread;
begin
    if not LongBool(FThread) then begin
        FThread := TMyThread.Create(false);
        {$IFDEF FPC}
        FThread.OnThreadReceiveMessage := @ReceiveMsg;
        {$ELSE}
        FThread.OnThreadReceiveMessage := ReceiveMsg;
        {$ENDIF}
    end;
end;

procedure TForm1.StopThread;
begin
    if LongBool(FThread) then begin
        FThread.StopThread;
        FThread.Free;
        FThread := nil;
    end;
end;

{ TMyThread }

procedure TMyThread.ReceiveString(var Msg: TThreadMessage);
var s: string;
begin
   s := FreeString(Msg.LParam);
   SendGUIMessage(WM_STRING, 0, NewString(s));
   Sleep(5000);
   SendGUIMessage(WM_STRING, 0, NewString(s));
end;

end.


Проект под Delphi:
+
unit LazMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, WThread;

const
  WM_STRING = WM_USER+$120;

type
    { TMyThread }

    TMyThread = class(TWThread)
    private
        procedure ReceiveString(var Msg: TThreadMessage); message WM_STRING;
    end;

  TfrmThreadTest = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FThread: TMyThread;
    procedure StartThread;
    procedure StopThread;
  public
    procedure ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
  end;

var
  frmThreadTest: TfrmThreadTest;

implementation

{$R *.dfm}

procedure TfrmThreadTest.Button1Click(Sender: TObject);
begin
  if LongBool(FThread) then
      StopThread
  else
      StartThread;
end;

procedure TfrmThreadTest.Button2Click(Sender: TObject);
var s: string;
begin
    s := '';
    if LongBool(FThread) and InputQuery('Input', 'Enter text', s) then begin
        // отправляем введенную строку в доп. поток
        Memo1.Lines.Add(Format('-> %s', [s]));
        FThread.PostMessage(WM_STRING, 0, NewString(s));
        s := '';
    end;
end;

procedure TfrmThreadTest.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    if LongBool(FThread) then
        StopThread;
end;

procedure TfrmThreadTest.ReceiveMsg(Sender: TWThread; Msg: TThreadMessage);
begin
    if Msg.Message = WM_STRING then
        Memo1.Lines.Add(Format('<- %s', [FreeString(Msg.LParam)]));
end;

procedure TfrmThreadTest.StartThread;
begin
    if not LongBool(FThread) then begin
        FThread := TMyThread.Create(false);
        {$IFDEF FPC}
        FThread.OnThreadReceiveMessage := @ReceiveMsg;
        {$ELSE}
        FThread.OnThreadReceiveMessage := ReceiveMsg;
        {$ENDIF}
    end;
end;

procedure TfrmThreadTest.StopThread;
begin
    if LongBool(FThread) then begin
        FThread.StopThread;
        FThread.Free;
        FThread := nil;
    end;
end;

{ TMyThread }

procedure TMyThread.ReceiveString(var Msg: TThreadMessage);
var s: string;
begin
   s := FreeString(Msg.LParam);
   SendGUIMessage(WM_STRING, 0, NewString(s));
   Sleep(5000);
   SendGUIMessage(WM_STRING, 0, NewString(s));
end;

end.


Результаты в обоих средах разработки одинаковы. :)
29 окт 13, 16:46    [15047828]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
Кстати, кто-нибудь возьмется протестировать под линуксом? Очень хочется узнать результат кросс-платформенности.
29 окт 13, 17:16    [15048034]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
white_nigger
Member

Откуда: Тула
Сообщений: 2145
Зря на Dimonka наехали, он более грамотную архитектуру предлагал
30 окт 13, 03:06    [15050030]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
white_nigger
Зря на Dimonka наехали, он более грамотную архитектуру предлагал

Ровно с тем-же количеством аргументов можно и опровергнуть эту грамотность.
30 окт 13, 09:38    [15050494]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
white_nigger
Member

Откуда: Тула
Сообщений: 2145
Я вижу три аргумента.
1. Разделение логики. Нет мешанины в коде. Т.е. шаблон превращается по факту в готовый, расширяемый паттерн.
2. За выноса логики юзер-работы появляется легкая возможность покрытия её тестом.
3. Гм... а вы в команде работали? Сопровождать дешевле граммотную архитектуру

Ну в-общем каждый судит со своего опыта. Можно отнестись "работает - да и ладно", а можно продумать на будущее
30 окт 13, 11:00    [15051087]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
white_nigger
а можно продумать на будущее

Для ленивых в инете полно оберток в виде компонент и даже целых библиотек для работы с потоками. Я-же предложил свою модель, без наворотов, но покрывающую большинство мелких задач с минимумом типичных ошибок. У каждого своя ниша.

+
Димонка - тролль, который сочиняет проблемы в голове, а не в коде.
30 окт 13, 11:08    [15051163]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
white_nigger
Member

Откуда: Тула
Сообщений: 2145
Насчет спойлера - не знаю, не следил за его постами. Просто в данном, конкретном случае его подход мне больше импонирует. Причины я отписал выше. В любом случае - мир, дружба, жвачка
30 окт 13, 12:47    [15051896]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Dimonka
Member

Откуда:
Сообщений: 1179
wadman
Димонка - тролль, который сочиняет проблемы в голове, а не в коде.

Спасибо, конечно, за оценку. Но в век ООП и предметности пересылать из потока в поток практически машинные примитивы - это огромное достижение. То что нужно 99.9% программистов ежедневно.

Я вижу сутуацию примерно так: ты придумал проблему, успешно её решил, а все кто считает, что проблемы-то в основном у людей другие, - тролли и негодяи. Жаль что меня забанят, но не мог не ответить.
30 окт 13, 15:56    [15053710]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Гаджимурадов Рустам
Member

Откуда:
Сообщений: 60053

Dimonka> Жаль что меня забанят, но не мог не ответить.

Не, пока не забанят. Но предлагаю озвучить, какая
проблема(ы), по-твоему, более насущна и её (их) решение.

Posted via ActualForum NNTP Server 1.5

30 окт 13, 16:02    [15053773]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Dimonka
Member

Откуда:
Сообщений: 1179
Гаджимурадов Рустам
Dimonka> Жаль что меня забанят, но не мог не ответить.

Не, пока не забанят. Но предлагаю озвучить, какая
проблема(ы), по-твоему, более насущна и её (их) решение.


Одно из решений я уже предлагал выше. Ну а проблемы старые:
1. вынести пользовательский код в поток
2. передать этому коду данные
3. узнать, что код выполнен (данные обработаны)

Если первый и третий пункт в "шаблоне" более менее решён, то второй решается, только через извращения (примитивы), которые автор топика называет API. Опять же, данные обработаны, но с передачей результатов работы те же проблемы, что и в пункте 2.

Очень не понимаю, почему автор топика так агресивен к достаточно контруктивной (на мой взгляд) критике.
30 окт 13, 16:11    [15053876]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
Dimonka
Очень не понимаю, почему автор топика так агресивен к достаточно контруктивной (на мой взгляд) критике.

14918946

Еще раз: у этого решения своя ниша, минимум наворотов и, соответственно, ошибок. Особенно для новичков, которых-то голый TThread запутывает.
30 окт 13, 16:18    [15053946]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Гаджимурадов Рустам
Member

Откуда:
Сообщений: 60053

Dimonka> Одно из решений я уже предлагал выше

C кодом?

Posted via ActualForum NNTP Server 1.5

30 окт 13, 16:38    [15054113]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
Марат Сафин, кстати, твой вариант с TValue/Variant не выдерживает мой тест в дельфи. В лазарусе - все отлично. Потому пришлось отказаться в пользу LParam, чтоб работало одинаково на обоих платформах.
30 окт 13, 16:42    [15054139]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Dimonka
Member

Откуда:
Сообщений: 1179
Гаджимурадов Рустам
Dimonka> Одно из решений я уже предлагал выше
C кодом?

По крайней мере с кодом возможного интерфейса. Я не обещал дать готовое решение. Просто предлагал способ обойти недостатки данного решения.
30 окт 13, 17:36    [15054671]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Марат Сафин
Member

Откуда:
Сообщений: 619
wadman,
Какой ешё тест?
30 окт 13, 19:44    [15055292]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25711
Марат Сафин
wadman,
Какой ешё тест?

Который придумал Димонка 15047828 Если жать "тест" (Button2) подряд 5 раз и вводить с 1о-го по 5-ть, то вылетает ошибка. Текст не помню, но воспроизвести не составит труда.
30 окт 13, 20:38    [15055455]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Марат Сафин
Member

Откуда:
Сообщений: 619
wadman
Марат Сафин, кстати, твой вариант с TValue/Variant не выдерживает мой тест в дельфи. В лазарусе - все отлично. Потому пришлось отказаться в пользу LParam, чтоб работало одинаково на обоих платформах.

Там метод Destroy переделать нужно, сначала вызывать inherited а потом уничтожать объекты, я забыл про эту особенность TThread. то есть вот так:
destructor TWThread.Destroy;
begin
  inherited;
  FMsgEvent.Free;
  FQueue.Free;
end;
31 окт 13, 07:21    [15056478]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Марат Сафин
Member

Откуда:
Сообщений: 619
Других косяков не нашёл, у меня работает на ура.
31 окт 13, 07:25    [15056480]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Марат Сафин
Member

Откуда:
Сообщений: 619
Dimonka,
Писал я год назад такую вот штуку возможно это то, что вы хотели.
31 окт 13, 09:14    [15056620]     Ответить | Цитировать Сообщить модератору
Топик располагается на нескольких страницах: Ctrl  назад   1 2 3 [4] 5 6 7 8 9 10 .. 19   вперед  Ctrl
Все форумы / Delphi Ответить