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

Откуда: Санкт-Петербург
Сообщений: 25729
Марат Сафин, думал, думал над твоим решением... Есть мои мелкие "но" с передачей параметра в поток и получением результата, но в целом весьма изящно. Для меня открытием стало наличие TEvent :)
2 окт 13, 09:19    [14910237]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Dimonka
Member

Откуда:
Сообщений: 1179
wadman
Dimonka
А если внутри твоего кода, то надо будет редактировать весь код, где использовался твой "шаблон".

Пояснить, что такое шаблон? Заканчивай оффтопить, выдвигай пожелания и свои варианты. Описал-же идеальный вариант, похвастайся и реализацией.

Не понимаю, что тебе пояснить? Как наследоваться от TAbstractJob?
  TMyThreadJob = class(TAbstractJob)
  public
    procedure DoJob; override;
    property Любые Данные: Любого типа;
  end;

procedure TMyThreadJob.DoJob;
begin
  // Делай что хочешь с данными 
end;

  // И в коде потоку передаёшь задание:
  Job := TMyThreadJob.Create;
  MyThread.AddJob(Job);


По вкусу делаешь очередь обработки заданий:
  while not Self.Terminated do
  begin
    FListLock.Acquire;
    if JobCount > 0 then
    begin
      FListLock.Release;
      Job := GetJob;
      Job.DoJob;
      // Здесь можешь оповестить, что задание сделано
      // ThisJobIsFinished(Job);
      // В зависимости от модели управления заданием, можешь освободить память из под задания
      // FreeAndNil(Job);
    end
    else
    begin
      FJobAdded.ResetEvent;
      FListLock.Release;
      FJobAdded.WaitFor(1000);
    end;
  end;

Получение следующего задания из списка:
function TBaseJobThread.GetJob: TAbstractJob;
begin
  FListLock.Acquire;
  try
    if FFIFO then
    begin
      Result := FList[FList.Count - 1];
      FList.Delete(FList.Count - 1);
    end
    else
    begin
      Result := FList[0];
      FList.Delete(0);
    end;
  finally
    FListLock.Release;
  end;
end;


// Добавление задания
procedure TBaseJobThread.AddJob(AJob: TAbstractJob);
begin
  FListLock.Acquire;
  try
    FList.Add(AJob);
    FJobAdded.SetEvent;
  finally
    FListLock.Release;
  end;
end;


Ну и для пояснения:
FJobAdded: TEvent;
FListLock: TCriticalSection;
2 окт 13, 11:46    [14911219]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
Dimonka
Ну и для пояснения:

Поясни, что значат эти куски кода для людей, которые впервые столкнулись с потоками? Это по-твоему решение для новичка?
2 окт 13, 11:59    [14911320]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Dimonka
Member

Откуда:
Сообщений: 1179
wadman
Dimonka
Ну и для пояснения:

Поясни, что значат эти куски кода для людей, которые впервые столкнулись с потоками? Это по-твоему решение для новичка?

Так людям и не надо ничего понимать, им надо просто унаследоваться от задания:

TMyThreadJob = class(TAbstractJob)
  public
    procedure DoJob; override;
    property Любые Данные: Любого типа;
  end;

Я не делаю "шаблон", я просто подсказываю, в какую сторону крутить архитектуру, чтобы твою конструкцию мог использовать не только ты сам.
2 окт 13, 12:38    [14911664]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
Dimonka
Так людям и не надо ничего понимать

Уровни "написания" кода:
1. API
2. VCL
3. VCL+Component
4. Нанять программиста.

Людям, которым не нужно что-либо понимать достаточно пунктов 3 и 4. Я работаю на производстве, где скорость - ключевой фактор и потому п.1 в приоритете. Ты-же не предлагаешь ничего. Лишь толсто троллишь. Какой там по счету(?) и последний раз: есть свой вариант? Выкладывай. Рабочий вариант. Твоего решения.
2 окт 13, 13:03    [14911818]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
MrCat
Guest
Кстати, а кто-нибудь помнит - в Лазаре есть посылка сообщений потоку? Они под Linux эмулируются или нет? Конечно, своя очередь заданий с синхронизацией доступа в любом случае будет работать, но интересно - будет ли работать под Linux первый вариант.
2 окт 13, 13:04    [14911822]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
MrCat
Кстати, а кто-нибудь помнит - в Лазаре есть посылка сообщений потоку?

