ReSQL.ru
     
powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Delphi [игнор отключен] [закрыт для гостей] / Шаблон класса для работы с потоком (WThread, Thread)
469 сообщений из 469, показаны все 19 страниц
  все  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411716
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Собственно, сам шаблон с небольшими комментариями именно в тех местах, которые нужны на обывательском уровне, чтобы только добавить свой код.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
unit WThread;

interface

uses
    Classes,
    Windows,
    Messages,
    SysUtils;

type
    TWThread = class;

    // событие на получение строки из потока
    TWThreadReceiveString = procedure(Sender: TWThread; const Text: string) of object;
    // событие на получение числа из потока
    TWThreadReceiveInt = procedure(Sender: TWThread; const Int: Integer) of object;
    // событие на получение строки и числа из потока
    TWThreadReceiveStringWord = procedure(Sender: TWThread; const Text: string; const Wrd: Word) of object;
    // событие на получение двух чисел из потока
    TWThreadReceiveIntWord = procedure(Sender: TWThread; const Int: Integer; const Wrd: Word) of object;

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceviceString: TWThreadReceiveString;
        FOnThreadReceiveInt: TWThreadReceiveInt;
        FOnThreadReceiveStringWord: TWThreadReceiveStringWord;
        FOnThreadReceiveIntWord: TWThreadReceiveIntWord;
    protected
        procedure WWindowProc(var Msg: TMessage);
        procedure SendString(const Text: string);
        procedure SendInteger(const Int: Integer);
        procedure SendStringWord(const Text: string; const Wrd: Word);
        procedure SendIntegerWord(const Int: Integer; const Wrd: Word);
        procedure DoThreadReceiveString(const Text: string);
        procedure Execute; override; // шаблон процедуры
    public
        constructor Create(CreateSuspended: Boolean); virtual;
        destructor Destroy; override;
        // отправка любого сообщения в поток
        function SendMessageToThread(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // отправка строки в поток
        function SendStringToThread(const Text: string): boolean;
        // остановка потока по феншую
        function StopThread: boolean;
        // события на получение данных из потока
        property OnThreadReceviceString: TWThreadReceiveString read FOnThreadReceviceString write FOnThreadReceviceString;
        property OnThreadReceiveInt: TWThreadReceiveInt read FOnThreadReceiveInt write FOnThreadReceiveInt;
        property OnThreadReceiveStringWord: TWThreadReceiveStringWord read FOnThreadReceiveStringWord write FOnThreadReceiveStringWord;
        property OnThreadReceiveIntWord: TWThreadReceiveIntWord read FOnThreadReceiveIntWord write FOnThreadReceiveIntWord;
    end;

implementation

const
    WM_BASE             = WM_USER + $100;
    WM_STRING           = WM_BASE + 1;
    WM_INT              = WM_BASE + 2;
    WM_STRING_WORD      = WM_BASE + 3;
    WM_INT_WORD         = WM_BASE + 4;

    WM_MAX              = WM_INT_WORD;

{ TWThread }

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

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

procedure TWThread.DoThreadReceiveString(const Text: string);
begin
    if Assigned(FOnThreadReceviceString) then
        FOnThreadReceviceString(Self, Text);
end;

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

function TWThread.SendStringToThread(const Text: string): boolean;
var buf: LPARAM;
begin
    buf := 0;
    String(Buf) := Text;
    result := PostThreadMessage(ThreadID, WM_STRING, 0, buf);
end;

procedure TWThread.Execute;
var
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;
    str: string;
label
    EndOfThread;
begin
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    SleepEx(20, false);

    // тестовый пример vvv
    SendString('WThread started');
    // тестовый пример ^^^

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_BASE, WM_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, INFINITE, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    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 // оконные сообщения тоже получаем
                Terminate;
                goto EndOfThread;
            end;
            WM_STRING: begin
                LPARAM(str) := msg.lParam;
                // что-нибудь делаем со строкой. например, отправляем обратно

                // тестовый пример vvv
                SendString(Format('received: %s', [str]));
                // тестовый пример ^^^

                str := ''; // "отпускаем" строку после работы с ней
            end;
            WM_INT: begin
                // здесь получаем число в msg.lparam;
            end;
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

procedure TWThread.SendInteger(const Int: Integer);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT, 0, Int);
end;

procedure TWThread.SendIntegerWord(const Int: Integer; const Wrd: Word);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT_WORD, Wrd, Int);
end;

procedure TWThread.SendString(const Text: string);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, 0, buf);
end;

procedure TWThread.SendStringWord(const Text: string; const Wrd: Word);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, Wrd, buf);
end;

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

procedure TWThread.WWindowProc(var Msg: TMessage);
var str: String;
begin
    case Msg.Msg of
        WM_STRING: begin
            LPARAM(str) := Msg.LParam;
            DoThreadReceiveString(str);
            Msg.Result := 1;
        end;
        WM_INT: begin
            if Assigned(FOnThreadReceiveInt) then
                FOnThreadReceiveInt(Self, Msg.LParam);
            Msg.Result := 1;
        end;
        WM_STRING_WORD: begin
            LPARAM(str) := Msg.LParam;
            if Assigned(FOnThreadReceiveStringWord) then
                FOnThreadReceiveStringWord(Self, str, Msg.WParam);
            Msg.Result := 1;
        end;
        WM_INT_WORD: begin
            if Assigned(FOnThreadReceiveIntWord) then
                FOnThreadReceiveIntWord(Self, Msg.LParam, Msg.WParam);
            Msg.Result := 1;
        end;
    else
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

end.



Тестовый проект. Форма состоит из мemo, и двух кнопок: одна запускает/останавливает поток, другая отправляет строку в поток.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
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;

type
  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: TWThread;
    procedure ReceiveString(Sender: TWThread; const Text: string);
    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.SendStringToThread(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.ReceiveString(Sender: TWThread; const Text: string);
begin
    Memo1.Lines.Add(Format('<- %s', [Text]));
end;

procedure TfrmWThreadTest.StartThread;
begin
    if not Assigned(FThread) then begin
        FThread := TWThread.Create(true);
        FThread.OnThreadReceviceString := ReceiveString;
        FThread.Start;
    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;

end.



Тестирование было с ReportMemoryLeaksOnShutdown := true; что показало, что память не теряется при многочисленных отправках строк. Delphi XE2.

Вопросы, предложения? :)

Репозитарий на гитхабе: https://github.com/wadman/wthread/
...
Рейтинг: 0 / 0
30.09.2013, 13:10
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411889
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadman,

1. KISS
2. RTFM твой WM_STRING - это PSM_SHEETINFO. маловероятно, конечно, что система догадается посласть его твоему окну, но когда догадается таки - ожидаемой строки ты там не найдешь))
3. зачем отправлять всего лишь Word, когда "по ширине" вполне пролазит WPARAM?
...
Рейтинг: 0 / 0
30.09.2013, 14:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411901
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00ch KISS
Не осилил, поясни. Если речь о Terminate и goto, то считай это перестраховкой для начинающего.
fd00chтвой WM_STRING - это PSM_SHEETINFO.
WM_USER + $100 + 1 <> WM_USER+101
fd00chзачем отправлять всего лишь Word, когда "по ширине" вполне пролазит WPARAM?
Можно и так.
...
Рейтинг: 0 / 0
30.09.2013, 14:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411938
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadmanWM_USER + $100 + 1 <> WM_USER+101профнепригодность, блин, доллары перестаю замечать

wadmanНе осилил, пояснизачем писать сложно, когда можно просто? у тебя задача потока в чем заключается?
...
Рейтинг: 0 / 0
30.09.2013, 15:09
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411944
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chу тебя задача потока в чем заключается?
У меня - ни в чем. Свистоперделка Конкретный вопрос задай.
...
Рейтинг: 0 / 0
30.09.2013, 15:14
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411965
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
1. зачем нужен такой поток?
2. зачем потоку нужны сообщающие о принятых данных события, которые не синхронизированы ни с чем?
3. по мотивам п.2. в чьем контексте вызывается TfrmWThreadTest.ReceiveString с обращением к Memo1?
...
Рейтинг: 0 / 0
30.09.2013, 15:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411971
Aleksey V.P.
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aleksey V.P.
Участник
wadman,

Не понял для чего шаблон потока. Сделай пояснения, please.
...
Рейтинг: 0 / 0
30.09.2013, 15:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411973
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00ch1. зачем нужен такой поток?
2. зачем потоку нужны сообщающие о принятых данных события, которые не синхронизированы ни с чем?
Это шаблон.
fd00chв чьем контексте вызывается TfrmWThreadTest.ReceiveString с обращением к Memo1?
Естественно в главном потоке, который обслуживает VCL. Как и все, что дергается из WWindowProc.
...
Рейтинг: 0 / 0
30.09.2013, 15:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411978
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Aleksey V.P.Сделай пояснения, please.
Для людей, которые создают такие темы:
http://www.sql.ru/forum/1050309/tthread-nuzhna-li-v-privedennom-kode-sinhronizaciya
http://www.sql.ru/forum/1050203/obrashhenie-k-forme-iz-thread
http://www.sql.ru/forum/1049953/osnovy-tthread
...
Рейтинг: 0 / 0
30.09.2013, 15:39
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411988
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
Я вижу в тексте слово GOTO - код КГ/АМ
...
Рейтинг: 0 / 0
30.09.2013, 15:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411992
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
defecatorЯ вижу в тексте слово GOTO - код КГ/АМ
Перед этим Label не заметил?
...
Рейтинг: 0 / 0
30.09.2013, 15:49
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38411997
Aleksey V.P.
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aleksey V.P.
Участник
wadmanДля людей, которые создают такие темы:
http://www.sql.ru/forum/1050309/tthread-nuzhna-li-v-privedennom-kode-sinhronizaciya
http://www.sql.ru/forum/1050203/obrashhenie-k-forme-iz-thread
http://www.sql.ru/forum/1049953/osnovy-tthread

Спасиба за пояснения, буэшечку словил. Поясни смысл использования оператора GoTo, без него никак не обойтись?
...
Рейтинг: 0 / 0
30.09.2013, 15:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412005
Aleksey V.P.
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aleksey V.P.
Участник
wadman,

Например использовать try .. finally .. end..
...
Рейтинг: 0 / 0
30.09.2013, 15:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412007
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Aleksey V.P.без него никак не обойтись?
Обойтись, тот же break. Только я не сторонник бинарной логики "если, то", то есть если выполняется, как заложено, то нехай буде.
...
Рейтинг: 0 / 0
30.09.2013, 15:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412010
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Aleksey V.P.Например использовать try .. finally .. end..
В этом коде это лишнее. Раз уж такой любитель процедурных вызовов, то try должны расставлены быть в вызываемых процедурах.
...
Рейтинг: 0 / 0
30.09.2013, 15:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412012
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadmanЕстественно в главном потоке, который обслуживает VCL. Как и все, что дергается из WWindowProc.да, прощелкал, что создание окна идет из конструктора, а не из Execute
...
Рейтинг: 0 / 0
30.09.2013, 16:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412043
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
wadman http://www.sql.ru/forum/1050203/obrashhenie-k-forme-iz-thread
14899112 Пример на основе моего модуля:
1. Добавляется процедура своего парсера.
2. В Execute ловится любой свой код посредством SendMessageToThread и процедура запускается.
3. Из потока вполне себе можно отправлять сообщения: прогресс выполнения, коды действия, диагностические сообщения и т.п.

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
unit WThread;

interface

uses
    Classes,
    Windows,
    Messages,
    SysUtils;

type
    TWThread = class;

    // событие на получение строки из потока
    TWThreadReceiveString = procedure(Sender: TWThread; const Text: string) of object;
    // событие на получение числа из потока
    TWThreadReceiveInt = procedure(Sender: TWThread; const Int: Integer) of object;
    // событие на получение строки и числа из потока
    TWThreadReceiveStringWord = procedure(Sender: TWThread; const Text: string; const DWrd: Word) of object;
    // событие на получение двух чисел из потока
    TWThreadReceiveIntWord = procedure(Sender: TWThread; const Int: Integer; const DWrd: Word) of object;

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceviceString: TWThreadReceiveString;
        FOnThreadReceiveInt: TWThreadReceiveInt;
        FOnThreadReceiveStringWord: TWThreadReceiveStringWord;
        FOnThreadReceiveIntWord: TWThreadReceiveIntWord;
    protected
        procedure WWindowProc(var Msg: TMessage);
        procedure SendString(const Text: string);
        procedure SendInteger(const Int: Integer);
        procedure SendStringWord(const Text: string; const Wrd: DWord);
        procedure SendIntegerWord(const Int: Integer; const Wrd: DWord);
        procedure DoThreadReceiveString(const Text: string);
        procedure ParseUrl(const URL: string); // процедура парсера
        procedure Execute; override; // шаблон процедуры
    public
        constructor Create(CreateSuspended: Boolean); virtual;
        destructor Destroy; override;
        // отправка любого сообщения в поток
        function SendMessageToThread(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // отправка строки в поток
        function SendStringToThread(const Text: string): boolean;
        // отправка числа и строки в поток
        function SendStringIntToThread(const Text: string; const Wrd: DWord): boolean;
        // остановка потока по феншую
        function StopThread: boolean;
        // события на получение данных из потока
        property OnThreadReceviceString: TWThreadReceiveString read FOnThreadReceviceString write FOnThreadReceviceString;
        property OnThreadReceiveInt: TWThreadReceiveInt read FOnThreadReceiveInt write FOnThreadReceiveInt;
        property OnThreadReceiveStringWord: TWThreadReceiveStringWord read FOnThreadReceiveStringWord write FOnThreadReceiveStringWord;
        property OnThreadReceiveIntWord: TWThreadReceiveIntWord read FOnThreadReceiveIntWord write FOnThreadReceiveIntWord;
    end;

implementation

const
    WM_BASE             = WM_USER + $100;
    WM_STRING           = WM_BASE + 1;
    WM_INT              = WM_BASE + 2;
    WM_STRING_WORD      = WM_BASE + 3;
    WM_INT_WORD         = WM_BASE + 4;

    WM_MAX              = WM_INT_WORD;

{ TWThread }

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

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

procedure TWThread.DoThreadReceiveString(const Text: string);
begin
    if Assigned(FOnThreadReceviceString) then
        FOnThreadReceviceString(Self, Text);
end;

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

function TWThread.SendStringToThread(const Text: string): boolean;
var buf: LPARAM;
begin
    buf := 0;
    String(Buf) := Text;
    result := PostThreadMessage(ThreadID, WM_STRING, 0, buf);
end;

function TWThread.SendStringIntToThread(const Text: string; const Wrd: DWord): boolean;
var buf: LPARAM;
begin
    buf := 0;
    String(Buf) := Text;
    result := PostThreadMessage(ThreadID, WM_STRING_WORD, Wrd, buf);
end;

procedure TWThread.Execute;
var
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;
    str: string;
    dw: DWord;
label
    EndOfThread;
begin
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    SleepEx(20, false);

    // тестовый пример vvv
    SendString('WThread started');
    // тестовый пример ^^^

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_BASE, WM_MAX, PM_REMOVE) then begin
            dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, INFINITE, QS_ALLINPUT);
            case dwHandleSignaled of
                WAIT_OBJECT_0: begin // выставлено событие остановки потока
                    Terminate;
                    goto EndOfThread;
                end;
                WAIT_OBJECT_0 + 1: begin // получено сообщение
                    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 // оконные сообщения тоже получаем
                Terminate;
                goto EndOfThread;
            end;
            WM_STRING: begin
                LPARAM(str) := msg.lParam;
                // что-нибудь делаем со строкой. например, отправляем обратно

                // тестовый пример vvv
                SendString(Format('received: %s', [str]));
                // тестовый пример ^^^

                str := ''; // "отпускаем" строку после работы с ней
            end;
            WM_INT: begin
                // здесь получаем число в msg.lparam;
            end;
            WM_STRING_WORD: begin
                dw := msg.wParam;
                LPARAM(str) := msg.lParam;
                // что-нибудь делаем со строкой и числом.
                // например число было 77
                case dw of
                    77: ParseUrl(str);
                end;

                str := ''; // "отпускаем" строку после работы с ней
            end;
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

procedure TWThread.ParseUrl(const URL: string);
begin
    SendString('Begin parsing...');
    // парсер
    SendString('Done parsing...');
end;

procedure TWThread.SendInteger(const Int: Integer);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT, 0, Int);
end;

procedure TWThread.SendIntegerWord(const Int: Integer; const Wrd: DWord);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT_WORD, Wrd, Int);
end;

procedure TWThread.SendString(const Text: string);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, 0, buf);
end;

procedure TWThread.SendStringWord(const Text: string; const Wrd: DWord);
var buf: LParam;
begin
    buf := 0;
    String(buf) := Text;
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_STRING, Wrd, buf);
end;

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

procedure TWThread.WWindowProc(var Msg: TMessage);
var str: String;
begin
    case Msg.Msg of
        WM_STRING: begin
            LPARAM(str) := Msg.LParam;
            DoThreadReceiveString(str);
            Msg.Result := 1;
        end;
        WM_INT: begin
            if Assigned(FOnThreadReceiveInt) then
                FOnThreadReceiveInt(Self, Msg.LParam);
            Msg.Result := 1;
        end;
        WM_STRING_WORD: begin
            LPARAM(str) := Msg.LParam;
            if Assigned(FOnThreadReceiveStringWord) then
                FOnThreadReceiveStringWord(Self, str, Msg.WParam);
            Msg.Result := 1;
        end;
        WM_INT_WORD: begin
            if Assigned(FOnThreadReceiveIntWord) then
                FOnThreadReceiveIntWord(Self, Msg.LParam, Msg.WParam);
            Msg.Result := 1;
        end;
    else
        Msg.Result := DefWindowProc(FToolWindow, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

end.



То есть поток выполняется всегда, но когда не парсит, то ожидает "приказа" в виде SendStringIntToThread(77, 'http://ya.ru')
...
Рейтинг: 0 / 0
30.09.2013, 16:19
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412112
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadman,

Блин, как-то всё необоснованно сложно завернуто.
Нет никакого стека для присланных URL, если поток не пропарсил предыдущий URL, то передать следующий URL будет проблематично. Особенно если это связано с большими ресурсными затратами или с обращением к устройствам ввода/вывода.

Предлагаю изменить для теста код твоего потока следующим образом:
procedure TWThread.ParseUrl(const URL: string);
begin
SendString('Begin parsing...');
// парсер
Sleep(1000);
SendString('Done parsing...');
end;

и попробовать пообращаться к потоку раз в пол секунды с разными урлами. Сколько урлов пропарсит твой поток?
...
Рейтинг: 0 / 0
30.09.2013, 17:19
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412125
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaНет никакого стека для присланных URL
Откуда такая информация?
DimonkaСколько урлов пропарсит твой поток?
Столько, сколько вмещает очередь сообщений ОС.
...
Рейтинг: 0 / 0
30.09.2013, 17:28
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412139
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Но именно в случае парсером страниц я бы сделал не один, а 50 потоков, регулируемых из главного, а не пихал бы всю работу в один доп поток. И при этом анализировал бы занятость потоков. Благо для этого (диалога между основным и доп потоком) тут все предусмотрено.
...
Рейтинг: 0 / 0
30.09.2013, 17:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412228
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Завтра напишу чуть более сложный пример для 50-ти потоков, которые стартуют случайно, отсчитывают случайное количество секунд и сообщают о своей работу основному потоку. Никаких тормозов интерфейса при этом не будет. Примерно такой метод работы с устройствами у меня используется на производстве.
...
Рейтинг: 0 / 0
30.09.2013, 18:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412263
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaНет никакого стека для присланных URL
Откуда такая информация?
DimonkaСколько урлов пропарсит твой поток?
Столько, сколько вмещает очередь сообщений ОС.
Ну так вот в том-то и дело, что поток использует очередь сообщений, а не очередь заданий. Отправителю надо будет хранить урлы, пока их не обработает поток.
Напиши код по обработке 2х урлов применро так:
Код: pascal
1.
2.
3.
4.
5.
s := "123";
Thread.DoParseURL(s);
s := "321";
Thread.DoParseURL(s);
s := "";

и посмотри, что он тебе выдаст.

Только не забудь поставить sleep(20) в парсинг урлов для изображения непосильного труда.

зы
DoParseURL() должен посылать какие надо команды для парсинга.
...
Рейтинг: 0 / 0
30.09.2013, 18:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412284
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Dimonka, сам напиши DoParseUrl и покажи, что в нем не так. У меня впечатление, что ты не понимаешь до конца, как это работает.
...
Рейтинг: 0 / 0
30.09.2013, 19:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412290
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
2 wadman

Не вчитывался ни в класс, ни в шаблон, ни в ваш диалог,
но на беглый взгляд - я бы ни в коем, НИ В КОЕМ случае
не использовал сообщения/события для обмена данными,
только для сигнализации. Тем более в шаблоне потока.

Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
30.09.2013, 19:30
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412293
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadman,

я так полагаю, это будет что-то вроде этого?

Код: pascal
1.
2.
3.
4.
5.
  
procedure TWThread.DoParseURL(const URL: string);
begin
  SendStringWord(URL, 77);
end;



Можешь тестировать :)
...
Рейтинг: 0 / 0
30.09.2013, 19:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412305
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Гаджимурадов Рустамя бы ни в коем, НИ В КОЕМ случае
не использовал сообщения/события для обмена данными,
только для сигнализации. Тем более в шаблоне потока.
И это правильно. Шаблон-же. Нужна копия данных, с выделением памяти. Но вот

Dimonka,

кажется хочет сделать свою работу моими руками, подогнав за мой счет шаблон под конкретную задачу. :)
DimonkaМожешь тестировать :)
Напишу конкретный парсер, где процедура парсинга будет твоя. А остальное, вместе с менеджером потоков, белым/черным списком урлов и диагностическими сообщениями - мое. Недорого.
...
Рейтинг: 0 / 0
30.09.2013, 19:53
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412314
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadman,

Получается, вместо примера использования ты показываешь мусор.
...
Рейтинг: 0 / 0
30.09.2013, 20:11
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412316
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Dimonka, некрасиво брать на слабо. Идеального кода не существует, как и людей. Научись адаптировать код, если программист. Это лишь шаблон, который справляется с необходимым минимумом.
...
Рейтинг: 0 / 0
30.09.2013, 20:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412417
Arioch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Arioch
Участник
Гаджимурадов РустамНИ В КОЕМ случае не использовал сообщения/события для обмена данными

Майкрософт ниего против не имеет, однако: http://msdn.microsoft.com/en-us/library/windows/desktop/ms649011.aspx
...
Рейтинг: 0 / 0
30.09.2013, 23:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412448
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
Arioch> Майкрософт ниего против не имеет, однако

Ну, Майкрософту и вам, с ним согласным, виднее, конечно.
Можете хоть в ногу себе стрелять, MS тоже против не будет.

P.S. Если уж чешется WM_COPYDATA, то лучше напрямую
MMF использовать (оно через них работает, AFAIK).

Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
30.09.2013, 23:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412449
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
Кстати, не заметил по ссылке ничего про "не имеет против".

Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
01.10.2013, 00:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412555
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
AriochМайкрософт ниего против не имеет
У МС примеры, которые я подсматривал как раз таки имеют свойство копировать данные (LocalAlloc, LocalFree) и передавать ссылку при работе с потоками.
...
Рейтинг: 0 / 0
01.10.2013, 08:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412558
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Нечто такое:
Код: pascal
1.
2.
3.
4.
5.
6.
            i := Length(Value)*SizeOfChar+SizeOfChar;
            buf1 := Pointer(LocalAlloc(LPTR, i));
            if (buf1 <> nil)and(FWindowHandle <> 0) then begin
                Move(PChar(Value)^, buf1^, i);
                PostMessage(FWindowHandle, WM_RECEIVE, 0, LPARAM(buf1));
            end;
...
Рейтинг: 0 / 0
01.10.2013, 09:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412684
Arioch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Arioch
Участник
Тем не менее, никаких рекомендаций против использования WM_COPYDATA там нет, ни в общем виде ни ввиде ограничений
...
Рейтинг: 0 / 0
01.10.2013, 10:52
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412772
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Dimonka, в общем, я учел твое замечание и допилил малость. Хотя все равно считаю, что твой пример - сие есть ошибка в проектировании: нужен менеджер потоков, который реагирует на занятость/свободность потоков.

Шаблон:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
unit WThread;
// модуль-шаблон для работы с доп.потоками
// позволяет "общаться" дополнительному и основному потокам посредством системной очереди сообщений
// без вызова синхронизации
// (c) wadman 2013
// допиливание и замечания приветствуются

// 1 для работы необходимо изменить/дописать метод Execute
// 2 присвоить необходимые события OnReceiveXXX - это события будут вызываться в основном потоке в порядке очереди
// 3 protected процедуры SendXXX используются в Execute, т.е. внути доп. потока и вызывают соответствующие события
//   в совновном потоке. см.п.2
// 4 для сообщения информации доп.потоку из основного используются процедуры SendToThreadXXX

interface

uses
    Classes,
    Windows,
    Messages,
    SysUtils;

type
    TWThread = class;

    // событие на получение строки из потока
    TWThreadReceiveString = procedure(Sender: TWThread; const Text: string) of object;
    // событие на получение числа из потока
    TWThreadReceiveInt = procedure(Sender: TWThread; const Int: Integer) of object;
    // событие на получение строки и числа из потока
    TWThreadReceiveStringWord = procedure(Sender: TWThread; const Text: string; const DWrd: DWord) of object;
    // событие на получение двух чисел из потока
    TWThreadReceiveIntWord = procedure(Sender: TWThread; const Int: Integer; const DWrd: DWord) of object;
    // событие на получение сообщения из потока
    TWThreadReceiveMessage = procedure(Sender: TWThread; const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM) of object;

    TWThread = class(TThread)
    private
        FToolWindow: THandle;
        hCloseEvent: THandle;
        FOnThreadReceiveString: TWThreadReceiveString;
        FOnThreadReceiveInt: TWThreadReceiveInt;
        FOnThreadReceiveStringWord: TWThreadReceiveStringWord;
        FOnThreadReceiveIntWord: TWThreadReceiveIntWord;
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
    protected
        function NewString(const Text: string): Pointer;
        function FreeString(var P: LPARAM): String;
        procedure WWindowProc(var Msg: TMessage);
        // 5 процедур отправки данных из Execute, с вызовом событий OnThreadReceiveXXX в основном потоке
        procedure SendString(const Text: string);
        procedure SendInteger(const Int: Integer);
        procedure SendStringWord(const Text: string; const Wrd: DWord);
        procedure SendIntegerWord(const Int: Integer; const Wrd: DWord);
        procedure SendMyMessage(const Msg: TMessage);

        procedure DoThreadReceiveString(const Text: string);
        procedure DoThreadReceiveInt(const Int: Integer);
        procedure DoThreadReceiveStringWord(const Text: string; const DWrd: DWord);
        procedure DoThreadReceiveIntWord(const Int: Integer; const DWrd: DWord);
        procedure DoThreadReceiveMessage(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
        procedure Execute; override; // шаблон процедуры
    public
        constructor Create(CreateSuspended: Boolean); virtual;
        destructor Destroy; override;
        // отправка любого сообщения В поток
        function SendToThreadMessage(AMsg: UInt; wParam: WPARAM; lParam: LPARAM): BOOL;
        // отправка строки В поток
        function SendToThreadString(const Text: string): boolean;
        // отправка числа и строки В поток
        function SendToThreadStringWord(const Text: string; const Wrd: DWord): boolean;
        // отправка числа В поток
        function SendToThreadInt(const Int: Integer): boolean;
        // отправка двух чисел В поток
        function SendToThreadIntWord(const Int: Integer; const Wrd: DWord): boolean;
        // остановка потока по феншую
        function StopThread: boolean;
        // события на получение данных ИЗ потока, вызываются в основном потоке
        property OnThreadReceiveString: TWThreadReceiveString read FOnThreadReceiveString write FOnThreadReceiveString;
        property OnThreadReceiveInt: TWThreadReceiveInt read FOnThreadReceiveInt write FOnThreadReceiveInt;
        property OnThreadReceiveStringWord: TWThreadReceiveStringWord read FOnThreadReceiveStringWord write FOnThreadReceiveStringWord;
        property OnThreadReceiveIntWord: TWThreadReceiveIntWord read FOnThreadReceiveIntWord write FOnThreadReceiveIntWord;
        property OnThreadReceiveMessage: TWThreadReceiveMessage read FOnThreadReceiveMessage write FOnThreadReceiveMessage;
    end;

implementation

const
    WM_BASE             = WM_USER + $100;
    WM_STRING           = WM_BASE + 1;
    WM_INT              = WM_BASE + 2;
    WM_STRING_WORD      = WM_BASE + 3;
    WM_INT_WORD         = WM_BASE + 4;
    WM_MSG              = WM_BASE + 5;

    WM_MAX              = WM_MSG;

    SizeOfChar          = SizeOf(Char);

{ TWThread }

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

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

procedure TWThread.DoThreadReceiveInt(const Int: Integer);
begin
    if Assigned(FOnThreadReceiveInt) then
        FOnThreadReceiveInt(Self, Int);
end;

procedure TWThread.DoThreadReceiveIntWord(const Int: Integer; const DWrd: DWord);
begin
    if Assigned(FOnThreadReceiveIntWord) then
        FOnThreadReceiveIntWord(Self, Int, DWrd);
end;

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

procedure TWThread.DoThreadReceiveString(const Text: string);
begin
    if Assigned(FOnThreadReceiveString) then
        FOnThreadReceiveString(Self, Text);
end;

procedure TWThread.DoThreadReceiveStringWord(const Text: string; const DWrd: DWord);
begin
    if Assigned(FOnThreadReceiveStringWord) then
        FOnThreadReceiveStringWord(Self, Text, DWrd);
end;

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

function TWThread.SendToThreadString(const Text: string): boolean;
var buf: Pointer;
begin
    buf := NewString(Text);
    result := PostThreadMessage(ThreadID, WM_STRING, 0, LPARAM(buf));
end;

function TWThread.SendToThreadStringWord(const Text: string; const Wrd: DWord): boolean;
var buf: Pointer;
begin
    buf := NewString(Text);
    result := PostThreadMessage(ThreadID, WM_STRING_WORD, Wrd, LPARAM(buf));
end;

function TWThread.SendToThreadInt(const Int: Integer): boolean;
begin
    result := PostThreadMessage(ThreadID, WM_INT, 0, Int);
end;

function TWThread.SendToThreadIntWord(const Int: Integer; const Wrd: DWord): boolean;
begin
    result := PostThreadMessage(ThreadID, WM_INT_WORD, Wrd, Int);
end;

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

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

    // тестовый пример vvv удалить
    SendString('WThread started');
    // тестовый пример ^^^

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

    while not Terminated do begin
        if not PeekMessage(msg, 0, WM_BASE, WM_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
                    // событие "таймер", если MSWait = количество миллисекунд
                    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;
            // обработка сообщений из основного потока через SendToThreadXXX
            WM_INT: begin // SendToThreadInt
                // msg.lParam = Integer
            end;
            WM_STRING: begin //SendStringToThread
                str := FreeString(msg.lParam);
                SendString(str);
            end;
            WM_INT_WORD: begin // SendToThreadIntWord
                // msg.lparam = Integer
                // msg.wparam = dword
            end;
            WM_STRING_WORD: begin // SendToThreadStringWord
                // msg.wparam = dword
                str := FreeString(msg.lParam);
                SendString(str);
            end;
            // здесь можно добавить свои события, отправленные SendToThreadMessage из основного потока
        end;
    end;
EndOfThread:
    // все что создали в начале процедуры, здесь удаляем
end;

function TWThread.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 TWThread.NewString(const Text: string): Pointer;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > 0 then begin
        Result := Pointer(LocalAlloc(LPTR, l+SizeOfChar));
        if LongBool(Result) then
            Move(Pointer(Text)^, Result^, l);
    end else
        Result := nil;
end;

procedure TWThread.SendInteger(const Int: Integer);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT, 0, Int);
end;

procedure TWThread.SendIntegerWord(const Int: Integer; const Wrd: DWord);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, WM_INT_WORD, Wrd, Int);
end;

procedure TWThread.SendMyMessage(const Msg: TMessage);
begin
    if FToolWindow <> 0 then
        PostMessage(FToolWindow, Msg.Msg, Msg.WParam, Msg.LParam);
end;

procedure TWThread.SendString(const Text: string);
var buf: Pointer;
begin
    buf := NewString(Text);
    if LongBool(buf) and (FToolWindow <> 0) then
        PostMessage(FToolWindow, WM_STRING, 0, LPARAM(buf))
    else
        FreeString(LPARAM(buf));
end;

procedure TWThread.SendStringWord(const Text: string; const Wrd: DWord);
var buf: Pointer;
begin
    buf := NewString(Text);
    if LongBool(buf) and (FToolWindow <> 0) then
        PostMessage(FToolWindow, WM_STRING, Wrd, LPARAM(buf))
    else
        FreeString(LPARAM(buf));
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_STRING: begin
            DoThreadReceiveString(FreeString(Msg.LParam));
            Msg.Result := 1;
        end;
        WM_INT: begin
            DoThreadReceiveInt(Msg.LParam);
            Msg.Result := 1;
        end;
        WM_STRING_WORD: begin
            DoThreadReceiveStringWord(FreeString(Msg.LParam), Msg.WParam);
            Msg.Result := 1;
        end;
        WM_INT_WORD: begin
            DoThreadReceiveIntWord(Msg.LParam, Msg.WParam);
            Msg.Result := 1;
        end;
        WM_MSG: 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.



Тестовый пример прежний, из стартового сообщения.
...
Рейтинг: 0 / 0
01.10.2013, 11:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412882
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
Читал, читал, и "Не выдержала душа поэта" :)
На сколько я понимаю основная мысль TWThread это посылка команды в поток что бы поток эту команду выполнил (асинхронно).
Вот альтернативный вариант, так сказать как бы я это сделал:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
unit WThread;

interface

uses
  Classes, Rtti, Generics.Collections, SyncObjs;

type
  TThreadMsg = record
    Msg: Word;
    Value: TValue;
  end;

  TWThread = class(TThread)
  private
    FMsgEvent: TEvent;
    FQueue: TQueue<TThreadMsg>;
  protected
    procedure Execute; override;
    procedure TerminatedSet; override;
  public
    constructor Create; overload;
    constructor Create(CreateSuspended: Boolean); overload;
    destructor Destroy; override;

    procedure PostMessage(AMessage: Word; const AValue: TValue);
  end;

implementation

{ TWThread }

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

constructor TWThread.Create(CreateSuspended: Boolean);
begin
  inherited Create(CreateSuspended);
  FQueue:=TQueue<TThreadMsg>.Create;
  FMsgEvent:=TEvent.Create(nil, False, False, '');
end;

destructor TWThread.Destroy;
begin
  FMsgEvent.Free;
  FQueue.Free;
  inherited;
end;

procedure TWThread.Execute;
var
  Msg: TThreadMsg;
begin
  while not Terminated do
  begin
    if (FMsgEvent.WaitFor = wrSignaled) and not Terminated then
    begin
      repeat
        TMonitor.Enter(FQueue);
        try
          Msg:=FQueue.Dequeue;
        finally
          TMonitor.Exit(FQueue);
        end;
        Dispatch(Msg);
      until FQueue.Count = 0;
    end;
  end;
end;

procedure TWThread.PostMessage(AMessage: Word; const AValue: TValue);
var
  Msg: TThreadMsg;
begin
  Msg.Msg:=AMessage;
  Msg.Value:=AValue;
  TMonitor.Enter(FQueue);
  try
    FQueue.Enqueue(Msg);
  finally
    TMonitor.Exit(FQueue);
  end;
  FMsgEvent.SetEvent;
end;

procedure TWThread.TerminatedSet;
begin
  inherited;
  FMsgEvent.SetEvent;
