Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 5

Project THSYNCH

Project Structure


THSYNCH.DPR

program ThSynch;

uses
  Forms,
  SyncForm in 'SyncForm.pas' {Form1},
  Mutex in 'Mutex.pas' {Form4},
  Plain in 'Plain.pas' {Form2},
  CritSec in 'CritSec.pas' {Form3},
  TCriSect in 'TCriSect.pas' {Form5};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TForm4, Form4);
  Application.CreateForm(TForm2, Form2);
  Application.CreateForm(TForm3, Form3);
  Application.CreateForm(TForm5, Form5);
  Application.Run;
end.

SYNCFORM.PAS

unit SyncForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  Plain, CritSec, Mutex, TCriSect;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form2.Show;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Form3.Show;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  Form4.Show;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  Form5.Show;
end;

end.

MUTEX.PAS

unit Mutex;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TListThread = class (TThread)
  private
    Str: String;
  protected
    procedure AddToList;
    procedure Execute; override;
  public
    LBox: TListBox;
  end;

  TForm4 = class(TForm)
    BtnStart: TButton;
    ListBox1: TListBox;
    ListBox2: TListBox;
    procedure BtnStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    Th1, Th2: TListThread;
  public
    { Public declarations }
  end;

var
  Form4: TForm4;
  Letters: string = 'AAAAAAAAAAAAAAAAAAAA';
  hMutex: THandle;

implementation

{$R *.DFM}

procedure TListThread.AddToList;
begin
  if Assigned (LBox) then
    LBox.Items.Add (Str);
end;

procedure TListThread.Execute;
var
  I, J, K: Integer;
begin
  for I := 0 to 50 do
  begin
    WaitForSingleObject (hMutex, INFINITE);
    for J := 1 to 20 do
      for K := 1 to 2601 do // useless repetition...
        if Letters [J] < 'Z' then
          Letters [J] := Succ (Letters [J])
        else
          Letters [J] := 'A';
    Str := Letters;
    ReleaseMutex (hMutex);
    Synchronize (AddToList);
  end;
end;

procedure TForm4.BtnStartClick(Sender: TObject);
begin
  ListBox1.Clear;
  ListBox2.Clear;
  Th1 := TListThread.Create (True);
  Th2 := TListThread.Create (True);
  Th1.FreeOnTerminate := True;
  Th2.FreeOnTerminate := True;
  Th1.LBox := Listbox1;
  Th2.LBox := Listbox2;
  Th1.Resume;
  Th2.Resume;
end;

procedure TForm4.FormCreate(Sender: TObject);
begin
  hMutex := CreateMutex (nil, false, nil);
end;

procedure TForm4.FormDestroy(Sender: TObject);
begin
  CloseHandle (hMutex);
end;


end.

PLAIN.PAS

unit Plain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TListThread = class (TThread)
  private
    Str: String;
  protected
    procedure AddToList;
    procedure Execute; override;
  public
    LBox: TListBox;
  end;

  TForm2 = class(TForm)
    ListBox1: TListBox;
    ListBox2: TListBox;
    BtnStart: TButton;
    procedure BtnStartClick(Sender: TObject);
  private
    Th1, Th2: TListThread;
  public
    { Public declarations }
  end;

var
  Form2: TForm2;
  Letters: string = 'AAAAAAAAAAAAAAAAAAAA';

implementation

{$R *.DFM}

procedure TListThread.AddToList;
begin
  if Assigned (LBox) then
    LBox.Items.Add (Str);
end;

procedure TListThread.Execute;
var
  I, J, K: Integer;
begin
  for I := 0 to 50 do
  begin
    for J := 1 to 20 do
      for K := 1 to 2601 do // useless repetition...
        if Letters [J] < 'Z' then
          Letters [J] := Succ (Letters [J])
        else
          Letters [J] := 'A';
    Str := Letters;
    Synchronize (AddToList);
  end;
end;

