Ex FastStopThread converted to Lazarus

2024-11-24 16:53:48 +02:00 · 2024-10-13 22:34:02 +03:00 · 2024-10-13 22:34:02 +03:00 · c6251d64b2
commit c6251d64b2
parent 4aa4cad0fe
8 changed files with 295 additions and 14 deletions
--- a/.gitignore
+++ b/.gitignore
@ -40,3 +40,5 @@ __history
 /ExExceptions/lib
 /ExSync/ExEvent/SimpleLogger/lib
 /ExSync/ExEvent/SimpleLogger/backup
+/ExSync/ExEvent/FastStopThread/backup
+/ExSync/ExEvent/FastStopThread/lib
--- a/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.ico
+++ b/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.ico
--- a/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.lpi
+++ b/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.lpi
@ -0,0 +1,85 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="FastStopThreadLaz"/>
+      <Scaled Value="True"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <XPManifest>
+        <DpiAware Value="True"/>
+      </XPManifest>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <RequiredPackages>
+      <Item>
+        <PackageName Value="LCL"/>
+      </Item>
+    </RequiredPackages>
+    <Units>
+      <Unit>
+        <Filename Value="FastStopThreadLaz.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="FastStopThreadUnit.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form2"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+      </Unit>
+      <Unit>
+        <Filename Value="..\..\..\CommonUtils\TimeIntervals.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="FastStopThreadLaz"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="..\..\..\CommonUtils"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf3"/>
+      </Debugging>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.lpr
+++ b/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.lpr
@ -0,0 +1,24 @@
+program FastStopThreadLaz;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  {$IFDEF HASAMIGA}
+  athreads,
+  {$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, FastStopThreadUnit, TimeIntervals;
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Scaled:=True;
+  Application.Initialize;
+  Application.CreateForm(TForm2, Form2);
+  Application.Run;
+end.
+
--- a/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.res
+++ b/ExSync/ExEvent/FastStopThread/FastStopThreadLaz.res
--- a/ExSync/ExEvent/FastStopThread/FastStopThreadUnit.dfm
+++ b/ExSync/ExEvent/FastStopThread/FastStopThreadUnit.dfm
@ -2,8 +2,8 @@ object Form2: TForm2
  Left = 0
  Top = 0
  Caption = #1044#1077#1084#1086#1085#1089#1090#1088#1072#1094#1080#1103' '#1088#1072#1073#1086#1090#1099' '#1089' '#1089#1086#1073#1099#1090#1080#1103#1084#1080
-  ClientHeight = 321
-  ClientWidth = 523
+  ClientHeight = 351
+  ClientWidth = 574
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
@ -25,46 +25,54 @@ object Form2: TForm2
  end
  object Label2: TLabel
    Left = 8
-    Top = 255
+    Top = 286
    Width = 359
    Height = 19
    Caption = #1054#1089#1090#1072#1085#1086#1074' '#1087#1086#1090#1086#1082#1072' '#1080' '#1091#1085#1080#1095#1090#1086#1078#1077#1085#1080#1077' '#1086#1073#1098#1077#1082#1090#1072' '#1079#1072#1085#1103#1083#1086':'
  end
  object labFreeThreadTime: TLabel
    Left = 376
-    Top = 255
+    Top = 286
    Width = 24
    Height = 19
    Caption = '???'
  end
  object Label3: TLabel
    Left = 8
-    Top = 224
+    Top = 255
    Width = 239
    Height = 19
    Caption = #1042#1099#1079#1086#1074#1086#1074' '#1084#1077#1090#1086#1076#1072'  DoUsefullWork:'
  end
  object labUseFullCalls: TLabel
    Left = 256
-    Top = 224
+    Top = 255
    Width = 9
    Height = 19
    Caption = '0'
  end
  object Label4: TLabel
    Left = 8
-    Top = 284
+    Top = 315
    Width = 342
    Height = 19
    Caption = #1042#1086#1079#1086#1073#1085#1086#1074#1083#1077#1085#1080#1077' '#1087#1086#1090#1086#1082#1072' '#1087#1086#1089#1083#1077' SetEvent '#1079#1072#1085#1103#1083#1086':'
  end
  object labResumeThreadAfterSetEvent: TLabel
    Left = 376
-    Top = 284
+    Top = 315
    Width = 24
    Height = 19
    Caption = '???'
  end
+  object labMsgFromThread: TLabel
+    Left = 72
+    Top = 120
+    Width = 24
+    Height = 19
+    Caption = '???'
+    Visible = False
+  end
  object btnRunThread: TButton
    Left = 72
    Top = 80
@ -76,7 +84,7 @@ object Form2: TForm2
  end
  object btnStopThread: TButton
    Left = 72
-    Top = 167
+    Top = 198
    Width = 289
    Height = 33
    Caption = #1054#1089#1090#1072#1085#1086#1074#1080#1090#1100' '#1087#1086#1090#1086#1082
@ -86,7 +94,7 @@ object Form2: TForm2
  end
  object btnWakeUp: TButton
    Left = 72
-    Top = 121
+    Top = 152
    Width = 289
    Height = 33
    Caption = #1056#1072#1079#1073#1091#1076#1080#1090#1100' '#1087#1086#1090#1086#1082
--- a/ExSync/ExEvent/FastStopThread/FastStopThreadUnit.lfm
+++ b/ExSync/ExEvent/FastStopThread/FastStopThreadUnit.lfm
@ -0,0 +1,123 @@
+object Form2: TForm2
+  Left = 0
+  Height = 351
+  Top = 0
+  Width = 574
+  Caption = 'Демонстрация работы с событиями'
+  ClientHeight = 351
+  ClientWidth = 574
+  Color = clBtnFace
+  Font.Color = clWindowText
+  Font.Height = -16
+  Font.Name = 'Tahoma'
+  Position = poScreenCenter
+  object Label1: TLabel
+    Left = 8
+    Height = 57
+    Top = 8
+    Width = 425
+    Caption = 'Пример демонстрирует организацию моментального'#13#10'завершения работы потока при использовании'#13#10'объекта синхронизации уровня ядра ОС: Event (событие)'
+  end
+  object Label2: TLabel
+    Left = 8
+    Height = 19
+    Top = 286
+    Width = 359
+    Caption = 'Останов потока и уничтожение объекта заняло:'
+  end
+  object labFreeThreadTime: TLabel
+    Left = 376
+    Height = 19
+    Top = 286
+    Width = 24
+    Caption = '???'
+  end
+  object Label3: TLabel
+    Left = 8
+    Height = 19
+    Top = 255
+    Width = 239
+    Caption = 'Вызовов метода  DoUsefullWork:'
+  end
+  object labUseFullCalls: TLabel
+    Left = 256
+    Height = 19
+    Top = 255
+    Width = 9
+    Caption = '0'
+  end
+  object Label4: TLabel
+    Left = 8
+    Height = 19
+    Top = 315
+    Width = 342
+    Caption = 'Возобновление потока после SetEvent заняло:'
+  end
+  object labResumeThreadAfterSetEvent: TLabel
+    Left = 376
+    Height = 19
+    Top = 315
+    Width = 24
+    Caption = '???'
+  end
+  object labMsgFromThread: TLabel
+    Left = 72
+    Height = 19
+    Top = 120
+    Width = 24
+    Caption = '???'
+    Visible = False
+  end
+  object btnRunThread: TButton
+    Left = 72
+    Height = 33
+    Top = 80
+    Width = 289
+    Caption = 'Запустить поток'
+    TabOrder = 0
+    OnClick = btnRunThreadClick
+  end
+  object btnStopThread: TButton
+    Left = 72
+    Height = 33
+    Top = 198
+    Width = 289
+    Caption = 'Остановить поток'
+    Enabled = False
+    TabOrder = 1
+    OnClick = btnStopThreadClick
+  end
+  object btnWakeUp: TButton
+    Left = 72
+    Height = 33
+    Top = 152
+    Width = 289
+    Caption = 'Разбудить поток'
+    Enabled = False
+    TabOrder = 2
+    OnClick = btnWakeUpClick
+  end
+  object cbUseProgressViewer: TCheckBox
+    Left = 376
+    Height = 23
+    Top = 88
+    Width = 118
+    Caption = 'Визуализация'
+    Font.CharSet = RUSSIAN_CHARSET
+    Font.Color = clBlack
+    Font.Height = -16
+    Font.Name = 'Tahoma'
+    Font.Pitch = fpVariable
+    Font.Quality = fqDraft
+    Font.Style = [fsStrikeOut]
+    ParentFont = False
+    TabOrder = 3
+    Visible = False
+  end
+  object Timer1: TTimer
+    Interval = 333
+    OnTimer = Timer1Timer
+    Left = 24
+    Top = 80
+  end
+end
--- a/ExSync/ExEvent/FastStopThread/FastStopThreadUnit.pas
+++ b/ExSync/ExEvent/FastStopThread/FastStopThreadUnit.pas
@ -1,10 +1,16 @@
-unit FastStopThreadUnit;
+{$IFDEF FPC}{$CODEPAGE UTF8}{$H+}{$MODE DELPHI}{$ENDIF}
+unit FastStopThreadUnit;

 interface

 uses
-  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
-  Dialogs, SyncObjs, StdCtrls, TimeIntervals, ProgressViewer, ExtCtrls;
+  {$IFnDEF FPC}
+    Windows, Messages, ProgressViewer, 
+  {$ELSE}
+    LCLIntf, LCLType, LMessages, 
+  {$ENDIF}
+    SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, SyncObjs, StdCtrls, TimeIntervals, 
+    ExtCtrls;

 type
  TMyThread = class(TThread)
@ -12,7 +18,10 @@ type
    Event: TEvent;
    FUseProgressViewer: Boolean;
    FUseFullCalls: Integer;
+    FGuiMsg: string;
    procedure DoUsefullWork;
+    procedure ShowMsg(Msg: string);
+    procedure UpdateGui;
  protected
    procedure Execute; override;
  public
@ -35,6 +44,7 @@ type
    labUseFullCalls: TLabel;
    Label4: TLabel;
    labResumeThreadAfterSetEvent: TLabel;
+    labMsgFromThread: TLabel;
    procedure btnRunThreadClick(Sender: TObject);
    procedure btnStopThreadClick(Sender: TObject);
    procedure btnWakeUpClick(Sender: TObject);
@ -53,7 +63,11 @@ var

 implementation

-{$R *.dfm}
+{$IFnDEF FPC}
+  {$R *.dfm}
+{$ELSE}
+  {$R *.lfm}
+{$ENDIF}

 { TMyThread }

@ -88,23 +102,36 @@ end;
 procedure TMyThread.Execute;
 var
  WaitRes: TWaitResult;
+  {$IFnDEF FPC}
  pv: TProgressViewer;
+  {$ENDIF}
 begin
+  {$IFnDEF FPC}
  pv := nil; // Чтобы компилятор не выдавал Warning
+  {$ENDIF}
+  
  while not Terminated do
  begin
+    ShowMsg('Ожидание события...');
+
    // Внимание! Визуализация ожидания события вносит значительные накладные
    // расходы и значительно увеличивает время уничтожения потока!
+    {$IFnDEF FPC}
    if FUseProgressViewer then
      pv := TProgressViewer.Create('Ожидание события');
+    {$ENDIF}

    WaitRes := Event.WaitFor(5 * 1000); // Ожидание события - 5 секунд

    if WaitRes = wrSignaled then
      tiSignalled.Stop; // Останавливаем измерение времени

+    ShowMsg('');
+
+    {$IFnDEF FPC}
    if FUseProgressViewer then
      pv.TerminateProgress;
+    {$ENDIF}  

    // Выполняем полезную работу если окончился таймаут ожидания (wrTimeout),
    // либо если произошёл вызов метода WakeUp
@ -113,6 +140,18 @@ begin
  end;
 end;

+procedure TMyThread.ShowMsg(Msg: string);
+begin
+  FGuiMsg := Msg;
+  TThread.Synchronize(nil, UpdateGui);
+end;
+
+procedure TMyThread.UpdateGui;
+begin
+  Form2.labMsgFromThread.Visible := FGuiMsg <> '';
+  Form2.labMsgFromThread.Caption := FGuiMsg;
+end;
+
 procedure TMyThread.WakeUp;
 begin
  tiSignalled.Start;