end;

end.


Наследник получается вот таким:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
unit Unit2;

interface

uses
  Windows, Messages, WThread;

const
  CM_TESTEVENT = WM_USER;

type
  TMyTestThread = class(TWThread)
  private
    procedure cmTestEvent(var Msg: TThreadMsg); message CM_TESTEVENT;
  end;

implementation

uses
  Unit1;

{ TMyTestThread }

procedure TMyTestThread.cmTestEvent(var Msg: TThreadMsg);
var
  I: Integer;
begin
  for I := 0 to 20 do
    Windows.PostMessage(Form1.Handle, CM_THREADEVENT, ThreadID, I);
end;

end.


Посылаем команду
Код: pascal
1.
  Th1.PostMessage(CM_TESTEVENT, 'Тестовая строка');


Cделано для XE3 но при определённых доработках можно перенести на более ранние версии. Например в место TValue можно использовать Variant.
...
Рейтинг: 0 / 0
01.10.2013, 12:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412895
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
Упс, цикл не правильный поставил, нужно заменить
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
      repeat
        TMonitor.Enter(FQueue);
        try
          Msg:=FQueue.Dequeue;
        finally
          TMonitor.Exit(FQueue);
        end;
        Dispatch(Msg);
      until FQueue.Count = 0;


на while
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
      while FQueue.Count > 0 do
      begin
        TMonitor.Enter(FQueue);
        try
          Msg:=FQueue.Dequeue;
        finally
          TMonitor.Exit(FQueue);
        end;
        Dispatch(Msg);
      end;

...
Рейтинг: 0 / 0
01.10.2013, 12:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412916
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат Сафин
Код: pascal
1.
procedure TWThread.PostMessage(AMessage: Word; const AValue: TValue);


Сейчас Димонка придет
...
Рейтинг: 0 / 0
01.10.2013, 12:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38412989
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
Почему интерфейс работы с потоками у всех вас такой заумный?

Сделайте по-человечески:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
type
  TAbstractJob = class
     procedure DoJob: virtual; abstract;
  end;

  TJobThread = class(TTHread)
  public
    procedure AddJob(Job: TAbstractJob);
    property FIFO: boolean;
  end;


Всё! больше нормальному человеку ничего не надо от потока.
А уж пользователь унаследуется от TAbstractJob и добавит свой функционал.
...
Рейтинг: 0 / 0
01.10.2013, 13:20
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413000
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaПочему интерфейс работы с потоками у всех вас такой заумный?
Проще и с кучей косяков, которые многие допускают по незнанию - TThread. Куда уж проще. Но ведь кому-то не просто хочется отдать другому потоку некую работу, а и получить результат и т.п.
...
Рейтинг: 0 / 0
01.10.2013, 13:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413017
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaПочему интерфейс работы с потоками у всех вас такой заумный?
Проще и с кучей косяков, которые многие допускают по незнанию - TThread. Куда уж проще. Но ведь кому-то не просто хочется отдать другому потоку некую работу, а и получить результат и т.п.

Т.е. с твоим интерфейсом косяков по незнанию будет меньше?
Или надо сделать всё настолько сложно, что пока разбираешься в том, что ты сделал, поймёшь как потоки работают? :)
...
Рейтинг: 0 / 0
01.10.2013, 13:30
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413021
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaТ.е. с твоим интерфейсом косяков по незнанию будет меньше?
Пока что ты нашел один и я его поправил.
...
Рейтинг: 0 / 0
01.10.2013, 13:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413028
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
Почему интерфейс работы с потоками у всех вас такой заумный?Почему интерфейс работы с потоками у всех вас такой заумный?
Кому то нравится цвет жёлтый, кому то красный, с интерфейсами такая же фигня :(
...
Рейтинг: 0 / 0
01.10.2013, 13:34
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413030
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaТ.е. с твоим интерфейсом косяков по незнанию будет меньше?
Пока что ты нашел один и я его поправил.

Основной косяк в том, что если пользователю надо будет добавить функционал к товему потоку, ему надо будет менять твой код.
Это, я считаю, в корне неправильно.
...
Рейтинг: 0 / 0
01.10.2013, 13:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413031
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaИли надо сделать всё настолько сложно, что пока разбираешься в том, что ты сделал, поймёшь как потоки работают? :)
Ты ведь не просто критикуешь, а понимаешь что и как? Будем рады увидеть и твой вариант реализации. :)
...
Рейтинг: 0 / 0
01.10.2013, 13:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413035
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaОсновной косяк в том, что если пользователю надо будет добавить функционал к товему потоку, ему надо будет менять твой код.
Я как-то не подумал об этом. Ты это серьезно?
...
Рейтинг: 0 / 0
01.10.2013, 13:39
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413061
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaОсновной косяк в том, что если пользователю надо будет добавить функционал к товему потоку, ему надо будет менять твой код.
Я как-то не подумал об этом. Ты это серьезно?

Ну дык, если ты вдруг скажешь - у меня ещё N косяков обнаружилось в коде и вот она - новая версия, то пользователь тебе скажет "спасыпо".
...
Рейтинг: 0 / 0
01.10.2013, 13:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413063
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaНу дык, если ты вдруг скажешь - у меня ещё N косяков обнаружилось в коде и вот она - новая версия, то пользователь тебе скажет "спасыпо".
А, ты все еще об идеальном коде...
...
Рейтинг: 0 / 0
01.10.2013, 14:02
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413082
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaНу дык, если ты вдруг скажешь - у меня ещё N косяков обнаружилось в коде и вот она - новая версия, то пользователь тебе скажет "спасыпо".
А, ты все еще об идеальном коде...

Я не об идеальном коде, а о практической стороне вопроса.
Если алгоритм пользователя вне твоего кода, то пользователю надо заменить только твой юнит. А если внутри твоего кода, то надо будет редактировать весь код, где использовался твой "шаблон".
...
Рейтинг: 0 / 0
01.10.2013, 14:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413092
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaА если внутри твоего кода, то надо будет редактировать весь код, где использовался твой "шаблон".
Пояснить, что такое шаблон? Заканчивай оффтопить, выдвигай пожелания и свои варианты. Описал-же идеальный вариант, похвастайся и реализацией.
...
Рейтинг: 0 / 0
01.10.2013, 14:19
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38413833
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат Сафин, думал, думал над твоим решением... Есть мои мелкие "но" с передачей параметра в поток и получением результата, но в целом весьма изящно. Для меня открытием стало наличие TEvent :)
...
Рейтинг: 0 / 0
02.10.2013, 09:19
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414039
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaА если внутри твоего кода, то надо будет редактировать весь код, где использовался твой "шаблон".
Пояснить, что такое шаблон? Заканчивай оффтопить, выдвигай пожелания и свои варианты. Описал-же идеальный вариант, похвастайся и реализацией.
Не понимаю, что тебе пояснить? Как наследоваться от TAbstractJob?
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
  TMyThreadJob = class(TAbstractJob)
  public
    procedure DoJob; override;
    property Любые Данные: Любого типа;
  end;

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

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



По вкусу делаешь очередь обработки заданий:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
  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;


Получение следующего задания из списка:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
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;



// Добавление задания
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
procedure TBaseJobThread.AddJob(AJob: TAbstractJob);
begin
  FListLock.Acquire;
  try
    FList.Add(AJob);
    FJobAdded.SetEvent;
  finally
    FListLock.Release;
  end;
end;



Ну и для пояснения:
FJobAdded: TEvent;
FListLock: TCriticalSection;
...
Рейтинг: 0 / 0
02.10.2013, 11:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414065
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaНу и для пояснения:
Поясни, что значат эти куски кода для людей, которые впервые столкнулись с потоками? Это по-твоему решение для новичка?
...
Рейтинг: 0 / 0
02.10.2013, 11:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414142
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaНу и для пояснения:
Поясни, что значат эти куски кода для людей, которые впервые столкнулись с потоками? Это по-твоему решение для новичка?
Так людям и не надо ничего понимать, им надо просто унаследоваться от задания:

Код: pascal
1.
2.
3.
4.
5.
TMyThreadJob = class(TAbstractJob)
  public
    procedure DoJob; override;
    property Любые Данные: Любого типа;
  end;


Я не делаю "шаблон", я просто подсказываю, в какую сторону крутить архитектуру, чтобы твою конструкцию мог использовать не только ты сам.
...
Рейтинг: 0 / 0
02.10.2013, 12:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414180
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaТак людям и не надо ничего понимать
Уровни "написания" кода:
1. API
2. VCL
3. VCL+Component
4. Нанять программиста.

Людям, которым не нужно что-либо понимать достаточно пунктов 3 и 4. Я работаю на производстве, где скорость - ключевой фактор и потому п.1 в приоритете. Ты-же не предлагаешь ничего. Лишь толсто троллишь. Какой там по счету(?) и последний раз: есть свой вариант? Выкладывай. Рабочий вариант. Твоего решения.
...
Рейтинг: 0 / 0
02.10.2013, 13:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414181
MrCat
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
MrCat
Гость
Кстати, а кто-нибудь помнит - в Лазаре есть посылка сообщений потоку? Они под Linux эмулируются или нет? Конечно, своя очередь заданий с синхронизацией доступа в любом случае будет работать, но интересно - будет ли работать под Linux первый вариант.
...
Рейтинг: 0 / 0
02.10.2013, 13:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414210
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
MrCatКстати, а кто-нибудь помнит - в Лазаре есть посылка сообщений потоку?
Там не все так просто. В винде все будет работать, а с линуксом придется повозиться http://wiki.freepascal.org/Multithreaded_Application_Tutorial/ru
...
Рейтинг: 0 / 0
02.10.2013, 13:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414212
Barmaley57
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Barmaley57
Участник
wadmanЯ работаю на производстве, где скорость - ключевой факторПоясни
...
Рейтинг: 0 / 0
02.10.2013, 13:24
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414214
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaТак людям и не надо ничего понимать
Уровни "написания" кода:
1. API
2. VCL
3. VCL+Component
4. Нанять программиста.

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

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

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

Ну и это ты хочешь что-то выложить, я ничего выкладывать не обещал. ;)
...
Рейтинг: 0 / 0
02.10.2013, 13:24
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414220
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Barmaley57wadmanЯ работаю на производстве, где скорость - ключевой факторПоясни
Поясняю: компы дохлые, смартфоны сейчас мощнее, а железячки, подключенные десятками к этим компам, критично относятся к скорости реакции - закрывают обмен по своей воле.
DimonkaИ твой код к API никакого отношения не имеет.
противоречит следующему
Dimonkaты пытаешься передать в поток через какие-то низкоуровневые примитивы

Ну да ладно.
DimonkaЯ предлагаю твоё месиво кода отделить от кода пользователя.
Отклонено.
...
Рейтинг: 0 / 0
02.10.2013, 13:27
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414259
MrCat
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
MrCat
Гость
с линуксом придется повозиться Да вот он меня и интересовал как раз. Если формулировать точнее, то эмулирована ли в LCL PostThreadMessage в сборке под Linux. Под виндой-то это без проблем должно работать - хоть в Лазаре, хоть где, сообщения - родной для неё механизм. В любом случае, можно импортировать из User32.dll.

Гугл сообщает, что PostThreadMessage в сборке под Линукс нет, что там вообще "так не принято". А если и проэмулируют её, то фиг знает через какой механизм. Понятненько.
...
Рейтинг: 0 / 0
02.10.2013, 13:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38414283
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanDimonkaИ твой код к API никакого отношения не имеет.
противоречит следующему
Dimonkaты пытаешься передать в поток через какие-то низкоуровневые примитивы
Первое утверждение перпендикулярно второму. Аббревиатура API никаким образом не накладывает ограничение на типы данных.

В общем, успехов.
...
Рейтинг: 0 / 0
02.10.2013, 14:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415237
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Версия без шаблона, для создания наследника. Подглядел у Марата Сафина. :)

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
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.



Адаптированный пример под этот модуль из первого сообщения
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
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.

...
Рейтинг: 0 / 0
03.10.2013, 11:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415513
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadman, зачем новые замороченные функции для "конвертации" string в LPARAM и обратно? твои прежние были чотче))
...
Рейтинг: 0 / 0
03.10.2013, 14:08
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415523
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chзачем новые замороченные функции для "конвертации" string в LPARAM и обратно? твои прежние были чотче))
Один товарищ нашел косячек в такой передаче. Искал и нашёл. Такой, с которым я на производстве даже не столкнулся. :)
...
Рейтинг: 0 / 0
03.10.2013, 14:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415527
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
и что же мешает написать подробности, а то кто-то использует аналогичный старому метод)
...
Рейтинг: 0 / 0
03.10.2013, 14:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415539
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chи что же мешает написать подробности, а то кто-то использует аналогичный старому метод)
Погоди, для начала поясни, что ты подразумеваешь под старым и новым методом?
...
Рейтинг: 0 / 0
03.10.2013, 14:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415552
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
старый
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
function NewString(const Str: string): LPARAM;
 begin
  Result:=0;
  string(Result):=Str
 end;

function FreeString(StrPtr: LPARAM): string;
 begin
  LPARAM(Result):=StrPtr
 end;


новый
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
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;
...
Рейтинг: 0 / 0
03.10.2013, 14:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415563
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00ch, ответ тут 14903409

В кратце, пока доп. поток работает со строкой как с константой, основной поток может с ней работать как с переменной, т.к. строка для него не залочена.
...
Рейтинг: 0 / 0
03.10.2013, 14:27
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415599
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadman, не понял, в чем проблема, поясни подробнее
...
Рейтинг: 0 / 0
03.10.2013, 14:45
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38415620
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00ch, теперь и я не понял, откуда тролль Димонка высосал проблему... Действительно её не существует и такой способ для передачи строк таки нормально себя ведет.

Проверка. Модуль:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
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.



Программа:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
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


Никаких потерь.
...
Рейтинг: 0 / 0
03.10.2013, 15:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38416394
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Немного доработанная процедура. Два некритичных проекта перевел на работу с этим модулем. Из изменений: добавлена процедур DirectTimeOut, которая вызывается после превышения интервала ожидания в этом-же потоке, а не по событию в основном.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
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.

...
Рейтинг: 0 / 0
04.10.2013, 10:09
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38424883
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

надеюсь, что это окончательный вариант, "... фактическая бумажка! Броня!!!" (с). А то у меня уже место на винте скоро кончится архивировать этот топег
...
Рейтинг: 0 / 0
11.10.2013, 18:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38424914
Гхостик
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гхостик
Гость
Может, выложить уже на Bitbucket?
...
Рейтинг: 0 / 0
11.10.2013, 19:09
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38425126
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Док, в окончательном варианте у меня в execute при вызове sleepex вместо false - true :) почему, хэлп ответит.
...
Рейтинг: 0 / 0
12.10.2013, 10:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38425139
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanпочему, хэлп ответит
т.е. у тебя еще и шкатулка с секретом?

Тогда нафиг, сам себе напишу
...
Рейтинг: 0 / 0
12.10.2013, 11:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38430776
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Пока что самая последняя версия.

Модуль:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
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.



Пример использования:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
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.

...
Рейтинг: 0 / 0
17.10.2013, 10:11
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38431255
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadman, а что произойдет с сообщениями, которые были отправлены ToolWindow в конце Execute, если след.командой будет вызов деструктора, где проиходит уничтожение этого самого ToolWindow?
...
Рейтинг: 0 / 0
17.10.2013, 14:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38431387
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chа что произойдет с сообщениями
Улетят в пустоту. Так же как и те, которые будут отправлены в поток до создания очереди сообщений для него, т.к. очередь для потока создается с небольшой задержкой.
...
Рейтинг: 0 / 0
17.10.2013, 15:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38432107
Фотография Gator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Gator
Участник
wadman, Вы ChangeLog ведёте? Скрываете? :)
...
Рейтинг: 0 / 0
17.10.2013, 23:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38432271
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Gatorwadman, Вы ChangeLog ведёте? Скрываете? :)
Таки нет. Впечатление, что такие мелочи не требуют соблюдения формальностей. На вопросы "что как и почему" отвечаю.
...
Рейтинг: 0 / 0
18.10.2013, 09:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38445448
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Поколение Next: Delphi&Lazarus. В виду отсутствия некоторых приятностей в Лазарусе пришлось немного извернуться. Для коммуникации доп. потока с основным прикрутил еще один поток.

Модуль:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
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:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
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:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
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.



Результаты в обоих средах разработки одинаковы. :)
...
Рейтинг: 0 / 0
29.10.2013, 16:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38445526
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Кстати, кто-нибудь возьмется протестировать под линуксом? Очень хочется узнать результат кросс-платформенности.
...
Рейтинг: 0 / 0
29.10.2013, 17:16
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446027
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
Зря на Dimonka наехали, он более грамотную архитектуру предлагал
...
Рейтинг: 0 / 0
30.10.2013, 03:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446154
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
white_niggerЗря на Dimonka наехали, он более грамотную архитектуру предлагал
Ровно с тем-же количеством аргументов можно и опровергнуть эту грамотность.
...
Рейтинг: 0 / 0
30.10.2013, 09:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446273
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
Я вижу три аргумента.
1. Разделение логики. Нет мешанины в коде. Т.е. шаблон превращается по факту в готовый, расширяемый паттерн.
2. За выноса логики юзер-работы появляется легкая возможность покрытия её тестом.
3. Гм... а вы в команде работали? Сопровождать дешевле граммотную архитектуру

Ну в-общем каждый судит со своего опыта. Можно отнестись "работает - да и ладно", а можно продумать на будущее
...
Рейтинг: 0 / 0
30.10.2013, 11:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446289
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
white_niggerа можно продумать на будущее
Для ленивых в инете полно оберток в виде компонент и даже целых библиотек для работы с потоками. Я-же предложил свою модель, без наворотов, но покрывающую большинство мелких задач с минимумом типичных ошибок. У каждого своя ниша.

 
Димонка - тролль, который сочиняет проблемы в голове, а не в коде.
...
Рейтинг: 0 / 0
30.10.2013, 11:08
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446466
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
Насчет спойлера - не знаю, не следил за его постами. Просто в данном, конкретном случае его подход мне больше импонирует. Причины я отписал выше. В любом случае - мир, дружба, жвачка
...
Рейтинг: 0 / 0
30.10.2013, 12:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446916
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanДимонка - тролль, который сочиняет проблемы в голове, а не в коде.
Спасибо, конечно, за оценку. Но в век ООП и предметности пересылать из потока в поток практически машинные примитивы - это огромное достижение. То что нужно 99.9% программистов ежедневно.

Я вижу сутуацию примерно так: ты придумал проблему, успешно её решил, а все кто считает, что проблемы-то в основном у людей другие, - тролли и негодяи. Жаль что меня забанят, но не мог не ответить.
...
Рейтинг: 0 / 0
30.10.2013, 15:56
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446935
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
Dimonka> Жаль что меня забанят, но не мог не ответить.

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

Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
30.10.2013, 16:02
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446963
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
Гаджимурадов РустамDimonka> Жаль что меня забанят, но не мог не ответить.

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

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

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

Очень не понимаю, почему автор топика так агресивен к достаточно контруктивной (на мой взгляд) критике.
...
Рейтинг: 0 / 0
30.10.2013, 16:11
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38446975
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
DimonkaОчень не понимаю, почему автор топика так агресивен к достаточно контруктивной (на мой взгляд) критике.
14918946

Еще раз: у этого решения своя ниша, минимум наворотов и, соответственно, ошибок. Особенно для новичков, которых-то голый TThread запутывает.
...
Рейтинг: 0 / 0
30.10.2013, 16:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447032
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
Dimonka> Одно из решений я уже предлагал выше

C кодом?

Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
30.10.2013, 16:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447040
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат Сафин, кстати, твой вариант с TValue/Variant не выдерживает мой тест в дельфи. В лазарусе - все отлично. Потому пришлось отказаться в пользу LParam, чтоб работало одинаково на обоих платформах.
...
Рейтинг: 0 / 0
30.10.2013, 16:42
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447176
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
Гаджимурадов РустамDimonka> Одно из решений я уже предлагал выше
C кодом?
По крайней мере с кодом возможного интерфейса. Я не обещал дать готовое решение. Просто предлагал способ обойти недостатки данного решения.
...
Рейтинг: 0 / 0
30.10.2013, 17:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447387
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
wadman,
Какой ешё тест?
...
Рейтинг: 0 / 0
30.10.2013, 19:44
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447436
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат Сафинwadman,
Какой ешё тест?
Который придумал Димонка 15047828 Если жать "тест" (Button2) подряд 5 раз и вводить с 1о-го по 5-ть, то вылетает ошибка. Текст не помню, но воспроизвести не составит труда.
...
Рейтинг: 0 / 0
30.10.2013, 20:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447692
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
wadmanМарат Сафин, кстати, твой вариант с TValue/Variant не выдерживает мой тест в дельфи. В лазарусе - все отлично. Потому пришлось отказаться в пользу LParam, чтоб работало одинаково на обоих платформах.
Там метод Destroy переделать нужно, сначала вызывать inherited а потом уничтожать объекты, я забыл про эту особенность TThread. то есть вот так:
Код: pascal
1.
2.
3.
4.
5.
6.
destructor TWThread.Destroy;
begin
  inherited;
  FMsgEvent.Free;
  FQueue.Free;
end;
...
Рейтинг: 0 / 0
31.10.2013, 07:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447693
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
Других косяков не нашёл, у меня работает на ура.
...
Рейтинг: 0 / 0
31.10.2013, 07:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447745
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
Dimonka,
Писал я год назад такую вот штуку возможно это то, что вы хотели.
...
Рейтинг: 0 / 0
31.10.2013, 09:14
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447757
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат СафинДругих косяков не нашёл, у меня работает на ура.
Это потому что строки не используются.

Модуль с вариантом:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
unit WThread2;

// модуль для работы с доп.потоками 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: Variant;
    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: Variant);
        {$ELSE}
        procedure SendGUIMessage(Message: Word; WParam: Word; LParam: Variant);
        {$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: Variant);
        {$ELSE}
        procedure PostMessage(Message: Word; WParam: Word; LParam: Variant);
        {$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): Variant;

// возвращение строки к привывчному виду после приема из другого потока
function FreeString(var P: Variant): 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: Variant);
        {$ELSE}
        procedure PostMessage(Message: Word; WParam: Word; LParam: Variant);
        {$ENDIF}
        procedure StopThread;
    end;

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

function FreeString(var P: Variant): String;
begin
    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: Variant);
{$ELSE}
procedure TGUIThread.PostMessage(Message: Word; WParam: Word; LParam: Variant);
{$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: Variant);
{$ELSE}
procedure TWThread.SendGUIMessage(Message: Word; WParam: Word; LParam: Variant);
{$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: Variant);
{$ELSE}
procedure TWThread.PostMessage(Message: Word; WParam: Word; LParam: Variant);
{$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.



Тестовый проект:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
unit LazMain;

interface

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

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.



Результат:
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
-> 1
<- 1
-> 2
-> 3
-> 4
-> 5
<- 1
<- 2
И First chance exception at $75F8B9BC. Exception class EVariantBadVarTypeError with message 'Invalid variant type'. Process LazThreadTest.exe (7848)

И "An unexpected memory leak has occured. The unexpected small block leaks are: 13-20 bytes: UnicodeString x 5; 21-28 bytes: Unknown x 5
...
Рейтинг: 0 / 0
31.10.2013, 09:29
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447766
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
wadmanЭто потому что строки не используются.
Тест простой: поставить фокус на кнопку Button2 и поехали! Enter 1 Enter Enter 2 Enter Enter 3 Enter Enter 4 Enter Enter 5 Enter

Должно быть так:
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
-> 1
<- 1
-> 2
-> 3
-> 4
-> 5
<- 1
<- 2
<- 2
<- 3
<- 3
<- 4
<- 4
<- 5
<- 5
...
Рейтинг: 0 / 0
31.10.2013, 09:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447784
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
wadman,
Я тестировал свой код, а не твой. В твоём коде косяк в использовании PThreadMessage нельзя выделять память через GetMem и освобождать через FreeMem, нужно пользоваться New и Dispose. Возможно есть другие ошибки.
...
Рейтинг: 0 / 0
31.10.2013, 09:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447791
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат СафинВозможно есть другие ошибки.
Ок, учел замечание по поводу New/Dispose. Memory leak остался. Включи в своем тесте ReportMemoryLeaksOnShutdown и погоняй его со строками, как у меня.
...
Рейтинг: 0 / 0
31.10.2013, 10:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447987
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
wadmanМарат СафинВозможно есть другие ошибки.
Ок, учел замечание по поводу New/Dispose. Memory leak остался. Включи в своем тесте ReportMemoryLeaksOnShutdown и погоняй его со строками, как у меня.
"Пилите, Шура, пилите. Они золотые" мне за поиск ошибок в вашем коде денег не платят :)
...
Рейтинг: 0 / 0
31.10.2013, 11:44
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447992
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат Сафинwadmanпропущено...

Ок, учел замечание по поводу New/Dispose. Memory leak остался. Включи в своем тесте ReportMemoryLeaksOnShutdown и погоняй его со строками, как у меня.
"Пилите, Шура, пилите. Они золотые" мне за поиск ошибок в вашем коде денег не платят :)
Вон оно что! Давай свой код, я найду ошибки в нем.
...
Рейтинг: 0 / 0
31.10.2013, 11:45
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38447995
host.13
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
host.13
Участник
wadman,

Вопросик: почему используется окно? Не проще ли без окна, но с очередью сообщений и использованием PostThreadMessage вместо PostMessage? Будет ли разница?
...
Рейтинг: 0 / 0
31.10.2013, 11:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38448003
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
host.13Вопросик: почему используется окно? Не проще ли без окна, но с очередью сообщений и использованием PostThreadMessage вместо PostMessage? Будет ли разница?
Последний вариант, который мультиплатформенный и вовсе без окон и PostThreadMessage.

А тот, что с окном, если его рассмотреть более внимательно, использует PostThreadMessage для отправки сообщения доппотоку, а окно для получения сообщения из доппотока и обработки его в событии основного потока.
...
Рейтинг: 0 / 0
31.10.2013, 11:49
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38448006
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
wadmanМарат Сафинпропущено...

"Пилите, Шура, пилите. Они золотые" мне за поиск ошибок в вашем коде денег не платят :)
Вон оно что! Давай свой код, я найду ошибки в нем.
14906181 учитывая 14906229 и 15056478
...
Рейтинг: 0 / 0
31.10.2013, 11:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38448016
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат Сафинwadmanпропущено...

Вон оно что! Давай свой код, я найду ошибки в нем.
14906181 учитывая 14906229 и 15056478
1. Последнее изменение значения не имеет.
2. У тебя нет обратного сообщения основному потоку.
...
Рейтинг: 0 / 0
31.10.2013, 11:54
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38448033
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
wadman2. У тебя нет обратного сообщения основному потоку.
А с учетом этого замечания не совсем понятно, зачем наворачивать такого потомка, если он отработает свое задание один раз и об этом никто не узнает. Здесь хватит перекрытия классического TThread.Execute.
...
Рейтинг: 0 / 0
31.10.2013, 11:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38448045
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
wadmanМарат Сафинпропущено...

14906181 учитывая 14906229 и 15056478
1. Последнее изменение значения не имеет.
2. У тебя нет обратного сообщения основному потоку.
1. Если поток чего то делает (тоесть в очереди есть сообщения), и в это время ты ему делаеш Terminate, а потом Free, то имеет.
2. Это не ошибка, а особенность реализации :)

Если есть ещё желание ковыряться в чужом коде то по ковыряйся в исходниках поста , там больше вероятность, что есть ошибка :)
...
Рейтинг: 0 / 0
31.10.2013, 12:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38448082
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат СафинЕсли есть ещё желание ковыряться в чужом коде то по ковыряйся в исходниках поста , там больше вероятность, что есть ошибка :)
Иди туда, не знаю куда, принести то, не знаю что. :)
...
Рейтинг: 0 / 0
31.10.2013, 12:15
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38448297
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
Марат СафинDimonka,
Писал я год назад такую вот штуку возможно это то, что вы хотели.
Да у меня сейчас вообще извращённая хотелка - хочется, чтобы всё ещё и в FMX красиво работало.
...
Рейтинг: 0 / 0
31.10.2013, 13:42
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38457385
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Вариант only for Windows дописан и доведен до производственного цикла. Вариант с передачей строк без выделения памяти признан негодным при интенсивном обмене строками, но оставлен в комментариях.

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
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;

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

type
    TWThread = class;

    // событие на получение сообщения из потока
    TWThreadReceiveMessage = procedure(Sender: TWThread; var Msg: TMessage) 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 PostMessageFromMe(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
        procedure DoThreadReceiveMessage(const Msg: Cardinal; const WParam: WPARAM; const 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): NativeInt;

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

implementation

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

    SizeOfChar          = SizeOf(Char);

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

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

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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
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(const Msg: Cardinal; const WParam: WPARAM; const LParam: LPARAM);
var ThreadMsg: TMessage;
begin
    if Assigned(FOnThreadReceiveMessage) then begin
        ThreadMsg.Msg := Msg;
        ThreadMsg.WParam := WParam;
        ThreadMsg.LParam := LParam;
        FOnThreadReceiveMessage(Self, ThreadMsg);
    end;
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, THandle(-1), 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
                        PostMessageFromMe(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Msg := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
end;

procedure TWThread.PostMessageFromMe(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_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.

...
Рейтинг: 0 / 0
08.11.2013, 09:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38457571
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
wadman,
Ошибку в своём коде с утечкой памяти, ты так и не нашёл, по этому всё переделал. А нужно просто в TWThread.Destroy почистить список FQueue. Что то типа:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
procedure TWThread.ClearQueue;
var
  Msg: PThreadMessage;
begin
  while FQueue.Count>0 do
  begin
    Msg:=FQueue[0];
    FQueue.Delete(0);
    Dispose(Msg);
  end;
end;

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

...
Рейтинг: 0 / 0
08.11.2013, 11:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38457575
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Марат СафинОшибку в своём коде с утечкой памяти, ты так и не нашёл, по этому всё переделал.
Тут ты не прав. Пока что есть две версии и вторая не отлажена, признаю, т.к. её предназначение - лазарус. Дойдут и до него руки и тогда совмещу все в одном.
...
Рейтинг: 0 / 0
08.11.2013, 11:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38457579
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
За подсказку спасибо. Я экстренно еще не убивал такой поток, потому в этом месте утечек не ловил.
...
Рейтинг: 0 / 0
08.11.2013, 11:52
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38457868
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadmanВариант с передачей строк без выделения памяти признан негодным при интенсивном обмене строкамишто?
...
Рейтинг: 0 / 0
08.11.2013, 13:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38457993
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chwadmanВариант с передачей строк без выделения памяти признан негодным при интенсивном обмене строкамишто?
SearchEngine после поиска по нескольким тысячам папок и после выдачи результата в тысячу файлов.
...
Рейтинг: 0 / 0
08.11.2013, 14:44
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38458019
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadmanSearchEngine после поиска по нескольким тысячам папок и после выдачи результата в тысячу файлов.ну значит, либо твой энджин где-то течет, либо ты какое-то непотребство в функции передаешь, либо прославленный оптимизатор оптимизирует))
...
Рейтинг: 0 / 0
08.11.2013, 14:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38458051
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chwadmanSearchEngine после поиска по нескольким тысячам папок и после выдачи результата в тысячу файлов.ну значит, либо твой энджин где-то течет, либо ты какое-то непотребство в функции передаешь, либо прославленный оптимизатор оптимизирует))
"Старый" способ работает на производстве и ничего с ним не происходит, но там нет таких экстремальных подач ото всюду. Скоро все переведу на праведный способ передачи данных путем создания снапшота, дабы избежать.
...
Рейтинг: 0 / 0
08.11.2013, 15:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38459982
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
SearchEngine

Форма
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
object frmSearchMain: TfrmSearchMain
  Left = 0
  Top = 0
  Caption = 'Search Engine'
  ClientHeight = 312
  ClientWidth = 604
  Color = clBtnFace
  Constraints.MinHeight = 350
  Constraints.MinWidth = 620
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  ScreenSnap = True
  OnCloseQuery = FormCloseQuery
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  DesignSize = (
    604
    312)
  PixelsPerInch = 96
  TextHeight = 13
  object Label3: TLabel
    Left = 8
    Top = 189
    Width = 35
    Height = 13
    Caption = 'Results'
  end
  object memLog: TMemo
    Left = 8
    Top = 208
    Width = 588
    Height = 96
    Anchors = [akLeft, akTop, akRight, akBottom]
    ReadOnly = True
    ScrollBars = ssBoth
    TabOrder = 2
    OnDblClick = memLogDblClick
    ExplicitWidth = 636
    ExplicitHeight = 238
  end
  object butStart: TButton
    Left = 497
    Top = 22
    Width = 99
    Height = 25
    Hint = 'Start search'
    Anchors = [akTop, akRight]
    Caption = '&Start!'
    Default = True
    TabOrder = 1
    OnClick = butStartClick
    ExplicitLeft = 545
  end
  object Panel1: TPanel
    Left = 8
    Top = 8
    Width = 483
    Height = 170
    Anchors = [akLeft, akTop, akRight]
    BevelOuter = bvLowered
    Caption = 'Panel1'
    ShowCaption = False
    TabOrder = 0
    ExplicitWidth = 531
    DesignSize = (
      483
      170)
    object Label2: TLabel
      Left = 8
      Top = 56
      Width = 27
      Height = 13
      Caption = 'M&ask '
      FocusControl = edMask
    end
    object Label1: TLabel
      Left = 8
      Top = 8
      Width = 80
      Height = 13
      Caption = 'Start from &folder'
      FocusControl = edStart
    end
    object Label4: TLabel
      Left = 8
      Top = 104
      Width = 56
      Height = 13
      Caption = '&Text to find'
    end
    object cbInsensetive: TCheckBox
      Left = 152
      Top = 144
      Width = 121
      Height = 17
      Caption = '&Case insensetive'
      Checked = True
      State = cbChecked
      TabOrder = 5
    end
    object cbRecursive: TCheckBox
      Left = 8
      Top = 144
      Width = 129
      Height = 17
      Caption = '&Recursive'
      Checked = True
      State = cbChecked
      TabOrder = 4
    end
    object edMask: TEdit
      Left = 8
      Top = 75
      Width = 466
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 2
      TextHint = '*.txt;*.ini'
      OnChange = CheckControls
      ExplicitWidth = 514
    end
    object butSelect: TButton
      Left = 416
      Top = 22
      Width = 58
      Height = 25
      Hint = 'Select folder...'
      Anchors = [akTop, akRight]
      Caption = 'S&elect...'
      TabOrder = 1
      OnClick = butSelectClick
      ExplicitLeft = 464
    end
    object edStart: TEdit
      Left = 8
      Top = 24
      Width = 402
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 0
      TextHint = 'C:\Documents and Settings'
      OnChange = CheckControls
      ExplicitWidth = 450
    end
    object edText: TEdit
      Left = 8
      Top = 120
      Width = 466
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 3
      TextHint = 'What!?'
      ExplicitWidth = 514
    end
    object cbAnsi: TCheckBox
      Left = 295
      Top = 144
      Width = 43
      Height = 17
      Caption = 'A&NSI'
      Checked = True
      State = cbChecked
      TabOrder = 6
      OnClick = CheckCodePages
    end
    object cbUTF8: TCheckBox
      Left = 363
      Top = 144
      Width = 57
      Height = 17
      Caption = 'UTF&8'
      TabOrder = 7
      OnClick = CheckCodePages
    end
    object cbUTF16: TCheckBox
      Left = 426
      Top = 144
      Width = 49
      Height = 17
      Caption = 'UTF1&6'
      TabOrder = 8
      OnClick = CheckCodePages
    end
  end
  object progress: TProgressBar
    Left = 48
    Top = 189
    Width = 548
    Height = 13
    Anchors = [akLeft, akTop, akRight]
    TabOrder = 3
    Visible = False
    ExplicitWidth = 596
  end
  object timerUpdateCaption: TTimer
    Enabled = False
    OnTimer = timerUpdateCaptionTimer
    Left = 744
    Top = 104
  end
