mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 12:29:27 +01:00
added multithreading examples
git-svn-id: trunk@9575 -
This commit is contained in:
mattias
parent
41947d6c28
commit
f10441b47f
15
.gitattributes
vendored
15
.gitattributes
vendored
@ -994,11 +994,26 @@ examples/memotest.lpi svneol=native#text/plain
|
||||
examples/memotest.pp svneol=native#text/pascal
|
||||
examples/messagedialogs.lpi svneol=native#text/plain
|
||||
examples/messagedialogs.pp svneol=native#text/pascal
|
||||
examples/multithreading/criticalsectionexample1.lpi svneol=native#text/plain
|
||||
examples/multithreading/criticalsectionexample1.lpr svneol=native#text/plain
|
||||
examples/multithreading/criticalsectionunit1.lfm svneol=native#text/plain
|
||||
examples/multithreading/criticalsectionunit1.lrs svneol=native#text/plain
|
||||
examples/multithreading/criticalsectionunit1.pas svneol=native#text/plain
|
||||
examples/multithreading/mainunit.lfm svneol=native#text/plain
|
||||
examples/multithreading/mainunit.lrs svneol=native#text/plain
|
||||
examples/multithreading/mainunit.pas svneol=native#text/plain
|
||||
examples/multithreading/multithreadingexample1.lpi svneol=native#text/plain
|
||||
examples/multithreading/multithreadingexample1.lpr svneol=native#text/plain
|
||||
examples/multithreading/processmessagesunit1.lfm svneol=native#text/plain
|
||||
examples/multithreading/processmessagesunit1.lrs svneol=native#text/plain
|
||||
examples/multithreading/processmessagesunit1.pas svneol=native#text/plain
|
||||
examples/multithreading/singlethreadingexample1.lpi svneol=native#text/plain
|
||||
examples/multithreading/singlethreadingexample1.lpr svneol=native#text/plain
|
||||
examples/multithreading/waitforexample1.lpi svneol=native#text/plain
|
||||
examples/multithreading/waitforexample1.lpr svneol=native#text/plain
|
||||
examples/multithreading/waitforunit1.lfm svneol=native#text/plain
|
||||
examples/multithreading/waitforunit1.lrs svneol=native#text/plain
|
||||
examples/multithreading/waitforunit1.pas svneol=native#text/plain
|
||||
examples/notebk.lpi svneol=native#text/plain
|
||||
examples/notebk.pp svneol=native#text/pascal
|
||||
examples/notebku.pp svneol=native#text/pascal
|
||||
|
||||
62
examples/multithreading/criticalsectionexample1.lpi
Normal file
62
examples/multithreading/criticalsectionexample1.lpi
Normal file
@ -0,0 +1,62 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<PathDelim Value="/"/>
|
||||
<Version Value="5"/>
|
||||
<General>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<TargetFileExt Value=""/>
|
||||
</General>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="criticalsectionexample1.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="CriticalSectionExample1"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="criticalsectionunit1.pas"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ResourceFilename Value="criticalsectionunit1.lrs"/>
|
||||
<UnitName Value="CriticalSectionUnit1"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="5"/>
|
||||
<SearchPaths>
|
||||
<SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/"/>
|
||||
</SearchPaths>
|
||||
<CodeGeneration>
|
||||
<Generate Value="Faster"/>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
</CONFIG>
|
||||
18
examples/multithreading/criticalsectionexample1.lpr
Normal file
18
examples/multithreading/criticalsectionexample1.lpr
Normal file
@ -0,0 +1,18 @@
|
||||
program CriticalSectionExample1;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}
|
||||
cthreads,
|
||||
{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms
|
||||
{ add your units here }, CriticalSectionUnit1;
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
43
examples/multithreading/criticalsectionunit1.lfm
Normal file
43
examples/multithreading/criticalsectionunit1.lfm
Normal file
@ -0,0 +1,43 @@
|
||||
object Form1: TForm1
|
||||
Caption = 'Form1'
|
||||
ClientHeight = 169
|
||||
ClientWidth = 312
|
||||
PixelsPerInch = 75
|
||||
HorzScrollBar.Page = 311
|
||||
VertScrollBar.Page = 168
|
||||
Left = 286
|
||||
Height = 169
|
||||
Top = 202
|
||||
Width = 312
|
||||
object Label1: TLabel
|
||||
Caption = 'Label1'
|
||||
Color = clNone
|
||||
ParentColor = False
|
||||
Left = 43
|
||||
Height = 17
|
||||
Top = 125
|
||||
Width = 65
|
||||
end
|
||||
object CountWithCritSecButton: TButton
|
||||
AutoSize = True
|
||||
BorderSpacing.InnerBorder = 4
|
||||
Caption = 'Count with critical section'
|
||||
OnClick = CountWithCritSecButtonClick
|
||||
TabOrder = 0
|
||||
Left = 40
|
||||
Height = 26
|
||||
Top = 24
|
||||
Width = 158
|
||||
end
|
||||
object CountWithoutCritSecButton: TButton
|
||||
AutoSize = True
|
||||
BorderSpacing.InnerBorder = 4
|
||||
Caption = 'Count without critical section'
|
||||
OnClick = CountWithoutCritSecButtonClick
|
||||
TabOrder = 1
|
||||
Left = 40
|
||||
Height = 26
|
||||
Top = 64
|
||||
Width = 175
|
||||
end
|
||||
end
|
||||
16
examples/multithreading/criticalsectionunit1.lrs
Normal file
16
examples/multithreading/criticalsectionunit1.lrs
Normal file
@ -0,0 +1,16 @@
|
||||
{ Dies ist eine automatisch erzeugte Lazarus-Ressourcendatei }
|
||||
|
||||
LazarusResources.Add('TForm1','FORMDATA',[
|
||||
'TPF0'#6'TForm1'#5'Form1'#7'Caption'#6#5'Form1'#12'ClientHeight'#3#169#0#11'C'
|
||||
+'lientWidth'#3'8'#1#13'PixelsPerInch'#2'K'#18'HorzScrollBar.Page'#3'7'#1#18
|
||||
+'VertScrollBar.Page'#3#168#0#4'Left'#3#30#1#6'Height'#3#169#0#3'Top'#3#202#0
|
||||
+#5'Width'#3'8'#1#0#6'TLabel'#6'Label1'#7'Caption'#6#6'Label1'#5'Color'#7#6'c'
|
||||
+'lNone'#11'ParentColor'#8#4'Left'#2'+'#6'Height'#2#17#3'Top'#2'}'#5'Width'#2
|
||||
+'A'#0#0#7'TButton'#22'CountWithCritSecButton'#8'AutoSize'#9#25'BorderSpacing'
|
||||
+'.InnerBorder'#2#4#7'Caption'#6#27'Count with critical section'#7'OnClick'#7
|
||||
+#27'CountWithCritSecButtonClick'#8'TabOrder'#2#0#4'Left'#2'('#6'Height'#2#26
|
||||
+#3'Top'#2#24#5'Width'#3#158#0#0#0#7'TButton'#25'CountWithoutCritSecButton'#8
|
||||
+'AutoSize'#9#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#30'Count without'
|
||||
+' critical section'#7'OnClick'#7#30'CountWithoutCritSecButtonClick'#8'TabOrd'
|
||||
+'er'#2#1#4'Left'#2'('#6'Height'#2#26#3'Top'#2'@'#5'Width'#3#175#0#0#0#0
|
||||
]);
|
||||
147
examples/multithreading/criticalsectionunit1.pas
Normal file
147
examples/multithreading/criticalsectionunit1.pas
Normal file
@ -0,0 +1,147 @@
|
||||
{
|
||||
***************************************************************************
|
||||
* *
|
||||
* This source is free software; you can redistribute it and/or modify *
|
||||
* it under the terms of the GNU General Public License as published by *
|
||||
* the Free Software Foundation; either version 2 of the License, or *
|
||||
* (at your option) any later version. *
|
||||
* *
|
||||
* This code is distributed in the hope that it will be useful, but *
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
||||
* General Public License for more details. *
|
||||
* *
|
||||
* A copy of the GNU General Public License is available on the World *
|
||||
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
||||
* obtain it by writing to the Free Software Foundation, *
|
||||
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
||||
* *
|
||||
***************************************************************************
|
||||
|
||||
Abstract:
|
||||
Demo to show how 5 threads increases a counter.
|
||||
With and without critical sections.
|
||||
|
||||
With critical sections you will always get 50000.
|
||||
Without you will see different results on each run and depending on your
|
||||
system.
|
||||
}
|
||||
unit CriticalSectionUnit1;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
|
||||
StdCtrls, LCLProc, LCLType, LCLIntf;
|
||||
|
||||
type
|
||||
|
||||
{ TMyThread }
|
||||
|
||||
TMyThread = class(TThread)
|
||||
public
|
||||
procedure Execute; override;
|
||||
property Finished: boolean read FFinished write FFinished;
|
||||
end;
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
TForm1 = class(TForm)
|
||||
CountWithoutCritSecButton: TButton;
|
||||
CountWithCritSecButton: TButton;
|
||||
Label1: TLabel;
|
||||
procedure CountWithCritSecButtonClick(Sender: TObject);
|
||||
procedure CountWithoutCritSecButtonClick(Sender: TObject);
|
||||
private
|
||||
public
|
||||
CriticalSection: TCriticalSection;
|
||||
Counter: integer;
|
||||
UseCriticalSection: boolean;
|
||||
procedure DoCounting;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.CountWithCritSecButtonClick(Sender: TObject);
|
||||
begin
|
||||
UseCriticalSection:=true;
|
||||
DoCounting;
|
||||
end;
|
||||
|
||||
procedure TForm1.CountWithoutCritSecButtonClick(Sender: TObject);
|
||||
begin
|
||||
UseCriticalSection:=false;
|
||||
DoCounting;
|
||||
end;
|
||||
|
||||
procedure TForm1.DoCounting;
|
||||
var
|
||||
i: Integer;
|
||||
Threads: array[1..5] of TMyThread;
|
||||
AllFinished: Boolean;
|
||||
begin
|
||||
Counter:=0;
|
||||
|
||||
// create the CriticalSection
|
||||
InitializeCriticalSection(CriticalSection);
|
||||
|
||||
// start 5 threads
|
||||
for i:=Low(Threads) to High(Threads) do
|
||||
Threads[i]:=TMyThread.Create(false);
|
||||
// wait till all threads finished
|
||||
repeat
|
||||
AllFinished:=true;
|
||||
for i:=Low(Threads) to High(Threads) do
|
||||
if not Threads[i].Finished then AllFinished:=false;
|
||||
until AllFinished;
|
||||
// free the threads
|
||||
for i:=Low(Threads) to High(Threads) do
|
||||
Threads[i].Free;
|
||||
|
||||
// free the CriticalSection
|
||||
DeleteCriticalSection(CriticalSection);
|
||||
|
||||
// show the Counter
|
||||
Label1.Caption:='Counter='+IntToStr(Counter);
|
||||
end;
|
||||
|
||||
{ TMyThread }
|
||||
|
||||
procedure TMyThread.Execute;
|
||||
var
|
||||
i: Integer;
|
||||
CurCounter: LongInt;
|
||||
j: Integer;
|
||||
begin
|
||||
// increment the counter many times
|
||||
// Because the other threads are doing the same, it will frequently happen,
|
||||
// that 2 (or more) threads read the same number, increment it by one and
|
||||
// write the result back, overwriting the result of the other threads.
|
||||
for i:=1 to 100000 do begin
|
||||
if Form1.UseCriticalSection then
|
||||
EnterCriticalSection(Form1.CriticalSection);
|
||||
try
|
||||
CurCounter:=Form1.Counter;
|
||||
for j:=1 to 1000 do ;
|
||||
inc(CurCounter);
|
||||
Form1.Counter:=CurCounter;
|
||||
finally
|
||||
if Form1.UseCriticalSection then
|
||||
LeaveCriticalSection(Form1.CriticalSection);
|
||||
end;
|
||||
end;
|
||||
Finished:=true;
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I criticalsectionunit1.lrs}
|
||||
|
||||
end.
|
||||
|
||||
@ -17,6 +17,12 @@
|
||||
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
||||
* *
|
||||
***************************************************************************
|
||||
|
||||
Abstract:
|
||||
Demo to show, how to start a thread and how synchronize with the main
|
||||
thread.
|
||||
Important: The cthread unint must be added to the uses section of the .lpr
|
||||
file. See multithreadingexample1.lpr.
|
||||
}
|
||||
unit MainUnit;
|
||||
|
||||
@ -60,18 +66,21 @@ procedure TForm1.FormCreate(Sender: TObject);
|
||||
var
|
||||
MyThread : TMyThread;
|
||||
begin
|
||||
MyThread := TMyThread.Create(True); // This way it doesn't start automatically
|
||||
if Assigned(MyThread.FatalException) then
|
||||
raise MyThread.FatalException;
|
||||
MyThread := TMyThread.Create(True); // With the True parameter it doesn't start automatically
|
||||
if Assigned(MyThread.FatalException) then
|
||||
raise MyThread.FatalException;
|
||||
|
||||
// Here the code initialises anything required before the threads starts executing
|
||||
// Here the code initialises anything required before the threads starts executing
|
||||
|
||||
MyThread.Resume;
|
||||
MyThread.Resume;
|
||||
end;
|
||||
|
||||
{ TMyThread }
|
||||
|
||||
procedure TMyThread.ShowStatus;
|
||||
// this method is only called by Synchronize(@ShowStatus) and therefore
|
||||
// executed by the main thread
|
||||
// The main thread can access GUI elements, for example Form1.Caption.
|
||||
begin
|
||||
Form1.Caption := fStatusText;
|
||||
end;
|
||||
@ -80,13 +89,13 @@ procedure TMyThread.Execute;
|
||||
var
|
||||
newStatus : string;
|
||||
begin
|
||||
fStatusText := 'Starting...';
|
||||
fStatusText := 'TMyThread Starting...';
|
||||
Synchronize(@Showstatus);
|
||||
fStatusText := 'Running...';
|
||||
fStatusText := 'TMyThread Running...';
|
||||
while (not Terminated) and (true {any condition required}) do begin
|
||||
|
||||
//here goes the code of the main thread loop
|
||||
newStatus:='Time: '+FormatDateTime('YYYY-MM-DD HH:NN:SS',Now);
|
||||
newStatus:='TMyThread Time: '+FormatDateTime('YYYY-MM-DD HH:NN:SS',Now);
|
||||
|
||||
if NewStatus <> fStatusText then begin
|
||||
fStatusText := newStatus;
|
||||
|
||||
@ -6,12 +6,11 @@
|
||||
<General>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<IconPath Value="./"/>
|
||||
<TargetFileExt Value=""/>
|
||||
</General>
|
||||
<LazDoc Paths=""/>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
|
||||
@ -3,12 +3,13 @@ program MultiThreadingExample1;
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
// for multi threading the cthreads unit must be used on unix systems:
|
||||
// for example: Linux, MacOSX, FreeBSD, Solaris
|
||||
{$IFDEF UNIX}
|
||||
cthreads,
|
||||
{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms
|
||||
{ add your units here }, MainUnit;
|
||||
Forms, MainUnit;
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
|
||||
34
examples/multithreading/processmessagesunit1.lfm
Normal file
34
examples/multithreading/processmessagesunit1.lfm
Normal file
@ -0,0 +1,34 @@
|
||||
object Form1: TForm1
|
||||
Caption = 'Form1'
|
||||
ClientHeight = 142
|
||||
ClientWidth = 303
|
||||
OnCreate = FormCreate
|
||||
PixelsPerInch = 75
|
||||
HorzScrollBar.Page = 302
|
||||
VertScrollBar.Page = 141
|
||||
Left = 286
|
||||
Height = 142
|
||||
Top = 202
|
||||
Width = 303
|
||||
object StartStopButton: TButton
|
||||
Anchors = [akTop]
|
||||
BorderSpacing.InnerBorder = 4
|
||||
Caption = 'Start'
|
||||
OnClick = StartStopButtonClick
|
||||
TabOrder = 0
|
||||
Left = 72
|
||||
Height = 25
|
||||
Top = 40
|
||||
Width = 158
|
||||
end
|
||||
object ProgressBar1: TProgressBar
|
||||
Anchors = [akTop, akLeft, akRight]
|
||||
Max = 1000
|
||||
Smooth = True
|
||||
Step = 1
|
||||
Left = 32
|
||||
Height = 20
|
||||
Top = 88
|
||||
Width = 244
|
||||
end
|
||||
end
|
||||
14
examples/multithreading/processmessagesunit1.lrs
Normal file
14
examples/multithreading/processmessagesunit1.lrs
Normal file
@ -0,0 +1,14 @@
|
||||
{ Dies ist eine automatisch erzeugte Lazarus-Ressourcendatei }
|
||||
|
||||
LazarusResources.Add('TForm1','FORMDATA',[
|
||||
'TPF0'#6'TForm1'#5'Form1'#7'Caption'#6#5'Form1'#12'ClientHeight'#3#142#0#11'C'
|
||||
+'lientWidth'#3'/'#1#8'OnCreate'#7#10'FormCreate'#13'PixelsPerInch'#2'K'#18'H'
|
||||
+'orzScrollBar.Page'#3'.'#1#18'VertScrollBar.Page'#3#141#0#4'Left'#3#30#1#6'H'
|
||||
+'eight'#3#142#0#3'Top'#3#202#0#5'Width'#3'/'#1#0#7'TButton'#15'StartStopButt'
|
||||
+'on'#7'Anchors'#11#5'akTop'#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6
|
||||
+#5'Start'#7'OnClick'#7#20'StartStopButtonClick'#8'TabOrder'#2#0#4'Left'#2'H'
|
||||
+#6'Height'#2#25#3'Top'#2'('#5'Width'#3#158#0#0#0#12'TProgressBar'#12'Progres'
|
||||
+'sBar1'#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#3'Max'#3#232#3#6'Smoot'
|
||||
+'h'#9#4'Step'#2#1#4'Left'#2' '#6'Height'#2#20#3'Top'#2'X'#5'Width'#3#244#0#0
|
||||
+#0#0
|
||||
]);
|
||||
138
examples/multithreading/processmessagesunit1.pas
Normal file
138
examples/multithreading/processmessagesunit1.pas
Normal file
@ -0,0 +1,138 @@
|
||||
{
|
||||
***************************************************************************
|
||||
* *
|
||||
* This source is free software; you can redistribute it and/or modify *
|
||||
* it under the terms of the GNU General Public License as published by *
|
||||
* the Free Software Foundation; either version 2 of the License, or *
|
||||
* (at your option) any later version. *
|
||||
* *
|
||||
* This code is distributed in the hope that it will be useful, but *
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
||||
* General Public License for more details. *
|
||||
* *
|
||||
* A copy of the GNU General Public License is available on the World *
|
||||
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
||||
* obtain it by writing to the Free Software Foundation, *
|
||||
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
||||
* *
|
||||
***************************************************************************
|
||||
|
||||
Abstract:
|
||||
Demo to show, how to process a big file with the main thread.
|
||||
}
|
||||
unit ProcessMessagesUnit1;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
|
||||
ComCtrls;
|
||||
|
||||
type
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
TForm1 = class(TForm)
|
||||
ProgressBar1: TProgressBar;
|
||||
StartStopButton: TButton;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure StartStopButtonClick(Sender: TObject);
|
||||
private
|
||||
procedure Run;
|
||||
procedure UpdateButton;
|
||||
public
|
||||
Running: boolean;
|
||||
Aborting: boolean;
|
||||
Filename: String;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
Filename:='processmessagesunit1.pas';
|
||||
end;
|
||||
|
||||
procedure TForm1.StartStopButtonClick(Sender: TObject);
|
||||
begin
|
||||
if not Running then
|
||||
Run
|
||||
else
|
||||
Aborting:=true;
|
||||
end;
|
||||
|
||||
procedure TForm1.Run;
|
||||
var
|
||||
fs: TFileStream;
|
||||
Buffer: string;
|
||||
Count: LongInt;
|
||||
i: Integer;
|
||||
Last: TDateTime;
|
||||
begin
|
||||
if Running then exit;
|
||||
Running:=true;
|
||||
UpdateButton;
|
||||
try
|
||||
// open a file
|
||||
fs:=TFileStream.Create(Filename,fmOpenRead);
|
||||
try
|
||||
SetLength(Buffer,10);
|
||||
while true do begin
|
||||
|
||||
// process all user events, like clicking on the button
|
||||
Application.ProcessMessages;
|
||||
if Aborting or Application.Terminated then break;
|
||||
|
||||
// read some bytes
|
||||
Count:=fs.Read(Buffer[1],length(Buffer));
|
||||
if Count=0 then break;
|
||||
|
||||
// process ...
|
||||
for i:=1 to Count do begin
|
||||
Last:=Now;
|
||||
repeat
|
||||
until Now-Last>(double(1)/fs.Size)/10000;
|
||||
end;
|
||||
|
||||
// show progress
|
||||
ProgressBar1.Position:=ProgressBar1.Min
|
||||
+((ProgressBar1.Max-ProgressBar1.Min+1)*fs.Position) div fs.Size;
|
||||
end;
|
||||
finally
|
||||
fs.Free;
|
||||
end;
|
||||
except
|
||||
on E: Exception do begin
|
||||
MessageDlg('Error',E.Message,mtError,[mbCancel],0);
|
||||
end;
|
||||
end;
|
||||
Aborting:=false;
|
||||
Running:=false;
|
||||
UpdateButton;
|
||||
end;
|
||||
|
||||
procedure TForm1.UpdateButton;
|
||||
begin
|
||||
if Running then begin
|
||||
if Aborting then
|
||||
StartStopButton.Caption:='Aborting ...'
|
||||
else
|
||||
StartStopButton.Caption:='Running ...';
|
||||
end else begin
|
||||
StartStopButton.Caption:='Start';
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I processmessagesunit1.lrs}
|
||||
|
||||
end.
|
||||
|
||||
63
examples/multithreading/singlethreadingexample1.lpi
Normal file
63
examples/multithreading/singlethreadingexample1.lpi
Normal file
@ -0,0 +1,63 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<PathDelim Value="/"/>
|
||||
<Version Value="5"/>
|
||||
<General>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<IconPath Value="./"/>
|
||||
<TargetFileExt Value=""/>
|
||||
</General>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="singlethreadingexample1.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="SingleThreadingExample1"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="processmessagesunit1.pas"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ResourceFilename Value="processmessagesunit1.lrs"/>
|
||||
<UnitName Value="ProcessMessagesUnit1"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="5"/>
|
||||
<SearchPaths>
|
||||
<SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/"/>
|
||||
</SearchPaths>
|
||||
<CodeGeneration>
|
||||
<Generate Value="Faster"/>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
</CONFIG>
|
||||
18
examples/multithreading/singlethreadingexample1.lpr
Normal file
18
examples/multithreading/singlethreadingexample1.lpr
Normal file
@ -0,0 +1,18 @@
|
||||
program SingleThreadingExample1;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms
|
||||
{ add your units here }, ProcessMessagesUnit1;
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
244
examples/multithreading/waitforexample1.lpi
Normal file
244
examples/multithreading/waitforexample1.lpi
Normal file
@ -0,0 +1,244 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<PathDelim Value="/"/>
|
||||
<Version Value="5"/>
|
||||
<General>
|
||||
<MainUnit Value="0"/>
|
||||
<TargetFileExt Value=""/>
|
||||
<ActiveEditorIndexAtStart Value="0"/>
|
||||
</General>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IgnoreBinaries Value="False"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item1>
|
||||
</RequiredPackages>
|
||||
<Units Count="8">
|
||||
<Unit0>
|
||||
<Filename Value="waitforexample1.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="WaitForExample1"/>
|
||||
<CursorPos X="8" Y="14"/>
|
||||
<TopLine Value="1"/>
|
||||
<EditorIndex Value="1"/>
|
||||
<UsageCount Value="20"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ResourceFilename Value="waitforunit1.lrs"/>
|
||||
<UnitName Value="WaitForUnit1"/>
|
||||
<CursorPos X="20" Y="32"/>
|
||||
<TopLine Value="1"/>
|
||||
<EditorIndex Value="0"/>
|
||||
<UsageCount Value="20"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit1>
|
||||
<Unit2>
|
||||
<Filename Value="mainunit.pas"/>
|
||||
<UnitName Value="MainUnit"/>
|
||||
<CursorPos X="1" Y="27"/>
|
||||
<TopLine Value="1"/>
|
||||
<EditorIndex Value="7"/>
|
||||
<UsageCount Value="10"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit2>
|
||||
<Unit3>
|
||||
<Filename Value="../../../freepascal/fpc/fcl/inc/custapp.pp"/>
|
||||
<UnitName Value="CustApp"/>
|
||||
<CursorPos X="14" Y="69"/>
|
||||
<TopLine Value="47"/>
|
||||
<EditorIndex Value="6"/>
|
||||
<UsageCount Value="10"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit3>
|
||||
<Unit4>
|
||||
<Filename Value="../../../freepascal/fpc/rtl/objpas/classes/classesh.inc"/>
|
||||
<CursorPos X="18" Y="1220"/>
|
||||
<TopLine Value="1196"/>
|
||||
<EditorIndex Value="3"/>
|
||||
<UsageCount Value="10"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit4>
|
||||
<Unit5>
|
||||
<Filename Value="../../../freepascal/fpc/rtl/objpas/classes/classes.inc"/>
|
||||
<CursorPos X="1" Y="103"/>
|
||||
<TopLine Value="75"/>
|
||||
<EditorIndex Value="5"/>
|
||||
<UsageCount Value="10"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit5>
|
||||
<Unit6>
|
||||
<Filename Value="../../../freepascal/fpc/rtl/inc/threadh.inc"/>
|
||||
<CursorPos X="59" Y="136"/>
|
||||
<TopLine Value="110"/>
|
||||
<EditorIndex Value="2"/>
|
||||
<UsageCount Value="10"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit6>
|
||||
<Unit7>
|
||||
<Filename Value="../../../freepascal/fpc/rtl/linux/tthread.inc"/>
|
||||
<CursorPos X="3" Y="292"/>
|
||||
<TopLine Value="290"/>
|
||||
<EditorIndex Value="4"/>
|
||||
<UsageCount Value="10"/>
|
||||
<Loaded Value="True"/>
|
||||
</Unit7>
|
||||
</Units>
|
||||
<JumpHistory Count="30" HistoryIndex="29">
|
||||
<Position1>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="158" Column="1" TopLine="122"/>
|
||||
</Position1>
|
||||
<Position2>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="112" Column="11" TopLine="90"/>
|
||||
</Position2>
|
||||
<Position3>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="102" Column="1" TopLine="90"/>
|
||||
</Position3>
|
||||
<Position4>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="145" Column="1" TopLine="109"/>
|
||||
</Position4>
|
||||
<Position5>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="45" Column="1" TopLine="45"/>
|
||||
</Position5>
|
||||
<Position6>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="145" Column="19" TopLine="109"/>
|
||||
</Position6>
|
||||
<Position7>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="72" Column="1" TopLine="50"/>
|
||||
</Position7>
|
||||
<Position8>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="144" Column="22" TopLine="108"/>
|
||||
</Position8>
|
||||
<Position9>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="110" Column="5" TopLine="56"/>
|
||||
</Position9>
|
||||
<Position10>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="105" Column="15" TopLine="102"/>
|
||||
</Position10>
|
||||
<Position11>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="76" Column="1" TopLine="54"/>
|
||||
</Position11>
|
||||
<Position12>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="114" Column="8" TopLine="96"/>
|
||||
</Position12>
|
||||
<Position13>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="115" Column="5" TopLine="93"/>
|
||||
</Position13>
|
||||
<Position14>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="53" Column="25" TopLine="26"/>
|
||||
</Position14>
|
||||
<Position15>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="45" Column="25" TopLine="23"/>
|
||||
</Position15>
|
||||
<Position16>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="118" Column="62" TopLine="96"/>
|
||||
</Position16>
|
||||
<Position17>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="133" Column="7" TopLine="111"/>
|
||||
</Position17>
|
||||
<Position18>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="40" Column="36" TopLine="18"/>
|
||||
</Position18>
|
||||
<Position19>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="66" Column="15" TopLine="35"/>
|
||||
</Position19>
|
||||
<Position20>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="133" Column="1" TopLine="101"/>
|
||||
</Position20>
|
||||
<Position21>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="21" Column="1" TopLine="1"/>
|
||||
</Position21>
|
||||
<Position22>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="149" Column="11" TopLine="116"/>
|
||||
</Position22>
|
||||
<Position23>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="71" Column="12" TopLine="49"/>
|
||||
</Position23>
|
||||
<Position24>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="103" Column="38" TopLine="81"/>
|
||||
</Position24>
|
||||
<Position25>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="102" Column="1" TopLine="81"/>
|
||||
</Position25>
|
||||
<Position26>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="148" Column="11" TopLine="115"/>
|
||||
</Position26>
|
||||
<Position27>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="129" Column="5" TopLine="114"/>
|
||||
</Position27>
|
||||
<Position28>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="150" Column="1" TopLine="114"/>
|
||||
</Position28>
|
||||
<Position29>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="147" Column="1" TopLine="116"/>
|
||||
</Position29>
|
||||
<Position30>
|
||||
<Filename Value="waitforunit1.pas"/>
|
||||
<Caret Line="152" Column="3" TopLine="118"/>
|
||||
</Position30>
|
||||
</JumpHistory>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="5"/>
|
||||
<SearchPaths>
|
||||
<SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/"/>
|
||||
</SearchPaths>
|
||||
<CodeGeneration>
|
||||
<Generate Value="Faster"/>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
</CONFIG>
|
||||
18
examples/multithreading/waitforexample1.lpr
Normal file
18
examples/multithreading/waitforexample1.lpr
Normal file
@ -0,0 +1,18 @@
|
||||
program WaitForExample1;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}
|
||||
cthreads,
|
||||
{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms
|
||||
{ add your units here }, WaitForUnit1;
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
32
examples/multithreading/waitforunit1.lfm
Normal file
32
examples/multithreading/waitforunit1.lfm
Normal file
@ -0,0 +1,32 @@
|
||||
object Form1: TForm1
|
||||
ActiveControl = Button1
|
||||
Caption = 'Form1'
|
||||
ClientHeight = 359
|
||||
ClientWidth = 394
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
PixelsPerInch = 75
|
||||
HorzScrollBar.Page = 393
|
||||
VertScrollBar.Page = 358
|
||||
Left = 286
|
||||
Height = 359
|
||||
Top = 202
|
||||
Width = 394
|
||||
object Button1: TButton
|
||||
BorderSpacing.InnerBorder = 4
|
||||
Caption = 'Start'
|
||||
OnClick = Button1Click
|
||||
TabOrder = 0
|
||||
Left = 32
|
||||
Height = 25
|
||||
Top = 16
|
||||
Width = 75
|
||||
end
|
||||
object Memo1: TMemo
|
||||
Align = alBottom
|
||||
TabOrder = 1
|
||||
Height = 303
|
||||
Top = 56
|
||||
Width = 394
|
||||
end
|
||||
end
|
||||
13
examples/multithreading/waitforunit1.lrs
Normal file
13
examples/multithreading/waitforunit1.lrs
Normal file
@ -0,0 +1,13 @@
|
||||
{ Dies ist eine automatisch erzeugte Lazarus-Ressourcendatei }
|
||||
|
||||
LazarusResources.Add('TForm1','FORMDATA',[
|
||||
'TPF0'#6'TForm1'#5'Form1'#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'
|
||||
+#12'ClientHeight'#3'g'#1#11'ClientWidth'#3#138#1#8'OnCreate'#7#10'FormCreate'
|
||||
+#9'OnDestroy'#7#11'FormDestroy'#13'PixelsPerInch'#2'K'#18'HorzScrollBar.Page'
|
||||
+#3#137#1#18'VertScrollBar.Page'#3'f'#1#4'Left'#3#30#1#6'Height'#3'g'#1#3'Top'
|
||||
+#3#202#0#5'Width'#3#138#1#0#7'TButton'#7'Button1'#25'BorderSpacing.InnerBord'
|
||||
+'er'#2#4#7'Caption'#6#5'Start'#7'OnClick'#7#12'Button1Click'#8'TabOrder'#2#0
|
||||
+#4'Left'#2' '#6'Height'#2#25#3'Top'#2#16#5'Width'#2'K'#0#0#5'TMemo'#5'Memo1'
|
||||
+#5'Align'#7#8'alBottom'#8'TabOrder'#2#1#6'Height'#3'/'#1#3'Top'#2'8'#5'Width'
|
||||
+#3#138#1#0#0#0
|
||||
]);
|
||||
162
examples/multithreading/waitforunit1.pas
Normal file
162
examples/multithreading/waitforunit1.pas
Normal file
@ -0,0 +1,162 @@
|
||||
{
|
||||
***************************************************************************
|
||||
* *
|
||||
* This source is free software; you can redistribute it and/or modify *
|
||||
* it under the terms of the GNU General Public License as published by *
|
||||
* the Free Software Foundation; either version 2 of the License, or *
|
||||
* (at your option) any later version. *
|
||||
* *
|
||||
* This code is distributed in the hope that it will be useful, but *
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
||||
* General Public License for more details. *
|
||||
* *
|
||||
* A copy of the GNU General Public License is available on the World *
|
||||
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
||||
* obtain it by writing to the Free Software Foundation, *
|
||||
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
||||
* *
|
||||
***************************************************************************
|
||||
|
||||
Abstract:
|
||||
Demo to show, how a Thread waits for another.
|
||||
}
|
||||
unit WaitForUnit1;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
|
||||
StdCtrls, LCLProc;
|
||||
|
||||
type
|
||||
|
||||
{ TBaseThread }
|
||||
|
||||
TBaseThread = class(TThread)
|
||||
public
|
||||
procedure Log(const Msg: string; AppendLineEnd: boolean = true);
|
||||
end;
|
||||
|
||||
{ TThreadA }
|
||||
|
||||
TThreadA = class(TBaseThread)
|
||||
public
|
||||
WaitForB: PRtlEvent;
|
||||
procedure Execute; override;
|
||||
end;
|
||||
|
||||
{ TThreadB }
|
||||
|
||||
TThreadB = class(TBaseThread)
|
||||
private
|
||||
FCounter: integer;
|
||||
public
|
||||
procedure Execute; override;
|
||||
property Counter: integer read FCounter write FCounter;
|
||||
end;
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
TForm1 = class(TForm)
|
||||
Button1: TButton;
|
||||
Memo1: TMemo;
|
||||
procedure Button1Click(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
private
|
||||
ACriticalSection: TRTLCriticalSection;
|
||||
MsgText: string;
|
||||
procedure AddMessage;
|
||||
public
|
||||
ThreadA: TThreadA;
|
||||
ThreadB: TThreadB;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.Button1Click(Sender: TObject);
|
||||
begin
|
||||
if ThreadA=nil then
|
||||
ThreadA:=TThreadA.Create(false);
|
||||
end;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
InitCriticalSection(ACriticalSection);
|
||||
end;
|
||||
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
DoneCriticalsection(ACriticalSection);
|
||||
end;
|
||||
|
||||
procedure TForm1.AddMessage;
|
||||
begin
|
||||
Memo1.Lines.Text:=MsgText;
|
||||
end;
|
||||
|
||||
{ TThreadA }
|
||||
|
||||
procedure TThreadA.Execute;
|
||||
begin
|
||||
Form1.ThreadB:=TThreadB.Create(false);
|
||||
// create event
|
||||
WaitForB:=RTLEventCreate;
|
||||
while not Application.Terminated do begin
|
||||
Log('A: wait for B ...');
|
||||
// wait infinitely (until B wakes A)
|
||||
RtlEventWaitFor(WaitForB);
|
||||
Log('A: ThreadB.Counter='+IntToStr(Form1.ThreadB.Counter));
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TThreadB }
|
||||
|
||||
procedure TThreadB.Execute;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Counter:=0;
|
||||
while not Application.Terminated do begin
|
||||
Log('B: Working ...');
|
||||
for i:=1 to 5 do begin
|
||||
Sleep(300);
|
||||
Log('..... ',false);
|
||||
end;
|
||||
Log('');
|
||||
inc(Counter);
|
||||
Log('B: Wake A');
|
||||
// wake A
|
||||
RtlEventSetEvent(Form1.ThreadA.WaitForB);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TBaseThread }
|
||||
|
||||
procedure TBaseThread.Log(const Msg: string; AppendLineEnd: boolean);
|
||||
var
|
||||
s: String;
|
||||
begin
|
||||
EnterCriticalsection(Form1.ACriticalSection);
|
||||
s:=Msg;
|
||||
if AppendLineEnd then
|
||||
s:=s+LineEnding;
|
||||
dbgout(s);
|
||||
Form1.MsgText:=Form1.MsgText+s;
|
||||
Synchronize(@Form1.AddMessage);
|
||||
LeaveCriticalsection(Form1.ACriticalSection);
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I waitforunit1.lrs}
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user