Там не все так просто. В винде все будет работать, а с линуксом придется повозиться http://wiki.freepascal.org/Multithreaded_Application_Tutorial/ru
2 окт 13, 13:23    [14911959]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Barmaley57
Member

Откуда: Москва
Сообщений: 5708
wadman
Я работаю на производстве, где скорость - ключевой фактор
Поясни
2 окт 13, 13:24    [14911966]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Dimonka
Member

Откуда:
Сообщений: 1179
wadman
Dimonka
Так людям и не надо ничего понимать

Уровни "написания" кода:
1. API
2. VCL
3. VCL+Component
4. Нанять программиста.

Людям, которым не нужно что-либо понимать достаточно пунктов 3 и 4. Я работаю на производстве, где скорость - ключевой фактор и потому п.1 в приоритете.

Ниф$%я не понял. Обоснуй, почему твой код будет хоть как-то быстрее работать? :)
И твой код к API никакого отношения не имеет.

Да и вообще забавная иерархия. Ты забыл в пункте 0. ассемблер добавить и в пункте -1. Голый машинный код. Если уж дело о скорости речь идёт.

wadman
Ты-же не предлагаешь ничего. Лишь толсто троллишь. Какой там по счету(?) и последний раз: есть свой вариант? Выкладывай. Рабочий вариант. Твоего решения.

Я предлагаю твоё месиво кода отделить от кода пользователя. Всё, что ты пытаешься передать в поток через какие-то низкоуровневые примитивы, кодируя типизированные данные, можно легко передавать в нормальном виде через задания. Любой контекст.

Ну и это ты хочешь что-то выложить, я ничего выкладывать не обещал. ;)
2 окт 13, 13:24    [14911972]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
Barmaley57
wadman
Я работаю на производстве, где скорость - ключевой фактор
Поясни

Поясняю: компы дохлые, смартфоны сейчас мощнее, а железячки, подключенные десятками к этим компам, критично относятся к скорости реакции - закрывают обмен по своей воле.
Dimonka
И твой код к API никакого отношения не имеет.

противоречит следующему
Dimonka
ты пытаешься передать в поток через какие-то низкоуровневые примитивы


Ну да ладно.
Dimonka
Я предлагаю твоё месиво кода отделить от кода пользователя.

Отклонено.
2 окт 13, 13:27    [14911998]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
MrCat
Guest
с линуксом придется повозиться
Да вот он меня и интересовал как раз. Если формулировать точнее, то эмулирована ли в LCL PostThreadMessage в сборке под Linux. Под виндой-то это без проблем должно работать - хоть в Лазаре, хоть где, сообщения - родной для неё механизм. В любом случае, можно импортировать из User32.dll.

Гугл сообщает, что PostThreadMessage в сборке под Линукс нет, что там вообще "так не принято". А если и проэмулируют её, то фиг знает через какой механизм. Понятненько.
2 окт 13, 13:58    [14912246]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Dimonka
Member

Откуда:
Сообщений: 1179
wadman
Dimonka
И твой код к API никакого отношения не имеет.

противоречит следующему
Dimonka
ты пытаешься передать в поток через какие-то низкоуровневые примитивы

Первое утверждение перпендикулярно второму. Аббревиатура API никаким образом не накладывает ограничение на типы данных.

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

Откуда: Санкт-Петербург
Сообщений: 25729
Версия без шаблона, для создания наследника. Подглядел у Марата Сафина. :)

+
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;
        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;
        // отправка любого сообщения В этот поток
        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;
    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 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;
end;

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

destructor TWThread.Destroy;
begin
    CloseHandle(hCloseEvent);
    DeallocateHWnd(FToolWindow);
    inherited;
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, false);

    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
                    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;
        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 FormCreate(Sender: TObject);
    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 Assigned(FThread) then
        StopThread
    else
        StartThread;
end;

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

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

procedure TfrmWThreadTest.FormCreate(Sender: TObject);
begin
    Memo1.Lines.Clear;
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 Assigned(FThread) then begin
        FThread := TMyThread.Create(false);
        FThread.OnThreadReceiveMessage := ReceiveMsg;
    end;
end;

procedure TfrmWThreadTest.StopThread;
begin
    if Assigned(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);
begin
    // отправляем полученную строку обратно главному потоку
    SendMessageFromMe(Msg.Msg, Msg.WParam, Msg.LParam);