end



Исходник
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
unit SearchMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, FileCtrl, WThread,
  Generics.Collections, Types, StrUtils, ShellApi, Vcl.ComCtrls;

const
  //WM_THREAD_BASE            = WM_USER + $100;
  WM_SCAN_FOLDERS_START     = WM_THREAD_BASE + 1;
  WM_SCAN_FOLDERS_ADD       = WM_THREAD_BASE + 2;
  WM_SCAN_FOLDERS_END       = WM_THREAD_BASE + 3;
  WM_SEARCH_START           = WM_THREAD_BASE + 4;
  WM_SEARCH_MATCH           = WM_THREAD_BASE + 20;
  WM_SEARCH_END             = WM_THREAD_BASE + 6;
  WM_ACCESS_DENIED          = WM_THREAD_BASE + 10;

type
  TWorkFlow = class(TObject)
  public
    Path: string;
    Scaning: boolean;
    Scaned: boolean;
    constructor Create(const APath: string);
    procedure SetScaning;
    procedure SetScaned;
  end;

  TScanFolders = class(TWThread)
  private
    FPath: string;
    FMask: string;
  protected
    procedure ScanFoldersStart(var Msg: TThreadMessage); message WM_SCAN_FOLDERS_START;
  public
    property Path: string read FPath write FPath;
    property Mask: string read FMask write FMask;
  end;

  TSearchFiles = class(TWThread)
  private
    FPath: string;
    FMask: string;
    FCaseIns: boolean;
    FText: string;
    FAsAnsi: boolean;
    FAsUtf8: boolean;
    FAsUtf16: boolean;
    FAnsiBuf: TBytes;
    FUndoSeek: integer;
    procedure SetText(const Value: string);
    procedure SetCaseIns(const Value: boolean);
  protected
    procedure SearchStart(var Msg: TThreadMessage); message WM_SEARCH_START;
    property undoSeek: integer read FUndoSeek;
  public
    property Path: string read FPath write FPath;
    property Mask: string read FMask write FMask;
    property CaseIns: boolean read FCaseIns write SetCaseIns;
    property AsAnsi: boolean read FAsAnsi write FAsAnsi;
    property AsUtf8: boolean read FAsUtf8 write FAsUtf8;
    property AsUtf16: boolean read FAsUtf16 write FAsUtf16;
    property Text: string read FText write SetText;
  end;

  TfrmSearchMain = class(TForm)
    Label3: TLabel;
    memLog: TMemo;
    butStart: TButton;
    Panel1: TPanel;
    cbInsensetive: TCheckBox;
    cbRecursive: TCheckBox;
    edMask: TEdit;
    Label2: TLabel;
    butSelect: TButton;
    edStart: TEdit;
    Label1: TLabel;
    timerUpdateCaption: TTimer;
    Label4: TLabel;
    edText: TEdit;
    progress: TProgressBar;
    cbAnsi: TCheckBox;
    cbUTF8: TCheckBox;
    cbUTF16: TCheckBox;
    procedure timerUpdateCaptionTimer(Sender: TObject);
    procedure CheckControls(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure memLogDblClick(Sender: TObject);
    procedure CheckCodePages(Sender: TObject);
    procedure butSelectClick(Sender: TObject);
    procedure butStartClick(Sender: TObject);
  private
    FSearching: boolean;
    FUpdateIndex: integer;
    FFoldersList: TList<TWorkFlow>;
    procedure SetSearching(const Value: boolean);
    procedure UpdateControls;
    procedure StartSearch;
    procedure StopSearch;
    procedure OnReceive(Sender: TWThread; var Msg: TThreadMessage);
    procedure AddToLog(const AText: string);
    function GetThread: TSearchFiles;
  public
    procedure UpdateCaption;
    property Searching: boolean read FSearching write SetSearching;
  end;

var
  frmSearchMain: TfrmSearchMain;
  arrThreads: array of TSearchFiles;
  ScanThread: TScanFolders;
  SearchCount, FilesCount: integer;
  MAX_THREADS: integer;

implementation

{$R *.dfm}

function Min(A1, A2: Integer): Integer;
begin
    if A1 > A2 then Result := A2
    else Result := A1;
end;

{ TfrmSearchMain }

procedure TfrmSearchMain.AddToLog(const AText: string);
begin
    memLog.Lines.Add(Format('%s | %s', [FormatDateTime('hh.nn.ss.zzz', Now), AText]));
end;

procedure TfrmSearchMain.butSelectClick(Sender: TObject);
var s: string;
begin
    s := edStart.Text;
    if SelectDirectory('', '', s, [sdNewUI]) then begin
        edStart.Text := s;
        UpdateControls;
    end;
end;

procedure TfrmSearchMain.butStartClick(Sender: TObject);
begin
    if Searching and (MessageDlg('You are sure?!', mtConfirmation, mbYesNo, 0) = mrYes) then begin
        Searching := False;
        AddToLog('Cancel operation.');
    end else if not Searching then begin
        Searching := true;
    end;
end;

procedure TfrmSearchMain.CheckCodePages(Sender: TObject);
begin
    if (not cbAnsi.Checked) and (not cbUTF8.Checked) and (not cbUTF16.Checked) then
        cbAnsi.Checked := true;
end;

procedure TfrmSearchMain.CheckControls(Sender: TObject);
begin
    UpdateControls;
end;

procedure TfrmSearchMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
    CanClose := (not Searching)or(MessageDlg('You are sure?', mtConfirmation, mbYesNo, 0) = mrYes);
    if Searching and CanClose then
        StopSearch;
end;

procedure TfrmSearchMain.FormCreate(Sender: TObject);
begin
    MAX_THREADS := TThread.ProcessorCount * 2;
    ScanThread := TScanFolders.Create;
    ScanThread.OnThreadReceiveMessage := OnReceive;
    FFoldersList := TList<TWorkFlow>.Create;
    UpdateControls;
end;

procedure TfrmSearchMain.FormDestroy(Sender: TObject);
begin
    FFoldersList.Free;
    ScanThread.StopThread;
    ScanThread.Free;
end;

function TfrmSearchMain.GetThread: TSearchFiles;
begin
    Result := TSearchFiles.Create;
    with Result do begin
        Mask := edMask.Text;
        Text := edText.Text;
        CaseIns := cbInsensetive.Checked;
        AsAnsi := cbAnsi.Checked;
        AsUtf8 := cbUTF8.Checked;
        AsUtf16 := cbUTF16.Checked;
        OnThreadReceiveMessage := OnReceive;
    end;
end;

procedure TfrmSearchMain.memLogDblClick(Sender: TObject);
var s: string;
    i: integer;
begin
    s := memLog.Lines[memLog.Perform(EM_LINEFROMCHAR, memLog.SelStart, 0)];
    i := Pos('Match found: ', s);
    if i > 0 then begin
        s := '/select, '+Copy(s, i+13, 1024);
        ShellExecute(Application.Handle,'OPEN','EXPLORER',PWideChar(s),'',SW_NORMAL)
    end;
end;

procedure TfrmSearchMain.SetSearching(const Value: boolean);
begin
    if Value <> FSearching then begin
        FSearching := Value;
        if FSearching then begin
            progress.Max := 0;
            progress.Position := 0;
            progress.Show;
            butStart.Caption := 'Stop!';
            FUpdateIndex := 0;
            UpdateCaption;
            timerUpdateCaption.Enabled := True;
            UpdateControls;
            StartSearch;
        end else begin
            progress.Hide;
            butStart.Caption := 'Start!';
            timerUpdateCaption.Enabled := false;
            UpdateCaption;
            UpdateControls;
            StopSearch;
        end;
    end;
end;

procedure TfrmSearchMain.StartSearch;
var i: integer;
    wf: TWorkFlow;
begin
    if cbRecursive.Checked then begin
        SetLength(arrThreads, MAX_THREADS);
        for i := Low(arrThreads) to High(arrThreads) do begin
            arrThreads[i] := GetThread;
        end
    end else begin
        SetLength(arrThreads, 1);
        arrThreads[0] := GetThread;
    end;
    SleepEx(20, True);
    SearchCount := 0;
    FilesCount := 0;
    memLog.Lines.Clear;
    if cbRecursive.Checked then begin
        AddToLog('Preparing folders...');
        ScanThread.Path := edStart.Text;
        ScanThread.Mask := edMask.Text;
        ScanThread.PostToThreadMessage(WM_SCAN_FOLDERS_START, 1, 0);
    end else begin
        AddToLog('Start Search engine...');
        wf := TWorkFlow.Create(IncludeTrailingBackslash(edStart.Text));
        FFoldersList.Add(wf);
        arrThreads[0].PostToThreadMessage(WM_SEARCH_START, 1, NewString(wf.Path));
    end;
end;

procedure TfrmSearchMain.StopSearch;
var i: integer;
begin
    for I := Low(arrThreads) to High(arrThreads) do
        if Assigned(arrThreads[i]) then begin
            arrThreads[i].StopThread;
            arrThreads[i].Free;
            arrThreads[i] := nil;
        end;
    for i := 0 to FFoldersList.Count-1 do
        FFoldersList[i].Free;
    FFoldersList.Clear;
end;

procedure TfrmSearchMain.timerUpdateCaptionTimer(Sender: TObject);
begin
    UpdateCaption;
end;

procedure TfrmSearchMain.UpdateCaption;
var s: string;
begin
    if not Searching then
        Caption := 'Search Engine'
    else begin
        Inc(FUpdateIndex);
        case FUpdateIndex mod 4 of
            0: s := '|';
            1: s := '/';
            2: s := '-';
            3: s := '\';
        end;
        Caption := Format('(%s) Search Engine', [s]);
    end;
end;

procedure TfrmSearchMain.UpdateControls;
begin
    butStart.Enabled := Searching or (Length(edStart.Text) + Length(edMask.Text) > 4);
    butSelect.Enabled := not Searching;
    edStart.Enabled := not Searching;
    edMask.Enabled := not Searching;
    cbInsensetive.Enabled := not Searching;
    cbRecursive.Enabled := not Searching;
    cbAnsi.Enabled := not Searching;
    cbUTF8.Enabled := not Searching;
    cbUTF16.Enabled := not Searching;
end;

procedure TfrmSearchMain.OnReceive(Sender: TWThread; var Msg: TThreadMessage);
var i, x: integer;

    function GetPathIndex(const APath: string): integer;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if CompareText(FFoldersList[i].Path, APath) = 0 then
                Exit(i);
        result := -1;
    end;

    function GetNextToSend: integer;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if (not FFoldersList[i].Scaning) and (not FFoldersList[i].Scaned) then
                Exit(i);
        result := -1;
    end;

    function AllScaned: boolean;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if not FFoldersList[i].Scaned then
                Exit(false);
        result := true;
    end;

    function IsScanning: boolean;
    var i: integer;
    begin
        for i := 0 to FFoldersList.Count-1 do
            if FFoldersList[i].Scaning then
                Exit(true);
        result := false;
    end;

begin
    if Searching then
    case Msg.Message of
        WM_SCAN_FOLDERS_END: begin
            if FFoldersList.Count > 0 then begin
                AddToLog(Format('Prepared %d folder(s). Start Search engine...', [FFoldersList.Count]));
                x := Min(FFoldersList.Count-1, High(arrThreads));
                for i := 0 to x do begin
                    arrThreads[i].PostToThreadMessage(WM_SEARCH_START, 1, NewString(FFoldersList[i].Path));
                    FFoldersList[i].SetScaning;
                end;
                progress.Max := FFoldersList.Count;
            end else begin
                AddToLog('Prepared 0 folder(s). Search engine not started.');
                Searching := false;
            end;
        end;
        WM_SCAN_FOLDERS_ADD: begin
            FFoldersList.Add(TWorkFlow.Create(FreeString(Msg.LParam)));
        end;
        WM_SEARCH_MATCH: begin
            AddToLog(Format('Match found: %s', [FreeString(Msg.LParam)]));
            Inc(FilesCount);
        end;
        WM_ACCESS_DENIED: begin
            AddToLog(Format('Access error: %s', [FreeString(Msg.LParam)]));
        end;
        WM_SEARCH_END: begin
            Inc(SearchCount);
            i := GetPathIndex(TSearchFiles(Sender).Path);
            FFoldersList[i].SetScaned;
            if not AllScaned then begin
                i := GetNextToSend;
                if i <> -1 then begin
                    Sender.PostToThreadMessage(WM_SEARCH_START, 1, NewString(FFoldersList[i].Path));
                    FFoldersList[i].SetScaning;
                end;
            end else if not IsScanning then begin
                AddToLog(Format('Stop search engine. %d file(s) found.', [FilesCount]));
                Searching := false;
            end;
            progress.Position := SearchCount;
        end;
    end;
end;

{ TScanFolders }

procedure TScanFolders.ScanFoldersStart(var Msg: TThreadMessage);

    procedure Search(const APath, AMask: string);
    var sr: TSearchRec;
        i: integer;
        ar: TStringDynArray;
    begin
        ar := SplitString(AMask, ';, ');
        for i := Low(ar) to High(ar) do
            if (not Terminated) and (FindFirst(APath + Trim(ar[i]), faReadOnly or faArchive, sr) = 0) then begin
                PostMessageFromThread(WM_SCAN_FOLDERS_ADD, 0, NewString(APath));
                break;
            end else
                FindClose(sr);
        FindClose(sr);
        if FindFirst(APath + '*', faDirectory, sr) = 0 then begin
            repeat
                if LongBool((sr.Attr and faDirectory)) then begin
                    if (sr.Name <> '.') and (sr.Name <> '..') then
                        Search(IncludeTrailingBackslash(APath+sr.Name), AMask);
                end;
            until LongBool(FindNext(sr)) or Terminated;
            FindClose(sr);
        end;
    end;

begin
    Search(IncludeTrailingBackslash(Path), Mask);
    PostMessageFromThread(WM_SCAN_FOLDERS_END, 0, 0);
end;

{ TSearchFiles }

procedure TSearchFiles.SearchStart(var Msg: TThreadMessage);
var buf: TBytes;
    resu: boolean;

    procedure UpperArray(var arr: TBytes; const len: integer);
    var l: integer;
    begin
        if len = -1 then
            l := Length(arr)
        else
            l := len;
        CharUpperBuffA(@arr[0], l);
    end;

    function ScanArray(const buf: TBytes; const size: integer): boolean;
    var x, y, hw: integer;
    begin
        result := false;
        hw := high(FAnsiBuf);
        for x := Low(buf) to Min(High(buf), size)-high(FAnsiBuf) do begin
            if buf[x] = FAnsiBuf[0] then
                for y := 1 to hw do
                    if buf[x+y] <> FAnsiBuf[y] then
                        break
                    else if y = hw then
                        Exit(true);
        end;
    end;

    procedure ScanFile(const AFileName: string);
    var f: file;
        res: integer;
        io: integer;

        function ScanAnsi(buf: TBytes; const len: integer): boolean;
        var b: TBytes;
        begin
            if CaseIns then begin
                SetLength(b, Length(buf));
                Move(buf[0], b[0], len);
                UpperArray(b, len);
                result := ScanArray(b, len);
            end else begin
                result := ScanArray(buf, len);
            end;
        end;

        function ScanUtf8(buf: TBytes; const len: integer): boolean;
        var b: TBytes;
            s: string;
        begin
            b := TEncoding.Convert(TEncoding.UTF8, TEncoding.ANSI, buf, 0, len);
            if CaseIns then
                UpperArray(b, -1);
            result := ScanArray(b, length(b));
        end;

        function ScanUtf16(buf: TBytes; const len: integer): boolean;
        var b: TBytes;
        begin
            b := TEncoding.Convert(TEncoding.Unicode, TEncoding.ANSI, buf, 0, len);
            if CaseIns then
                UpperArray(b, -1);
            result := ScanArray(b, length(b));
        end;

    begin
        {$I-}
        FileMode := fmOpenRead;
        AssignFile(f, AFileName);
        Reset(f, 1);
        io := IOResult;
        if io = 0 then begin
            repeat
                BlockRead(f, buf[0], Length(buf), res);
                if AsUtf8 or AsUtf16 then begin
                    resu := (AsAnsi and ScanAnsi(buf, res-1))
                        or (AsUtf8 and ScanUtf8(buf, res))
                        or (AsUtf16 and ScanUtf16(buf, res));
                end else begin
                    if CaseIns then
                        UpperArray(buf, res);
                    resu := ScanArray(buf, res-1);
                end;
                if resu then begin
                    PostMessageFromThread(WM_SEARCH_MATCH, 0, NewString(AFileName));
                    Break;
                end;
                if (not Eof(F)) then
                    Seek(F, FilePos(F)-undoSeek);
            until (Length(buf) <> res) or (Terminated);
            CloseFile(f);
        end else begin
            PostMessageFromThread(WM_ACCESS_DENIED, 0, NewString(Format('%s [%d]', [AFileName, io])));
        end;
        IOResult;
        {$I+}
    end;

    procedure Search(const APath, AMask: string);
    var sr: TSearchRec;
        i: integer;
        ar: TStringDynArray;
    begin
        ar := SplitString(AMask, ';, ');
        for i := Low(ar) to High(ar) do begin
            if FindFirst(APath + Trim(ar[i]), faReadOnly or faArchive, sr) = 0 then begin
                repeat
                    ScanFile(APath + sr.Name);
                until LongBool(FindNext(sr)) or Terminated;
                FindClose(sr);
            end;
        end;
    end;

begin
    Path := FreeString(Msg.LParam);
    SetLength(buf, 65534);
    FUndoSeek := Length(FAnsiBuf)-1;
    if AsUtf16 then
        FUndoSeek := FUndoSeek * 2;
    Search(Path, Mask);
    PostMessageFromThread(WM_SEARCH_END, 0, NewString(Path));
end;

procedure TSearchFiles.SetCaseIns(const Value: boolean);
begin
    FCaseIns := Value;
    Text := Text;
end;

procedure TSearchFiles.SetText(const Value: string);

    function GetAsAnsi(const S: String): TBytes;
    var b: TBytes;
    begin
        SetLength(b, Length(s)*SizeOf(Char));
        Move(s[1], b[0], Length(b));
        Result := TEncoding.Convert(TEncoding.Unicode, TEncoding.ANSI, b);
    end;

begin
    FText := Value;
    if Length(Value) > 0 then begin
        FAnsiBuf := GetAsAnsi(Value);
        if CaseIns then
            CharUpperBuffA(@FAnsiBuf[0], Length(FAnsiBuf));
    end else begin
        SetLength(FAnsiBuf, 0);
    end;
end;

{ TWorkFlow }

constructor TWorkFlow.Create(const APath: string);
begin
    Path := APath;
    Scaned := false;
    Scaning := false;
end;

procedure TWorkFlow.SetScaned;
begin
    Scaned := true;
    Scaning := false;
end;

procedure TWorkFlow.SetScaning;
begin
    Scaned := false;
    Scaning := true;
end;

end.



WThread
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, версия от 08.11.2013
//
// использование:
// 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

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

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

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 = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
{$IFNDEF FPC}
        procedure WWindowProc(var Msg: TMessage);
{$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;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
            // см 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 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

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

const
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
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;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    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);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
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}
    FToolWindow := AllocateHWnd(WWindowProc);
    hCloseEvent := CreateEvent(nil, true, false, nil);
{$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);
    DeallocateHWnd(FToolWindow);
{$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
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
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        DoTimeOut;
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

    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, THandle(-1), 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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

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
        PostMessage(FToolWindow, Msg, WParam, LParam);
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    Terminate;
    SetEvent(hCloseEvent);
    SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$ENDIF}
end;

{$IFNDEF FPC}
procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        end;
        WM_THREAD_BASE..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;
{$ENDIF}

end.

...
Рейтинг: 0 / 0
11.11.2013, 11:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38459987
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Забыл добавить... Результат можно скачать тут
 
wadman.ru/files/searchengine.zip
...
Рейтинг: 0 / 0
11.11.2013, 11:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38495267
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Пример с окном, для которого сообщения обрабатываются в другом потоке.

Форма с тремя кнопка и код её модуля:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
unit mainThreadWnd;

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_SHOW1    = WM_THREAD_BASE + 1;
    WM_HIDE1    = WM_THREAD_BASE + 2;

type
    TWindowThread = class(TWThread)
        procedure WMShow1(var Msg: TThreadMessage); message WM_SHOW1;
        procedure WMHide1(var Msg: TThreadMessage); message WM_HIDE1;
    end;

  TfrmThreadWnd = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FThread: TWindowThread;
  public
  end;

var
  frmThreadWnd: TfrmThreadWnd;

implementation

{$R *.dfm}

procedure TfrmThreadWnd.Button1Click(Sender: TObject);
begin
    FThread.PostToThreadMessage(WM_SHOW1, 0, 0);
end;

procedure TfrmThreadWnd.Button2Click(Sender: TObject);
var i: integer;
begin
    for i := 0 to 1000 do
        Sleep(100);
end;

procedure TfrmThreadWnd.Button3Click(Sender: TObject);
begin
    FThread.PostToThreadMessage(WM_HIDE1, 0, 0);
end;

procedure TfrmThreadWnd.FormCreate(Sender: TObject);
begin
    FThread := TWindowThread.Create;
end;

procedure TfrmThreadWnd.FormDestroy(Sender: TObject);
begin
    FThread.StopThread;
    FThread.Free;
end;

{ TWindowThread }

function DefWindowProc1(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
    Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;

procedure TWindowThread.WMShow1(var Msg: TThreadMessage);
var
    WndClassEx:  TWNDCLASSEX;
begin
    if FWindowHandle = 0 then begin

        WndClassEx.cbSize := sizeOf (TWndClassEx);
        WndClassEx.lpszClassName := 'PlainWindowThreadTest';
        WndClassEx.style :=cs_VRedraw or cs_HRedraw;
        WndClassEx.hInstance := HInstance;
        WndClassEx.lpfnWndProc := @DefWindowProc1;
        WndClassEx.cbClsExtra := 0;
        WndClassEx.cbWndExtra := 0;
        WndClassEx.hIcon := LoadIcon (hInstance,
            MakeIntResource ('MAINICON'));
        WndClassEx.hIconSm  := LoadIcon (hInstance,
            MakeIntResource ('MAINICON'));
        WndClassEx.hCursor := LoadCursor (0, idc_Arrow);;
        WndClassEx.hbrBackground := CreateSolidBrush ($ccffff);
        WndClassEx.lpszMenuName := nil;

        RegisterClassEx(WndCLassEx);

        FWindowHandle := CreateWindowEx(0,WndClassEx.lpszClassName,'First_WinAPI_Programm',
            WS_popup or WS_BORDER or WS_EX_TRANSPARENT or WS_EX_TOPMOST or WS_CAPTION or WS_DLGFRAME
            ,100,100,584,630,0,0,HInstance,nil);

        SetLayeredWindowAttributes(FWindowHandle, RGB(255,255,255), 255, LWA_ALPHA);

    end;

    ShowWindow(FWindowHandle, SW_NORMAL);
end;

procedure TWindowThread.WMHide1(var Msg: TThreadMessage);
begin
    if FWindowHandle <> 0 then
        ShowWindow(FWindowHandle, SW_HIDE);
end;

end.



Слегка допиленный для этой "задачи" WThread:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, версия от 08.11.2013
//
// использование:
// 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

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

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

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 = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
{$IFNDEF FPC}
        FWindowHandle: THandle;
        procedure WWindowProc(var Msg: TMessage);
{$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;
    public
        constructor Create; overload;
        constructor Create(CreateSuspended: Boolean); overload;
        destructor Destroy; override;
            // см 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 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

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

const
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
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;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    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);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
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}
    FToolWindow := AllocateHWnd(WWindowProc);
    hCloseEvent := CreateEvent(nil, true, false, nil);
    FWindowHandle := 0;
{$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);
    DeallocateHWnd(FToolWindow);
{$ENDIF}
    inherited;
end;

procedure TWThread.DirectTimeOut;
begin
    // override
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
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        DoTimeOut;
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

    MSWait: Cardinal;
Label
    EndOfThread;
begin
    // следующая строка должна быть всегда первой в процедуре, т.к. запускает очередь сообщений для потока
    PeekMessage(msg, THandle(-1), 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 ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

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
        PostMessage(FToolWindow, Msg, WParam, LParam);
{$ENDIF}
end;

procedure TWThread.StopThread;
begin
{$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.SetEvent;
{$ELSE}
    Terminate;
    SetEvent(hCloseEvent);
    SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
{$ENDIF}
end;

{$IFNDEF FPC}
procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        end;
        WM_THREAD_BASE..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;
{$ENDIF}

end.



Тэги (на всякий): WThread Window WindowProc
...
Рейтинг: 0 / 0
10.12.2013, 12:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38511635
Guest2013
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Guest2013
Участник
wadman,

TAwaitable - реально круто написано, случайно наткнулся...
...
Рейтинг: 0 / 0
25.12.2013, 00:22
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38511644
asviridenkov
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
asviridenkov
Участник
Guest2013wadman,

TAwaitable - реально круто написано, случайно наткнулся...

Да нафига все это нужно, когде есть OTL?
...
Рейтинг: 0 / 0
25.12.2013, 00:42
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38511670
Guest2013
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Guest2013
Участник
asviridenkov,

OTL - огромна, а тут нативный коротенький код, и такие возможности...
...
Рейтинг: 0 / 0
25.12.2013, 01:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38511679
asviridenkov
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
asviridenkov
Участник
Guest2013asviridenkov,

OTL - огромна, а тут нативный коротенький код, и такие возможности...

Ну OTL не зря огромна
...
Рейтинг: 0 / 0
25.12.2013, 02:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38511703
Марат Сафин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Марат Сафин
Участник
Guest2013wadman,

TAwaitable - реально круто написано, случайно наткнулся...
Посмотрите лучше вот это .
...
Рейтинг: 0 / 0
25.12.2013, 06:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38511740
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Guest2013 TAwaitable - реально круто написано, случайно наткнулся...
Кроме как дернуть запрос в фоне, не придумал как еще это применить в реальности. В моей. У меня основная задача потоков - "общение" с основным, т.к. идет длительная работа, которая логируется и при этом вводятся поправки в дальнейшие действия.
...
Рейтинг: 0 / 0
25.12.2013, 09:19
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38543391
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Досадно, но я допустил серьезную багу, когда окно для общения создается в основном потоке, а удаляется - в другом. Поправил. В связи с чем для остановки потока должна вызываться процедура StopThread.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 30.01.2014
//
// использование:
// 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

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

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

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 = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
{$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;
            // см 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;
            // 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
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
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;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    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);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
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;
{$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.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
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        DoTimeOut;
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

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;

{$IFNDEF FPC}

procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        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;

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

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

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

{$ENDIF}

end.



И небольшой бонус. Модуль для логирования, безопасный для многопоточного окружения.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
// superlog (c) wadman, 2012-2014
// multithread safe logging

unit superlog;

{$B-} // complete boolean eval

interface

var SuperLogFileName: string;
    SuperLogEnabled: boolean;

function PostToLog(const Text: string): boolean;

implementation

uses SysUtils, Windows, Messages, DateUtils;

const WM_ADD_TO_LOG = WM_USER + $1001;

var
    LogWindowHandle: Cardinal;
    FirstLine: boolean;

const
    cUtilWindowExClass: TWndClass = (
        style: 0;
        lpfnWndProc: nil;
        cbClsExtra: 0;
        cbWndExtra: SizeOf(TMethod);
        hInstance: 0;
        hIcon: 0;
        hCursor: 0;
        hbrBackground: 0;
        lpszMenuName: nil;
        lpszClassName: 'TPUtilWindowLogEx');

    SizeOfChar          = SizeOf(Char);

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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
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 AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, SuperLogFileName);
        if (FileExists(SuperLogFileName)) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss:zzz', Now), Text]));
        Flush(t);
        CloseFile(t);
        result := true;
    finally
        //Application.HandleException(Self);
    end;
end;

function StdWndProc(Window: THandle; Message, wp: WPARAM;
  lp: LPARAM): LRESULT; stdcall;
begin
    if Message = WM_ADD_TO_LOG then begin
        Result := Byte(AddToLog(UnixToDateTime(wp), FreeString(lp)));
    end else
        Result := DefWindowProc(Window, Message, wp, lp);
end;

procedure AllocateHWndEx;
var
    TempClass: TWndClass;
    UtilWindowExClass: TWndClass;
    ClassRegistered: Boolean;
begin
    UtilWindowExClass := cUtilWindowExClass;
    UtilWindowExClass.hInstance := HInstance;
    UtilWindowExClass.lpfnWndProc := @StdWndProc;

    ClassRegistered := Windows.GetClassInfo(HInstance, UtilWindowExClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @StdWndProc) then begin
        if ClassRegistered then
            Windows.UnregisterClass(UtilWindowExClass.lpszClassName, HInstance);
        Windows.RegisterClass(UtilWindowExClass);
    end;
    LogWindowHandle := Windows.CreateWindowEx(Windows.WS_EX_TOOLWINDOW, UtilWindowExClass.lpszClassName,
        '', Windows.WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);

    SetWindowLongPtr(LogWindowHandle, GWL_WNDPROC, LONG_PTR(@StdWndProc));
end;

procedure DeallocateHWndEx;
begin
    Windows.DestroyWindow(LogWindowHandle);
end;

function PostToLog(const Text: string): boolean;
begin
    result := SuperLogEnabled and LongBool(LogWindowHandle)
        and PostMessage(LogWindowHandle, WM_ADD_TO_LOG, DateTimeToUnix(Now), NewString(Text));
end;

function InitLogs: boolean;
begin
    SuperLogFileName := ChangeFileExt(ParamStr(0), '.log');
    AllocateHWndEx;
    result := LogWindowHandle <> 0;
end;

procedure DoneLogs;
begin
    if LogWindowHandle <> 0 then
        DeallocateHWndEx;
end;

initialization
    SuperLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

...
Рейтинг: 0 / 0
30.01.2014, 12:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38547238
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
WThread: исключена отправка сообщения самому себе при прямом (TimeoutIsDirect = true) вызове DirectTimeOut, когда значение таймаута в самой процедуре меняется.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 03.02.2014
//
// использование:
// 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

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

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

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 = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FTimeOut: Cardinal;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        procedure SetTimeOut(const Value: Cardinal);
    protected
{$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;
            // см 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;
            // 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
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
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;
{$ELSE}
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

function FreeString(var P: NativeInt): String;
begin
    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);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
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;
{$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.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
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, MSWait, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        if LongBool(FWindowHandle) and (FWindowHandle = msg.hwnd) then begin
            // хэндл окна присвоен и пришло сообщение для окна
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                MSWait := msg.wParam;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

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;

{$IFNDEF FPC}

procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        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;

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

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

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

{$ENDIF}

end.



superlog: убрал передачу времени в юникс-формате из-за отсутствия поддержки микросекунд.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
// superlog (c) wadman, 2012-2014, 03.02.2014
// multithread safe logging

unit superlog;

{$B+} // complete boolean eval

interface

var SuperLogFileName: string;
    SuperLogEnabled: boolean;

function PostToLog(const Text: string): boolean;

implementation

uses SysUtils, Windows, Messages, DateUtils;

const WM_ADD_TO_LOG = WM_USER + $1001;

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

var
    LogWindowHandle: Cardinal;
    FirstLine: boolean;

const
    cUtilWindowExClass: TWndClass = (
        style: 0;
        lpfnWndProc: nil;
        cbClsExtra: 0;
        cbWndExtra: SizeOf(TMethod);
        hInstance: 0;
        hIcon: 0;
        hCursor: 0;
        hbrBackground: 0;
        lpszMenuName: nil;
        lpszClassName: 'TPUtilWindowLogEx');

    SizeOfChar          = SizeOf(Char);

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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
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 AddToLog(const DT: TDateTime; const Text: string): boolean;
var t: TextFile;
begin
    result := false;
    try
        AssignFile(t, SuperLogFileName);
        if (FileExists(SuperLogFileName)) then begin
            Append(t);
            if FirstLine then begin
                WriteLn(t, '');
            end;
        end else begin
            Rewrite(t);
        end;
        FirstLine := false;
        WriteLn(t, Format('%s : %s', [FormatDateTime('dd.mm.yyyy hh:nn:ss:zzz', DT), Text]));
        //Flush(t);
        CloseFile(t);
        result := true;
    finally
        //Application.HandleException(Self);
    end;
end;

function StdWndProc(Window: THandle; Message, wp: WPARAM;
  lp: LPARAM): LRESULT; stdcall;
var p: PLogRecord;
begin
    if Message = WM_ADD_TO_LOG then begin
        p := PLogRecord(lp);
        Result := Byte(AddToLog(p^.DT, FreeString(p^.PString)));
        FreeMem(p);
    end else
        Result := DefWindowProc(Window, Message, wp, lp);
end;

procedure AllocateHWndEx;
var
    TempClass: TWndClass;
    UtilWindowExClass: TWndClass;
    ClassRegistered: Boolean;
begin
    UtilWindowExClass := cUtilWindowExClass;
    UtilWindowExClass.hInstance := HInstance;
    UtilWindowExClass.lpfnWndProc := @StdWndProc;

    ClassRegistered := Windows.GetClassInfo(HInstance, UtilWindowExClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @StdWndProc) then begin
        if ClassRegistered then
            Windows.UnregisterClass(UtilWindowExClass.lpszClassName, HInstance);
        Windows.RegisterClass(UtilWindowExClass);
    end;
    LogWindowHandle := Windows.CreateWindowEx(Windows.WS_EX_TOOLWINDOW, UtilWindowExClass.lpszClassName,
        '', Windows.WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);

    SetWindowLongPtr(LogWindowHandle, GWL_WNDPROC, LONG_PTR(@StdWndProc));
end;

procedure DeallocateHWndEx;
begin
    Windows.DestroyWindow(LogWindowHandle);
end;

function PostToLog(const Text: string): boolean;
var p: PLogRecord;
    d: TDateTime;
begin
    result := SuperLogEnabled and LongBool(LogWindowHandle);
    if result then begin
        d := Now;
        p := AllocMem(SizeOf(TLogRecord));
        p^.DT := d;
        p^.PString := NewString(Text);
        result := PostMessage(LogWindowHandle, WM_ADD_TO_LOG, 0, NativeInt(p));
        if not result then
            FreeMem(p);
    end;
end;

function InitLogs: boolean;
begin
    SuperLogFileName := ChangeFileExt(ParamStr(0), '.log');
    AllocateHWndEx;
    result := LogWindowHandle <> 0;
end;

procedure DoneLogs;
begin
    if LogWindowHandle <> 0 then
        DeallocateHWndEx;
end;

initialization
    SuperLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

...
Рейтинг: 0 / 0
03.02.2014, 14:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38547854
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

а нет желания выкладывать релизы куда-нить на расшаренный ресурс, а под спойлер класть только очередной измененный кусок кода?
...
Рейтинг: 0 / 0
03.02.2014, 22:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38547864
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
А зачем? Пока тут всё помещается - нет нужды.
Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
03.02.2014, 23:01
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38548045
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
Гаджимурадов Рустам,

смайлик забыл поставить?

имхо, портянку кода можно и в стороннем редакторе посмотреть, а вот готовый юнит удобно сразу из архива прикрутить, чем копипастить код отсюда.
...
Рейтинг: 0 / 0
04.02.2014, 08:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38548067
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Докготовый юнит удобно сразу из архива прикрутить, чем копипастить код отсюда
Add new -> Unit -> Ctrl-V + Save As

Пока не вижу в этом необходимости, т.к. и потребность особая не замечена. Приводится лишь как часть примеров/решений.
...
Рейтинг: 0 / 0
04.02.2014, 09:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38548914
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanне вижу в этом необходимости, т.к. и потребность особая не замечена
"... а как дысал, как дысал ..." (с)

имхо, любое дело нужно доводить до логического конца, как женщину до оргазма
...
Рейтинг: 0 / 0
04.02.2014, 16:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38548981
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
 
Докимхо, любое дело нужно доводить до логического конца, как женщину до оргазма

У тебя один оргазм, у других - другой... Кто его знает, сколько тут уже на седьмом небе об счастья?
...
Рейтинг: 0 / 0
04.02.2014, 16:44
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38549210
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
Док> смайлик забыл поставить?

Нет. Кроме портянок есть ещё и файлы.
Сторонние ресурсы тут не нужны и неудобны.
Posted via ActualForum NNTP Server 1.5
...
Рейтинг: 0 / 0
04.02.2014, 18:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38595540
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Не помню, что конкретно менял, но нечто для стабильности DirectTimeOut и смены интервала ожидания в нем.

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 25.03.2014
//
// использование:
// 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

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

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

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 = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        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;
            // см 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
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        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
    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);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
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;
{$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.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
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        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;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
end;

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;

{$IFNDEF FPC}

procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        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;

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

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

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

{$ENDIF}

end.



superlog, добавлены уровни детализации.

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
// superlog (c) wadman, 2012-2014, 12.03.2014
// multithread safe logging

unit superlog;

{$B+} // complete boolean eval

interface

// log level
type
    TLogLevel = (SLL_MINIMUM, SLL_NORMAL, SLL_MAXIMUM, SLL_EXTRA);

var SuperLogFileName: string;
    SuperLogEnabled: boolean;
    SuperLogLevel: TLogLevel;

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

implementation

uses SysUtils, Windows, Messages, DateUtils;

const WM_ADD_TO_LOG = WM_USER + $1001;

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

var
    LogWindowHandle: Cardinal;
    FirstLine: boolean;

const
    cUtilWindowExClass: TWndClass = (
        style: 0;
        lpfnWndProc: nil;
        cbClsExtra: 0;
        cbWndExtra: SizeOf(TMethod);
        hInstance: 0;
        hIcon: 0;
        hCursor: 0;
        hbrBackground: 0;
        lpszMenuName: nil;
        lpszClassName: 'TPUtilWWindowLogEx');

    SizeOfChar          = SizeOf(Char);

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);
        P := LocalFree(HLOCAL(P));
    end;
end;

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

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

function StdWndProc(Window: THandle; Message, wp: WPARAM;
  lp: LPARAM): LRESULT; stdcall;
var p: PLogRecord;
begin
    if Message = WM_ADD_TO_LOG then begin
        p := PLogRecord(lp);
        Result := Byte(AddToLog(p^.DT, FreeString(p^.PString)));
        FreeMem(p);
    end else
        Result := DefWindowProc(Window, Message, wp, lp);
end;

procedure AllocateHWndEx;
var
    TempClass: TWndClass;
    UtilWindowExClass: TWndClass;
    ClassRegistered: Boolean;
begin
    UtilWindowExClass := cUtilWindowExClass;
    UtilWindowExClass.hInstance := HInstance;
    UtilWindowExClass.lpfnWndProc := @StdWndProc;

    ClassRegistered := Windows.GetClassInfo(HInstance, UtilWindowExClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @StdWndProc) then begin
        if ClassRegistered then
            Windows.UnregisterClass(UtilWindowExClass.lpszClassName, HInstance);
        Windows.RegisterClass(UtilWindowExClass);
    end;
    LogWindowHandle := Windows.CreateWindowEx(Windows.WS_EX_TOOLWINDOW, UtilWindowExClass.lpszClassName,
        '', Windows.WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);

    SetWindowLongPtr(LogWindowHandle, GWL_WNDPROC, LONG_PTR(@StdWndProc));
end;

procedure DeallocateHWndEx;
begin
    Windows.DestroyWindow(LogWindowHandle);
end;

function PostToLog(const Text: string): boolean;
begin
    PostToLog(Text, SLL_NORMAL);
end;

function PostToLog(const Text: string; const Level: TLogLevel): boolean;
var p: PLogRecord;
    d: TDateTime;
begin
    if SmallInt(Level) <= SmallInt(SuperLogLevel) then begin
        result := SuperLogEnabled and LongBool(LogWindowHandle);
        if result then begin
            d := Now;
            p := AllocMem(SizeOf(TLogRecord));
            p^.DT := d;
            p^.PString := NewString(Text);
            result := PostMessage(LogWindowHandle, WM_ADD_TO_LOG, 0, NativeInt(p));
            if not result then begin
                LocalFree(HLOCAL(p^.PString));
                FreeMem(p);
            end;
        end;
    end else
        Result := true;
end;

function InitLogs: boolean;
begin
    SuperLogFileName := ChangeFileExt(ParamStr(0), '.log');
    AllocateHWndEx;
    result := LogWindowHandle <> 0;
end;

procedure DoneLogs;
begin
    if LogWindowHandle <> 0 then
        DeallocateHWndEx;
end;

initialization
    SuperLogLevel := SLL_NORMAL;
    SuperLogEnabled := InitLogs;
    FirstLine := true;

finalization
    DoneLogs;

end.

...
Рейтинг: 0 / 0
25.03.2014, 11:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38595621
Glays
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Glays
Участник
wadman, я забыл, я уже просил выложить проект на SF?
...
Рейтинг: 0 / 0
25.03.2014, 12:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38595633
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Glaysя забыл, я уже просил выложить проект на SF?
Не этот, но
Гаджимурадов РустамСторонние ресурсы тут не нужны и неудобны.
...
Рейтинг: 0 / 0
25.03.2014, 13:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38595952
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

"Дрожки! Дрожки!" (с) Демки! Демки!
...
Рейтинг: 0 / 0
25.03.2014, 16:08
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38595982
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
ДокДемки! Демки!
Дык... Их есть тут. SearchEngine, окно в доп.потоке и т.д.
...
Рейтинг: 0 / 0
25.03.2014, 16:16
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38630213
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Добавил процедуры InitThread и DoneThread, которые выполняются в контексте потока.

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 30.04.2014
//
// использование:
// 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

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоки используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,SyncObjs
{$ENDIF}
    ;

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

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 = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        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
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
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);
        P := LocalFree(HLOCAL(P));
    end;
end;

function NewString(const Text: string): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        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
    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);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
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;
{$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.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
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    InitThread;
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            end;
    end;
{$ELSE}
    message: TThreadMessage;
    HandlesToWaitFor: array [0 .. 0] of THandle;
    dwHandleSignaled: DWORD;
    msg: TMsg;

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

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLEVENTS);

            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
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    Continue;
                end;
            end;
        end;
        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;
            end;
            WM_THREAD_BASE..WM_THREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                Dispatch(message);
            end;
        end;
    end;
