paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-27 11:00:37 +02:00
Code Issues Packages Projects Releases Wiki Activity

added multithreading examples

Browse Source 
git-svn-id: trunk@9575 -
This commit is contained in:
mattias 2006-07-08 15:12:53 +00:00
parent 41947d6c28
commit f10441b47f
19 changed files with 1058 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
.gitattributes vendored
View File

@ -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
View 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
View 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
View 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
View 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
View 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.

25
examples/multithreading/mainunit.pas
View File

@ -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;

3
examples/multithreading/multithreadingexample1.lpi
View File

@ -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>

5
examples/multithreading/multithreadingexample1.lpr
View File

@ -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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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.