end;

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

Откуда: Нижний Новгород
Сообщений: 5913
wadman, зачем новые замороченные функции для "конвертации" string в LPARAM и обратно? твои прежние были чотче))
3 окт 13, 14:08    [14918424]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
fd00ch
зачем новые замороченные функции для "конвертации" string в LPARAM и обратно? твои прежние были чотче))

Один товарищ нашел косячек в такой передаче. Искал и нашёл. Такой, с которым я на производстве даже не столкнулся. :)
3 окт 13, 14:12    [14918467]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
fd00ch
Member

Откуда: Нижний Новгород
Сообщений: 5913
и что же мешает написать подробности, а то кто-то использует аналогичный старому метод)
3 окт 13, 14:13    [14918474]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
fd00ch
и что же мешает написать подробности, а то кто-то использует аналогичный старому метод)

Погоди, для начала поясни, что ты подразумеваешь под старым и новым методом?
3 окт 13, 14:18    [14918515]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
fd00ch
Member

Откуда: Нижний Новгород
Сообщений: 5913
старый
function NewString(const Str: string): LPARAM;
 begin
  Result:=0;
  string(Result):=Str
 end;

function FreeString(StrPtr: LPARAM): string;
 begin
  LPARAM(Result):=StrPtr
 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;

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;
3 окт 13, 14:23    [14918561]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
fd00ch, ответ тут 14903409

В кратце, пока доп. поток работает со строкой как с константой, основной поток может с ней работать как с переменной, т.к. строка для него не залочена.
3 окт 13, 14:27    [14918594]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
fd00ch
Member

Откуда: Нижний Новгород
Сообщений: 5913
wadman, не понял, в чем проблема, поясни подробнее
3 окт 13, 14:45    [14918762]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

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

Проверка. Модуль:
+
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;
        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;
        // отправка любого сообщения В этот поток
        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;
    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;
end;

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

destructor TWThread.Destroy;
begin
    CloseHandle(hCloseEvent);
    DeallocateHWnd(FToolWindow);
    inherited;
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, false);

    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
                    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;
        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 FormCreate(Sender: TObject);
    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 Assigned(FThread) then
        StopThread
    else
        StartThread;
end;

procedure TfrmWThreadTest.Button2Click(Sender: TObject);
var s: string;
begin
    if Assigned(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 Assigned(FThread) then
        StopThread;
end;

procedure TfrmWThreadTest.FormCreate(Sender: TObject);
begin
    Memo1.Lines.Clear;
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 Assigned(FThread) then begin
        FThread := TMyThread.Create(false);
        FThread.OnThreadReceiveMessage := ReceiveMsg;
    end;
end;

procedure TfrmWThreadTest.StopThread;
begin
    if Assigned(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.


Результат в мемо:
автор
-> 1
<- 1
-> 2
-> 3
-> 4
-> 5
<- 1
<- 2
<- 2
<- 3
<- 3
<- 4
<- 4
<- 5
<- 5


Никаких потерь.
3 окт 13, 15:05    [14918946]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
Немного доработанная процедура. Два некритичных проекта перевел на работу с этим модулем. Из изменений: добавлена процедур DirectTimeOut, которая вызывается после превышения интервала ожидания в этом-же потоке, а не по событию в основном.
+
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, false);

    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.
4 окт 13, 10:09    [14922148]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Док
Member

Откуда: Казань
Сообщений: 6290
wadman,

надеюсь, что это окончательный вариант, "... фактическая бумажка! Броня!!!" (с). А то у меня уже место на винте скоро кончится архивировать этот топег
11 окт 13, 18:38    [14958108]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
Гхостик
Guest
Может, выложить уже на Bitbucket?
11 окт 13, 19:09    [14958200]     Ответить | Цитировать Сообщить модератору
 Re: Шаблон класса для работы с потоком (WThread, Thread)  [new]
wadman
Member

Откуда: Санкт-Петербург
Сообщений: 25729
Док, в окончательном варианте у меня в execute при вызове sleepex вместо false - true :) почему, хэлп ответит.
12 окт 13, 10:40    [14960102]     Ответить | Цитировать Сообщить модератору
Топик располагается на нескольких страницах: Ctrl  назад   1 2 [3] 4 5 6 7 8 9 10 .. 19   вперед  Ctrl
Все форумы / Delphi Ответить