EndOfThread:
{$ENDIF}
    DoneThread;
end;

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;

{$IFNDEF FPC}

procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        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;

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

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

procedure TWThread.InitThread;
begin
    // empty
end;

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

{$ENDIF}

end.

...
Рейтинг: 0 / 0
30.04.2014, 14:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38707827
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Убран всем ненавистный goto :)
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013, 2014, версия от 28.07.2014
//
// использование:
// 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

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

{$IF DECLARED(FireMonkeyVersion)}
  {$DEFINE HAS_FMX}
{$ELSE}
  {$DEFINE HAS_VCL}
{$IFEND}

// для передачи строк между потоками используется выделенная память
{$DEFINE ALLOC_STRING}

interface

uses
    Classes,
    Messages,
    SysUtils
{$IFDEF FPC}
    ,Windows
    ,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 = class(TThread)
    private
{$IFDEF FPC}
        FQueue: TList;
        FSection: TCriticalSection;
        FMessageEvent: TEvent;
        FGUIThread: TThread;
{$ELSE}
        FToolWindow: THandle;
        hCloseEvent: THandle;
{$ENDIF}
        FOnThreadReceiveMessage: TWThreadReceiveMessage;
        FOnTimeOut: TWThreadTimeOut;
        FTimeOutIsDirect: boolean;
        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
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);


{$IFDEF ALLOC_STRING}
// для передачи строки между программами
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;

// для передачи строки в пределах одной программы
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);
        P := LocalFree(HLOCAL(P));
    end;
end;

// для передачи строки в пределах одной программы
function NewString(const Text: string): NativeInt;
var l: Integer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := LocalAlloc(LPTR, l+SizeOfChar);
        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
    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);
begin
    while List.Count > 0 do
        FreeMem(List[0]);
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;
{$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.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
    result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));
{$ENDIF}
end;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    InitThread;
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            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);
    InitThread;
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    //SleepEx(20, true);

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLEVENTS);

            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
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    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;
            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;
    end;
{$ENDIF}
    DoneThread;
end;

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;

{$IFNDEF FPC}

procedure TWThread.WWindowProc(var Msg: TMessage);
begin
    case Msg.Msg of
        WM_TIMEOUT: begin
            DoTimeout;
            Msg.Result := 1;
        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;

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

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

procedure TWThread.InitThread;
begin
    // empty
end;

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

{$ENDIF}

end.



Примеры использования:
1. DirMonitor: запускает два доп-потока. Первый "ищет" новый файл в спец.папке, второй - его обрабатывает.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
unit DirMonitorMain;

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_FILE_FOUND       = WM_THREAD_BASE + 1;
    WM_PROCESS_FILE     = WM_THREAD_BASE + 2;
    WM_PROCESSED_FILE   = WM_THREAD_BASE + 3;

type
    TDirMonitorThread = class(TWthread)
    private
        FDir: string;
    public
        constructor Create(const ADir: string);
        procedure DirectTimeOut; override;
        property Dir: string read FDir;
    end;

    TImportThread = class(TWThread)
    public
        procedure WMProcessFile(var Msg: TThreadMessage); message WM_PROCESS_FILE;
    end;

  TfrmDirMonitorMain = class(TForm)
        Memo1: TMemo;
        procedure FormCreate(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
  private
        FDirMonitorThread: TDirMonitorThread;
        FImportThread: TImportThread;
  public
        procedure OnReceiveFromThread(Sender: TWThread; var Msg: TThreadMessage);
        procedure ToLog(const Text: string);
  end;

var
  frmDirMonitorMain: TfrmDirMonitorMain;

implementation

{$R *.dfm}

{ TDirMonitorThread }

constructor TDirMonitorThread.Create(const ADir: string);
begin
    inherited Create;
    // папка
    FDir := ADir;
    // приоритет
    Priority := tpLower;
    // процедура DirectTimeOut по таймауту будет выполнятся в контексте этого потока
    TimeOutIsDirect := true;
    // раз в минуту
    FTimeOut := 60000;
end;

// выполняется в доп. потоке
procedure TDirMonitorThread.DirectTimeOut;
begin
    // симулируем ситуацию, когда файл наден и скопирован и передаем путь и имя файла в основной поток
    // NewString и FreeString важны для передачи строк между потоками
    PostMessageFromThread(WM_FILE_FOUND, 0, NewString(IncludeTrailingBackslash(Dir)+Format('File%d.dbf', [Random(100)])));
    // и дальше уходим спать на минуту
end;

{ TImportThread }
// выполняется в доп. потоке
procedure TImportThread.WMProcessFile(var Msg: TThreadMessage);
var FileName: string;
begin
    // симулируем обработку файла
    FileName := FreeString(Msg.LParam);
    // будем 5 секунд импортировать
    SleepEx(5000, true);
    // сообщим об окончании обработки
    PostMessageFromThread(WM_PROCESSED_FILE, 0, NewString(FileName));
end;

{ TfrmDirMonitorMain }

// процедура, которая обрабатывает в основном потоке сообщения от доп. потоков
procedure TfrmDirMonitorMain.FormCreate(Sender: TObject);
var i: int64;
    ii: integer;
    ai: array[0..3] of byte;
begin
    Randomize;
    Memo1.Lines.Clear;
    // Запускаем доп. потоки
    FDirMonitorThread := TDirMonitorThread.Create('D:\SomeDir');    // 2060
    FDirMonitorThread.OnThreadReceiveMessage := OnReceiveFromThread;
    FImportThread := TImportThread.Create;
    FImportThread.OnThreadReceiveMessage := OnReceiveFromThread;
end;

procedure TfrmDirMonitorMain.FormDestroy(Sender: TObject);
begin
    FDirMonitorThread.StopThread;
    FImportThread.StopThread;
end;

// обработчик сообщений от доп потоков
procedure TfrmDirMonitorMain.OnReceiveFromThread(Sender: TWThread; var Msg: TThreadMessage);
var FileName: string;
begin
    case Msg.Message of
        WM_FILE_FOUND: begin
            // новый файл найден см. TDirMonitorThread.DirectTimeOut;
            // NewString и FreeString важны для передачи строк между потоками
            FileName := FreeString(Msg.LParam);
            ToLog(Format('Found: %s', [FileName]));
            // сообщим импортирующему потоку имя этого файла
            FImportThread.PostToThreadMessage(WM_PROCESS_FILE, 0, NewString(FileName));
        end;
        WM_PROCESSED_FILE: begin
            // импортирующий поток сообщил о том, что обработка закончена
            FileName := FreeString(Msg.LParam);
            ToLog(Format('Imported: %s', [FileName]));
        end;
    end;
end;

procedure TfrmDirMonitorMain.ToLog(const Text: string);
begin
    Memo1.Lines.Add(Format('%s : %s', [FOrmatDateTime('hh:nn:ss:zzz', Now), Text]));
end;

end.



2. Запускает окно из другого потока и симулирует "тяжелую" работу в основном.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
unit mainThreadWnd;

interface

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

const
    WM_SHOW1    = WM_THREAD_BASE + 1;
    WM_HIDE1    = WM_THREAD_BASE + 2;

type
    TWindowThread = class(TWThread)
        procedure WMShow1(var Msg: TThreadMessage); message WM_SHOW1;
        procedure WMHide1(var Msg: TThreadMessage); message WM_HIDE1;
    end;

  TfrmThreadWnd = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FThread: TWindowThread;
  public
  end;

var
  frmThreadWnd: TfrmThreadWnd;

implementation

{$R *.dfm}

procedure TfrmThreadWnd.Button1Click(Sender: TObject);
begin
    FThread.PostToThreadMessage(WM_SHOW1, 0, 0);
end;

procedure TfrmThreadWnd.Button2Click(Sender: TObject);
var i: integer;
begin
    for i := 0 to 10 do
        Sleep(100);
end;

procedure TfrmThreadWnd.Button3Click(Sender: TObject);
begin
    FThread.PostToThreadMessage(WM_HIDE1, 0, 0);
end;

procedure TfrmThreadWnd.FormCreate(Sender: TObject);
begin
    FThread := TWindowThread.Create;
end;

procedure TfrmThreadWnd.FormDestroy(Sender: TObject);
begin
    FThread.StopThread;
    FThread.Free;
end;

{ TWindowThread }

var
    LabelText, LabelTime, ProgressBar: THandle;
    fstart: TDateTime;

function DefWindowProc1(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
 WorkTime : String;
 Pos : integer;
begin
    if Msg = WM_TIMER then begin
        WorkTime:=TimeToStr(Frac(now)-Frac(fStart));
        SetWindowText(LabelTime,Pchar(WorkTime));
    end else
    Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;

procedure TWindowThread.WMShow1(var Msg: TThreadMessage);
var
  WndClassEx: TWNDCLASSEX;
  st: String;
  lFlags: Cardinal;
  lRect: TRect;
begin

if FWindowHandle = 0 then
  begin

    WndClassEx.cbSize := sizeOf(TWNDCLASSEX);
    WndClassEx.lpszClassName := 'PlainWindowThreadTest';
    WndClassEx.style := cs_VRedraw or cs_HRedraw;
    WndClassEx.hInstance := hInstance;
    WndClassEx.lpfnWndProc := @DefWindowProc1;
    WndClassEx.cbClsExtra := 0;
    WndClassEx.cbWndExtra := 0;
    WndClassEx.hIcon := LoadIcon(hInstance, MakeIntResource('MAINICON'));
    WndClassEx.hIconSm := LoadIcon(hInstance, MakeIntResource('MAINICON'));
    WndClassEx.hCursor := LoadCursor(0, idc_Arrow);;
    WndClassEx.hbrBackground := COLOR_BTNFACE + 1;
    WndClassEx.lpszMenuName := nil;

    RegisterClassEx(WndClassEx);

    // Главное окно
    FWindowHandle := CreateWindowEx(WS_EX_LAYERED, WndClassEx.lpszClassName, '...',
      WS_VISIBLE or WS_CLIPSIBLINGS or
    WS_CLIPCHILDREN or WS_OVERLAPPEDWINDOW
        , 100, 100, 370, 90, 0, 0, hInstance, nil);

    // Текст
    LabelText := CreateWindow('Static', 'Выполнение запроса...',
      WS_VISIBLE or WS_CHILD, 5, 10, 300, 15, FWindowHandle, 0,
      hInstance, nil);

    // Время ожидания
    LabelTime := CreateWindow('Static', '00:00',
      WS_VISIBLE or WS_CHILD, 295, 10, 300, 15, FWindowHandle, 0,
      hInstance, nil);

    // Прогресс
    ProgressBar := CreateWindow('msctls_progress32', '',
      WS_VISIBLE or WS_CHILD, 5, 30, 345, 15, FWindowHandle, 0,
      hInstance, nil);

    SendMessage(ProgressBar, PBM_SETRANGE, 0, MakeLong(0, 100));
    SendMessage(ProgressBar, PBM_SETPOS, 0, 0);

    SetLayeredWindowAttributes(FWindowHandle, RGB(255, 255, 255), 255,
      LWA_ALPHA);

  end;

  if FWindowHandle <> 0 then begin
        ShowWindow(FWindowHandle, SW_NORMAL);
        UpdateWindow(FWindowHandle);
        SetTimer(FWindowHandle, 1, 1000, nil);
  end;
end;

procedure TWindowThread.WMHide1(var Msg: TThreadMessage);
begin
    if FWindowHandle <> 0 then begin
        ShowWindow(FWindowHandle, SW_HIDE);
    end;
end;

end.

...
Рейтинг: 0 / 0
29.07.2014, 10:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38708401
_Док_
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
_Док_
Гость
wadman,

в Лазаре можно из доп.потока напрямую обращаться к приватным полям основного потока и наоборот В дельфях же вроде не так (щас проверить не могу)?
Это я к тому, что для FPC может не стоит городить огород?
...
Рейтинг: 0 / 0
29.07.2014, 17:28
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38708419
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
_Док_, тынц давай. :)
...
Рейтинг: 0 / 0
29.07.2014, 17:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38708720
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

"...и опыт - сын ошибок трудных ... " (с)

Ты можешь этот тынц сам увидеть, если Лазарь откроешь Вечерком могу выложить тестовый проект (ноут дома).
...
Рейтинг: 0 / 0
30.07.2014, 09:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38708727
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
ДокТы можешь этот тынц сам увидеть, если Лазарь откроешь Вечерком могу выложить тестовый проект (ноут дома).
Жду... Хоть пойму, при чем здесь приватные поля основного потока. :)
...
Рейтинг: 0 / 0
30.07.2014, 09:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38708753
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,
 

"— Слушай, я русский язык не хорошо знаю… Он пошёл туалет, а Валико постучил дверь и сказал — что тоже… хочет… Такие вопросы задаёте, что неудобно отвечать… даже…"

Вечером, все вечером ...
...
Рейтинг: 0 / 0
30.07.2014, 10:08
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709158
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
Ну вот например:
 
интерфейс
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
  { TMyThread }

  TMyThread = class(TThread)
  protected
    procedure Execute; override;
  end;

  { TFrmMain }

  TFrmMain = class(TForm)
    BtnRun: TButton;
    Label1: TLabel;
    procedure BtnRunClick(Sender: TObject);
  private
    { private declarations }
    FStrMgs: String;
    FMyThread: TMyThread;
  public
    { public declarations }
  end;

 
implementation
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
{ TMyThread }

procedure TMyThread.Execute;
var
  i: Integer;
begin
  i:= 0;
while i < 200 do
  begin
    Inc(i);
    FrmMain.FStrMgs:= Format('I = %d',[i]); //а дельфи так может?
    Sleep(50);
  end;

Terminate;
end;

{ TFrmMain }

procedure TFrmMain.BtnRunClick(Sender: TObject);
begin
  FMyThread:= TMyThread.Create(False);
  FMyThread.Priority:= tpLower;
  FMyThread.FreeOnTerminate:= True;

  while not FMyThread.Finished do
    begin
      Label1.Caption:= FStrMgs;
      Application.ProcessMessages;
      BtnRun.Enabled:= FMyThread.Finished;
    end;
end;

 
картинко

Под основным потоком я подразумевал поток, в котором Гуй отрисовывается
...
Рейтинг: 0 / 0
30.07.2014, 15:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709173
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Док
Код: pascal
1.
    FrmMain.FStrMgs:= Format('I = %d',[i]); //а дельфи так может?


С трудом себе представляю, зачем это нужно. Ведь оно само по себе не о чем не говорит главному потоку, который в это время выполняет мягко говоря такой г-код, чтобы самому догадаться об изменениях переменной:
Док
Код: pascal
1.
2.
3.
4.
5.
6.
while not FMyThread.Finished do
    begin
      Label1.Caption:= FStrMgs;
      Application.ProcessMessages;
      BtnRun.Enabled:= FMyThread.Finished;
    end;


Да и по идее этот код должен загрузить процессор.

Потому все таки правильнее и проще передать новое значение переменной вместе с сообщением. Или я не до конца разглядел твою мысль?
...
Рейтинг: 0 / 0
30.07.2014, 15:22
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709211
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanкоторый в это время выполняет мягко говоря такой г-код, чтобы самому догадаться об изменениях переменной
честно говоря, не понял - основной поток не в силах уследить, что делается с его переменными?

зы. Я не спорю, я просто интересуюсь, ибо гуманитарий ;)
...
Рейтинг: 0 / 0
30.07.2014, 15:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709236
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Докосновной поток не в силах уследить, что делается с его переменными?
Ты привел один из способов самостоятельного отслеживания изменений. Сам понимаешь, вариант совсем не вариант. Все таки сообщения, содержащие новые данные как-то более надежный и простой механизм.

Грубо говоря я не увидел применения твоему способу.
...
Рейтинг: 0 / 0
30.07.2014, 16:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709247
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanТы привел один из способов самостоятельного отслеживания изменений.
Ты имеешь ввиду ProcessMessages?
...
Рейтинг: 0 / 0
30.07.2014, 16:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709260
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
ДокwadmanТы привел один из способов самостоятельного отслеживания изменений.
Ты имеешь ввиду ProcessMessages?
Именно.
...
Рейтинг: 0 / 0
30.07.2014, 16:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709542
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

ну, у меня тогда появился повод переписать код на событийную модель
...
Рейтинг: 0 / 0
30.07.2014, 22:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38709670
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Докну, у меня тогда появился повод переписать код на событийную модель
А было так, как ты показал?
...
Рейтинг: 0 / 0
31.07.2014, 09:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38710504
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

поскольку в тонкости диспетчеризации сообщений я стал вникать только в последнее время, то в Лазаре (а ЕМНИП, Дельфя описанных мною выше вольностей не позволяла) в тестовых проектах для разнообразия я где-то написал так, а где-то по другому.

Теперь, конечно же, придется делать по фен-шую :)

зы. Лазарь вообще, отдельная песТня. Я тут виндовые проекты стал портировать в никсы - много интересного познал
...
Рейтинг: 0 / 0
01.08.2014, 08:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38858536
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
Достаточно часто (но не всегда) в одном и том же месте появляется ошибка.
Access violation at address .... in module 'MyExe.exe'. Read of address 0000000F.

WThread.TWThread.PostToThreadMessage (Line 393, "WThread.pas") - по EurekaLog

версия от 28.07.2014
result := (not Suspended)and(PostThreadMessage(ThreadID, Msg, wParam, lParam));

Не знаю как лечить. Может быть поможете?
Раньше использовали предыдущие версии и все нормально работало.
...
Рейтинг: 0 / 0
20.01.2015, 14:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38858539
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Максим УлитинWThread.TWThread.PostToThreadMessage (Line 393, "WThread.pas") - по EurekaLog
А остальное, что было до этого? И что отправляется?
...
Рейтинг: 0 / 0
20.01.2015, 14:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859315
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
wadman,

сейчас отправлю в личку.

А так, вкратце там выводится форма с часиками (что типа что-то выполняется и ждите). форма нарисована на winapi. с помощью вашего класса все данные на этой форме обновляются.
...
Рейтинг: 0 / 0
21.01.2015, 10:26
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859318
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
wadman,

что-то лички тут не нашел, ладно, тогда так отправлю
...
Рейтинг: 0 / 0
21.01.2015, 10:28
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859385
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Максим Улитин, то, что я там увидел - это тотальное непонимание как работать с потоками и памятью...

Например: Под параметры память выделяется, а под текст - нет. См. функции NewString, FreeString.
Код: pascal
1.
2.
3.
4.
5.
6.
7.
Procedure MyThreadMessageDlgWarnOk(ThreadParams: PThreadParams;
  Const MessageText: String);
Begin
  If ThreadParams = Nil Then
    Exit;
  ThreadParams^.MessageType := mtWarning;
  ThreadParams^.MessageText := MessageText;


Это зачем дергается в другом потоке?
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
Procedure TTimerThread.Execute;
Begin
  Inherited;

  While Not Terminated Do
  Begin
    Sleep(400);
    If Not Stop Then
      Synchronize(UpdateForm);
  End;
End;

Procedure TTimerThread.UpdateForm;
Var
  frmStatus: TfrmStatus;
Begin
  If QuickSameText(Params.ProgressBar.Properties.Text, ExcelCreate) Then
  Begin
    Application.ProcessMessages;
    Exit;
  End;


Ниже еще интереснее: зачем sleep?
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
  FWThread.FStart := Now;
  If Not ThreadParams.NoShowForm Then
  Begin
    Application.ProcessMessages;
    Sleep(250);
    FWThread.PostToThreadMessage(WM_SHOW1, 0, 0);
    Sleep(250);
    Application.ProcessMessages;
  End;



На сколько я понял - это тяжелое наследие какого-то участка кода, который когда-то работал в одном потоке и теперь стоит задача разнести на разные?

Чтобы найти место, где и из-за чего возникает ошибка вынеси TWindowThread в отдельный модуль и протестируй его на пустом проекте.
...
Рейтинг: 0 / 0
21.01.2015, 11:09
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859446
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Взглянул более внимательно... Это стоит переписать с нуля. Совсем.
Вынести экспорт в другой поток будет проще.
...
Рейтинг: 0 / 0
21.01.2015, 11:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859607
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
wadman,

Ну там все намного проще. раньше все это было написано как класс, в котором запускается отдельной процесс с какой-то логикой. То есть был основной поток с программой, из основного потока создавался поток с нужной процедурой и еще один поток для отрисовки окна.
все работало нормально, без каких либо ошибок и все было хорошо. Но пришлось все переписывать, так как если в этом отдельном потоке создавался fastreport с поддержкой мультизадачности (EnableThreadSafe = False), то по полной начинало все глючить.
И из-за этого было быстренько все переписано и теперь поток не создается с нужной процедурой, а выполняется в основном потоке. А для отрисовки окна используется Ваш класс. Да, переписано все через ж.., но к сожалению что есть, то и есть. Вначале писал я (с кучей поток), переписывал не я, а человек, который уже был уволен за кучу своих ошибок.
N-ая часть этого кода из приложенного файла не используется уже совсем, валяется как мусор или пережиток былого. А почистить времени нет.

> На сколько я понял - это тяжелое наследие какого-то участка кода, который когда-то работал в одном потоке и теперь стоит задача разнести на разные?
Наоборот, был когда то перевод с кучи потоков на один поток (ну +1 на форму с "часиками")

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

> Например: Под параметры память выделяется, а под текст - нет. См. функции NewString, FreeString.
раньше так все и было, сейчас это не нужно

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

P.S.: А так, по существу, как то никогда не было проблем как с потоками, так и с дин памятью, так и с тем, как с ней работать
...
Рейтинг: 0 / 0
21.01.2015, 12:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859625
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Максим УлитинПросто опять же, раньше на какой-то другой версии Вашего класса ошибка не возникала, сейчас возникает. Вот стало интересно почему, отсюда и спросил
Раньше видимо и код экспорта был иным. В том коде, который приведен ошибки такой быть не может. По меньшей мере при работе именно с wthread (предлагаю протестировать на пустом приложении). А проблемы с памятью имеются и я их показал. Потому и просил стек вызова показать.
Скорее всего поток к тому времени не создан, либо убит (то есть равен nil) и обращение к ThreadID вызывает ошибку.
wadmanА остальное, что было до этого?
Максим УлитинНо пришлось все переписывать, так как если в этом отдельном потоке создавался fastreport с поддержкой мультизадачности (EnableThreadSafe = False), то по полной начинало все глючить.
Фастрепорт глючит именно из-за тех-же ошибок, что я и показал. Они тоже любят баловаться Application.ProcessMessages не анализируя EnableThreadSafe. :) Я и его наставил на путь истинный 2 года назад и с тех пор не обновляю. Теперь он работает в потоках.
Максим Улитинsleep нужен для того, чтобы сообщение нормально отправилось.
Формы можно создавать заранее скрытыми.
...
Рейтинг: 0 / 0
21.01.2015, 13:11
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859903
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
wadman,

код экспорта был таким же с точностью до байта, как и в тех версиях Вашего класса. Кстати еще раз, это не экспорт, а выполнение любых процедур, когда заранее точно не известно выполнится ли эта процедура быстро или нет.
На тему Procedure TTimerThread.UpdateForm; - он не используется совсем у меня. Как уже сказал, остались части, надо вычистить.

На тему слипа. там идет основной поток программы, а раз так, то могу делать в основном потоке что хочу. Разве нет?

На тему ThreadParams^.MessageText := MessageText;
ThreadParams - это рекорд, под который выделена память с помощью new. По моему я уже выделил память, в том числе и под строку. А работаю исключительно с указателем на этот рекорд и эту строку. Разве нужно еще раз выделять память под строку уже в выделенной памяти под весь рекорд?

> А проблемы с памятью имеются и я их показал.
вроде проблем этих нет. могу конечно просмотреть в дебаге в отдельном приложении. Только боюсь под это уйдет уйма времени, так как ошибка на реальных проектах возникает очень часто раз из тысячи, а бывает сразу.

> Скорее всего поток к тому времени не создан, либо убит (то есть равен nil) и обращение к ThreadID вызывает ошибку.
вполне возможно, надо попробовать поставить проверку
...
Рейтинг: 0 / 0
21.01.2015, 16:56
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859918
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Максим УлитинThreadParams - это рекорд, под который выделена память с помощью new.
Вот тебе и понимание работы с памятью и потоками... String по умолчанию уже давно лишь ссылка на участок памяти с символами.
...
Рейтинг: 0 / 0
21.01.2015, 17:01
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859941
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
wadman,

> String по умолчанию уже давно лишь ссылка на участок памяти с символами
конечно я это знаю

> Вот тебе и понимание работы с памятью и потоками
оке, тогда объясни что не так? и почему огромное количество времени (с 2006 по 2013 год) предыдущий вариант этого класса (моего класса формы с часами) работал БЕЗ ЕДИНОЙ ПРОБЛЕМЫ?
проблема с EnableThreadSafe = false не в счет, тут уже прикол самого фастрепорта, как Вы сами написали.
...
Рейтинг: 0 / 0
21.01.2015, 17:14
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859953
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Максим Улитиноке, тогда объясни что не так? и почему огромное количество времени (с 2006 по 2013 год) предыдущий вариант этого класса (моего класса формы с часами) работал БЕЗ ЕДИНОЙ ПРОБЛЕМЫ?
Я не знаю как еще объяснить. Что именно тут не понятно?
wadmanString по умолчанию уже давно лишь ссылка на участок памяти с символами.
Везение это не положительная оценка навыков программирования, если что.
...
Рейтинг: 0 / 0
21.01.2015, 17:19
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859954
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
wadmanМаксим УлитинThreadParams - это рекорд, под который выделена память с помощью new.
Вот тебе и понимание работы с памятью и потоками... String по умолчанию уже давно лишь ссылка на участок памяти с символами.
Если не считать ещё уличной магии массивов, которая подчищает строки при выходе из процедуры.
...
Рейтинг: 0 / 0
21.01.2015, 17:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859959
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
wadman,

оке, тогда помоги плиз, если конечно не затрудняю.
нужно запускать процедуру в том же потоке, что и основная программа, но при этом создавалась форма, в котором был label с каким-то там сообщением, которое можно менять в любой момент времени, progressbar, который так же можно менять, иконка для красивости и label с временем, который показывало сколько времени прошло с момента запуска данной процедуры. Но при этом в тексте самих этих процедур на запуск ничего переделывать было бы не надо.
...
Рейтинг: 0 / 0
21.01.2015, 17:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38859963
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
Dimonka,

подробнее пожалуйста
...
Рейтинг: 0 / 0
21.01.2015, 17:27
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38860038
Фотография Dimonka
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dimonka
Участник
Максим УлитинDimonka,

подробнее пожалуйста

Локальные строки как и другие динамические массивы уничтожаются при выходе из процедуры. Если строка тебе нужна в потоке, то необходимо сделать копию строки для потока. Просто полистай эту тему - все ответы здесь уже есть.
...
Рейтинг: 0 / 0
21.01.2015, 18:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38860053
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
Dimonka,

ну будем считать что мне везло столько лет. Думаю да, Вы правы, но работало ведь

Я думаю сделать так:
- вернуть свой класс в то состояние, которое было до прихода уволенного сотрудника (жаль что его тогда принял ,к сожалению. до сих пор косяки всплывают).
- сделать так, чтобы везде, где есть фастрепорт, запускалась отдельная процедура для вывода инфы (на экран или там в PDF)

думаю после этого глюки пропадут.
...
Рейтинг: 0 / 0
21.01.2015, 19:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38860301
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Максим Улитин- сделать так, чтобы везде, где есть фастрепорт, запускалась отдельная процедура для вывода инфы (на экран или там в PDF)
Если исходники фастрепорта есть, то ищи во всех местах вызов Application.ProcessMessages и делай перед этим проверки на опцию многопоточности. Кажется таких мест 5-6. И станет он белым и пушистым.
...
Рейтинг: 0 / 0
22.01.2015, 09:09
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38860391
Максим Улитин
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Максим Улитин
Гость
wadman,

спасибо, так и сделаю.

А так вчера почистил код в том модуле и избавился от мусора. И потом понял где проблема, это му.... нехороший человек таймер не прибивал. то есть он вроде написал, чтобы таймер прибивался, но сообщение о прибивании таймера забывал посылать.
в итоге написал тестовое приложение с бесконечным циклом на создание массива на 10 лямов рандом значений и сортировку через этот мой класс и оставил на ночь. Ни разу exception не сработал.

так что теперь в думах - вернуть что раньше писал или оставить что есть сейчас. как бы и тогда работало надежно, и сейчас работает по первым прикидкам вроде надежно
...
Рейтинг: 0 / 0
22.01.2015, 10:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38864066
Поток в службе...
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Поток в службе...
Гость
wadman,

Если заюзать юнит в сервисе, обработка сообщений между приложениями работать будет?
Спрашиваю т.к. у сервиса нет окна, и я не очень понимаю как сервисы между собой общаются...
Возможен ли обмен между 2-мя и более сервисами через этот юнит?
...
Рейтинг: 0 / 0
27.01.2015, 11:52
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38864750
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Поток в службе...,

в службе работает без проблем, между службами не пробовал.
...
Рейтинг: 0 / 0
27.01.2015, 19:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38932671
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
* Убрал утечки памяти, которые были под fpc.
+ Добавил буфер для отправки сообщений до того, как будет готова очередь
+ Добавил поддержку *nix для fpc

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&linux)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 09.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 = 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;
        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);