procedure TForm2.BtnStartClick(Sender: TObject);
begin
  ListBox1.Clear;
  ListBox2.Clear;
  Th1 := TListThread.Create (True);
  Th2 := TListThread.Create (True);
  Th1.FreeOnTerminate := True;
  Th2.FreeOnTerminate := True;
  Th1.LBox := Listbox1;
  Th2.LBox := Listbox2;
  Th1.Resume;
  Th2.Resume;
end;

end.

CRITSEC.PAS

unit CritSec;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TListThread = class (TThread)
  private
    Str: String;
  protected
    procedure AddToList;
    procedure Execute; override;
  public
    LBox: TListBox;
  end;

  TForm3 = class(TForm)
    BtnStart: TButton;
    ListBox1: TListBox;
    ListBox2: TListBox;
    procedure BtnStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    Th1, Th2: TListThread;
  public
    { Public declarations }
  end;

var
  Form3: TForm3;
  Letters: string = 'AAAAAAAAAAAAAAAAAAAA';
  Critical1: TRTLCriticalSection;

implementation

{$R *.DFM}

procedure TListThread.AddToList;
begin
  if Assigned (LBox) then
    LBox.Items.Add (Str);
end;

procedure TListThread.Execute;
var
  I, J, K: Integer;
begin
  for I := 0 to 50 do
  begin
    EnterCriticalSection (Critical1);
    for J := 1 to 20 do
      for K := 1 to 2601 do // useless repetition...
        if Letters [J] < 'Z' then
          Letters [J] := Succ (Letters [J])
        else
          Letters [J] := 'A';
    Str := Letters;
    LeaveCriticalSection (Critical1);
    Synchronize (AddToList);
  end;
end;

procedure TForm3.BtnStartClick(Sender: TObject);
begin
  ListBox1.Clear;
  ListBox2.Clear;
  Th1 := TListThread.Create (True);
  Th2 := TListThread.Create (True);
  Th1.FreeOnTerminate := True;
  Th2.FreeOnTerminate := True;
  Th1.LBox := Listbox1;
  Th2.LBox := Listbox2;
  Th1.Resume;
  Th2.Resume;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
  InitializeCriticalSection (Critical1);
end;

procedure TForm3.FormDestroy(Sender: TObject);
begin
  DeleteCriticalSection (Critical1);
end;


end.

TCRISECT.PAS

unit TCriSect;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, SyncObjs;

type
  TListThread = class (TThread)
  private
    Str: String;
  protected
    procedure AddToList;
    procedure Execute; override;
  public
    LBox: TListBox;
  end;

  TForm5 = class(TForm)
    BtnStart: TButton;
    ListBox1: TListBox;
    ListBox2: TListBox;
    procedure BtnStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    Th1, Th2: TListThread;
  public
    { Public declarations }
  end;

var
  Form5: TForm5;
  Letters: string = 'AAAAAAAAAAAAAAAAAAAA';
  Critical1: TCriticalSection;

implementation

{$R *.DFM}

procedure TListThread.AddToList;
begin
  if Assigned (LBox) then
    LBox.Items.Add (Str);
end;

procedure TListThread.Execute;
var
  I, J, K: Integer;
begin
  for I := 0 to 50 do
  begin
    Critical1.Enter;
    for J := 1 to 20 do
      for K := 1 to 2601 do // useless repetition...
        if Letters [J] < 'Z' then
          Letters [J] := Succ (Letters [J])
        else
          Letters [J] := 'A';
    Str := Letters;
    Critical1.Leave;
    Synchronize (AddToList);
  end;
end;

procedure TForm5.BtnStartClick(Sender: TObject);
begin
  ListBox1.Clear;
  ListBox2.Clear;
  Th1 := TListThread.Create (True);
  Th2 := TListThread.Create (True);
  Th1.FreeOnTerminate := True;
  Th2.FreeOnTerminate := True;
  Th1.LBox := Listbox1;
  Th2.LBox := Listbox2;
  Th1.Resume;
  Th2.Resume;