{$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
    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;

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

procedure TWThread.Execute;
var
{$IFDEF FPC}
    Message: PThreadMessage;
    wr: TWaitResult;
begin
    InitThread;
    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;
                    if (Message^.message >= WM_THREAD_BASE)
                        and (Message^.Message <= WM_THREAD_MAX) then
                            Dispatch(Message^);
                    FreeMem(Message);
                end;
                wrTimeout: begin
                    if FTimeOutIsDirect then
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                end;
            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);
    InitThread;
    PostMessageFromThread(WM_THREAD_READY, 0, 0);
    HandlesToWaitFor[0] := hCloseEvent;
    // SleepEx не нужен, если подготовительный код до цикла while будет достаточно долго выполняться
    // уточняется опытным путем, иначе очередь сообщений потока не успеет запуститься и сообщения могут улететь в пустоту
    //SleepEx(20, true);

    while not Terminated do begin
        if ((FWindowHandle = 0) and(not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE)))
            or((FWindowHandle <> 0) and (
                (not PeekMessage(msg, FWindowHandle, 0, 0, PM_REMOVE))
                and
                (not PeekMessage(msg, THandle(-1), WM_THREAD_BASE, WM_THREAD_MAX, PM_REMOVE))
            )) then begin

            if (FWindowHandle = 0) then
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLINPUT)
            else
                dwHandleSignaled := MsgWaitForMultipleObjects(1, HandlesToWaitFor, false, TimeOut, QS_ALLEVENTS);

            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
                        DirectTimeOut
                    else
                        PostMessageFromThread(WM_TIMEOUT, 0, 0);
                    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;
            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;
    end;
{$ENDIF}
    DoneThread;
end;

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.

...
Рейтинг: 0 / 0
10.04.2015, 08:56
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934663
Aleksandr Sharahov
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aleksandr Sharahov
Участник
wadman,

я бы заменил

Код: pascal
1.
2.
3.
4.
function FreeString(var P: NativeInt): String;
begin
    NativeInt(Result) := P;
end;



на

Код: pascal
1.
2.
3.
4.
5.
function FreeString(var P: NativeInt): String;
begin
    Result := '';
    NativeInt(Result) := P;
end;
...
Рейтинг: 0 / 0
13.04.2015, 12:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934665
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Aleksandr Sharahov, я этим совсем не пользуюсь. На что это влияет?
...
Рейтинг: 0 / 0
13.04.2015, 12:14
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934688
Aleksandr Sharahov
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aleksandr Sharahov
Участник
wadman,

на утечку, разумеется
...
Рейтинг: 0 / 0
13.04.2015, 12:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934725
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Aleksandr Sharahovна утечку, разумеется
Раз назвался груздемзнатоком... Поясни, сколько такая строка может прожить? К примеру, если идет долгая обработка одной команды, а в очереди несколько минут висит следующая с такой строкой - какие гарантии, что не затрется?

П.С. Спасибо, учту.
...
Рейтинг: 0 / 0
13.04.2015, 12:44
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934734
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadman, видимо, тебе намекают, что Result на входе вовсе не обязан быть пустой строкой, и своим хаком ты похеришь старое значение без отработки счетчика ссылок
...
Рейтинг: 0 / 0
13.04.2015, 12:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934745
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chчто Result на входе вовсе не обязан быть пустой строкой
Это новость для меня...
...
Рейтинг: 0 / 0
13.04.2015, 12:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934748
Aleksandr Sharahov
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aleksandr Sharahov
Участник
wadman,

Не совсем понял, о какой "такой" строке ты спрашиваешь.

Если речь об утечке, то там все просто. Строка, которая используется твоей функцией в качестве результата, приходит в нее из вызывающей процедуры и вовсе не обязана быть пустой. Поэтому ее необходимо финализировать, прежде чем жестко менять адрес данных.
...
Рейтинг: 0 / 0
13.04.2015, 12:53
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934756
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Aleksandr SharahovНе совсем понял, о какой "такой" строке ты спрашиваешь.
О такой, которую получили функцией NewString (FreeString обратная ей).
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
function NewString(const Text: string): NativeInt;
begin
    Result := 0;
    string(Result) := Text;
end;

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


Aleksandr SharahovСтрока, которая используется твоей функцией в качестве результата, приходит в нее из вызывающей процедуры и вовсе не обязана быть пустой.
Торможу чего-то... Как результат этой функции приходит из вызывающей её процедуры?
...
Рейтинг: 0 / 0
13.04.2015, 12:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934768
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
примерно таким:
Код: pascal
1.
procedure FreeString(var P: NativeInt; var Result: String);
...
Рейтинг: 0 / 0
13.04.2015, 13:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934772
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
fd00chпримерно таким:
Код: pascal
1.
procedure FreeString(var P: NativeInt; var Result: String);


Ты мне шаблон поломал... Давно догадывался, но не хотелось верить и копаться там. :)
...
Рейтинг: 0 / 0
13.04.2015, 13:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934774
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Точно не шутите, что результат может быть определен на входе?
...
Рейтинг: 0 / 0
13.04.2015, 13:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934802
Aleksandr Sharahov
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Aleksandr Sharahov
Участник
wadmanО такой, которую получили функцией NewString (FreeString обратная ей).

А если об этой, то будет жить, пока живо сообщение.

wadmanТочно не шутите, что результат может быть определен на входе?

А сегодня первое?
...
Рейтинг: 0 / 0
13.04.2015, 13:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934806
fd00ch
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
fd00ch
Участник
wadmanТочно не шутите, что результат может быть определен на входе? http://docwiki.embarcadero.com/RADStudio/XE7/en/Program_Control The following conventions are used for returning function result values.
For a string, dynamic array, method pointer, or variant result, the effects are the same as if the function result were declared as an additional var parameter following the declared parameters. In other words, the caller passes an additional 32-bit pointer that points to a variable in which to return the function result.
...
Рейтинг: 0 / 0
13.04.2015, 13:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38934821
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Aleksandr SharahovА сегодня первое?
Не все ограничиваются только первым числом.
Aleksandr SharahovА если об этой, то будет жить, пока живо сообщение.
Нужно будет погонять на сотне-другой потоков. Помнится, этот механизм валился на больших количествах передаваемых строк между потоками. Может как раз из-за этой "мелочи"...

fd00ch, спасибо.
...
Рейтинг: 0 / 0
13.04.2015, 13:29
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38935293
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman, тоже кстати пытался что-то подобное делать
у вас я смотрю по теме большой опыт
немного с другой стороны подошёл (связь односторонняя и полностью стандартными библами fpc)
 

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
unit Channels;

interface
uses SysUtils,SyncObjs,Queues;

type

  { TSomeChannel }

  TSomeChannel=class(TInterfacedObject)
   protected
     NeadQuit:boolean;
     Stoper:array[boolean] of TCriticalSection;
     StoperFlag:boolean;
     Locker:TCriticalSection;
   public
     constructor Create;
     destructor Destroy;override;
     procedure Close;
  end;

 { Channel }

 // one writer-creator, many readers not in created thread
 // only created thread can write and close
  generic Channel <T,TFIFO>=class(TSomeChannel)
   private
    FIFO:TFIFO;
    function GetDataExists: boolean;
   protected

   public
    destructor Destroy;override;

    property DataExists:boolean read GetDataExists;
    function Get(out Data:T):boolean;
    procedure Put(const Data:T);
  end;

implementation

{ TSomeChannel }

constructor TSomeChannel.Create;
begin
  inherited;
  Stoper[false]:=TCriticalSection.Create;
  Stoper[true]:=TCriticalSection.Create;
  Locker:=TCriticalSection.Create;

  Stoper[StoperFlag].Enter;
end;

destructor TSomeChannel.Destroy;
begin
  //wait  Reader=0;
  if not NeadQuit then begin
    Close;
  end;

  FreeAndNil(Stoper[false]);
  FreeAndNil(Stoper[true]);
  FreeAndNil(Locker);
  inherited;
end;

procedure TSomeChannel.Close;
begin
  NeadQuit:=true;
  if Assigned(Stoper[StoperFlag]) then begin
    Stoper[StoperFlag].Leave;
  end;
end;


{ Channel }

function Channel.Get(out Data: T): boolean;
var
 S:TCriticalSection;
begin
    repeat
        Locker.Enter; // wait push data
        try
          if FIFO.PopFront(Data) then exit(true);
          S:=Stoper[StoperFlag];
        finally
          Locker.Leave;
        end;
        if NeadQuit then exit(false);
        S.Enter;
        S.Leave;
    until false;
end;

function Channel.GetDataExists: boolean;
begin
  Result:=not FIFO.isEmpty;
end;

destructor Channel.Destroy;
begin
  inherited Destroy;
  FIFO.Clear;
end;

procedure Channel.Put(const Data: T);
begin
  Locker.Enter;
  try
      if FIFO.isEmpty then begin
        Stoper[StoperFlag].Leave;
        StoperFlag:=not StoperFlag;
        Stoper[StoperFlag].Enter;
      end;
      FIFO.PushBack(Data);
  finally
    Locker.Leave;
  end;
end;

end.


ну и очередь для этого простая
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
unit Queues;

{$mode objfpc}{$H+}

interface

type

  { Deque }

  generic Deque<T>=object
   protected
    type
    PDeq=^TDeq;
    TDeq=record
     Next,Prev:PDeq;
     Data:T;
    end;
   protected
    First,Last:PDeq;
    procedure ClearRec(R:PDeq);inline;
   public
    function isEmpty:boolean;inline;
    function PopBack(out res:T):boolean;
    function PopFront(out res:T):boolean;
    procedure PushBack(const v:T);
    procedure PushFront(const v:T);

    procedure Clear;
    procedure Init;
  end;


  { Queue }

  generic Queue<T>=object    // cicle buffer
   protected
    type
    PFIFORec=^TFIFOREC;
    TFIFORec=record
     Next:PFIFORec;
     Data:T;
    end;
   protected
    Last:PFIFOREC;
    procedure ClearRec(R:PFIFORec);inline;
    function PushFrontInternal(const v:T):PFIFOREC;inline;
   public
    function isEmpty:boolean;inline;
    function PopFront(out res:T):boolean;

    procedure PushBack(const v:T);
    procedure PushFront(const v:T);
    procedure Clear;
    procedure Init;
  end;


implementation

{ Queue }

procedure Queue.ClearRec(R: PFIFORec);
begin
  Finalize(R^);
  Dispose(R);
end;

function Queue.PushFrontInternal(const v: T): PFIFOREC;
var e:PFIFOREC;
begin
  New(e);
  e^.Data:=v;

  if Last<>nil then begin
    e^.Next:=Last^.Next;
    Last^.Next:=e;
  end else begin
    e^.Next:=e;
    Last:=e;
  end;
  Result:=e;
end;

function Queue.isEmpty: boolean;
begin
  Result:=(Last=nil);
end;

function Queue.PopFront(out res: T): boolean;
var e,d:PFIFOREC;
begin
  if isEmpty then exit(false);
  e:=Last^.Next;

  res:=e^.Data;
  d:=e^.Next;
  ClearRec(e);

  if e<>Last then begin
    Last^.Next:=d;
  end else begin
    Last:=nil;
  end;
  Result:=true;
end;

procedure Queue.PushBack(const v: T);
begin
  Last:=PushFrontInternal(v);
end;

procedure Queue.PushFront(const v: T);
begin
  PushFrontInternal(v);
end;

procedure Queue.Clear;
var e,d:PFIFORec;
begin
  if isEmpty then exit;
  e:=Last;

  repeat
   d:=e^.Next;
   ClearRec(e);
   e:=d;
  until e=Last;
  Last:=nil;
end;

procedure Queue.Init;
begin
  Last:=nil;
end;

{ Deque }

procedure Deque.ClearRec(R: PDeq);
begin
  Finalize(R^);
  Dispose(R);
end;

function Deque.isEmpty: boolean;
begin
  Result:=(First=nil);
end;

function Deque.PopBack(out res: T): boolean;
var e:PDeq;
begin
  if isEmpty then exit(false);
  e:=Last;
  res:=e^.Data;
  Last:=e^.Prev;
  ClearRec(e);

  if Last<>nil then begin
    Last^.Next:=nil;
  end else begin
    First:=nil;
  end;
  Result:=true;
end;

function Deque.PopFront(out res: T): boolean;
var e:PDeq;
begin
  if isEmpty then exit(false);
  e:=First;
  res:=e^.Data;
  First:=e^.Next;
  ClearRec(e);

  if First<>nil then begin
    First^.Prev:=nil;
  end else begin
    Last:=nil;
  end;
  Result:=true;
end;

procedure Deque.PushBack(const v: T);
var e:PDeq;
begin
  New(e);
  e^.Data:=v;
  e^.Prev:=Last;
  e^.Next:=nil;

  if Last<>nil then begin
    Last^.Next:=e;
  end else begin
    First:=e;
  end;
  Last:=e;
end;

procedure Deque.PushFront(const v: T);
var e:PDeq;
begin
  New(e);
  e^.Data:=v;
  e^.Prev:=nil;
  e^.Next:=First;

  if First<>nil then begin
    First^.Prev:=e;
  end else begin
    Last:=e;
  end;
  First:=e;
end;

procedure Deque.Clear;
var e,d:PDeq;
begin
  e:=First;
  while e<>nil do begin
   d:=e^.Next;
   ClearRec(e);
   e:=d;
  end;
  First:=nil;
  Last:=nil;
end;

procedure Deque.Init;
begin
  First:=nil;
  Last:=nil;
end;

end.


используется в потоке
Код: pascal
1.
while SomeChanel.get(data) do ...
...
Рейтинг: 0 / 0
13.04.2015, 20:02
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38935508
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)(связь односторонняя и полностью стандартными библами fpc)
У меня двусторонняя и тоже полностью стандартными. :) Особо в код не вникал... Есть какие-то преимущества?
...
Рейтинг: 0 / 0
14.04.2015, 08:52
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38936300
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,

основное было делить задачи на несколько потоков
т.е. 1 диспетчер раскидывает задания на несколько потоков
...
Рейтинг: 0 / 0
14.04.2015, 17:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38943495
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)основное было делить задачи на несколько потоков
т.е. 1 диспетчер раскидывает задания на несколько потоков
Из моего класса можно сделать и отдельный менеджер с ограниченным по количеству пулом потоков. Один-бы рулил всеми и не морозил при этом интерфейс.

* Исправил и скорректировал работу по таймеру. Теперь таймер отрабатывает точно (миллисекунда в миллисекунду), учитывая время работы процедур потока.

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
627.
628.
629.
630.
631.
632.
633.
634.
635.
636.
637.
638.
639.
640.
641.
642.
643.
644.
645.
646.
647.
648.
649.
650.
651.
652.
653.
654.
655.
656.
657.
658.
659.
660.
661.
662.
663.
664.
665.
666.
667.
668.
669.
670.
671.
672.
673.
674.
675.
676.
677.
678.
679.
680.
681.
682.
683.
684.
685.
686.
687.
688.
689.
690.
691.
692.
693.
694.
695.
696.
697.
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.

...
Рейтинг: 0 / 0
23.04.2015, 13:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38943497
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
А просто приаттачить файл к сообщению не судьба ?
...
Рейтинг: 0 / 0
23.04.2015, 13:15
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38943508
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
defecatorА просто приаттачить файл к сообщению не судьба ?
По себе сужу. Отсюда качаю файлы в редких и исключительных случаях.
А так хотя-бы код видно.

П.С. Там спойлер есть.
...
Рейтинг: 0 / 0
23.04.2015, 13:22
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38943948
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,

немного посмотрел, слишком жёстко, багфиксы
Код: pascal
1.
2.
3.
4.
{$IFDEF FPC_WIN}
    ,Messages
    ,Windows
{$ENDIF}

иначе под линуксом не компилится

Код: pascal
1.
2.
3.
{$IFDEF FPC}
    INFINITE            = Cardinal($FFFFFFFF);
{$ENDIF}

убрать, в SyncObjs описан ( в fpc 2.6 точно)

Код: pascal
1.
2.
3.
4.
                FSection.Enter;
                Message := FQueue[0];
                FQueue.Delete(0);
                FSection.Leave;

и
Код: pascal
1.
2.
3.
    FSection.Enter;
    FQueue.Add(Msg);
    FSection.Leave;

обрамить в FSection.Enter; try ... finally FSection.Leave;


FQueue - очередь лучше в отдельный класс вынести с методами PushToFront, ...(в fpc-stl есть очень неплохие реализации)
...
Рейтинг: 0 / 0
23.04.2015, 20:49
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38944144
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)иначе под линуксом не компилится
Под каким линуксом не компилится? FPC_WIN = WINDOWS.
kealon(Ruslan)в SyncObjs описан ( в fpc 2.6 точно)
kealon(Ruslan)обрамить в FSection.Enter; try ... finally FSection.Leave;
Учел, подумаю. :)
kealon(Ruslan)FQueue - очередь лучше в отдельный класс вынести с методами PushToFront, ...(в fpc-stl есть очень неплохие реализации)
Мне в некоторых местах нужен такой подход (с отдельной очередью для гуи) и в дельфи. То есть иногда дефайню FPC. Так что его специфические вещи мне навредят.
...
Рейтинг: 0 / 0
24.04.2015, 08:54
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38945053
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmankealon(Ruslan)иначе под линуксом не компилится
Под каким линуксом не компилится? FPC_WIN = WINDOWS.

этого модуля под линуксом нет, в дефайн FPC_WIN он у тебя не включён (выше вписан)
Код: pascal
1.
2.
3.
4.
5.
    Classes,
    Messages
{$IFDEF FPC_WIN}
    ,Windows
{$ENDIF}


wadmankealon(Ruslan)FQueue - очередь лучше в отдельный класс вынести с методами PushToFront, ...(в fpc-stl есть очень неплохие реализации)
Мне в некоторых местах нужен такой подход (с отдельной очередью для гуи) и в дельфи. То есть иногда дефайню FPC. Так что его специфические вещи мне навредят.
это не помешает, от TList просто унаследуй для дельфей с определением методов, а для fpc бери нативный

PS: мне кажется от окна винды стоит отказаться, ты всё равно уже очередь эмулируешь, да и от таймера(его можно отдельным потоком как источник задач создать, используя sleep или лучше TEvent.wait )

PSS:слишком сложно твоим классом пользоваться, надо упрощать - кода много, а на деле дальше While GetMsg do ... не уйти
...
Рейтинг: 0 / 0
24.04.2015, 22:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38945228
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan),

не хочешь признаваться, как добился, что модуль не компилируется под линуксом и не надо. :) у меня он работает.

Модуль сложный, да. Это "плата" за легкость его использования.
...
Рейтинг: 0 / 0
25.04.2015, 15:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38945326
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmankealon(Ruslan),

не хочешь признаваться, как добился, что модуль не компилируется под линуксом и не надо. :) у меня он работает.

Модуль сложный, да. Это "плата" за легкость его использования.

вот твоя редакция последняя
Код: pascal
1.
2.
3.
4.
5.
    Classes,
    Messages
{$IFDEF FPC_WIN}
    ,Windows
{$ENDIF}


я тебе сказал что она не компилится, так как модуля Messages под линуксом нет,
предложил подправить, вот так :
Код: pascal
1.
2.
3.
4.
5.
    Classes
{$IFDEF FPC_WIN}
   , Messages
    ,Windows
{$ENDIF}


это всё что имелось ввиду
...
Рейтинг: 0 / 0
25.04.2015, 20:10
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38945813
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan), еще разок: у меня компилируется (и даже работает) под линуксом, ибо в fpc/lazarus есть модуль messages.
...
Рейтинг: 0 / 0
27.04.2015, 08:54
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946388
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadman, при использовании в главной нити сообщения не поступают в файл,
пока не пройдет цикл обработки сообщений (что очевидно).
Очередь при этом растет. А в ней всего 10000 позиций (по умолчанию),
этого может оказаться маловато - будут потери записей лога. Простой выход:
меняем
Код: pascal
1.
result := PostMessage(LogWindowHandle, WM_ADD_TO_LOG, 0, NativeInt(p));

на
Код: pascal
1.
2.
3.
4.
if(GetCurrentThreadId <> MainThreadID) then
  result := PostMessage(LogWindowHandle, WM_ADD_TO_LOG, 0, NativeInt(p))
else
  Result := Boolean(SendMessage(LogWindowHandle, WM_ADD_TO_LOG, 0, NativeInt(p)));

Ну и резалт присвоить нужно для порядка, в реализации
Код: pascal
1.
function PostToLog(const Text: string): boolean;



При высокой нагрузке будут потери записей все одно.
Я себе делал класс лога через очередь, с пишущей ниткой,
постоянно ждущей и просыпающейся лишь по эвенту
(постановка записи в очередь / терминэйт нити).
...
Рейтинг: 0 / 0
27.04.2015, 16:33
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946394
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
Во как - тема-то вон какая...
Это про "15782361" .
...
Рейтинг: 0 / 0
27.04.2015, 16:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946402
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
dred2kпри использовании в главной нити сообщения не поступают в файл,
Я как раз и использую отдельный поток.
dred2kЯ себе делал класс лога через очередь, с пишущей ниткой,
:-) Ну у меня как раз такой и есть...
...
Рейтинг: 0 / 0
27.04.2015, 16:42
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946416
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadman:-) Ну у меня как раз такой и есть...
Я не уточнил - очередь данных (типа TList), а не системная очередь сообщений.
При интенсивной записи (в твоей реализации) код обработки,
пишущий в файл, "захлебнется" из-за накладных расходов записи -
не так это быстро, как ожидается.
Очередь сообщений "выбираться" не успеет.
PostMessage будет срабатывать не каждый раз, пойдут потери записей лога.
Для этой задачи, считаю, надежнее будет обычный threadsafe-буфер + нить записи.
...
Рейтинг: 0 / 0
27.04.2015, 16:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946420
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
dred2kВо как - тема-то вон какая...
Это про "15782361" .
Ой... Оказалось, там старая версия, а новее не выложил. Хотя с нагрузкой и эта версия отлично справляется.
...
Рейтинг: 0 / 0
27.04.2015, 16:51
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946425
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
В принципе, данный код легко модифицируется для защиты
от потерь - через буфер, опять же, с попыткой "досылки" сначала из него.
...
Рейтинг: 0 / 0
27.04.2015, 16:53
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946432
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadmanХотя с нагрузкой и эта версия отлично справляется.
Ну это да, как говорится - если "в мирное время".
...
Рейтинг: 0 / 0
27.04.2015, 16:54
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946649
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmankealon(Ruslan), еще разок: у меня компилируется (и даже работает) под линуксом, ибо в fpc/lazarus есть модуль messages.
Unix mint 17.1
Код: plaintext
1.
Free Pascal Compiler version 2.6.2-8 [2014/01/22] for x86_64
Copyright (c) 1993-2012 by Florian Klaempfl and others

Код: plaintext
1.
wthread.pas(44,6) Fatal: Can not find unit Messages used by WThread. Check if package LCLBase is in the dependencies.
там стаб обычный, по умолчанию не цепляемый, под люниксом он не нужен собственно

PS: к dred2k присоединяюсь, такая штука рухнет под нагрузками (но в принципе почти любая очередь рухнет под нагрузками)
нужна блокировка при переполнении канала
и
Код: pascal
1.
 FQueue.Delete(0);

- всё же очень плохая вещь
...
Рейтинг: 0 / 0
27.04.2015, 20:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946655
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)
Код: plaintext
Free Pascal Compiler version 2.6.2-8 [2014/01/22] for x86_64

FPC 2.6.4 и последний лазарус. Компилируется и работает.
kealon(Ruslan)к dred2k присоединяюсь, такая штука рухнет под нагрузками
Сэмулируй нагрузку, под которой грохнется. А то при опросе пары сотен штук устройств с киданием десятков сообщений в секунду почему-то не падает.

Мне интересны факты, а не теория.
...
Рейтинг: 0 / 0
27.04.2015, 21:01
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946676
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadmanМне интересны факты, а не теория.
При использовании обсуждаемой реализации объективно
нет возможности гарантировать, что записи лога не начнут
пропадать по причине переполнения оконной очереди сообщений.
Вот тебе и факт.
...
Рейтинг: 0 / 0
27.04.2015, 21:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38946803
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
dred2kВот тебе и факт.
Это не факт, а философия. Из товарища kealon(Ruslan) вытягивал несколько дней факт, почему у него не компилируется. Ну да ладно. Пока логирование в другом потоке не могу выложить, там несколько для меня специфичных вещей. Чуть позже, когда руки дойдут. Либо перепишу на основе wthread. Спасибо за обсуждение. :)
...
Рейтинг: 0 / 0
28.04.2015, 08:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38947197
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman, вроде нормальным английским языком, ошибка компиляции
wthread.pas(44,6) Fatal: Can not find unit Messages used by WThread. Check if package LCLBase is in the dependencies.
...
Рейтинг: 0 / 0
28.04.2015, 13:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38947218
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)вроде нормальным английским языком, ошибка компиляции
Обнови лазарус.
...
Рейтинг: 0 / 0
28.04.2015, 13:29
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38947769
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmankealon(Ruslan)вроде нормальным английским языком, ошибка компиляции
Обнови лазарус.
Check if package LCLBase is in the dependencies

PS: вот не знаю что ты упираешься, тем более под люниксом эти константы оттуда не нужны
...
Рейтинг: 0 / 0
28.04.2015, 19:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38948142
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)PS: вот не знаю что ты упираешься, тем более под люниксом эти константы оттуда не нужны
Есть этот модуль в 2.6.4., но ты одолел меня. Убрал совсем, нет в нем нужды (нужен был только для wm_user). :)
...
Рейтинг: 0 / 0
29.04.2015, 09:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38948165
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
wadman(нужен был только для wm_user)
Соврал, оттуда еще нужен TMessage... В общем учел, спасибо. В следующий раз messages будет вынесен куда следует.
...
Рейтинг: 0 / 0
29.04.2015, 09:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38948492
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Перенес messages, TList заменил на TQueue и по мелочи.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
627.
628.
629.
630.
631.
632.
633.
634.
635.
636.
637.
638.
639.
640.
641.
642.
643.
644.
645.
646.
647.
648.
649.
650.
651.
652.
653.
654.
655.
656.
657.
658.
659.
660.
661.
662.
663.
664.
665.
666.
667.
668.
669.
670.
671.
672.
673.
674.
675.
676.
677.
678.
679.
680.
681.
682.
683.
684.
685.
686.
687.
688.
689.
690.
691.
692.
693.
694.
695.
696.
unit WThread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&linux)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 29.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
    ,contnrs
{$IFNDEF FPC}
    ,Messages
{$ENDIF}
{$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: TQueue;
        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
{$IFNDEF WINDOWS}
    WM_THREAD_READY     = WM_USER+$102;
{$ENDIF}
    WM_TIMEOUT          = WM_USER+$101;

    SizeOfChar          = SizeOf(Char);

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

{$IFDEF ALLOC_STRING}
{$IFDEF ALL_WIN}
// для передачи строки между программами
function GlobalNewString(const Text: string): NativeInt;
var l: Integer;
    p: pointer;
begin
    l := Length(Text)*SizeOfChar;
    if L > SizeOfChar then begin
        Result := GlobalAlloc(GHND, l+SizeOfChar);
        if LongBool(Result) then begin
            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
{$HINTS OFF}
    if LongBool(P) then begin
        SetLength(Result, Length(PChar(P)));
        Move(Pointer(P)^, Pointer(Result)^, Length(Result)*SizeOfChar);
{$IFDEF ALL_WIN}
        P := LocalFree(HLOCAL(P));
{$ELSE}
        P := FreeMem(Pointer(P));
{$ENDIF}
    end;
end;

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

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

{$IFDEF FPC}
type

    { TGUIThread }

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

{ TGUIThread }

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

procedure TGUIThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.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.Pop;
                FSection.Leave;
                FCurrentMessage := Message^;
                FreeMem(Message);
                if (FCurrentMessage.Message >= WM_THREAD_BASE)
                    and(FCurrentMessage.Message <= WM_THREAD_MAX) then
                    Synchronize(@CallGUIThread);
            end;
        end;
    end;
end;

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

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

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

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

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

{ TWThread }

constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
{$IFDEF FPC}
    FQueue := TQueue.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.Push(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.Pop;
                    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.



Модуль WLog на основе WThread для логирования в отдельном потоке.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
unit WLog;
// wlog (c) wadman, 2015, 29.04.2015
// multithread safe logging

interface

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

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

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

implementation

uses SysUtils, WThread;

const
    WM_LOG      = WM_THREAD_BASE + 1;

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

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

var
    LogThread: TLogThread;
    FirstLine: boolean;

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

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

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

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

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

{ TLogThread }

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

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

finalization
    DoneLogs;

end.

...
Рейтинг: 0 / 0
29.04.2015, 12:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950040
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
Почистил.

Но таки удобнее иметь файл для скачивания, при портянках таких размеров.
...
Рейтинг: 0 / 0
30.04.2015, 19:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950046
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Гаджимурадов Рустам, имеешь в виду дублировать?
...
Рейтинг: 0 / 0
30.04.2015, 19:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950055
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,
смотри, ещё такая штучка
Код: pascal
1.
2.
3.
4.
5.
constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(CreateSuspended);
   .....................
end;


если заменить на
Код: pascal
1.
2.
3.
4.
5.
6.
constructor TWThread.Create(CreateSuspended: Boolean);
begin
    inherited Create(true);
   .....................
   if not CreateSuspended then Start;
end;


избавит от необходимости проверять инициализацию полей класса
...
Рейтинг: 0 / 0
30.04.2015, 19:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950510
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan), не понял глубины твоей мысли.
...
Рейтинг: 0 / 0
02.05.2015, 12:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950626
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,

что по твоему будет если вот это
Код: pascal
1.
2.
3.
4.
5.
6.
procedure TGUIThread.Execute;
var Message: PThreadMessage;
    wr: TWaitResult;
begin
    while not Terminated do begin
        wr := FMessageEvent.WaitFor(INFINITE);


начнёт исполняться раньше чем создастся FMessageEvent вот здесь
Код: pascal
1.
2.
3.
4.
constructor TGUIThread.Create(AOwner: TWThread);
begin
    inherited Create(False); //после этого отдельная ветка исполнения уже создана
    FMessageEvent := TEvent.Create(nil, False, False, '');
...
Рейтинг: 0 / 0
02.05.2015, 19:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950640
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)
Код: pascal
1.
//после этого отдельная ветка исполнения уже создана


То есть некто сумеет обратиться к gui-потоку до окончания конструктора TWThread.Create?

Код: pascal
1.
2.
3.
4.
  { Always start in suspended state, will be resumed in AfterConstruction if necessary
    See Mantis #16884 }
  FHandle := BeginThread(nil, StackSize, @ThreadProc, pointer(self), CREATE_SUSPENDED,
                         FThreadID);
...
Рейтинг: 0 / 0
02.05.2015, 20:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950641
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
kealon(Ruslan), это да, но вот так проще, нет ?
Код: pascal
1.
2.
3.
FMessageEvent := TEvent.Create(nil, False, False, '');
// создаем все, что может использовать в Execute
inherited Create(False);
...
Рейтинг: 0 / 0
02.05.2015, 20:45
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950643
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadman, эва как :)
...
Рейтинг: 0 / 0
02.05.2015, 20:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950657
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
dred2k, wadman

мда, умываю руки
пугает что Fixed in Version 2.6.0

надо будет в дельфи 7 посмореть
PS:я всё же лучше по старинке, так оно нам староверам спокойнее :-)
...
Рейтинг: 0 / 0
02.05.2015, 21:09
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950674
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan), без разницы, когда пофиксили: к гуи-потоку обращение происходит из twthread.execute , когда он уже создан и крутится.
...
Рейтинг: 0 / 0
02.05.2015, 22:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38950728
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,

да в курсе уже, механизм с AfterConstruction понятен, исходники посмотреть как-то мысли не возникало :-)
PS: в Delphi7 и раньше всё пучком, косяк в fpc тока был
...
Рейтинг: 0 / 0
03.05.2015, 09:02
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38956965
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
Попробовал модуль засунуть в свою программку на Lazarus. Скомпиленная под Win32 работает без запинки, а вот под wince не хочет. Досконально не проверял из-за временного отсутствия тестовой платформы. Может кто то сталкивался с особенностями PostMessage на wince?
...
Рейтинг: 0 / 0
13.05.2015, 06:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38956970
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
brick08Попробовал модуль засунуть в свою программку на Lazarus. Скомпиленная под Win32 работает без запинки, а вот под wince не хочет. Досконально не проверял из-за временного отсутствия тестовой платформы. Может кто то сталкивался с особенностями PostMessage на wince?

а как проверял при отсутствии платформы ?
...
Рейтинг: 0 / 0
13.05.2015, 06:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38956974
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
defecator,
проверял на панельке временно неиспользуемой, которая сейчас задействована на производстве.
...
Рейтинг: 0 / 0
13.05.2015, 07:02
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957024
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
brick08а вот под wince не хочет
Не хочу, говорит, и все тут?
...
Рейтинг: 0 / 0
13.05.2015, 08:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957067
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
wadmanНе хочу, говорит, и все тут?
явных ошибок не выдает. Экземпляр класса TWThread создается нормально. Застревает где-то на TWThread.Execute, т.к. до DirectTimeOut даже не доходит.
...
Рейтинг: 0 / 0
13.05.2015, 09:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957069
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
brick08wadmanНе хочу, говорит, и все тут?
явных ошибок не выдает. Экземпляр класса TWThread создается нормально. Застревает где-то на TWThread.Execute, т.к. до DirectTimeOut даже не доходит.
С какими опциями компилируешь (ОС, семейство процессоров и целевой процессор)?

Под fpc PostMessage не актуален, т.к. для общения между потоками работают event-ы и поток GUIThread.

П.С. Эмулятор-бы внятный найти...
...
Рейтинг: 0 / 0
13.05.2015, 09:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957078
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
wadmanС какими опциями компилируешь (ОС, семейство процессоров и целевой процессор)?

ОС - WinCE
Семейство процессоров - arm
Целевой - По умолчанию
скачал вот такой эмулятор
...
Рейтинг: 0 / 0
13.05.2015, 10:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957089
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
brick08wadmanС какими опциями компилируешь (ОС, семейство процессоров и целевой процессор)?

ОС - WinCE
Семейство процессоров - arm
Целевой - По умолчанию
скачал вот такой эмулятор
На нем проект, состоящий из одной пустой формы запускается?
...
Рейтинг: 0 / 0
13.05.2015, 10:10
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957091
Фотография Подкаблучнег
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Подкаблучнег
Участник
wadmanНа нем проект, состоящий из одной пустой формы запускается?
Да, запускается. Сделал тестовый проект. По кнопке запускает поток, который каждую секунду передает время. если нужен, могу скинуть.
...
Рейтинг: 0 / 0
13.05.2015, 10:15
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957098
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
упс, забыл перелогиниться
...
Рейтинг: 0 / 0
13.05.2015, 10:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957103
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
На эмуляторе работает, теперь и сам вижу.
А на устройстве нет? Тогда стоит подключить superlog 15510599 и через него выводить отладочную информацию.
...
Рейтинг: 0 / 0
13.05.2015, 10:28
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957115
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Соврал, wlog нужен. Он в первом сообщении на этой странице.
...
Рейтинг: 0 / 0
13.05.2015, 10:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957282
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
wadmanНа эмуляторе работает, теперь и сам вижу.
я неправильно выразился в предыдущем сообщении. На эмуляторе у меня тоже не работает. Похоже, что намудрил где-то. Прикладываю проект
...
Рейтинг: 0 / 0
13.05.2015, 12:19
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957492
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Проблема в TEvent, который для wince. Срабатывает до 12 раз в секунду по сигналу и ни о каком таймауте и речи нет.
Подумаю, как обойти...
...
Рейтинг: 0 / 0
13.05.2015, 13:56
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957603
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Собственно адаптировал под wince.

wthread.pas
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
627.
628.
629.
630.
631.
632.
633.
634.
635.
636.
637.
638.
639.
640.
641.
642.
643.
644.
645.
646.
647.
648.
649.
650.
651.
652.
653.
654.
655.
656.
657.
658.
659.
660.
661.
662.
663.
664.
665.
666.
667.
668.
669.
670.
671.
672.
673.
674.
675.
676.
677.
678.
679.
680.
681.
682.
683.
684.
685.
686.
687.
688.
689.
690.
691.
692.
693.
694.
695.
696.
697.
698.
699.
700.
701.
702.
703.
704.
705.
706.
707.
708.
709.
710.
711.
712.
713.
714.
715.
716.
717.
718.
719.
720.
721.
722.
723.
724.
725.
726.
727.
728.
729.
730.
731.
732.
733.
734.
735.
736.
737.
738.
739.
740.
741.
742.
743.
744.
745.
746.
747.
748.
749.
750.
751.
752.
753.
754.
755.
756.
757.
758.
759.
760.
761.
762.
763.
764.
765.
766.
767.
768.
769.
770.
771.
772.
773.
774.
775.
776.
777.
778.
779.
780.
781.
782.
783.
784.
785.
786.
787.
788.
789.
790.
791.
792.
793.
794.
795.
796.
797.
798.
799.
800.
801.
802.
803.
804.
805.
806.
807.
808.
809.
810.
811.
812.
813.
814.
815.
816.
817.
818.
819.
820.
821.
822.
823.
824.
825.
826.
827.
828.
829.
830.
831.
832.
833.
834.
835.
836.
837.
838.
839.
840.
841.
842.
843.
844.
845.
846.
847.
848.
849.
850.
851.
852.
853.
854.
855.
856.
857.
858.
859.
860.
861.
862.
863.
864.
865.
unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&linux)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 13.05.2015
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad
// При компиляции под *nix в файле проекта до раздела USES вставить строку строку {$DEFINE UseCThreads}
{$IFDEF FPC}
{$mode objfpc}{$H+}
    {$IFDEF WINDOWS}
        {$DEFINE FPC_WIN}
        {$DEFINE ALL_WIN}
    {$ELSE}
        {$DEFINE FPC_NIX}
    {$ENDIF}
{$ELSE}
    {$DEFINE WIN}
    {$DEFINE ALL_WIN}
{$ENDIF}

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

interface

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

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

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

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


    TWThread = class;

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

    { TWThread }

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

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

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

implementation

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

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

    SizeOfChar          = SizeOf(Char);

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

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

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

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

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

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

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

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

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

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

{$IFDEF FPC}
type

    { TGUIThread }

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

{ TGUIThread }

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

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

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

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

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

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

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

{ TWThread }

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

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

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

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

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

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

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

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

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

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

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

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

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

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

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

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

        if Terminated then break;

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

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

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

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

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

{$IFNDEF FPC}

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

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

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

{$ENDIF}

end.



wlog.pas
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
unit wlog;
// wlog (c) wadman, 2015, 13.05.2015
// multithread safe logging

interface

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

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

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

implementation

uses SysUtils, WThread;

const
    WM_LOG      = WM_THREAD_BASE + 1;

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

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

var
    LogThread: TLogThread;
    FirstLine: boolean;

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

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

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

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

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

{ TLogThread }

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

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

finalization
    DoneLogs;

end.



Во вложении дублеры.
...
Рейтинг: 0 / 0
13.05.2015, 14:49
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957954
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadman, это так и задумано (Create в деструкторе) ?
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
destructor TWEvent.Destroy;
begin
    {$IFDEF WINCE}
    CloseHandle(FWHandle);
    {$ELSE}
    inherited Create(nil, false, false, '');
    {$ENDIF}
end;
...
Рейтинг: 0 / 0
13.05.2015, 19:17
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957965
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
dred2k,

тут еще есть косячек... Не такой очевидный. Завтра поправлю.
Спасибо.
...
Рейтинг: 0 / 0
13.05.2015, 19:34
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957973
чччД
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
чччД
Участник
wadman,

"косячОк".
...
Рейтинг: 0 / 0
13.05.2015, 19:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38957980
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmanПроблема в TEvent, который для wince. Срабатывает до 12 раз в секунду по сигналу и ни о каком таймауте и речи нет.
Подумаю, как обойти...
в багрепорт писали?
...
Рейтинг: 0 / 0
13.05.2015, 19:52
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38958102
Фотография DarkMaster
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
DarkMaster
Участник
wadmandred2k,

тут еще есть косячек... Не такой очевидный. Завтра поправлю.
Спасибо.

А чо, красиво ;)
...
Рейтинг: 0 / 0
14.05.2015, 00:27
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38958259
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)wadmanПроблема в TEvent, который для wince. Срабатывает до 12 раз в секунду по сигналу и ни о каком таймауте и речи нет.
Подумаю, как обойти...
в багрепорт писали?
Написал-бы, если бы знал решение. С отладкой на wince нет желания разбираться (долго и лень), с учетом, что threadmansger и для обычной винды и для ce устанавливается один и тот же (судя по исходникам), то ковыряние тоже будет не быстрым.
CE порт в целом глючный. Написав приложение из окна, кнопки и потока с ивентом словил несколько ошибок/недочетов:
1. now не возвращает миллисекунды (кто виноват: fpc, эмулятор или wince?).
2. если окну поставить position в default, то приложение вылетает еще до показа окна.
3. event сигналит как оголтелый.

В общем, вот исправленный вариант.

wthread.pas
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
627.
628.
629.
630.
631.
632.
633.
634.
635.
636.
637.
638.
639.
640.
641.
642.
643.
644.
645.
646.
647.
648.
649.
650.
651.
652.
653.
654.
655.
656.
657.
658.
659.
660.
661.
662.
663.
664.
665.
666.
667.
668.
669.
670.
671.
672.
673.
674.
675.
676.
677.
678.
679.
680.
681.
682.
683.
684.
685.
686.
687.
688.
689.
690.
691.
692.
693.
694.
695.
696.
697.
698.
699.
700.
701.
702.
703.
704.
705.
706.
707.
708.
709.
710.
711.
712.
713.
714.
715.
716.
717.
718.
719.
720.
721.
722.
723.
724.
725.
726.
727.
728.
729.
730.
731.
732.
733.
734.
735.
736.
737.
738.
739.
740.
741.
742.
743.
744.
745.
746.
747.
748.
749.
750.
751.
752.
753.
754.
755.
756.
757.
758.
759.
760.
761.
762.
763.
764.
765.
766.
767.
768.
769.
770.
771.
772.
773.
774.
775.
776.
777.
778.
779.
780.
781.
782.
783.
784.
785.
786.
787.
788.
789.
790.
791.
792.
793.
794.
795.
796.
797.
798.
799.
800.
801.
802.
803.
804.
805.
806.
807.
808.
809.
810.
811.
812.
813.
814.
815.
816.
817.
818.
819.
820.
821.
822.
823.
824.
825.
826.
827.
828.
829.
830.
831.
832.
833.
834.
835.
836.
837.
838.
839.
840.
841.
842.
843.
844.
845.
846.
847.
848.
849.
850.
851.
852.
853.
854.
855.
856.
857.
858.
859.
860.
861.
862.
863.
864.
865.
866.
867.
868.
869.
870.
871.
872.
873.
874.
875.
unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&linux)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 14.05.2015
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad
// При компиляции под *nix в файле проекта до раздела USES вставить строку {$DEFINE UseCThreads}
{$IFDEF FPC}
{$mode objfpc}{$H+}
    {$IFDEF WINDOWS}
        {$DEFINE FPC_WIN}
        {$DEFINE ALL_WIN}
    {$ELSE}
        {$DEFINE FPC_NIX}
    {$ENDIF}
{$ELSE}
    {$DEFINE WIN}
    {$DEFINE ALL_WIN}
{$ENDIF}

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

interface

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

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

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

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


    TWThread = class;

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

    { TWThread }

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

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

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

implementation

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

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

    SizeOfChar          = SizeOf(Char);

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

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

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

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

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

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

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

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

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

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

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

{$IFDEF FPC}
type

    { TGUIThread }

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

{ TGUIThread }

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

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

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

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

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

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

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

{ TWThread }

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

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

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

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

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

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

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

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

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

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

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

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

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

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

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

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

        if Terminated then break;

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

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

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

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

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

{$IFNDEF FPC}

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

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

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

{$ENDIF}

end.



wlog.pas
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
unit wlog;
// wlog (c) wadman, 2015, 13.05.2015
// multithread safe logging

interface

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

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

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

implementation

uses SysUtils, WThread;

const
    WM_LOG      = WM_THREAD_BASE + 1;

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

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

var
    LogThread: TLogThread;
    FirstLine: boolean;

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

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

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

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

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

{ TLogThread }

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

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

finalization
    DoneLogs;

end.

...
Рейтинг: 0 / 0
14.05.2015, 09:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38958272
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
wadman,

Спасибо мил человек, будем пробовать. Если будет без глюков работать, пожалуй заменю коллбэки на твой модуль. О багах отрапортую, если что)
...
Рейтинг: 0 / 0
14.05.2015, 09:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38959408
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Решил полностью отказаться от общения между потоками с помощью оконной функции, которая в винде имеет некоторые ограничения, а на линуксе и вовсе не имеет прав на жизнь.
И добавил пример использования. Три класса потоков:
1) Менеджер, который управляет остальными потоками.
2) Поток, который ищет файлы и передают их менеджеру.
3. Поток(и), которые получают имена найденных файлов от менеджера для обработки.

wthread.pas
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
627.
628.
629.
630.
631.
632.
633.
634.
635.
636.
637.
638.
639.
640.
641.
642.
643.
644.
645.
646.
647.
648.
649.
650.
651.
652.
653.
654.
655.
656.
657.
658.
659.
660.
661.
662.
663.
664.
665.
666.
667.
668.
669.
670.
671.
672.
673.
674.
675.
676.
677.
678.
679.
680.
681.
682.
683.
684.
685.
686.
687.
688.
689.
690.
691.
692.
693.
694.
695.
696.
697.
698.
699.
700.
unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&*nix)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2015, версия от 14.05.2015
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad
// При компиляции под *nix в файле проекта до раздела USES вставить строку {$DEFINE UseCThreads}
{$IFDEF FPC}
{$mode objfpc}{$H+}
    {$IFDEF WINDOWS}
        {$DEFINE FPC_WIN}
        {$DEFINE ALL_WIN}
    {$ELSE}
        {$DEFINE FPC_NIX}
    {$ENDIF}
{$ELSE}
    {$DEFINE WIN}
    {$DEFINE ALL_WIN}
{$ENDIF}

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

interface

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

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

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

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


    TWThread = class;

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

    { TWThread }

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

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

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

implementation

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

    SizeOfChar          = SizeOf(Char);

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

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

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

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

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

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

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

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

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

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

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

type

    { TGUIThread }

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

{ TGUIThread }

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

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

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

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

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

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

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

{ TWThread }

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

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

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end.



wlog.pas
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
unit wlog;
// wlog (c) wadman, 2015, 15.05.2015
// multithread safe logging

interface

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

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

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

implementation

uses SysUtils, WThread;

const
    WM_LOG      = WM_THREAD_BASE + 1;

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

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

var
    LogThread: TLogThread;
    FirstLine: boolean;

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

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

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

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

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

{ TLogThread }

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

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

finalization
    DoneLogs;

end.



main.pas (форма с кнопкой и несколько обработчиков)
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
unit main;

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

interface

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

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

type

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

    { TSearchThread }

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

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

    { TJobThread }

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

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

    { TManageThread }

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

type

    { TForm1 }

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

var
    Form1: TForm1;

implementation

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

{ TManageThread }

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

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

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

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

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

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

{ TJobThread }

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

procedure TJobThread.DoneThread;
begin
end;

{ TSearchThread }

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

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

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

{ TForm1 }

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

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

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

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

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

end.

...
Рейтинг: 0 / 0
15.05.2015, 08:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #38959880
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Забыл упомянуть кое-что важное: теперь потоки могут общаться между собой минуя главный поток (VCL/LCL).
Код: pascal
1.
2.
        // отправка сообщения из этого потока другому потоку (см. OwnerWThread)
        procedure PostMessageToWThread(const Msg: Word; const WParam: Word; const LParam: NativeInt);
...
Рейтинг: 0 / 0
15.05.2015, 14:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39008828
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
wadmanРешил полностью отказаться от общения между потоками с помощью оконной функции, которая в винде имеет некоторые ограничения
Ограничения, как оказалось, были во мне. Сам наложил фильтр на оконные сообщения...
Вернул все на место и подправил пару ошибок.
В этот раз без портянок.

main.pas - пример использования TWThread. Чтобы он заработал, нужно создать пустой проект, бросить на форму одну кнопку и заменить главный модуль main.pas (названия модуля должны совпадать).
В примере демонстрируется создание менеджера потоков, потока для поиска файлов и несколько потоков для обработки найденных файлов: Поток-менеджер собирает список найденных файлов, принимая их названия от потока-поисковика и координирует работу потоков-обработчиков.
Всё "общение" между потоками выводится в лог-файл.
...
Рейтинг: 0 / 0
16.07.2015, 13:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39008837
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Хотя нет, пример все таки выложу в портянку.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
unit main;

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

interface

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

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

type

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

    { TSearchThread }

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

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

    { TJobThread }

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

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

    { TManageThread }

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

type

    { TForm1 }

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

var
    Form1: TForm1;

implementation

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

{ TManageThread }

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

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

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

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

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

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

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

{ TJobThread }

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

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

{ TSearchThread }

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

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

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

{ TForm1 }

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

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

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

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

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

end.

...
Рейтинг: 0 / 0
16.07.2015, 13:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39008879
Valery_B
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Valery_B
Участник
wadman,

Procedure Execute у тебя явно в вне общего контекста... т.е. Слишком громоздкая
И зачем там столько IFDEF ? По моему, только глаза мазолят,а польза, на мой взгляд, сомнительна...
...
Рейтинг: 0 / 0
16.07.2015, 14:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39008887
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Valery_B Слишком громоздкая
И зачем там столько IFDEF ?
На это обратил внимание?
Код: pascal
1.
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&*nix)



Если ТАКИЕ объемы исходников тебя пугают, то никогда не заглядывай в VCL/LCL.
...
Рейтинг: 0 / 0
16.07.2015, 14:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39008908
Valery_B
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Valery_B
Участник
wadman,

Я сказал только про один метод. Он действительно громоздкий.
Я бы сделал вот так:

Код: pascal
1.
2.
3.
4.
5.
if not Terminated then
   case WR of
     wrSignaled: DoWrSignaled(<парметры>);
     wrTimeout: DoWrTimeout(<параметры>);
   end;



+ ещё вынес бы пару методов.
Что бы в результате в Execute осталось 3-5 строчек.
...
Рейтинг: 0 / 0
16.07.2015, 14:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39008939
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Valery_BЯ бы сделал вот так:
Мысль понял, но так в принципе не получится, ибо бряки и континуумы еще нужны. А это сразу +3 строчки в каждый кейс. :)
Ну и да, в дельфи все это конечно громоздко выглядит, я предпочитаю последнее время в лазарусе редактировать, там ифдефы учитываются при отрисовке исходников.
...
Рейтинг: 0 / 0
16.07.2015, 14:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009011
Valery_B
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Valery_B
Участник
wadman, согласись, что так гораздо лучше.

Твои IFDEF LOG я удалил все принципиально. Можешь вернуть, если надо.
У меня на всё про всё заняло 10 минут.
Но результат проверить не могу :)

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
TWThread = class(TThread)
 private
  .... 
  FInternalTimeout: Cardinal;
  FBusy: TDateTime;
  Procedure DoWrSignaled;
  Procedure DoWrTimeout;
  Procedure ProcessLoop;
  Procedure CalculateTimeOut;
end;


Procedure TWThread.DoWrTimeout;
begin
 FInternalTimeout := TimeOut;
 if FTimeOutIsDirect then DirectTimeOut
  else
 begin
  PostMessageFromThread(WM_TIMEOUT, 0, 0);    // сообщение не занимает много времени, на точность не влияет
  FBusy := 0;
 end;
end;


Procedure TWThread.DoWrSignaled;
var
  Msg: PThreadMessage;
begin
   while FQueue.Count > 0 do
    begin
     FSection.Enter;
     Msg := FQueue.Pop;
     FSection.Leave;
    if (msg^.message >= WM_THREAD_BASE) and (msg^.Message <= WM_THREAD_MAX) then
      Dispatch(Msg^)
       else
      FreeMem(msg);
    end;
end;

Procedure TWThread.CalculateTimeOut;
var ms: Cardinal;
begin
  if (FBusy <> 0) then
   begin
    ms := GetMsFromDateTime(FBusy);
    if (ms > TimeOut) then
        FInternalTimeout := 0
         else
        FinternalTimeout := TimeOut - ms;
    end
   else
     FinternalTimeout := TimeOut;
end;

Procedure TWThread.ProcessLoop;
var
 wr: TWaitResult;
begin
 wr := FMessageEvent.WWaitFor(FInternalTimeout);
 FBusy := Now;
  if not Terminated then
    case WR of
     wrSignaled: DoWrSignaled;
     wrTimeout: DoWrTimeOut;
    end;
  CalculateTimeout;        // корректируем интервал таймаута на время выполнения кода выше
end;

procedure TWThread.Execute;
begin
 InitThread;
 FInternalTimeout := TimeOut;
 FBusy := 0;
 while not Terminated do
  ProcessLoop;
 DoneThread;
end;

...
Рейтинг: 0 / 0
16.07.2015, 15:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009023
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Valery_BНо результат проверить не могу :)
И это печально. :)
Это не взлетит, как минимум при общении между разными процессами под виндой, собственно почему я и вернул общение сообщениями.

П.С. Если тебе нужен именно такой вариант, то забирай, меняй как хочешь и пользуйся. Но зачем выкладывать нерабочий вариант, который даже не проверен (windows, wince, linux)?
...
Рейтинг: 0 / 0
16.07.2015, 15:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009029
Valery_B
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Valery_B
Участник
wadman Но зачем выкладывать нерабочий вариант

Как ни странно, это -твой вариант. Я просто разделил его на 5 методов.
...
Рейтинг: 0 / 0
16.07.2015, 15:44
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009042
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Valery_BКак ни странно, это -твой вариант.
Мой - рабочий и проверенный на всех платформах.
...
Рейтинг: 0 / 0
16.07.2015, 15:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009049
Valery_B
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Valery_B
Участник
wadman,

Покажи, тогда какая же строчка всё ломает ?
...
Рейтинг: 0 / 0
16.07.2015, 15:52
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009056
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Valery_BПокажи, тогда какая же строчка всё ломает ?
Хватит жечь напалмом. Твой модуль банально не компилируется, а переделывать и тестировать во всех нужных мне окружениях не вижу смысла. Он даже о сообщениях от других процессов не подозревает.
...
Рейтинг: 0 / 0
16.07.2015, 15:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009071
Valery_B
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Valery_B
Участник
wadman Твой модуль

Жаль только, что моего здесь ничего нету.
...
Рейтинг: 0 / 0
16.07.2015, 16:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39009310
Фотография Gator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Gator
Участник
Valery_Bwadman Твой модуль

Жаль только, что моего здесь ничего нету.Но перед этим
Valery_BТвои IFDEF LOG я удалил все принципиально. Можешь вернуть, если надо.
У меня на всё про всё заняло 10 минут.
Но результат проверить не могу :)А ещё что удалил/поправил?

Принцип знаешь? Работает? Не троржь!!!
...
Рейтинг: 0 / 0
16.07.2015, 21:33
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021361
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
2wadman
Помнится, мы с тобой уже пересекались по этой теме.
Глянь со стороны на модуль (D2010 >). Если что-то в комментах упустил - поясню.
Нужен внешний _конструктивный_ взгляд (ты по этой теме ближе, так что тебе адресую).
Ну, и все присоединяйтесь, разумеется.
...
Рейтинг: 0 / 0
03.08.2015, 02:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021362
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
Для затравки: DoCreate излишен, достаточно виртуального конструктора.
...
Рейтинг: 0 / 0
03.08.2015, 02:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021426
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Беглым взглядом не совсем уловил сути: сендер создается в другом потоке, который создается иными средствами (руками, а не сендером)? То есть это продвинутый обработчик очереди с объектами?

Ну и примеры-бы. Куда-ж без них?
...
Рейтинг: 0 / 0
03.08.2015, 09:24
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021514
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadman, в общем случае,
по месту использования - создаем экземпляр, объекты приходят по Post. Все.
...
Рейтинг: 0 / 0
03.08.2015, 11:08
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021532
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadmanсендер создается в другом потоке, который создается иными средствами (руками, а не сендером)? То есть это продвинутый обработчик очереди с объектами?
Это в буквальном смысле использование механизма PostMessage для прозрачной пересылки.
Со всеми плюсами (прозрачность) и минусами (очередь на самом деле конечна).
Если создать объект Sender-а в нитке и регулярно вызывать его ProcessMessages - события будут приходить и выполняться в контексте нитки (для главной нитки достаточно создания объекта, количество не важно - события приходят адресно).
Однако, главное и изначальное применение - создание экземпляра в любой дельфийской форме и дальнейшее использование "асинхронности" в различных операциях с передачей произвольных объектов. В той нитке, в которой создан объект (и в которой вызывается ProcessMessages - для главной нитки не нужно), в той и будут обрабатываться приходящие события.
wadmanНу и примеры-бы. Куда-ж без них?
Пока, к сожалению, без них.
Сделаю, нужны.
...
Рейтинг: 0 / 0
03.08.2015, 11:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021568
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
dred2kСо всеми плюсами (прозрачность) и минусами (очередь на самом деле конечна).
Меня удивляет акцент на длину очереди. На моем примере: дохлый целерон, на нем потоков около 120-ти (по одному на чтение и на запись), работа с железками. Нет никаких затыков и даже речи о десятках сообщений в очереди.

Хотя, это скорее вопрос архитектуры. Если криво написать, то можно нарваться на любые логические и физические лимиты.
...
Рейтинг: 0 / 0
03.08.2015, 11:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021581
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadman, акцент он не от "красного" словца.
Вот представь ситуацию:
1. Нитка получает некие данные и постит их в окно для визуализации. Важно, чтобы "все дошло".
2. Вполне себе штатно вызывается некий внешний вызов (к примеру, экспорт TcxGrid-а, который, к сожалению, ничего "не знает кроме себя") - все, события благополучно не обрабатываются и копятся в очереди, в общем случае - бесконтрольно.
И таких ситуаций - хватает.
Я считаю, что в общем случае следует использовать надежную схему "очередь событий с хранением" + событие "есть данные в очереди". Ну, а в частных и аккуратно - можно и очередь событий Windows, "как она есть".
Как-то так.
...
Рейтинг: 0 / 0
03.08.2015, 12:14
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39021587
dred2k
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
dred2k
Участник
wadmanХотя, это скорее вопрос архитектуры. Если криво написать, то можно нарваться на любые логические и физические лимиты.
Согласен. В "конце концов" все упрется в правильность подхода.
...
Рейтинг: 0 / 0
03.08.2015, 12:16
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39157161
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Из изменений помню только, что лог теперь не дергает закрытие/открытие файла, если в очереди есть сообщения, что ускоряет вывод лога при большом потоке данных.
 
wthread.pas
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
421.
422.
423.
424.
425.
426.
427.
428.
429.
430.
431.
432.
433.
434.
435.
436.
437.
438.
439.
440.
441.
442.
443.
444.
445.
446.
447.
448.
449.
450.
451.
452.
453.
454.
455.
456.
457.
458.
459.
460.
461.
462.
463.
464.
465.
466.
467.
468.
469.
470.
471.
472.
473.
474.
475.
476.
477.
478.
479.
480.
481.
482.
483.
484.
485.
486.
487.
488.
489.
490.
491.
492.
493.
494.
495.
496.
497.
498.
499.
500.
501.
502.
503.
504.
505.
506.
507.
508.
509.
510.
511.
512.
513.
514.
515.
516.
517.
518.
519.
520.
521.
522.
523.
524.
525.
526.
527.
528.
529.
530.
531.
532.
533.
534.
535.
536.
537.
538.
539.
540.
541.
542.
543.
544.
545.
546.
547.
548.
549.
550.
551.
552.
553.
554.
555.
556.
557.
558.
559.
560.
561.
562.
563.
564.
565.
566.
567.
568.
569.
570.
571.
572.
573.
574.
575.
576.
577.
578.
579.
580.
581.
582.
583.
584.
585.
586.
587.
588.
589.
590.
591.
592.
593.
594.
595.
596.
597.
598.
599.
600.
601.
602.
603.
604.
605.
606.
607.
608.
609.
610.
611.
612.
613.
614.
615.
616.
617.
618.
619.
620.
621.
622.
623.
624.
625.
626.
627.
628.
629.
630.
631.
632.
633.
634.
635.
636.
637.
638.
639.
640.
641.
642.
643.
644.
645.
646.
647.
648.
649.
650.
651.
652.
653.
654.
655.
656.
657.
658.
659.
660.
661.
662.
663.
664.
665.
666.
667.
668.
669.
670.
671.
672.
673.
674.
675.
676.
677.
678.
679.
680.
681.
682.
683.
684.
685.
686.
687.
688.
689.
690.
691.
692.
693.
694.
695.
696.
697.
698.
699.
700.
701.
702.
703.
704.
705.
706.
707.
708.
709.
710.
711.
712.
713.
714.
715.
716.
717.
718.
719.
720.
721.
722.
723.
724.
725.
726.
727.
728.
729.
730.
731.
732.
733.
734.
735.
736.
737.
738.
739.
740.
741.
742.
743.
744.
745.
746.
747.
748.
749.
750.
751.
752.
753.
754.
755.
756.
757.
758.
759.
760.
761.
762.
763.
764.
765.
766.
767.
768.
769.
770.
771.
772.
773.
774.
775.
776.
777.
778.
779.
780.
781.
782.
783.
784.
785.
786.
787.
788.
789.
790.
791.
792.
793.
794.
795.
796.
797.
798.
799.
800.
801.
802.
803.
804.
805.
806.
807.
808.
809.
810.
811.
812.
813.
814.
815.
816.
817.
818.
819.
820.
821.
822.
823.
824.
825.
826.
827.
828.
829.
830.
831.
832.
833.
834.
835.
836.
837.
838.
839.
840.
841.
842.
843.
844.
845.
846.
847.
848.
849.
850.
851.
852.
853.
854.
855.
856.
857.
858.
859.
860.
861.
862.
863.
864.
865.
866.
867.
868.
869.
870.
871.
872.
873.
874.
875.
876.
877.
878.
879.
880.
881.
882.
883.
884.
885.
886.
887.
888.
889.
890.
891.
892.
893.
894.
895.
896.
897.
898.
899.
900.
901.
902.
903.
904.
905.
906.
907.
908.
909.
910.
911.
912.
913.
914.
915.
916.
917.
918.
919.
920.
921.
922.
923.
924.
925.
926.
927.
928.
929.
930.
931.
932.
933.
934.
935.
936.
937.
938.
939.
940.
941.
942.
943.
944.
945.
946.
947.
unit wthread;
// модуль для работы с доп.потоками Delphi&Lazarus (win&wince&*nix)
// позволяет "общаться" дополнительному и основному потокам посредством очереди сообщений
// (c) wadman 2013-2016, версия от 15.01.2016
//
// использование:
// 1. Создать наследника с объявленными обработчиками сообщений
//  const WM_TEST_PROC = WM_THREAD_BASE + 1;
//  TMyThread = class(TWThread)
//     procedure WMTestProc(var Msg: TThreadMessage); message WM_TEST_PROC;
//  данные процедуры будут выполняться в доп.потоке путем отправки связанного с ними сообщения в поток
//  см. PostToThreadMessage
// 2. Присвоить форме обработчика(ов) события OnThreadReceiveMessage (OnTimeOut - при необходимости)
//
// Для обмена строками рекомендуется использовать функции NewString и FreeString
//
// Для корректной остановки потока и дальнейшей работы программы должна использоваться процедура StopThrad
// При компиляции под *nix в файле проекта до раздела USES вставить строку {$DEFINE UseCThreads}
{$IFDEF FPC}
{$mode objfpc}{$H+}
    {$IFDEF WINDOWS}
        {$DEFINE FPC_WIN}
        {$DEFINE ALL_WIN}
    {$ELSE}
        {$DEFINE FPC_NIX}
    {$ENDIF}
{$ELSE}
    {$DEFINE WIN}
    {$DEFINE ALL_WIN}
{$ENDIF}

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

interface

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

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

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

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


    TWThread = class;

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

    { TWThread }

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

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

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

implementation

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

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

    SizeOfChar          = SizeOf(Char);

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

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

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

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

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

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

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

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

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

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

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

{$IFDEF FPC}
type

    { TGUIThread }

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

{ TGUIThread }

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

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

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

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

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

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

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

{ TWThread }

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

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

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

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

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

procedure TWThread.DirectTimeOut;
begin
    // override
end;

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

function TWThread.ItsMe: boolean;
begin
    result := GetCurrentThreadId = ThreadID;
end;

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

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

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

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

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

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

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

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

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

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

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

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

        if Terminated then break;

        if LongBool(msg.hwnd) then begin
            TranslateMessage(msg);
            DispatchMessage(msg);
        end else case msg.message of
            WM_TIMEOUT: begin
                // изменен таймаут
                FTimeOut := msg.wParam;
                busy := 0;
            end;
            WM_WTHREAD_BASE..WM_WTHREAD_MAX: begin
                message.Message := Msg.message;
                message.WParam := Msg.wParam;
                message.LParam := Msg.lParam;
                {$IFDEF WTHREAD_DEBUG_LOG}
                intPostToLog(Format('dispatch msg %d (0x%0:x).', [Message.Message]), WLL_EXTRA);
                {$ENDIF}
                // ищем и вызываем procedure of object message
                Dispatch(message);
            end;
        end;

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

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

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

procedure TWThread.StopThread;
begin
    {$IFDEF FPC}
    TGUIThread(FGUIThread).StopThread;
    Terminate;
    FMessageEvent.WSetEvent;
    {$ELSE}
    SetLength(FQueueMessages, 0);
    FreeWindow;
    Terminate;
    SetEvent(hCloseEvent);
    //SleepEx(1, false);
    //result := WaitForSingleObject(Handle, 10000) <> WAIT_TIMEOUT;
    {$ENDIF}
    {$IFDEF WTHREAD_DEBUG_LOG}
    intPostToLog('stop signal.');
    {$ENDIF}
end;

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

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

{$IFNDEF FPC}

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

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

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

{$ENDIF}

end.



 
wlog.pas
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
unit wlog;
// wlog (c) wadman, 2015-2016, 19.01.2016
// multithread safe logging

interface

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

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

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

implementation

uses Windows, SysUtils, WThread;

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

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

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

var
    LogThread: TLogThread;
    FirstLine: boolean;
    log: TextFile;
    FileOpened: boolean;

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

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

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

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

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

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

    end;
end;

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

    end;
end;

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

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

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

{ TLogThread }

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

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

    end;
end;

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

finalization
    DoneLogs;

end.

...
Рейтинг: 0 / 0
28.01.2016, 09:22
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39158159
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
wadman,

Использую твой модуль в своем проекте. Работает пока без нареканий.
Небольшое предложение:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
        constructor Create(const AOwnerThread: TWThread; const AThreadName: string
        {$IFDEF WTHREAD_DEBUG_LOG}
                ; AUseDebugLog: Boolean = false
        {$ENDIF}
            ); overload;
        constructor Create(const AOwnerThread: TWThread; CreateSuspended: Boolean; const AThreadName: string
        {$IFDEF WTHREAD_DEBUG_LOG}
                ; AUseDebugLog: Boolean = false
        {$ENDIF}
                ); overload;


Чтобы не менять количество параметров в конструкторе, если включать wlog.
И еще не объясни назначение DoneThread. Код из него можно же написать в деструкторе.
...
Рейтинг: 0 / 0
29.01.2016, 08:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39158164
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
brick08Чтобы не менять количество параметров в конструкторе, если включать wlog.
wlog без проблем включается. Или ты WTHREAD_DEBUG_LOG используешь?
brick08И еще не объясни назначение DoneThread. Код из него можно же написать в деструкторе.
Код: pascal
1.
2.
3.
            // Две процедуры, которые выполняются в контексте потока. В начале и в конце.
        procedure InitThread; virtual;
        procedure DoneThread; virtual;
...
Рейтинг: 0 / 0
29.01.2016, 08:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39158190
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
[quot wadman]brick08 Или ты WTHREAD_DEBUG_LOG используешь?
В том то и дело, что при тестах, то включал, то выключал директиву. Соответственно компилятор начинает ругаться на несовпадение кол-ва параметров в конструкторе. Так вот, чтобы избежать этого, просто поставить AUseDebugLog: Boolean = True в конструкторе.

А разве деструктор не выполняется в контексте?
...
Рейтинг: 0 / 0
29.01.2016, 09:20
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39158210
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
brick08В том то и дело, что при тестах, то включал, то выключал директиву.
Вынеси в wthread.inc и добавь строку в оба модуля {$i wthread.inc}
Код: pascal
1.
2.
3.
// добавлять отладочную информацию с использованием модуля wlog
// для сборки демки необходимо включить (убрать точку)
{$DEFINE WTHREAD_DEBUG_LOG}


в wlog.pas поправь
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
function InitLogs: boolean;
begin
    WLogFileName := ChangeFileExt(ParamStr(0), '.log');
    LogThread := TLogThread.Create(nil, 'LogThread',
{$IFDEF WTHREAD_DEBUG_LOG}
        false,
{$ENDIF}
    false
    );
    result := LongBool(LogThread);
end;


В следующий раз выложу уже с этими изменениями.


brick08А разве деструктор не выполняется в контексте?
Нет.
...
Рейтинг: 0 / 0
29.01.2016, 09:33
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39158326
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Восстановил совместимость с *никсами (убрал PeekMessage).
...
Рейтинг: 0 / 0
29.01.2016, 11:24
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39303639
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Добавил поддержку AffinityMask. Теперь можно раскидывать потоки по разным ядрам.
...
Рейтинг: 0 / 0
05.09.2016, 10:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39304625
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,

а не пробовали I/O Completion Ports для этого приспособить?
...
Рейтинг: 0 / 0
06.09.2016, 17:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39304929
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)а не пробовали I/O Completion Ports для этого приспособить?
Попробовал-бы, если-бы знал "зачем?" :)
А почитав https://habrahabr.ru/post/59282/ и вовсе растерялся...
Чем оно хорошо и в каких случаях?
...
Рейтинг: 0 / 0
07.09.2016, 10:22
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39304988
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,
ну фактически, как я понимаю, конкретно для реализации логера, можно писать сразу в файл асинхронным способом и в потоке обработки только подчищать ресурсы выделенных буферов
т.е. алгоритм такой:
выделяется блок памяти (условно строка)

вызывается операция записи в файл, в которую передаётся выделенный блок

поток контроля порта отслеживает какие операции завершились и удаляет отработавшие буферы
...
Рейтинг: 0 / 0
07.09.2016, 11:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39304991
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)конкретно для реализации логера, можно писать сразу в файл асинхронным способом
Асинхронно - это без порядка, что, на мой взгляд, вредно для логирования, где порядок имеет первостепенное значение.
...
Рейтинг: 0 / 0
07.09.2016, 11:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305004
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmankealon(Ruslan)конкретно для реализации логера, можно писать сразу в файл асинхронным способом
Асинхронно - это без порядка, что, на мой взгляд, вредно для логирования, где порядок имеет первостепенное значение.
ну асинхронно здесь имеется ввиду "не ждать результата", порядок то будет соблюдаться
...
Рейтинг: 0 / 0
07.09.2016, 11:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305009
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)wadmanпропущено...