end;

procedure TForm5.FormCreate(Sender: TObject);
begin
  Critical1 := TCriticalSection.Create;
end;

procedure TForm5.FormDestroy(Sender: TObject);
begin
  Critical1.Free;
end;

end.

SYNCFORM.DFM

object Form1: TForm1
  Left = 142
  Top = 220
  Width = 296
  Height = 127
  Caption = 'Thread Win32 Synch'
  Font.Charset = ANSI_CHARSET
  Font.Color = clBlack
  Font.Height = -13
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  PixelsPerInch = 96
  TextHeight = 16
  object Button1: TButton
    Left = 12
    Top = 12
    Width = 125
    Height = 30
    Caption = 'Plain'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 144
    Top = 12
    Width = 129
    Height = 30
    Caption = 'Critical Section (API)'
    TabOrder = 1
    OnClick = Button2Click
  end
  object Button3: TButton
    Left = 12
    Top = 53
    Width = 125
    Height = 30
    Caption = 'Mutex (API)'
    TabOrder = 2
    OnClick = Button3Click
  end
  object Button4: TButton
    Left = 144
    Top = 52
    Width = 129
    Height = 30
    Caption = 'TCriticalSection'
    TabOrder = 3
    OnClick = Button4Click
  end
end

MUTEX.DFM

object Form4: TForm4
  Left = 249
  Top = 170
  Width = 449
  Height = 274
  Caption = 'Mutex'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -10
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object BtnStart: TButton
    Left = 7
    Top = 7
    Width = 60
    Height = 20
    Caption = 'Start'
    TabOrder = 0
    OnClick = BtnStartClick
  end
  object ListBox1: TListBox
    Left = 7
    Top = 32
    Width = 210
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 1
  end
  object ListBox2: TListBox
    Left = 222
    Top = 32
    Width = 211
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 2
  end
end

PLAIN.DFM

object Form2: TForm2
  Left = 193
  Top = 110
  Width = 448
  Height = 275
  Caption = 'Plain'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -10
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  PixelsPerInch = 96
  TextHeight = 13
  object ListBox1: TListBox
    Left = 7
    Top = 30
    Width = 210
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 0
  end
  object ListBox2: TListBox
    Left = 222
    Top = 30
    Width = 211
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 1
  end
  object BtnStart: TButton
    Left = 7
    Top = 7
    Width = 60
    Height = 20
    Caption = 'Start'
    TabOrder = 2
    OnClick = BtnStartClick
  end
end

CRITSEC.DFM

object Form3: TForm3
  Left = 218
  Top = 140
  Width = 449
  Height = 274
  Caption = 'Critical Section'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -10
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object BtnStart: TButton
    Left = 7
    Top = 7
    Width = 60
    Height = 20
    Caption = 'Start'
    TabOrder = 0
    OnClick = BtnStartClick
  end
  object ListBox1: TListBox
    Left = 7
    Top = 32
    Width = 210
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 1
  end
  object ListBox2: TListBox
    Left = 222
    Top = 32
    Width = 211
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 2
  end
end

TCRISECT.DFM

object Form5: TForm5
  Left = 229
  Top = 147
  Width = 448
  Height = 274
  Caption = 'TCriticalSection'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object BtnStart: TButton
    Left = 7
    Top = 7
    Width = 60
    Height = 20
    Caption = 'Start'
    TabOrder = 0
    OnClick = BtnStartClick
  end
  object ListBox1: TListBox
    Left = 7
    Top = 32
    Width = 210
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 1
  end
  object ListBox2: TListBox
    Left = 222
    Top = 32
    Width = 211
    Height = 211
    Font.Charset = ANSI_CHARSET
    Font.Color = clBlack
    Font.Height = -13
    Font.Name = 'Courier New'
    Font.Style = []
    ItemHeight = 16
    ParentFont = False
    TabOrder = 2
  end
end