Асинхронно - это без порядка, что, на мой взгляд, вредно для логирования, где порядок имеет первостепенное значение.
ну асинхронно здесь имеется ввиду "не ждать результата", порядок то будет соблюдаться
Хорошо, а плюс в чем, если сравнивать с моей реализацией?
Что у меня не хватает?
...
Рейтинг: 0 / 0
07.09.2016, 11:33
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305014
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmanХорошо, а плюс в чем, если сравнивать с моей реализацией?
Что у меня не хватает?
тут дело в том, что с излишком хватает
1. самое главное - очередь не придётся самостоятельно организовывать
2. возможно работать будет быстрее
...
Рейтинг: 0 / 0
07.09.2016, 11:38
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305018
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)1. самое главное - очередь не придётся самостоятельно организовывать
И у меня очередь не своя. :)
kealon(Ruslan)2. возможно работать будет быстрее
Скорее всего нет.
...
Рейтинг: 0 / 0
07.09.2016, 11:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305022
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmanСкорее всего нет.
я бы не был так категоричен без тестов, потому и спросил пробовали или нет
...
Рейтинг: 0 / 0
07.09.2016, 11:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305027
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)wadmanСкорее всего нет.
я бы не был так категоричен без тестов, потому и спросил пробовали или нет
Я-бы попробовал, если-бы мне сказали, что это лучше/быстрее/надежнее.
...
Рейтинг: 0 / 0
07.09.2016, 11:45
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305032
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadmanЯ-бы попробовал, если-бы мне сказали, что это лучше/быстрее/надежнее.
микрософт вроде так и говорит

msdnI/O completion ports provide an efficient threading model for processing multiple asynchronous I/O requests on a multiprocessor system. When a process creates an I/O completion port, the system creates an associated queue object for requests whose sole purpose is to service these requests. Processes that handle many concurrent asynchronous I/O requests can do so more quickly and efficiently by using I/O completion ports in conjunction with a pre-allocated thread pool than by creating threads at the time they receive an I/O request.
вы им доверяете?
...
Рейтинг: 0 / 0
07.09.2016, 11:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305040
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
kealon(Ruslan)вы им доверяете?
Они сравнивали с моим решением?
 
Про Оку тоже писали, что это комфортный пятиместный автомобиль и кому верить?
...
Рейтинг: 0 / 0
07.09.2016, 11:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305053
kealon(Ruslan)
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
kealon(Ruslan)
Участник
wadman,

если бы я знал
...
Рейтинг: 0 / 0
07.09.2016, 12:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305323
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
Системный threadpool однозначно быстрее чем TThread. В нашей библиотеке я его использую, например для многопоточного QuickSort, так там даже на относительно небольших объемах данных видно ускорение, которое с использованием TThread наоборот привело бы к замедлению из-за накладных расходов
...
Рейтинг: 0 / 0
07.09.2016, 16:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305438
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
white_niggerСистемный threadpool однозначно быстрее чем TThread.
Два вопроса...
1. Быстрее в каком качестве?
К примеру, нужно проверить информацию в базе и по результату запустить печать.
Я делаю просто: один поток проверяет, другой печатает.
2. Как тут (на практике) пул потоков может ускорить процесс?

П.С. Пул это нечто, что держит энное количество потоков с режиме ожидания и дергает их по мере необходимости? Тогда не вижу проблем, я именно так и делаю: запускаю потоки в любое удобное мне время и они ждут команды. Обертка, по сути, на это и ориентирована.
...
Рейтинг: 0 / 0
07.09.2016, 18:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305458
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
wadmanДва вопроса...
1. Быстрее в каком качестве?
К примеру, нужно проверить информацию в базе и по результату запустить печать.
Я делаю просто: один поток проверяет, другой печатает.
2. Как тут (на практике) пул потоков может ускорить процесс?

П.С. Пул это нечто, что держит энное количество потоков с режиме ожидания и дергает их по мере необходимости? Тогда не вижу проблем, я именно так и делаю: запускаю потоки в любое удобное мне время и они ждут команды. Обертка, по сути, на это и ориентирована.Зависит от конкретной задачи. У тебя этот юнит ведь тоже чтоб что-то распараллелить а потом сообщать о выполнении. Создание thread относительно тяжелая системная функция, плюс накладываются делфёвые расходы по созданию объекта. По сравнению с этим распараллеливание через Thread Pooling эффективно и производительнее. В качестве примера я привёл распараллеливание сортировки (также фильтрации, итерирования). Поскольку в делфи нет обертки для этого, поэтому обычно юзают наследников TThread. Если сравнить распараллеливание через системный пул и TThread последний проиграет по быстродействию (точнее непосредственно по запуску и завершению "распараллеленного" куска кода). Для кого-то это может быть критично. В наших продуктах используются оба подхода
...
Рейтинг: 0 / 0
07.09.2016, 19:17
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305467
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
white_niggerУ тебя этот юнит ведь тоже чтоб что-то распараллелить а потом сообщать о выполнении.
Распараллелить - да, но не одну задачу, а несколько разных . Потому пул тут не подходит.
Хотя можно и под одну задачу приспособить. Например при поиске строки в файлах.

Все тормоза упираются только в создание экземпляра.
Это не существенно в сравнении с основным циклом задач, когда приложение (например служба) стартует один раз и работает до конца.
...
Рейтинг: 0 / 0
07.09.2016, 19:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305473
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
wadmanРаспараллелить - да, но не одну задачу, а несколько разных . Потому пул тут не подходит.
Хотя можно и под одну задачу приспособить. Например при поиске строки в файлах.Системному пулу тоже пофигу что параллелить. Я просто для примера привел пример где у нас юзается. Кстати, надо будет ReplaceString попробовать реализовать через пул (где-то топик был, где попугаями мерялись :))
...
Рейтинг: 0 / 0
07.09.2016, 19:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305476
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
white_niggerwadmanРаспараллелить - да, но не одну задачу, а несколько разных . Потому пул тут не подходит.
Хотя можно и под одну задачу приспособить. Например при поиске строки в файлах.Системному пулу тоже пофигу что параллелить. Я просто для примера привел пример где у нас юзается. Кстати, надо будет ReplaceString попробовать реализовать через пул (где-то топик был, где попугаями мерялись :))
С юникодом replacestring не получится. С анси (то есть побайтно) - да.
Можем помериться на досуге. :)
...
Рейтинг: 0 / 0
07.09.2016, 19:54
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305633
vavan
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
vavan
Участник
white_niggerСистемный threadpool однозначно быстрее чем TThreadнет никаких принципиальных препятствий реализовать user space пул не менее эффективно чем ядровый хотя конечно второй даже при абсолютно одинаковой реализации всегда будет чуточку проворнее. но это еще надо суметь так нагрузить чтоб заметить
white_niggerвидно ускорение, которое с использованием TThread наоборот привело бы к замедлению из-за накладных расходовwhite_niggerСоздание thread относительно тяжелая системная функция, плюс накладываются делфёвые расходы по созданию объекта. По сравнению с этим распараллеливание через Thread Pooling эффективно и производительнеебудто кто-то заставляет каждый раз создавать потоки
...
Рейтинг: 0 / 0
08.09.2016, 09:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305786
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
vavanнет никаких принципиальных препятствий реализовать user space пул не менее эффективно чем ядровый хотя конечно второй даже при абсолютно одинаковой реализации всегда будет чуточку проворнее. но это еще надо суметь так нагрузить чтоб заметитьНу напиши эфективный пул, сравним на примере той же многопоточной сортировки...
...
Рейтинг: 0 / 0
08.09.2016, 12:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305842
Barmaley57
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Barmaley57
Участник
white_niggerСистемный threadpool однозначно быстрее чем TThread.Подождите товарищи! О каком системном пуле идет речь, применительно к порту завершения? Порт завершения - это же просто ядерная очередь операций ввода/вывода. Пул потоков для работы с ним один фиг надо создавать самому.
...
Рейтинг: 0 / 0
08.09.2016, 13:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305864
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
Barmaley57Подождите товарищи! О каком системном пуле идет речь, применительно к порту завершения? Порт завершения - это же просто ядерная очередь операций ввода/вывода. Пул потоков для работы с ним один фиг надо создавать самому.А что с ним не так? " You can also use the BindIoCompletionCallback function to post asynchronous I/O operations. On completion of the I/O , the callback is executed by a thread pool thread."
...
Рейтинг: 0 / 0
08.09.2016, 13:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305874
Barmaley57
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Barmaley57
Участник
white_nigger, MSDNThe thread pool maintains an I/O completion portтеперь понятно, что имелось ввиду. Только в этом случае уже не надо самому создавать порт завершения)
...
Рейтинг: 0 / 0
08.09.2016, 14:02
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39305900
vavan
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
vavan
Участник
white_niggerНу напиши эфективный пулменя пока устраивает тот что я использую и не хватало к вороху уже существующих готовых еще один писать
хотя 10+ лет назад я юзал именно родной виндовый, правда еще первой версии
white_niggerсравним на примере той же многопоточной сортировкинет у меня такой насущной необходимости чтоб этим заниматься
...
Рейтинг: 0 / 0
08.09.2016, 14:29
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323851
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Добавил компонент. Теперь можно кидать батоны потоки на форму и дергать таски. :)
Task - это задача, которая выполняется в доп. потоке.
Задач может быть много и все они выполнятся в порядке очереди.

Пример использования:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
procedure TForm1.Button3Click(Sender: TObject);
begin
    WCThread.Tasks[0].Start(10); // так задача запускается, параметр Variant
    Memo1.Lines.Add('Started');
end;

// вот эта задача, которая выполняется уже в доп. потоке
// никаких обращений к VCL отсюда! 
procedure TForm1.WCThreadTasks0Execute(Sender: TTaskItem);
var i: integer;
begin
    for i := 0 to Sender.Param-1 do
        // так проверяем, что задачу или поток еще не убили
        if not Sender.Terminated then begin
            Sleep(1000);
            // так сообщаем о прогрессе в основной поток
            Sender.PostProgress(i+1);
        end;
end;

procedure TForm1.WCThreadTasks0Progress(Sender: TTaskItem; const Value: Word);
begin
    // это прогресс, выполняется в основном потоке
    Memo1.Lines.Add(Format('Progress %d', [Value]));
end;

procedure TForm1.WCThreadTasks0Finished(Sender: TTaskItem);
begin
    // задача выполнена, сообщаем об этом
    Memo1.Lines.Add('Finished');
    // а можно запустить, к примеру, следующую (или не следующую) задачу 
    // WCThread.Tasks[1].Start('SomeString');
end;
...
Рейтинг: 0 / 0
10.10.2016, 15:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323872
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
думаю заюзать твой класс плюс BrainMM в одном чудовищном 19760178 приложении...
...
Рейтинг: 0 / 0
10.10.2016, 15:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323873
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
defecatorв одном чудовищном 19760178 приложении...
Хоть-бы рассказал, чего там чудовищного, что необходимо аж знать потолок количества потоков. :)
...
Рейтинг: 0 / 0
10.10.2016, 15:54
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323876
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
wadmandefecatorв одном чудовищном 19760178 приложении...
Хоть-бы рассказал, чего там чудовищного, что необходимо аж знать потолок количества потоков. :)
софтина с сотнями тыщ потоков, взаимодействующих между собой.
правда, внутри каждого потока примитивный простой код.
потом расскажу, если получится всё это запустить
...
Рейтинг: 0 / 0
10.10.2016, 15:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323879
Barmaley57
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Barmaley57
Участник
defecatorwadmanпропущено...

Хоть-бы рассказал, чего там чудовищного, что необходимо аж знать потолок количества потоков. :)
софтина с сотнями тыщ потоков, взаимодействующих между собой.
правда, внутри каждого потока примитивный простой код.
потом расскажу, если получится всё это запуститьчую нейронную сеть))
...
Рейтинг: 0 / 0
10.10.2016, 15:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323881
Barmaley57
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Barmaley57
Участник
defecatorесли получится всё это запуститьмашина ляжет) или выдаст тебе отказ по ресурсам ОС....
...
Рейтинг: 0 / 0
10.10.2016, 16:01
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323882
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Barmaley57defecatorесли получится всё это запуститьмашина ляжет) или выдаст тебе отказ по ресурсам ОС....
19760178
...
Рейтинг: 0 / 0
10.10.2016, 16:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323885
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
Barmaley57defecatorесли получится всё это запуститьмашина ляжет) или выдаст тебе отказ по ресурсам ОС....
не ляжет, на серваке со 128 гигами оперативы создалось чуть больше пяти миллионов потоков (которые TThread),
четыре процессора по 3.2 ГГц по четыре ядра на каждом плюс гипертрейд на каждом ядре.
Суммарная нагрузка была в районе 55-65 процентов.

Barmaley57чую нейронную сеть))
Точно, только другой структуры, не классической.
Надо опробовать идею
...
Рейтинг: 0 / 0
10.10.2016, 16:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323888
Barmaley57
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Barmaley57
Участник
defecatorне ляжет, на серваке со 128 гигами оперативы создалось чуть больше пяти миллионов потоков (которые TThread),
четыре процессора по 3.2 ГГц по четыре ядра на каждом плюс гипертрейд на каждом ядре.
Суммарная нагрузка была в районе 55-65 процентов.Гы!!! Стек потоков уменьшал с дефолта что-ли? Главное, чтобы стека хватило. Ну и ресурсов на обслуживание всего этого дела ОСь должна отхавать нехило. Тормоза сильно ощущались после этого выкрутаса?
...
Рейтинг: 0 / 0
10.10.2016, 16:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323890
Barmaley57
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Barmaley57
Участник
Опять таки, очереди сообщений то хватит, чтобы заюзать класс wadman'a?
...
Рейтинг: 0 / 0
10.10.2016, 16:14
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323891
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
Barmaley57defecatorне ляжет, на серваке со 128 гигами оперативы создалось чуть больше пяти миллионов потоков (которые TThread),
четыре процессора по 3.2 ГГц по четыре ядра на каждом плюс гипертрейд на каждом ядре.
Суммарная нагрузка была в районе 55-65 процентов.Гы!!! Стек потоков уменьшал с дефолта что-ли? Главное, чтобы стека хватило. Ну и ресурсов на обслуживание всего этого дела ОСь должна отхавать нехило. Тормоза сильно ощущались после этого выкрутаса?

мышка лагала сильно, а так внешне вроде несильно тормозила.
Оракля там ещё запущена, я с другого компа к ней цеплялся,
лаги при выполнении запросов были заметные
...
Рейтинг: 0 / 0
10.10.2016, 16:14
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323892
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
Barmaley57Опять таки, очереди сообщений то хватит, чтобы заюзать класс wadman'a?
кстати, про очереди в классе вадмана я что-то не подумал...
...
Рейтинг: 0 / 0
10.10.2016, 16:16
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39323897
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
defecatorBarmaley57Опять таки, очереди сообщений то хватит, чтобы заюзать класс wadman'a?
кстати, про очереди в классе вадмана я что-то не подумал...
Если очереди поломаются, то поменяй в wthread.inc режим на WTHREAD_LIBRARY.
Тогда будет использоваться TQueue для общения.
...
Рейтинг: 0 / 0
10.10.2016, 16:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39327281
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Полноценная версия компоненты для батонометателей.
Признаться, мне и самому так нравится больше. :)

Теперь есть обертка над wthread, которая делает таски (TTask), которые тоже являются компонентами.
Пользоваться стало чуть проще и удобнее.
Пакет ставится в delphi и в lazarus для простоты.
Под *nix пока не проверял.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms, Dialogs, wcthread, StdCtrls;

type
  TfrmWCThreadDemo = class(TForm)
    Memo1: TMemo;
    butDemoTimer: TButton;
    WCThread1: TWCThread;
    TaskDemoTimer: TTask;
    procedure FormDestroy(Sender: TObject);
    procedure TaskDemoTimerExecute(Sender: TTask);
    procedure TaskDemoTimerFinished(Sender: TTask);
    procedure TaskDemoTimerProgress(Sender: TTask; const Value: Word);
    procedure butDemoTimerClick(Sender: TObject);
  private
  public
    procedure AddLog(const Text: string);
  end;

var
  frmWCThreadDemo: TfrmWCThreadDemo;

implementation

{$R *.dfm}

procedure TfrmWCThreadDemo.TaskDemoTimerExecute(Sender: TTask);
var i: integer;
begin
    // этот метод выполняется в другом потоке, в это время форму можно таскать и ничего не тормозит
    for I := 0 to Sender.Param-1 do begin
        // проверка на то, что поток еще выполняется
        if Sender.Terminated then exit;
        Sleep(1000);
        // сообщаем о прогрессе основной форме
        Sender.PostProgress(i+1);
    end;
end;

procedure TfrmWCThreadDemo.FormDestroy(Sender: TObject);
begin
    // обязательное условие, ожидание окончания работы задачи на случай закрытия формы при выполняющейся задаче
    WCThread1.FinishAllTasks;
end;

procedure TfrmWCThreadDemo.AddLog(const Text: string);
begin
    // добавляет сообщение в лог
    Memo1.Lines.Add(Format('%s : %s', [FormatDateTime('hh:nn:ss.zzz', Now), Text]));
end;

procedure TfrmWCThreadDemo.butDemoTimerClick(Sender: TObject);
begin
    // так запускается задача в другом потоке
    TaskDemoTimer.Start(20);
    AddLog(Format('%s %s', [TaskDemoTimer.Name, 'start']));
end;

procedure TfrmWCThreadDemo.TaskDemoTimerFinished(Sender: TTask);
begin
    // задача сообщила обо окончании работы
    // здесь можно запустить другую задачу (выполняется в основном vcl потоке)
    AddLog(Format('%s %s', [Sender.Name, 'finished']));
end;

procedure TfrmWCThreadDemo.TaskDemoTimerProgress(Sender: TTask; const Value: Word);
begin
    // выполняется в основном vcl потоке
    AddLog(Format('%s %s %d', [Sender.Name, 'progress', Value]));
end;

end..

...
Рейтинг: 0 / 0
14.10.2016, 17:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39327283
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
И сами пакеты для delphi и lazarus.
...
Рейтинг: 0 / 0
14.10.2016, 17:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39327382
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
На Убунту (16) тоже работает с парой приведений типов. :)
...
Рейтинг: 0 / 0
14.10.2016, 21:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39328028
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Протестировано в следующих комбинациях: Ubuntu 14, 16 (LTS), WinCE 5, Windows XP/7, Delphi XE2, Lazarus 1.6.
Работает. :)
...
Рейтинг: 0 / 0
17.10.2016, 10:39
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39328306
серый-серый ник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
серый-серый ник
Гость
wadman,
может пора уже на гитхаб?
...
Рейтинг: 0 / 0
17.10.2016, 15:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39328494
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
серый-серый никможет пора уже на гитхаб?
я давно ему об этом говорил. И неплохо бы с демками...
...
Рейтинг: 0 / 0
17.10.2016, 18:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39328532
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Доксерый-серый никможет пора уже на гитхаб?
я давно ему об этом говорил. И неплохо бы с демками...
А какая демка нужна?
Вроде уже проще некуда: бросил компоненту, накидал таски (которые как сообщения для потока) и вперед.
Без сарказма. Я думал, что теперь всё просто. Без ручного кода, всё в пределах основных принципов дельфи.
...
Рейтинг: 0 / 0
17.10.2016, 20:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329216
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanбросил компоненту
вот видишь, теперь уже компонента. А я в первый раз об этом слышу, хотя за этим топиком внимательно слежу :)
...
Рейтинг: 0 / 0
18.10.2016, 18:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329218
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanБез ручного кода
а я по старинке, ручками. Только пару функций из твоего модуля использую ...
...
Рейтинг: 0 / 0
18.10.2016, 18:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329287
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Докwadmanбросил компоненту
вот видишь, теперь уже компонента. А я в первый раз об этом слышу, хотя за этим топиком внимательно слежу :)
Это появилось ровно на этой странице.
Выше описано.

ДокwadmanБез ручного кода
а я по старинке, ручками. Только пару функций из твоего модуля использую ...
NewString/FreeString?
...
Рейтинг: 0 / 0
18.10.2016, 19:33
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329298
Ghost Writer
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Ghost Writer
Участник
wadman,

в D7 не работает?
у меня при установке [Error] wthread.pas(357): Undeclared identifier: 'FHandle'

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
function TWEvent.GetHandle: THandle;
begin
    {$IFDEF WINCE}
    result := FWHandle;
    {$ELSE}
    result := FHandle;
    {$ENDIF}
end;
...
Рейтинг: 0 / 0
18.10.2016, 19:45
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329300
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Ghost Writer,

видимо нет, не тестировал. Завтра посмотрю.
...
Рейтинг: 0 / 0
18.10.2016, 19:49
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329479
Кар-Кар
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Кар-Кар
Участник
Почему такой большой? Зачем вы тащите все эти Classes...

Немного творчества и, в качестве идеи:
Код: pascal
1.
2.
    function WaitForMultipleThreads(Quantity:DWORD;const Parameter:Pointer;
      const WaitAll:BOOL;const Milliseconds:DWORD;const Proc:TCallback):DWORD;


Все. Одна функция на все случаи жизни. AsyncCall напоминает, но там опять всякие Classes, SysUtils и т.п., а выше чисто Windows.

Набросал эскиз:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
  TMTACallback = reference to function (Parameter:Pointer;const ThreadIndex,ThreadCount:DWORD):Integer;
  TMTA = class
  private type
  
    PThread = ^TThread;
    TThread = record
      Param  : Pointer;
      Proc   : TMTACallback;
      Index  : DWORD;
      Count  : DWORD;
      Signal : THandle;
      Handle : THandle;
      Id     : TThreadID; 
    end;
    
  private
    FThreads   : array [0..63] of TThread;
    FSignals   : array [0..63] of THandle;
  public
    function WaitForMultipleThreads(Quantity:DWORD;const Parameter:Pointer;
      const WaitAll:BOOL;const Milliseconds:DWORD;const Proc:TMTACallback):DWORD;
  end;

implementation

function ThreadExecute(Parameter:Pointer):Integer;
var
Thread : TMTA.PThread;
begin
Thread := TMTA.PThread(Parameter);
Result := Thread^.Proc(Thread^.Param, Thread^.Index, Thread^.Count);
SetEvent(Thread^.Signal);
end;

function ThreadCreate(var Thread:TMTA.TThread):Boolean;
begin
Thread.Signal := CreateEvent(nil,True,False,nil);
if Thread.Signal = 0 then Exit(False);
Thread.Handle := BeginThread(nil,0,@ThreadExecute,Pointer(@Thread),CREATE_SUSPENDED,Thread.Id);
if Thread.Handle <> 0 then Exit(True);
CloseHandle(Thread.Signal);
Result := False;
end;

function TMTA.WaitForMultipleThreads(Quantity:DWORD;const Parameter:Pointer;
  const WaitAll:BOOL;const Milliseconds:DWORD;const Proc:TMTACallback):DWORD;
var
i     : DWORD;
Count : DWORD;
begin
if Quantity > 64 then Exit(WAIT_FAILED);
Count := 0;
Quantity := (Quantity-1) and $7F; 
repeat
  if ThreadCreate(FThreads[Count]) then
  begin
    FThreads[Count].Param := Parameter;
    FThreads[Count].Proc := Proc;
    FThreads[Count].Index := Count;  
    FSignals[Count] := FThreads[Count].Signal;
    Inc(Count);
  end else
  begin
    Dec(Quantity);
  end;
until Count >= Quantity;
for i := 0 to Count-1 do
begin
  FThreads[i].Count := Count;
  ResumeThread(FThreads[i].Handle);
end;  
Result :=  WaitForMultipleObjects(Count,@FSignals[0],WaitAll,Milliseconds);
end;

Набросал тест:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
  with TMTA.Create do
  try
    case WaitForMultipleThreads(4,Pointer(List),True,INFINITE,
      function (Parameter:Pointer;const ThreadIndex,ThreadCount:DWORD):Integer
      var
      List  : TStringList;
      I     : Integer;
      D     : Integer;
      Z     : Integer;
      Start : Integer;
      Stop  : Integer;
      begin
      List := TStringList(Parameter);
      D := List.Count div ThreadCount;
      Z := ThreadIndex + 1;
      Start := (Z - 1) + (D * (Z - 1));
      if Z <> ThreadCount then
        Stop := (Z + (D * Z)) - 1 else
        Stop := List.Count-1;
      for I := Start to Stop do
        List[I] := '#'+IntToStr(I)+'   '+List[I];
      end) of
    WAIT_OBJECT_0:
      begin

      end;
    end;
  finally
    List.SaveToFile('D:\out.ini');
    Free;
  end;

И сработал! Как ни странно, но все линии пронумеровались нормально. В будущем если: вызывать с WaitAll = False, чтобы возвращаться если кто-то отработал и т.к. вызов из главного, то можно будет кое-чего в UI обновить безопасно - автоматический синхронайз фактически. Каллбэк переделать, чтобы вместо ThreadIndex/ThreadCount была какая-нибудь структура ThreadContext где можно было бы даже другими потоками поуправлять. Типа там Int64 с 64-мя битами(как раз максимальное поддерживаемое), которые отвечают за запущенность параллельных; через атомарный OR/AND брать и включать/отключать.
...
Рейтинг: 0 / 0
19.10.2016, 06:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329531
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Кар-КарЗачем вы тащите все эти Classes...
Один пишет "сделай компонет", другой "зачем classes". :)

Далее обсудим, когда расскажешь, на каких платформах это работает и что это делает?
...
Рейтинг: 0 / 0
19.10.2016, 09:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329719
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Допилил под Delphi 7.

Демо-код такой-же, как и под ubuntu и wince.
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, wcthread, StdCtrls;

type
  TForm1 = class(TForm)
    WCThread1: TWCThread;
    TaskDemoTimer: TTask;
    Memo1: TMemo;
    butDemoTimer: TButton;
    procedure butDemoTimerClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure TaskDemoTimerExecute(Sender: TTask);
    procedure TaskDemoTimerFinished(Sender: TTask);
    procedure TaskDemoTimerProgress(Sender: TTask; const Value: Word);
  private
    { Private declarations }
  public
    procedure AddLog(const Text: string);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.AddLog(const Text: string);
begin
  Memo1.Lines.Add(Format('%s : %s', [FormatDateTime('hh:nn:ss.zzz', Now), Text]));
end;

procedure TForm1.butDemoTimerClick(Sender: TObject);
begin
  Memo1.Lines.Clear;
  AddLog(Format('Processor count: %d', [WCThread1.ProcessorCount]));
  TaskDemoTimer.Start(20);
  AddLog(Format('%s %s', [TaskDemoTimer.Name, 'start']));
end;

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

procedure TForm1.TaskDemoTimerExecute(Sender: TTask);
var i: integer;
begin
  // another thread
  for i := 0 to Sender.Param-1 do begin
    if Sender.Terminated then exit;
    Sleep(1000);
    Sender.PostProgress(i);
  end;
end;

procedure TForm1.TaskDemoTimerFinished(Sender: TTask);
begin
  AddLog(Format('%s %s', [Sender.Name, 'finished']));
end;

procedure TForm1.TaskDemoTimerProgress(Sender: TTask; const Value: Word);
begin
  AddLog(Format('%s %s %d', [Sender.Name, 'progress', Value]));
end;

end.

...
Рейтинг: 0 / 0
19.10.2016, 12:39
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329960
gssbox
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
gssbox
Гость
К моему удивлению, компонент установился и заработал в Lazarus на Ubuntu Mate 15.04 на миниПК с ARM процессором.
Пришлось только добавить в файл lpr проекта перед uses строчку {$DEFINE UseCThreads}, иначе приложение с тестовым примером вылетало с ошибкой RunError(232).
...
Рейтинг: 0 / 0
19.10.2016, 15:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329966
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
gssboxПришлось только добавить в файл lpr проекта перед uses строчку {$DEFINE UseCThreads}, иначе приложение с тестовым примером вылетало с ошибкой RunError(232).
В wthread.pas warning имеется, но на него видимо мало кто обращает внимание в окошке компиляции...
Код: pascal
1.
2.
3.
4.
5.
    {$IFDEF UNIX}
        {$Message WARN 'WTHREAD: Add cthreads and cmem units to a project file.'}
        //cthreads,
        //cmem,
    {$ENDIF}



А вообще, об этом пишется почти в каждой теме про лазарус и многопоточность.
"Подошел к писуару, расстегни ширинку".
...
Рейтинг: 0 / 0
19.10.2016, 15:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329979
gssbox
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
gssbox
Гость
Вот кстати интересный момент когда раскомментил cthreads в файле wthread.pas:
Код: pascal
1.
2.
3.
4.
5.
 {$IFDEF UNIX}
        {$Message WARN 'WTHREAD: Add cthreads and cmem units to a project file.'}
        cthreads,
        cmem,
    {$ENDIF}



то ошибка вылетала все равно, помогло только описанное выше изменение в файле WThreadTask.pas:

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
program WThreadTask;

{$mode objfpc}{$H+}
{$DEFINE UseCThreads} //Здесь добавил эту строчку
uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Interfaces, // this includes the LCL widgetset
  Forms, TstWThread
  { you can add units after this };

{$R *.res}

begin
  RequireDerivedFormResource:=True;
  Application.Initialize;
  Application.CreateForm(TfrmWCThreadDemo, frmWCThreadDemo);
  Application.Run;
end.
...
Рейтинг: 0 / 0
19.10.2016, 15:59
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329986
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
gssboxВот кстати интересный момент когда раскомментил cthreads в файле wthread.pas:
Тут и не поможет. Модули cthreads и cmem должны быть самыми первыми модулями для проекта, а не для модуля.
...
Рейтинг: 0 / 0
19.10.2016, 16:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39329990
gssbox
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
gssbox
Гость
Ну так cthreads и был первым для проекта(см. выше), но заработало без ошибок только после добавления
{$DEFINE UseCThreads} перед uses.
...
Рейтинг: 0 / 0
19.10.2016, 16:10
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39330009
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
gssboxНу так cthreads и был первым для проекта(см. выше), но заработало без ошибок только после добавления
{$DEFINE UseCThreads} перед uses.
"Был" не значит, что использовался.
О чем спор? Что я не достаточно тонко намекаю на этот факт текстом сообщения?
gssbox
Код: pascal
1.
Add cthreads and cmem units to a project file.
...
Рейтинг: 0 / 0
19.10.2016, 16:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39330012
gssbox
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
gssbox
Гость
Да спора нет, просто поделился информацией. Я на Lazarus только начал работать и у него есть свои не очевидные для меня нюансы.
...
Рейтинг: 0 / 0
19.10.2016, 16:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39330018
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
gssboxДа спора нет, просто поделился информацией. Я на Lazarus только начал работать и у него есть свои не очевидные для меня нюансы.
Меня давно уже посещала мысль, что вместо warn нужно сделать некомпилируемую конструкцию.
Чтоб сразу (и хотя-бы раз) бросалась в глаза. :)
...
Рейтинг: 0 / 0
19.10.2016, 16:42
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39330123
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanЭто появилось ровно на этой странице.
Выше описано.
Точно. Это ты меня красивыми картинками от сути отвлек ;)
wadmanNewString/FreeString?
вот шайтан-малай, откуда знал, а?

зы. когда перелез на Лазарь, дал себе зарок: минимум сторонних компонентов, все ручками. В искушение вводишь

зыы. спасибо за труды. Дельная вещь. Пора на лазарныхевых форумах об этом компоненте трубить...
...
Рейтинг: 0 / 0
19.10.2016, 18:15
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39330148
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Докзы. когда перелез на Лазарь, дал себе зарок: минимум сторонних компонентов, все ручками. В искушение вводишь

зыы. спасибо за труды. Дельная вещь. Пора на лазарныхевых форумах об этом компоненте трубить...
Для лазаря что бесплатно, то всё родное. :)

ЗЫ, всегда пожалуйста.
...
Рейтинг: 0 / 0
19.10.2016, 19:27
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39330825
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Док, тыж вроде на 1.7 сидишь? Вот поддержка 1.7 :)
П.С. И теперь не нужно править файл проекта на предмет Define UseCThreads под *никсами. "Само".
...
Рейтинг: 0 / 0
20.10.2016, 16:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39331020
Фотография makhaon
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
makhaon
Участник
gssboxДа спора нет, просто поделился информацией. Я на Lazarus только начал работать и у него есть свои не очевидные для меня нюансы.

везде свои особенности. то, что ты пишешь - есть в faq по лазарусу.
...
Рейтинг: 0 / 0
20.10.2016, 19:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39331030
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
makhaongssboxДа спора нет, просто поделился информацией. Я на Lazarus только начал работать и у него есть свои не очевидные для меня нюансы.

везде свои особенности. то, что ты пишешь - есть в faq по лазарусу.
В принципе он верно поступил описав свой опыт
Хотя теперь в этом уже нет необходимости. "Само" делается. :)
...
Рейтинг: 0 / 0
20.10.2016, 19:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39331801
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Говорят, выкладывать вечером в пятницу обновление - плохая примета.
Заметил, что processorCount в никсах всегда возвращает 1. Поправил.
Добавил возможность отправки своего сообщения из потока.
Ну и редактор тасков довел до ума.
Демка прилагается.
...
Рейтинг: 0 / 0
21.10.2016, 17:01
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39333361
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Добавил общий параметр ко всем задачам (TWCThread.Param) и метод для ожидания не аварийного завершения задач (TWCThread.WaitAllTasks).
...
Рейтинг: 0 / 0
25.10.2016, 11:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39334416
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Убрал мемлик, перекроил код, убрал весьма досадную ошибку, прикрутил пару демок (в т.ч. и обновлялку в два потока и фоновое формирование lazReport).
Кажется, уже можно серьезно пользоваться. :)
...
Рейтинг: 0 / 0
26.10.2016, 14:26
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39334906
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
wadman,
Из за строки
Код: pascal
1.
THandle             = ;


в модулях где указан wthread и используя переменную с типом THandle, думаешь, что это будет System.THandle, а на самом деле TEventHandle. Думаю, нужно поправить.
...
Рейтинг: 0 / 0
27.10.2016, 05:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39334907
Фотография brick08
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
brick08
Участник
brick08Из за строки
Код: pascal
1.
2.
3.
    {$IFNDEF WINCE}
    THandle             = TEventHandle;
    {$ENDIF}
...
Рейтинг: 0 / 0
27.10.2016, 05:09
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39334982
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
brick08Думаю, нужно поправить.
Согласен.
...
Рейтинг: 0 / 0
27.10.2016, 09:52
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39364995
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
В связи с новой темой про потоки вспомнилось, что и я чего-то допилил за это время.
Но не помню что. Факт в том, что фоновые работы (печать, работа с БД и т.п.) теперь переделал на компонент wcthread.
И это работает. :)
...
Рейтинг: 0 / 0
12.12.2016, 15:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39391374
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
попробовал вашу библиотечку, таски подергал

правильно я понимаю что таски выполняются последовательно и сам тред после того как таск закончил свою работу не убивается а висит в памяти и ждет возможного повторного запуска?
...
Рейтинг: 0 / 0
25.01.2017, 17:24
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39391451
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
энди,

всё верно.
...
Рейтинг: 0 / 0
25.01.2017, 18:27
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39391523
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Ну в принципе никакой трагедии я не вижу, тред все равно создается при первом запуске, т.е даже если в программе вагон тасков то в пуле будут только те которые запускались хоть раз. Вот думаю не замирить ли как-нибудь таски с экшенами, все же для дельфи это более родное понятие, да и зачастую весь функционал программы разбит именно на экшены, а так получится 2 дублирующих списка, список экшенов в каждом из которых фактически запуск таска. Наблюдается некоторая избыточность.
...
Рейтинг: 0 / 0
25.01.2017, 19:20
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39391542
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
энди,

нет никакого пула. Таск - это компонент-обертка над сообщением потоку.
Запускаешь таск - по сути отправляешь сообщение потоку.
Обработка сообщения (таска) идет в контексте доп.потока.
При чем тут экшены, ума не приложу. :)
...
Рейтинг: 0 / 0
25.01.2017, 19:45
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39391774
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Ну пулом я это назвал из соображений того что тред не убивается а остается в памяти для последующих запусков :)

А про экшены я это сказал к тому что в принципе стандартная программа это посути набор TAction, прибитых к тулбарам, меню и прочему. При переделке такой программы на таски посути каждый TAction будет преставлять собой одну строчку c вызовом таска. А в описании формы будет двойной список из TAction и TTask с практически идентичными именами и фактически завязанных друг на друга. Вот я и подумал не нарисовать ли наследника на TActionList с возможностью назначения TTask для запуска. Если не назначен то работает стандартный функционал, а если назначен то просто идет его запуск и не надо прописывать OnExecute.
...
Рейтинг: 0 / 0
26.01.2017, 09:05
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39391911
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
эндиВот я и подумал не нарисовать ли наследника на TActionList с возможностью назначения TTask для запуска. Если не назначен то работает стандартный функционал, а если назначен то просто идет его запуск и не надо прописывать OnExecute.
Если я верно понял, то не дергай сам Execute у таска, иначе это будет не многопоточка.
Чтобы задача отработала в другом потоке, таск нужно запускать только через Start.
...
Рейтинг: 0 / 0
26.01.2017, 11:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39391959
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Да про start у таска я уже вчера понял, я имел ввиду Execute у TAction
...
Рейтинг: 0 / 0
26.01.2017, 12:16
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39392324
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Что-то у меня не получилось нормально поймать exception райзнутый в таске, они где-то глушатся и не рерайзятся при завершении работы таска с ошибкой?
...
Рейтинг: 0 / 0
26.01.2017, 17:17
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39392331
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
эндиони где-то глушатся и не рерайзятся при завершении работы таска с ошибкой?
Конечно. Лови сам и передавай в vcl через TTask.PostMessage -> OnMessage.
...
Рейтинг: 0 / 0
26.01.2017, 17:20
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39392345
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
ок, завтра поэкспериментирую
но спасибо за приятную обертку :)
...
Рейтинг: 0 / 0
26.01.2017, 17:29
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39392352
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
эндино спасибо за приятную обертку :)
Не за что. :)
...
Рейтинг: 0 / 0
26.01.2017, 17:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39393898
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Я вот тут что подумал, а может имеет смысл передавать exception пойманный в потоке не через messages, а в finish самого потока, тогда не надо перехватывать сообщения. Да и получится чуток логичнее, поток все равно завершился, но только с exception<>nil.
...
Рейтинг: 0 / 0
28.01.2017, 23:20
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39393948
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
энди,

поток на этом не останавливается.
Что мешает присвоить Param любое свое значение на выходе из OnExecute?
Этот же Param и будет в финише.
...
Рейтинг: 0 / 0
29.01.2017, 10:11
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394008
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Просто получается что для того чтобы поймать raise из потока мне надо перехватывать messages. А мне на самом деле сообщения из потока вообще не нужны, мне надо просто запустить и понять в конце выполнения потока были ошибки или нет, вот и все.
...
Рейтинг: 0 / 0
29.01.2017, 14:24
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394111
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
эндиА мне на самом деле сообщения из потока вообще не нужны, мне надо просто запустить и понять в конце выполнения потока были ошибки или нет, вот и все.
Как ты хочешь это понять, если обратную связь не хочешь получать?
Попробуй из наследника TThread поймай exception. :)
 
Хинт: он молча схлопнется.


П.С. Ты кажется не понял концепцию моего потока: он работает (или спит) до конца работы приложения. Таск - это не поток, это сообщение для потока. Если хочешь обратную связь от таска (сообщения), придется потрудиться написать еще один обработчик. Иначе никак.
...
Рейтинг: 0 / 0
29.01.2017, 18:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394218
Фотография makhaon
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
makhaon
Участник
wadman,

авторПопробуй из наследника TThread поймай exception. :)

Я ловлю их и перезапускаю рухнувшие потоки.
...
Рейтинг: 0 / 0
29.01.2017, 21:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394232
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
makhaonwadman,

авторПопробуй из наследника TThread поймай exception. :)

Я ловлю их и перезапускаю рухнувшие потоки.
Каким образом ловишь?
...
Рейтинг: 0 / 0
29.01.2017, 21:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394253
Фотография makhaon
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
makhaon
Участник
wadman,

Обрабатываю OnTerminate, в нём при существовании FatalException считается, что поток упал. Создаю новый инстанс, присваиваю ссылку на поток ему. Стоит счетчик перезапусков, если он достиг порога - то считается, что поток умер фатально и перезапустить его автоматически не представляется возможным. Так обрабатываются несколько критичных потоков. Работает нормально.
Сервера, работающие 365/7/24.
...
Рейтинг: 0 / 0
29.01.2017, 22:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394287
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Но ведь посути ты возвращаешь мне информацию 2 способами, через messages и через finish таска, так почему надо возвращать информацию об ошибке внутри таска именно через messages, а не через finish?
...
Рейтинг: 0 / 0
30.01.2017, 00:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394364
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
эндитак почему надо возвращать информацию об ошибке внутри таска именно через messages, а не через finish?
Дак что тебе мешает получить информацию через finish?
Код: pascal
1.
TTaskFinish     = procedure(const Sender: TTask; const Msg: Word; const Param: Variant) of object;


В Param в OnExecute ты можешь присвоить что угодно на выходе и оно в финише передастся.
...
Рейтинг: 0 / 0
30.01.2017, 09:17
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394366
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
makhaonТак обрабатываются несколько критичных потоков.
Интересный подход, но не лучше-ли если не писать не падающий код, то хотя-бы не убивать и запускать поток лишний раз?
...
Рейтинг: 0 / 0
30.01.2017, 09:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394391
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Не падающий код это утопия :)
...
Рейтинг: 0 / 0
30.01.2017, 10:00
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39394507
Фотография makhaon
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
makhaon
Участник
wadman,

Код максимально чистится, и продолжает. Абсолютное большинство вопросов почистилось еще у себя на тестах. Стараемся исправлять каждое. Но, к сожалению, единичные исключения всё еще бывают, хотя в последнее время всё реже. Не всё удаётся найти.

"хотя-бы не убивать и запускать поток лишний раз"

Я поток не убиваю. Если в execute случается необработанное исключение - то поток заканчивается и убивается сам. Можно, конечно, все исключения ловить и не выпускать 'за' execute, но это плохой подход. В случае, например, AV это почти гарантированно закончится фатально для всего сервиса. Перезапуск потока же часто спасает ситуацию.
...
Рейтинг: 0 / 0
30.01.2017, 12:17
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39402469
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Посидел повертел тут таски на реальных задачах и понял что меня смущает.
1) word передаваемый в start потока, зачем? если еще один доп параметр то за ним вроде как вариант идет и можно там его гонять если очень хочется что-то в таск передать.
2) variant в качестве входного параметра не сказать чтобы очень удобен, я привык параметры гонять с помощью коллекций и обычно пользую тупо TParams из db.pas. Он позволяет иметь кучу типов параметров, читаем и пишем как хотим без всякой сериализации/десериализации в Variant
3) Зачем вообще все эти входные параметры если можно иметь банальный набор значений в той же форме и зачитать их уже в самом таске. Вопрос многопоточности в этом случае не стоит так как таски выполняются последовательно.
4) Идеальным вариантом параметра для start выглядит имя процедуры которую таск уже запускает внутри себя в отдельном потоке. Тогда не надо на каждый чих заводить отдельный таск.
...
Рейтинг: 0 / 0
10.02.2017, 19:53
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39402584
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
энди1) word передаваемый в start потока, зачем?
Можешь не использовать. Там три варианта Start, один из них без параметров.
энди2) variant в качестве входного параметра не сказать чтобы очень удобен, я привык параметры гонять с помощью коллекций и обычно пользую тупо TParams из db.pas. Он позволяет иметь кучу типов параметров, читаем и пишем как хотим без всякой сериализации/десериализации в Variant
В варианте можно передать и массив. И массив массивов. И т.д. :)
энди3) Зачем вообще все эти входные параметры если можно иметь банальный набор значений в той же форме и зачитать их уже в самом таске. Вопрос многопоточности в этом случае не стоит так как таски выполняются последовательно.
Они выполняются относительно доп.потока последовательно, но для основного потока они выполняются параллельно.
Задача на смекалку:
Код: pascal
1.
2.
3.
4.
5.
6.
form1.SomeValue := 1;
Task1.Start; // выполняется минуту
form1.SomeValue := 2;
Task1.Start; // выполняется минуту
form1.SomeValue := 3;
Task1.Start; // тоже минуту


Какое значение будет в SomeValue, когда запустится таск первый и второй раз?
 
подсказка, не подглядывай
Для первого раза там в 99% случаев будет уже 3, для второго будет 3 уже 100%

энди4) Идеальным вариантом параметра для start выглядит имя процедуры которую таск уже запускает внутри себя в отдельном потоке. Тогда не надо на каждый чих заводить отдельный таск.
Этот вариант уже сделан. В обработчике OnExecute, который и является процедурой.
...
Рейтинг: 0 / 0
11.02.2017, 10:47
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39402617
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Ну у меня в основном потоке красивая форма прогресса отрисовывается с анимацией, так что очереди тасков у меня не будет даже чисто теоретически. Так что проблемы с глобальными переменными быть не может.
Да и передавать через вариант скажем набор разнотипных объектов или переменных не так чтобы совсем уж логично. Хотя конечно это личное дело каждого.
На самом деле лвиная доля типовых тасков это типовые операции с датасетом, открытие например. Так что таск на открытие можно иметь один, просто передавать в него датасет который там уже и открывать попутно отрисовывая красивое окно ожидания.
...
Рейтинг: 0 / 0
11.02.2017, 12:30
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39402642
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
энди,
не понимаю. Предлагаешь урезать функционал под тебя?
Перепиши как хочешь, исходники полностью доступны. Уж извини, что тоже пользуюсь библиотекой и не ограничиваюсь только одним случаем.
И копирование файлов идет фоном в два потока, и непрерывная печать на упаковке, и формирование выгрузок в эксель и т.д.
...
Рейтинг: 0 / 0
11.02.2017, 13:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39402757
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
да не, я не претензии, все равно спасибо за либу, снимает головную боль
а так да, я уже кривенького наследника накропал под свои типы задач :)
...
Рейтинг: 0 / 0
11.02.2017, 19:12
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39435554
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

иконки не было в комплекте или она потерялась?
...
Рейтинг: 0 / 0
09.04.2017, 22:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39435624
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Докиконки не было в комплекте или она потерялась?
Не было. На кой она? :)
...
Рейтинг: 0 / 0
10.04.2017, 09:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39437678
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Убрал StopThread (Terminate удобнее).
Добавил возможность стартовать поток 2 из потока 1 с обратной связью в поток 1 (а не VCL/LCL).
Тут нужно понимать, что используется механизм сообщений и обратная связь идет через очередь потока 1.
Убрал жуткую ошибку, которая тянулась с самого начала, но вылезла только на стресс-тесте в внезапным закрытием, когда потоки во всю "общаются".
Ну и исправления по мелочи...
...
Рейтинг: 0 / 0
13.04.2017, 08:46
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39439066
sql2012
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
sql2012
Участник
wadman,

из simpledemo -
В TaskDemoTimerExecute поменял с 1000 на 5000:
Код: pascal
1.
2.
   // hard work
   Sleep(5000);



При закрытии приложения - падает при вызове GetTerminated

автор---------------------------
Debugger Exception Notification
---------------------------
Project Project1.exe raised exception class EAccessViolation with message 'Access violation at address 00456F74 in module 'Project1.exe'. Read of address 00000050'. Process stopped. Use Step or Run to continue.
---------------------------
OK Help
---------------------------
...
Рейтинг: 0 / 0
15.04.2017, 10:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39439078
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
sql2012,

логично. Компонента то шлепнута.
Либо замени слип на работу с проверкой терминатора, либо увеличь интервал ожидания в finishalltasks в деструкторе формы.
...
Рейтинг: 0 / 0
15.04.2017, 11:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39439082
sql2012
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
sql2012
Участник
wadman,

Спасибо.
...
Рейтинг: 0 / 0
15.04.2017, 11:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39485732
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Залил на гитхаб: https://github.com/wadman/wthread/

Из последних изменений: поток для синхронного вызова vcl/lcl перевел в режим singleton.
Как раньше не догадался? При большом количестве потоков большой и не нужный расход памяти и дескрипторов.
Теперь таски по умолчанию принудительно прибиваются при Destroy, если не вызвать явно ожидание их работы (FinishAllTasks, WaitAllTasks). Раньше было наоборот.
...
Рейтинг: 0 / 0
10.07.2017, 13:28
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538557
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Добавил TWEvent.WaitForMultiple, который, соответственно, работает только со своим классом.
Подходит для синхронизации нескольких потоков TWThread, TWCThread.
...
Рейтинг: 0 / 0
19.10.2017, 11:17
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538598
schi
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
schi
Участник
А можно для тормознутых и бестолковых пояснить, чем отличается от ThreadPool, QueueUserWorkItem, QueueUserAPC, etc ?
...
Рейтинг: 0 / 0
19.10.2017, 12:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538601
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
schiА можно для тормознутых и бестолковых пояснить, чем отличается от ThreadPool, QueueUserWorkItem, QueueUserAPC, etc ?
Не я писал.
...
Рейтинг: 0 / 0
19.10.2017, 12:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538640
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
wadmanschiА можно для тормознутых и бестолковых пояснить, чем отличается от ThreadPool, QueueUserWorkItem, QueueUserAPC, etc ?
Не я писал.
А точнее - не трогал, не сравнивал. Решал свои задачи.
Мне для полного счастья не хватает пула и, соответственно, авто-балансира.
...
Рейтинг: 0 / 0
19.10.2017, 12:44
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538655
schi
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
schi
Участник
wadmanschiА можно для тормознутых и бестолковых пояснить, чем отличается от ThreadPool, QueueUserWorkItem, QueueUserAPC, etc ?
Не я писал.

+100500

Я тут по наводке white_nigger в одном из постов заинтересовался возможностью запускать асинхронное выполнение кода, не создавая вручную потомков TThread, через QueueUserWorkItem, довольно интересно в несложных случаях. Прочитал про то, что у тебя рабочие потоки живут до конца работы процесса, заинтересовался.
...
Рейтинг: 0 / 0
19.10.2017, 13:08
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538717
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
schiПрочитал про то, что у тебя рабочие потоки живут до конца работы процесса, заинтересовался.
Не совсем до конца процесса, а до сигнала.
Они не мешаются, есть-пить не просят, пока спят.
Будить-то дешевле, чем создавать.
...
Рейтинг: 0 / 0
19.10.2017, 14:08
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538920
white_nigger
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
white_nigger
Участник
wadmanЗалил на гитхаб: https://github.com/wadman/wthread/ Не прошло и пяти лет! Молодец что-таки сподобился
...
Рейтинг: 0 / 0
19.10.2017, 16:40
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39538945
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
white_niggerwadmanЗалил на гитхаб: https://github.com/wadman/wthread/ Не прошло и пяти лет! Молодец что-таки сподобился
С появлением 2-го и 3-го места, где мне нужны мои исходники, пришлось перейти на процесс синхронизации... :)
...
Рейтинг: 0 / 0
19.10.2017, 16:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39539949
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

тебя поздравить можно, вошел в список классиков :)
...
Рейтинг: 0 / 0
21.10.2017, 20:26
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39540078
Гаджимурадов Рустам
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гаджимурадов Рустам
Участник
А чего рейтинг не 5 звёзд? :)
...
Рейтинг: 0 / 0
22.10.2017, 13:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39540148
чччД
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
чччД
Участник
Гаджимурадов Рустам,

пять. Просто они серенькие.
...
Рейтинг: 0 / 0
22.10.2017, 17:16
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39540232
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
Гаджимурадов РустамА чего рейтинг не 5 звёзд? :)
рейтинг ты ставишь сам, когда устанавливаешь компоненту. Видимо, народ не заморачивается с этим, ибо похоже на лайки в соцсетях
...
Рейтинг: 0 / 0
23.10.2017, 08:37
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39540241
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Доктебя поздравить можно, вошел в список классиков :)
Приятно, конечно... И странно, что не связались. :)
...
Рейтинг: 0 / 0
23.10.2017, 08:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39540242
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Поставили совместимость с карбоном. Неужто под макосью проверили или от фонаря?
...
Рейтинг: 0 / 0
23.10.2017, 09:02
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39540245
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanНеужто под макосью проверили или от фонаря?
попроси Gallerman'a проверить, помнится, у него на виртуалке макось стоит
...
Рейтинг: 0 / 0
23.10.2017, 09:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39577827
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Вадман, посоветуй, как лучше всего в основном потоке дождаться окончания единственного
запущенного таска. При этом в основном потоке идет отрисовка окна с анимированным гифом.

Пока ничего тупее бесконечного цикла до Task.IsFinished=true c sleep
и aplication.processmessagess в теле цикла голову не приходит.
...
Рейтинг: 0 / 0
29.12.2017, 12:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39577896
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
энди,

у таска соответствующее событие есть.
Чем не подходит?
...
Рейтинг: 0 / 0
29.12.2017, 13:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39577987
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
код-лапша получается, хотел чтобы читаемость была получше, вроде

task.start
ожидаем окончания работы таска
вывод/обработка результатов работы таска

сам таск у меня достаточно унифицированный, т.е обработка результатов разная, а execute таска унифицирован
да вот хотя бы типичный пример
есть таск обеспечивающий открытие массива датасетов, но при этом есть задача как просто открыть ряд справочников, так и например открыть пачку справочников и после этого еще заполнить например комбобоксы для фильтров.
А плодить разные таски не хочется, и так читаемость кода ужасная :(
...
Рейтинг: 0 / 0
29.12.2017, 16:20
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39578009
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
энди,

я уже тёплый, но...
Задействовать другой поток и processmessages для ожидания его завершения?
Это за гранью. Либо либо.
...
Рейтинг: 0 / 0
29.12.2017, 17:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39578015
энди
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
энди
Участник
Да я пожалуй не совсем удачно применил Ваш модуль, скорее мне больше подойдет AsyncCalls для моей специфики.
...
Рейтинг: 0 / 0
29.12.2017, 17:16
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39623355
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Хвастану слегка: на макосях тоже работает.
И реальные пользователи так или иначе связываются и отписываются о багах. :)

Остается только вопрос с freebsd. Не ясно, бага в сырцах fpc (скорее всего) или в ос.
...
Рейтинг: 0 / 0
30.03.2018, 15:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39628915
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Интересно, кто таки следит за пакетом в онлайн менеджере лазаруса? Почти по пятам обновляют...

Док, не ты, случаем? :)
...
Рейтинг: 0 / 0
12.04.2018, 10:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39629351
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanДок, не ты, случаем? :)
не-а :)

Я тут сгоряча Алексу пообещал иконки для Rxlib обновить в соответствии со нынешними лазарусовскими стандартными, день ушел на адаптацию к inkscape (привык за много лет к CorelDraw'у), пока весь в работе.

Кстати, может заодно и тебе сделаю. Хорошо бы ты прислал какой-нить эскиз какой. У меня есть наметки, но фантазия уже не та
...
Рейтинг: 0 / 0
12.04.2018, 17:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39629369
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
ДокУ меня есть наметки, но фантазия уже не та
Не думаю, что у меня лучше. :)
Примерно так когда-то хотел нарисовать. Квадраты/потоки: 5-2-1 или 5-3-1.
...
Рейтинг: 0 / 0
12.04.2018, 17:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39629370
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Или черно-белое.
...
Рейтинг: 0 / 0
12.04.2018, 17:42
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39629381
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
А если как-то так?
...
Рейтинг: 0 / 0
12.04.2018, 17:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39629385
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
ДокА если как-то так?


Буквы на иконках мне кажутся излишками, если они не касаются строк ввода. :)
А "поток" на холсте 16х16 вообще сложно придумать оригинально...
...
Рейтинг: 0 / 0
12.04.2018, 17:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39629396
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

имхо, иконки должны быть ассоциативно-интуитивно понятными. Поэтому там часто используются практически одни и те же распространенные обозначения (благо, в Лазаре картинки фриварные и выложены в свободный доступ в LCCR в SVG-формате). Буковки здесь, скорее, играют роль графического "префикса".

Ладно, дойдут руки, потом поговорим :)
...
Рейтинг: 0 / 0
12.04.2018, 18:13
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39635054
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

глянь варианты
 




...
Рейтинг: 0 / 0
23.04.2018, 22:24
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39635074
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Док,
ближайшие пару недель далек от компа.
Как в лазаре, глаз за который цепляется? :-)
...
Рейтинг: 0 / 0
24.04.2018, 00:53
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39635144
_Док_
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
_Док_
Гость
wadmanКак в лазаре, глаз за который цепляется? :-)
Если в контексте общей цветовой палитры, то последний. Но по информативности мне больше первый нравится.

Кстати, под Лазарь требуемые размеры иконок 24, 36 и 48 px. Напомгни мне, если не трудно, размеры под дельфи
...
Рейтинг: 0 / 0
24.04.2018, 09:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39635238
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
_Док_wadmanКак в лазаре, глаз за который цепляется? :-)
Если в контексте общей цветовой палитры, то последний. Но по информативности мне больше первый нравится.

Кстати, под Лазарь требуемые размеры иконок 24, 36 и 48 px. Напомгни мне, если не трудно, размеры под дельфи
Последний раз рисовал 16х. В последних версиях может быть иначе с поддержкой hdpi.
...
Рейтинг: 0 / 0
24.04.2018, 11:50
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39635332
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

Тогда сделаю полный набор, добавлю еще 16 и 32.

Так всё-таки, какую делать?
...
Рейтинг: 0 / 0
24.04.2018, 13:25
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39635826
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Док,

пусть будет первый. :)
...
Рейтинг: 0 / 0
25.04.2018, 09:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39636225
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

 
глянь, все ли устраивает
- 16 х 16

- 24 х 24

- 32 х 32

- 36 х 36

- 48 х 48
...
Рейтинг: 0 / 0
25.04.2018, 16:56
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39636235
YuRock
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
YuRock
Участник
Дорожные знаки какие-то)
...
Рейтинг: 0 / 0
25.04.2018, 17:11
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39636302
Tactical Nuclear Penguin
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Tactical Nuclear Penguin
Участник
YuRockДорожные знаки какие-то)

скорее что-то падает
оптом :)
...
Рейтинг: 0 / 0
25.04.2018, 18:32
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39636305
Tactical Nuclear Penguin
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Tactical Nuclear Penguin
Участник
Докwadman,

 
глянь, все ли устраивает
- 16 х 16

- 24 х 24

- 32 х 32

- 36 х 36

- 48 х 48


художника может обидеть каждый (с)
разверни чтобы стрелки вверх были
имхо будет гораздо лучше
...
Рейтинг: 0 / 0
25.04.2018, 18:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39636307
YuRock
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
YuRock
Участник
Tactical Nuclear Penguinразверни чтобы стрелки вверх были
Лучше слева направо
...
Рейтинг: 0 / 0
25.04.2018, 18:45
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39636564
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
Tactical Nuclear Penguinразверни чтобы стрелки вверх были
знаешь, почему нельзя заниматься сексом прилюдно?

Считаешь, что дефолтовая
информативнее?
YuRockДорожные знаки какие-то)
на всех не угодишь :)

В мелких иконках вообще сложно отобразить какие-то детали, даже с 32 битами цвета, поэтому там всегда получается все очень условно. Можно, конечно, сделать по типу узнаваемого логотипа.

Подожду, что скажет начальник транспортного цеха :) В любом случае, это просто моя инициатива. Не понравится, забью на нее.
...
Рейтинг: 0 / 0
26.04.2018, 09:11
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39636580
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
Tactical Nuclear Penguinразверни чтобы стрелки вверх были
 
развернул...











YuRockЛучше слева направо
 
повернул...








 
и даже перевернул...








...
Рейтинг: 0 / 0
26.04.2018, 09:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39639175
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Доки даже перевернул...
Этот вариант мне более по душе. Спасибо. :)
...
Рейтинг: 0 / 0
03.05.2018, 08:57
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39639359
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadmanЭтот вариант мне более по душе.
архивчик приложил. Если надо, подкину векторные исходники
...
Рейтинг: 0 / 0
03.05.2018, 13:07
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39649403
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
ДокwadmanЭтот вариант мне более по душе.
архивчик приложил. Если надо, подкину векторные исходники

http://www.sql.ru/forum/actualfile.aspx?id=21384173] Приложенный файл (wthread.7z - 7Kb)
Влепил иконку. Спасибо, Док! :)
...
Рейтинг: 0 / 0
24.05.2018, 13:34
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39650205
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
wadman,

обращайся, если дизайн потребуется обновить. Я тут немного с Rxlib-скими иконками поднаторел. Теперь знаю, куда идти, если профессию потребуется сменить :)
...
Рейтинг: 0 / 0
26.05.2018, 00:35
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39650389
alekcvp
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
alekcvp
Участник
Док,

А что, есть свежий RxLib? А оно ещё актуально? В смысле половина вроде уже нативно встроена, не?
...
Рейтинг: 0 / 0
26.05.2018, 17:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39650728
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
alekcvpВ смысле половина вроде уже нативно встроена, не?
я имел ввиду форк Алексея Логунова под Лазарь
https://svn.code.sf.net/p/lazarus-ccr/svn/components/rx/trunk
...
Рейтинг: 0 / 0
27.05.2018, 19:28
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755799
Freestyler
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Freestyler
Гость
Добрый день!

подскажите как можно реализовать с помощью компонента такой порядок работы:

обработка выполняется в потоке с периодичностью (например 10 минут)
при этом пользователь может по кнопке принудительно запустить эту же обработку.

требуется ли внешний таймер?
...
Рейтинг: 0 / 0
04.01.2019, 10:23
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755814
Фотография X-Cite
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
X-Cite
Участник
FreestylerДобрый день!

подскажите как можно реализовать с помощью компонента такой порядок работы:

обработка выполняется в потоке с периодичностью (например 10 минут)
при этом пользователь может по кнопке принудительно запустить эту же обработку.

требуется ли внешний таймер?
Версия Delphi какая?
...
Рейтинг: 0 / 0
04.01.2019, 11:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755830
Freestyler
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Freestyler
Гость
X-Cite,

Delphi 7
...
Рейтинг: 0 / 0
04.01.2019, 12:42
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755836
Vlad F
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Vlad F
Участник
Freestyler,

Опиши задачу подробнее и, особенно, нужны ли тебе две одновременные параллельные описанные обработки. В противном случае достаточно (и проще, надежнее) будет одного только таймера.
...
Рейтинг: 0 / 0
04.01.2019, 13:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755860
Freestyler
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Freestyler
Гость
Vlad F,


Обработка по сути вызов хранимых процедур из БД.
параллельно две обработки не нужны:
в том случае если пользователь нажал кнопку когда уже выполняется обработка - нужно дождаться завершения обработки и по ее результатам или повторный запуск или обработка не требуется. следующий интервал запуска обработки наступит через 10 минут
...
Рейтинг: 0 / 0
04.01.2019, 14:48
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755865
Vlad F
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Vlad F
Участник
Freestyler,

Резюмирую, скрипач поток не нужен, по таймеру запускается упомянутый алгоритм, дизейблит пользовательскую кнопку, отрабатывает свое, енайблит кнопку, рестартует таймер до следующей итерации. При нажатии кнопки сходным образом дизейблиться/енайблиться таймер.
...
Рейтинг: 0 / 0
04.01.2019, 14:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755870
YuRock
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
YuRock
Участник
Freestyler,

вот без компонента:
 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
type
  TRunSPThread = class( TThread )
  private
    FWaitEvent: TSimpleEvent;
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;

    procedure WakeUp;
  end;

constructor TRunSPThread.Create;
begin
  inherited Create( False );
  FWaitEvent := TSimpleEvent.Create;
end;

destructor TRunSPThread.Destroy;
begin
  Terminate;
  FWaitEvent.SetEvent;
  inherited Destroy;
  FWaitEvent.Free;
end;

procedure TRunSPThread.Execute;
begin
  repeat
    FWaitEvent.ResetEvent;
    FWaitEvent.WaitFor( 10 * 60 * 1000 );
    if Terminated then
      Exit;

    // run SP
  until not Terminated;
end;

procedure TRunSPThread.WakeUp;
begin
  FWaitEvent.SetEvent;
end;


"если пользователь нажал кнопку" - то вызываем WakeUp.

Freestylerнужно дождаться завершения обработки и по ее результатам или повторный запуск или обработка не требуется
Это уже навороты, делай сам. Например, нужен дополнительный Event, которого ждать в начале WakeUp.
...
Рейтинг: 0 / 0
04.01.2019, 15:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755890
Freestyler
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Freestyler
Гость
Vlad F,

Спасибо.
в таком варианте будет блокировать работу приложения
...
Рейтинг: 0 / 0
04.01.2019, 16:31
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755891
Freestyler
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Freestyler
Гость
YuRock,

Спасибо за пример!
+- такой вариант работает сейчас. была мысль переложить доп. потоки на компонент.
...
Рейтинг: 0 / 0
04.01.2019, 16:33
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755900
Vlad F
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Vlad F
Участник
Freestylerв таком варианте будет блокировать работу приложения
А я тебя переспросил, и ты сказал что приложение все равно ждет окончания обработки.
...
Рейтинг: 0 / 0
04.01.2019, 16:54
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755901
Vlad F
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Vlad F
Участник
Freestyler+- такой вариант работает сейчас. была мысль переложить доп. потоки на компонент.
Больше компонентов, хороших и разных!!))
...
Рейтинг: 0 / 0
04.01.2019, 16:56
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39755926
Freestyler
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Freestyler
Гость
Vlad F,

безусловно автору спасибо за компонент!
хотелось попробовать применить в проекте.
задача думаю типовая для многих - периодически что-то делать (подтягивать) в фоне
при этом чтобы была возможность пользователю это сделать явно
...
Рейтинг: 0 / 0
04.01.2019, 18:43
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39756390
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
FreestylerДобрый день!

подскажите как можно реализовать с помощью компонента такой порядок работы:

обработка выполняется в потоке с периодичностью (например 10 минут)
при этом пользователь может по кнопке принудительно запустить эту же обработку.

требуется ли внешний таймер?
Можно. Достаточно метода Task WaitMS и проверки флага Terminated перед запуском задачи.
...
Рейтинг: 0 / 0
06.01.2019, 20:04
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39756398
Freestyler
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Freestyler
Гость
wadman,

то есть процедура вида

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
procedure Task_1_Execute;
begin
  repeat
    WaitMS 
    if Terminated then
      Exit;

    // run SP
  until not Terminated;
end;



как тогда лучше сделать принудительный запуск (по кнопке) ?
просто проверить если задача не завершена то не делать?
...
Рейтинг: 0 / 0
06.01.2019, 20:36
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39756953
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Freestyler,

подумав на трезвую голову я-бы все таки сделал с таймером, но который запускает задачу в потоке. Плюс кнопка, которая запускает задачу и сбрасывает таймер. Так проще.
...
Рейтинг: 0 / 0
09.01.2019, 08:18
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39771444
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
Отсюда

Докдемок в комплекте OPM нету что ли?
а, нет, вижу. Правда у меня только SimpleDemo запустилось без установки доп.компонент.

Кстати, если трижды нажать на DemoTimer, то получим отлуп

Код: pascal
1.
2.
3.
4.
5.
Project WCThreadDemo raised exception class 'Exception' with message:
TaskDemoTimer cannot start while destroying.

 In file 'wcthread.pas' at line 654:
raise Exception.CreateFmt('%s cannot start while destroying.', [Name]);



По-моему, я тебе про это уже говорил.
...
Рейтинг: 0 / 0
09.02.2019, 00:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39771446
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
Док Отсюда

Докдемок в комплекте OPM нету что ли?
а, нет, вижу. Правда у меня только SimpleDemo запустилось без установки доп.компонент.

Кстати, если трижды нажать на DemoTimer, то получим отлуп

Код: pascal
1.
2.
3.
4.
5.
Project WCThreadDemo raised exception class 'Exception' with message:
TaskDemoTimer cannot start while destroying.

 In file 'wcthread.pas' at line 654:
raise Exception.CreateFmt('%s cannot start while destroying.', [Name]);




По-моему, я тебе про это уже говорил.
Много кто говорил. Там системный слип для имитации тяжелой работы. Нужно заменить самой работой с проверкой терминатора задачи/потока.
...
Рейтинг: 0 / 0
09.02.2019, 00:41
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39845666
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
Поднял старый проект, который использовал wthread
странно он как-то работает.

Запустил simpledemo из комплекта wthread
И оказалось, что он задачи выполняет последовательно, а не параллельно.

Наверное, в чём-то есть замес ?
...
Рейтинг: 0 / 0
06.08.2019, 08:58
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39845670
Фотография wadman
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
wadman
Участник
defecatorИ оказалось, что он задачи выполняет последовательно, а не параллельно.
Один компонент = один поток. Задача = сообщение, сообщения обрабатываются в порядке очереди.
...
Рейтинг: 0 / 0
06.08.2019, 09:21
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39845675
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
wadmandefecatorИ оказалось, что он задачи выполняет последовательно, а не параллельно.
Один компонент = один поток. Задача = сообщение, сообщения обрабатываются в порядке очереди.

что-то я такое подозревал.
руки тому оторвать, кто писал прогу с одним компонентом
...
Рейтинг: 0 / 0
06.08.2019, 09:28
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39845699
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
defecatorруки тому оторвать, кто писал прогу с одним компонентом
"... от Питера до Москвы..." ©
...
Рейтинг: 0 / 0
06.08.2019, 10:06
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39845740
Фотография Док
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Док
Участник
defecator,

Мих, ты всегда был тру-программистом. WThread, имхо, достаточно унифицированный компонент для быстрого решения шаблонной задачи. Зачем тебе он? :)
...
Рейтинг: 0 / 0
06.08.2019, 10:55
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39845749
Фотография Дегтярев Евгений
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Дегтярев Евгений
Участник
Докdefecator,

Мих, ты всегда был тру-программистом. WThread, имхо, достаточно унифицированный компонент для быстрого решения шаблонной задачи. Зачем тебе он? :)

авторПоднял старый проект , который использовал wthread

видимо так было не всегда )
...
Рейтинг: 0 / 0
06.08.2019, 11:03
| Ответить | Цитировать | Написать  
Шаблон класса для работы с потоком (WThread, Thread)
    #39845776
Фотография defecator
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
defecatorПривилегированный пользователь
Модератор форума
Докdefecator,

Мих, ты всегда был тру-программистом. WThread, имхо, достаточно унифицированный компонент для быстрого решения шаблонной задачи. Зачем тебе он? :)

попросили проект поглядеть, который не работает так, как надо
А там я обнаружил, что используется wthread

полез изучать демки, чтобы понять, что не так.
...
Рейтинг: 0 / 0
06.08.2019, 11:47
| Ответить | Цитировать | Написать  
469 сообщений из 469, показаны все 19 страниц
  все  
Форумы / Delphi [игнор отключен] [закрыт для гостей] / Шаблон класса для работы с потоком (WThread, Thread)
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение   Полит. конфиден.  
NoSQL.ru       Кролег: Проекты, Новости, Чат       РЕД ФОРУМ       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?all=1&fid=58&tid=2039179]:
 0ms
get settings:
 9ms
get forum list:
 16ms
check forum access:
 2ms
check topic access:
 2ms
track hit:
 150ms
get topic data:
 9ms
get forum data:
 2ms
get page messages:
 273ms
get tp. blocked users:
 1ms
others: 269ms
total:  733ms
созд. / загр.: 733ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]