├── .gitignore ├── Common ├── Common.pas ├── UICommon.pas ├── uDemoBase.dfm └── uDemoBase.pas ├── DemoCapture ├── uDemoCapture.dfm └── uDemoCapture.pas ├── DemoCriticalSections ├── CriticalSectionThread.pas ├── uDemoCriticalSections.dfm └── uDemoCriticalSections.pas ├── DemoDatabase ├── DatabaseThread.pas ├── uDemoDatabase.dfm └── uDemoDatabase.pas ├── DemoDownload ├── DownloadThread.pas ├── uDemoDownload.dfm └── uDemoDownload.pas ├── DemoHttpServer ├── HttpServerThread.pas ├── uDemoHttpServer.dfm └── uDemoHttpServer.pas ├── DemoHurtMyCpu ├── CpuMonitor.pas ├── HurtMyCpuThread.pas ├── uDemoHurtMyCpu.dfm └── uDemoHurtMyCpu.pas ├── DemoOmniThreads ├── uDemoOmniThreads.dfm └── uDemoOmniThreads.pas ├── DemoProgress ├── ProgressThread.pas ├── uDemoProgress.dfm └── uDemoProgress.pas ├── DemoQueues ├── uDemoThreadQueue.dfm └── uDemoThreadQueue.pas ├── DemoThreadPools ├── ThreadPoolThread.pas ├── uDemoThreadPools.dfm └── uDemoThreadPools.pas ├── DemoWindowsMessages ├── uDemoWindowsMessages.dfm └── uDemoWindowsMessages.pas ├── Icons ├── Camera-256.ico └── webcam-256.ico ├── README.md ├── Screenshots ├── SS-Database.png ├── SS-Downloading.png ├── SS-Home.png ├── SS-HurtMyCpu.png └── SS-ProgressBar.png ├── ThreadDemo.dpr ├── ThreadDemo.dproj ├── ThreadDemo.res ├── ThreadIcon.ico ├── ThreadIcon.png ├── uMain.dfm └── uMain.pas /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | -------------------------------------------------------------------------------- /Common/Common.pas: -------------------------------------------------------------------------------- 1 | unit Common; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, System.SysUtils; 7 | 8 | implementation 9 | 10 | end. 11 | -------------------------------------------------------------------------------- /Common/UICommon.pas: -------------------------------------------------------------------------------- 1 | unit UICommon; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, System.SysUtils, 7 | Winapi.Windows, 8 | Vcl.Controls, Vcl.Graphics, Vcl.ComCtrls; 9 | 10 | function ListViewCellRect(AListView: TCustomListView; AColIndex: Integer; 11 | AItemIndex: Integer): TRect; 12 | 13 | procedure DrawProgressBar(const ACanvas: TCanvas; const ARect: TRect; 14 | const APercent: Single; 15 | const ABackColor: TColor = clGray; const AForeColor: TColor = clNavy; 16 | const AText: String = ''); 17 | 18 | implementation 19 | 20 | function ListViewCellRect(AListView: TCustomListView; AColIndex: Integer; 21 | AItemIndex: Integer): TRect; 22 | var 23 | I: Integer; 24 | begin 25 | Result:= AListView.Items[AItemIndex].DisplayRect(TDisplayCode.drBounds); 26 | for I:= 0 to AColIndex-1 do 27 | Result.Left := Result.Left + AListView.Column[I].Width; 28 | Result.Width:= AListView.Column[AColIndex].Width; 29 | end; 30 | 31 | procedure DrawProgressBar(const ACanvas: TCanvas; const ARect: TRect; 32 | const APercent: Single; 33 | const ABackColor: TColor = clGray; const AForeColor: TColor = clNavy; 34 | const AText: String = ''); 35 | const 36 | DRAW_FLAGS = DT_SINGLELINE or DT_CENTER or DT_VCENTER; 37 | var 38 | BR, FR, TR: TRect; 39 | S: String; 40 | begin 41 | //Draw background 42 | BR:= ARect; 43 | InflateRect(BR, -2, -2); 44 | ACanvas.Pen.Width:= 1; 45 | ACanvas.Pen.Style:= psSolid; 46 | ACanvas.Pen.Color:= AForeColor; 47 | ACanvas.Brush.Style:= bsSolid; 48 | ACanvas.Brush.Color:= ABackColor; 49 | ACanvas.Rectangle(BR); 50 | 51 | //Draw foreground 52 | FR:= BR; 53 | InflateRect(FR, -1, -1); 54 | FR.Width:= Trunc(FR.Width * APercent); 55 | ACanvas.Pen.Style:= psClear; 56 | ACanvas.Brush.Color:= AForeColor; 57 | ACanvas.FillRect(FR); 58 | 59 | //Draw text 60 | TR:= BR; 61 | ACanvas.Font.Color:= clWhite; 62 | ACanvas.Font.Style:= [fsBold]; 63 | ACanvas.Font.Height:= ARect.Height - 6; 64 | ACanvas.Pen.Style:= psClear; 65 | ACanvas.Brush.Style:= bsClear; 66 | if AText = '' then 67 | S:= FormatFloat('0%', APercent * 100) 68 | else 69 | S:= AText; 70 | DrawText(ACanvas.Handle, PChar(S), Length(S), TR, DRAW_FLAGS); 71 | 72 | end; 73 | 74 | end. 75 | -------------------------------------------------------------------------------- /Common/uDemoBase.dfm: -------------------------------------------------------------------------------- 1 | object frmDemoBase: TfrmDemoBase 2 | Left = 0 3 | Top = 0 4 | BorderStyle = bsNone 5 | Caption = 'Demo Base Form' 6 | ClientHeight = 450 7 | ClientWidth = 780 8 | Color = clWhite 9 | Constraints.MinHeight = 450 10 | Constraints.MinWidth = 780 11 | DoubleBuffered = True 12 | Font.Charset = DEFAULT_CHARSET 13 | Font.Color = clWindowText 14 | Font.Height = -11 15 | Font.Name = 'Tahoma' 16 | Font.Style = [] 17 | OldCreateOrder = False 18 | PixelsPerInch = 96 19 | TextHeight = 13 20 | end 21 | -------------------------------------------------------------------------------- /Common/uDemoBase.pas: -------------------------------------------------------------------------------- 1 | unit uDemoBase; 2 | 3 | interface 4 | 5 | (* 6 | This form is the base for all other demo content forms. All of them are 7 | inherited from this one. `SetEnabledState()` should be overridden 8 | in order to imlement enabling/disabling controls when it is busy. 9 | *) 10 | 11 | uses 12 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 13 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls; 14 | 15 | type 16 | TfrmDemoBase = class; 17 | 18 | TDemoFormClass = class of TfrmDemoBase; 19 | 20 | TfrmDemoBase = class(TForm) 21 | private 22 | 23 | public 24 | procedure SetEnabledState(const Enabled: Boolean); virtual; 25 | end; 26 | 27 | var 28 | frmDemoBase: TfrmDemoBase; 29 | 30 | implementation 31 | 32 | {$R *.dfm} 33 | 34 | { TfrmDemoBase } 35 | 36 | procedure TfrmDemoBase.SetEnabledState(const Enabled: Boolean); 37 | begin 38 | //Nothing here, instead the inherited forms will implement this... 39 | 40 | end; 41 | 42 | end. 43 | -------------------------------------------------------------------------------- /DemoCapture/uDemoCapture.pas: -------------------------------------------------------------------------------- 1 | unit uDemoCapture; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls; 8 | 9 | type 10 | TfrmDemoCapture = class(TfrmDemoBase) 11 | Label12: TLabel; 12 | Label1: TLabel; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | frmDemoCapture: TfrmDemoCapture; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /DemoCriticalSections/CriticalSectionThread.pas: -------------------------------------------------------------------------------- 1 | unit CriticalSectionThread; 2 | 3 | { 4 | -------------------------------------------------------------------------------- 5 | 6 | This unit is separated into 2 main parts: 7 | 1) TLocker 8 | 2) TLockedThread 9 | 10 | -------------------------------------------------------------------------------- 11 | 12 | TLocker 13 | 14 | Encapsulates locking an object. When creating, pass the object 15 | you wish to lock. Make sure you don't store a reference to 16 | that object anywhere else - that would defeat the purpose. 17 | 18 | You can accomplish the same without using this TLocker class, 19 | but it helps to make sure you really hide the object's 20 | access through a universal function that must be used. 21 | 22 | The idea is any time you want to access this object, 23 | you would call the Lock function, which returns the object, 24 | but ONLY when another thread is finished with it. 25 | Once finished, call Unlock to allow another thread to use. 26 | 27 | ALL access to this object should be through this lock mechanism. 28 | Any place that ignores the lock would break the rule and 29 | no longer serve its purpose. This would include objects which 30 | the VCL or other framework or library might directly access 31 | behind your back, such as list items for example. 32 | UI controls cannot be protected with this, because the 33 | VCL has absolutely no idea about your lock and would ignore it. 34 | 35 | The end goal is to protect memory from being accessed by more 36 | than one thread at the same time, which could lead to 37 | unpredictable results, such as deadlocks, or race conditions. 38 | 39 | All Lock/Unlock usage should be wrapped with try..finally blocks. 40 | 41 | var 42 | O: TMyObject; 43 | begin 44 | O:= TMyObject(L.Lock); 45 | try 46 | //Do something with O... 47 | 48 | finally 49 | L.Unlock; 50 | end; 51 | end; 52 | 53 | -------------------------------------------------------------------------------- 54 | 55 | TLockedThread 56 | 57 | A thread which implements TLocker to protect an object. 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- 62 | } 63 | 64 | interface 65 | 66 | uses 67 | System.Classes, System.SysUtils, System.SyncObjs; 68 | 69 | type 70 | 71 | TLocker = class(TObject) 72 | private 73 | FLock: TCriticalSection; 74 | strict private 75 | FObj: TObject; 76 | public 77 | constructor Create(AObj: TObject); 78 | destructor Destroy; override; 79 | function Lock: TObject; 80 | procedure Unlock; 81 | end; 82 | 83 | implementation 84 | 85 | { TLocker } 86 | 87 | constructor TLocker.Create(AObj: TObject); 88 | begin 89 | FObj:= AObj; 90 | FLock:= TCriticalSection.Create; 91 | end; 92 | 93 | destructor TLocker.Destroy; 94 | begin 95 | FLock.Enter; 96 | FLock.Leave; 97 | FreeAndNil(FLock); 98 | inherited; 99 | end; 100 | 101 | function TLocker.Lock: TObject; 102 | begin 103 | //First, we try to "lock" it, which will wait until another thread is finished, 104 | // that is, if any thread was using it at all. Otherwise, will return immediately. 105 | FLock.Enter; 106 | //Now that it's locked, we return the internal object reference... 107 | Result:= FObj; 108 | end; 109 | 110 | procedure TLocker.Unlock; 111 | begin 112 | //When a thread is done using an object, it must "unlock" it to allow 113 | // another thread to be able to access it. 114 | FLock.Leave; 115 | end; 116 | 117 | end. 118 | -------------------------------------------------------------------------------- /DemoCriticalSections/uDemoCriticalSections.pas: -------------------------------------------------------------------------------- 1 | unit uDemoCriticalSections; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls; 8 | 9 | type 10 | TfrmDemoCriticalSections = class(TfrmDemoBase) 11 | Label12: TLabel; 12 | Label1: TLabel; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | frmDemoCriticalSections: TfrmDemoCriticalSections; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /DemoDatabase/DatabaseThread.pas: -------------------------------------------------------------------------------- 1 | unit DatabaseThread; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, System.SysUtils, System.Generics.Collections, 7 | DB, ADODB, ActiveX; 8 | 9 | type 10 | TLightDataset = class; 11 | TDatabaseThread = class; 12 | 13 | TDatasetEvent = procedure(Sender: TObject; Dataset: TLightDataset) of object; 14 | 15 | TExceptionEvent = procedure(Sender: TObject; E: Exception) of object; 16 | 17 | //Mimics a dataset, but using strings only and extremely basic functionality. 18 | // Just serves as a dirty way to carry data from one thread to another. 19 | // Presumably, you would be populating your own properties of an object 20 | // using the data returned in the dataset. 21 | TLightDataset = class(TObject) 22 | private 23 | FColDefs: TStringList; 24 | FRows: TObjectList; 25 | procedure Clear; 26 | function GetCol(const Index: Integer): String; 27 | function GetRow(const Index: Integer): TStringList; 28 | public 29 | constructor Create; 30 | destructor Destroy; override; 31 | procedure LoadFromDataset(ADataset: TDataset); 32 | public 33 | function ColCount: Integer; 34 | function RowCount: Integer; 35 | property Cols[const Index: Integer]: String read GetCol; 36 | property Rows[const Index: Integer]: TStringList read GetRow; 37 | end; 38 | 39 | //Encapsulates a database connection inside of a thread. 40 | TDatabaseThread = class(TThread) 41 | private 42 | FDB: TADOConnection; 43 | FQry: TADOQuery; 44 | FSql: TStringList; 45 | FConnStr: String; 46 | FData: TLightDataset; 47 | FException: Exception; 48 | FOnData: TDatasetEvent; 49 | FOnException: TExceptionEvent; 50 | procedure Init; 51 | procedure Uninit; 52 | procedure SetSql(const Value: TStrings); 53 | function GetSql: TStrings; 54 | procedure SetConnStr(const Value: String); 55 | protected 56 | procedure Execute; override; 57 | procedure SYNC_OnData; 58 | procedure SYNC_OnException; 59 | public 60 | constructor Create; reintroduce; 61 | destructor Destroy; override; 62 | property ConnStr: String read FConnStr write SetConnStr; 63 | property Sql: TStrings read GetSql write SetSql; 64 | property OnData: TDatasetEvent read FOnData write FOnData; 65 | property OnException: TExceptionEvent read FOnException write FOnException; 66 | end; 67 | 68 | implementation 69 | 70 | { TLightDataset } 71 | 72 | constructor TLightDataset.Create; 73 | begin 74 | FColDefs:= TStringList.Create; 75 | FRows:= TObjectList.Create(True); 76 | end; 77 | 78 | destructor TLightDataset.Destroy; 79 | begin 80 | FreeAndNil(FRows); 81 | FreeAndNil(FColDefs); 82 | inherited; 83 | end; 84 | 85 | procedure TLightDataset.Clear; 86 | begin 87 | FColDefs.Clear; 88 | FRows.Clear; 89 | end; 90 | 91 | procedure TLightDataset.LoadFromDataset(ADataset: TDataset); 92 | var 93 | X: Integer; 94 | R: TStringList; 95 | begin 96 | //Populates object structure based on data in a dataset. 97 | 98 | //First, clear existing data... 99 | Clear; 100 | 101 | //Populate field (column) names... 102 | for X := 0 to ADataset.Fields.Count-1 do begin 103 | FColDefs.Append(ADataset.Fields[X].FieldName); 104 | end; 105 | 106 | //Populate rows and their data as strings... 107 | ADataset.First; 108 | while not ADataset.Eof do begin 109 | R:= TStringList.Create; 110 | try 111 | for X := 0 to ADataset.Fields.Count-1 do begin 112 | try 113 | R.Append(ADataset.Fields[X].AsString); 114 | except 115 | //In case there's a data type that can't be copied to a string... 116 | R.Append('(ERROR)'); 117 | end; 118 | end; 119 | finally 120 | FRows.Add(R); 121 | end; 122 | ADataset.Next; 123 | end; 124 | 125 | end; 126 | 127 | function TLightDataset.ColCount: Integer; 128 | begin 129 | Result:= Self.FColDefs.Count; 130 | end; 131 | 132 | function TLightDataset.RowCount: Integer; 133 | begin 134 | Result:= Self.FRows.Count; 135 | end; 136 | 137 | function TLightDataset.GetCol(const Index: Integer): String; 138 | begin 139 | Result:= Self.FColDefs[Index]; 140 | end; 141 | 142 | function TLightDataset.GetRow(const Index: Integer): TStringList; 143 | begin 144 | Result:= Self.FRows[Index]; 145 | end; 146 | 147 | { TDatabaseThread } 148 | 149 | constructor TDatabaseThread.Create; 150 | begin 151 | inherited Create(True); //Suspended, so it will need to be started manually. 152 | FSql:= TStringList.Create; 153 | //We can't create database components here, because they require COM. 154 | // Instead, they get created within the thread context itself. 155 | end; 156 | 157 | destructor TDatabaseThread.Destroy; 158 | begin 159 | FreeAndNil(FSql); 160 | inherited; 161 | end; 162 | 163 | function TDatabaseThread.GetSql: TStrings; 164 | begin 165 | Result:= TStrings(FSql); 166 | end; 167 | 168 | procedure TDatabaseThread.SetSql(const Value: TStrings); 169 | begin 170 | FSql.Assign(Value); 171 | end; 172 | 173 | procedure TDatabaseThread.SetConnStr(const Value: String); 174 | begin 175 | FConnStr := Value; 176 | end; 177 | 178 | procedure TDatabaseThread.SYNC_OnData; 179 | begin 180 | if Assigned(FOnData) then 181 | FOnData(Self, FData); 182 | end; 183 | 184 | procedure TDatabaseThread.SYNC_OnException; 185 | begin 186 | if Assigned(FOnException) then 187 | FOnException(Self, FException); 188 | end; 189 | 190 | procedure TDatabaseThread.Init; 191 | begin 192 | //Since ADO is based on COM, we have to initialize COM within this thread... 193 | CoInitialize(nil); 194 | //Now it's safe to use ADO... 195 | FDB:= TADOConnection.Create(nil); 196 | FDB.LoginPrompt:= False; 197 | FQry:= TADOQuery.Create(nil); 198 | FQry.Connection:= FDB; 199 | FData:= TLightDataset.Create; 200 | end; 201 | 202 | procedure TDatabaseThread.Uninit; 203 | begin 204 | FreeAndNil(FData); 205 | FQry.Close; 206 | FDB.Connected:= False; 207 | FreeAndNil(FQry); 208 | FreeAndNil(FDB); 209 | //When we're done using COM... 210 | CoUninitialize; 211 | end; 212 | 213 | procedure TDatabaseThread.Execute; 214 | begin 215 | Init; 216 | try 217 | try 218 | //Now we are actually using the database components... 219 | FDB.ConnectionString:= FConnStr; 220 | FDB.Connected:= True; 221 | FQry.SQL.Assign(FSql); 222 | FQry.Open; 223 | try 224 | //Copy data over to lightweight (thread safe) object... 225 | FData.LoadFromDataset(FQry); 226 | finally 227 | FQry.Close; 228 | end; 229 | //Once we have the data, we synchronize it back to the caller... 230 | Synchronize(SYNC_OnData); 231 | except 232 | on E: Exception do begin 233 | //If any exception happens, synchronize it back to the caller... 234 | FException:= E; 235 | Synchronize(SYNC_OnException); 236 | end; 237 | end; 238 | finally 239 | Uninit; 240 | end; 241 | Terminate; 242 | end; 243 | 244 | end. 245 | -------------------------------------------------------------------------------- /DemoDatabase/uDemoDatabase.pas: -------------------------------------------------------------------------------- 1 | unit uDemoDatabase; 2 | 3 | (* 4 | Demonstrates how to use databases via ADO in threads. 5 | *) 6 | 7 | interface 8 | 9 | uses 10 | Winapi.Windows, Winapi.Messages, 11 | System.SysUtils, System.Variants, System.Classes, System.UITypes, 12 | Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls, 13 | Vcl.ExtCtrls, Vcl.Buttons, Vcl.Grids, 14 | ADODB, 15 | DatabaseThread, Vcl.ComCtrls, Vcl.Imaging.GIFImg; 16 | 17 | type 18 | TfrmDemoDatabase = class(TfrmDemoBase) 19 | Label12: TLabel; 20 | Panel1: TPanel; 21 | Label4: TLabel; 22 | txtConnStr: TEdit; 23 | btnConnStr: TSpeedButton; 24 | Panel2: TPanel; 25 | Label2: TLabel; 26 | txtSql: TMemo; 27 | Panel3: TPanel; 28 | btnExec: TBitBtn; 29 | gData: TStringGrid; 30 | pSpinner: TPanel; 31 | imgSpinner: TImage; 32 | procedure btnExecClick(Sender: TObject); 33 | procedure btnConnStrClick(Sender: TObject); 34 | procedure FormCreate(Sender: TObject); 35 | procedure FormResize(Sender: TObject); 36 | private 37 | procedure ThreadData(Sender: TObject; Dataset: TLightDataset); 38 | procedure ThreadException(Sender: TObject; E: Exception); 39 | procedure LoadDataIntoGrid(AData: TLightDataset); 40 | procedure ClearGrid; 41 | public 42 | procedure SetEnabledState(const Enabled: Boolean); override; 43 | end; 44 | 45 | var 46 | frmDemoDatabase: TfrmDemoDatabase; 47 | 48 | implementation 49 | 50 | {$R *.dfm} 51 | 52 | procedure TfrmDemoDatabase.ClearGrid; 53 | begin 54 | gData.RowCount:= 2; 55 | gData.ColCount:= 1; 56 | gData.Cols[0].Clear; 57 | end; 58 | 59 | procedure TfrmDemoDatabase.FormCreate(Sender: TObject); 60 | begin 61 | inherited; 62 | imgSpinner.Align:= alClient; 63 | pSpinner.Width:= 300; 64 | pSpinner.Height:= 300; 65 | end; 66 | 67 | procedure TfrmDemoDatabase.FormResize(Sender: TObject); 68 | begin 69 | inherited; 70 | pSpinner.Left:= (ClientWidth div 2) - (pSpinner.Width div 2); 71 | pSpinner.Top:= (ClientHeight div 2) - (pSpinner.Height div 2); 72 | end; 73 | 74 | procedure TfrmDemoDatabase.btnConnStrClick(Sender: TObject); 75 | begin 76 | inherited; 77 | txtConnStr.Text:= PromptDataSource(Self.Handle, txtConnStr.Text); 78 | end; 79 | 80 | procedure TfrmDemoDatabase.btnExecClick(Sender: TObject); 81 | var 82 | T: TDatabaseThread; 83 | begin 84 | inherited; 85 | SetEnabledState(False); 86 | ClearGrid; 87 | T:= TDatabaseThread.Create; 88 | T.ConnStr:= Self.txtConnStr.Text; 89 | T.Sql.Assign(Self.txtSql.Lines); 90 | T.OnData:= ThreadData; 91 | T.OnException:= ThreadException; 92 | T.FreeOnTerminate:= True; 93 | T.Start; 94 | //DO NOT TRY TO ACCESS T AFTER THIS POINT since it's FreeOnTerminate 95 | end; 96 | 97 | procedure TfrmDemoDatabase.SetEnabledState(const Enabled: Boolean); 98 | begin 99 | inherited; 100 | btnExec.Enabled:= Enabled; 101 | txtConnStr.Enabled:= Enabled; 102 | txtSql.Enabled:= Enabled; 103 | btnConnStr.Enabled:= Enabled; 104 | pSpinner.Visible:= not Enabled; 105 | TGifImage(imgSpinner.Picture.Graphic).Animate:= not Enabled; 106 | end; 107 | 108 | procedure TfrmDemoDatabase.ThreadData(Sender: TObject; Dataset: TLightDataset); 109 | begin 110 | //Received dataset response from thread... 111 | LoadDataIntoGrid(Dataset); 112 | SetEnabledState(True); 113 | end; 114 | 115 | procedure TfrmDemoDatabase.ThreadException(Sender: TObject; E: Exception); 116 | begin 117 | //Received exception response from thread... 118 | MessageDlg('EXCEPTION: '+E.Message, mtError, [mbOK], 0); 119 | SetEnabledState(True); 120 | end; 121 | 122 | procedure TfrmDemoDatabase.LoadDataIntoGrid(AData: TLightDataset); 123 | var 124 | X: Integer; 125 | begin 126 | 127 | //Set grid size... 128 | gData.ColCount:= AData.ColCount; 129 | if AData.RowCount > 1 then 130 | gData.RowCount:= AData.RowCount+1 131 | else 132 | gData.RowCount:= 2; 133 | 134 | //Column headers... 135 | for X := 0 to AData.ColCount-1 do begin 136 | gData.Cells[X, 0]:= AData.Cols[X]; 137 | end; 138 | 139 | //Rows of data... 140 | for X := 0 to AData.RowCount-1 do begin 141 | //Since the grid's rows support assigning a complete list of values... 142 | gData.Rows[X+1].Assign(AData.Rows[X]); 143 | end; 144 | 145 | end; 146 | 147 | end. 148 | -------------------------------------------------------------------------------- /DemoDownload/DownloadThread.pas: -------------------------------------------------------------------------------- 1 | unit DownloadThread; 2 | 3 | (* 4 | This unit contains functionality for downloading a file from the web. 5 | There are 3 different demonstrations to do so: 6 | - Without a Thread - Call "DownloadFile" procedure directly. 7 | - With a Thread Class - Create instance of TDownloadThread, assign callback, and start. 8 | - With an Anonymous Thread - Call "DownloadFileAnonymous" procedure and wait for callback. 9 | *) 10 | 11 | interface 12 | 13 | uses 14 | System.Classes, System.SysUtils, IdHTTP; 15 | 16 | type 17 | 18 | //This event type is used to pass back the completion of a downloaded file. 19 | TDownloadDoneEvent = procedure(Sender: TObject; const Success: Boolean) of object; 20 | 21 | //This is a dedicated thread class for the purpose of downloading a file. 22 | TDownloadThread = class(TThread) 23 | private 24 | FUrl: String; 25 | FFilename: String; 26 | FSuccess: Boolean; //Used internally when synchronizing success of download on completion. 27 | FOnFinished: TDownloadDoneEvent; 28 | procedure SetFilename(const Value: String); 29 | procedure SetURL(const Value: String); 30 | protected 31 | procedure Execute; override; //Note the "override" because it's called internally. 32 | procedure SYNC_OnFinished; //Note that there are no parameters on this method. 33 | public 34 | constructor Create; reintroduce; //Note the "reintroduce" because we want to hide the original. 35 | destructor Destroy; override; 36 | property URL: String read FURL write SetURL; //The URL to be downloaded. 37 | property Filename: String read FFilename write SetFilename; //The local filename to save file to. 38 | property OnFinished: TDownloadDoneEvent read FOnFinished write FOnFinished; //Triggered upon completion. 39 | end; 40 | 41 | 42 | function DownloadFile(const URL: String; const Filename: String): Boolean; 43 | 44 | procedure DownloadFileAnonymous(const URL: String; const Filename: String; 45 | const OnFinished: TDownloadDoneEvent); 46 | 47 | 48 | implementation 49 | 50 | 51 | function DownloadFile(const URL: String; const Filename: String): Boolean; 52 | var 53 | Cli: TIdHTTP; 54 | FS: TFileStream; 55 | begin 56 | //This is the core function for downloading ANY file using ANY method. 57 | // All 3 methods use this. The function itself does NOT run in the context 58 | // of any particular thread, but instead by whatever thread called it. 59 | 60 | Cli:= TIdHTTP.Create(nil); 61 | try 62 | //We're setting a custom user agent because our friends at ThinkBroadband.com 63 | // wish to be able to explicitly track requests coming from this demo app, 64 | // in order to prevent yourself from getting blacklisted. 65 | Cli.Request.UserAgent:= 'Mozilla/5.0 (compatible; JD Thread Demo)'; 66 | 67 | FS:= TFileStream.Create(Filename, fmCreate); 68 | try 69 | 70 | //Now that we've created an instance of TIdHTTP and TFileStream, 71 | // we can actually download the file. If you wish, you could download 72 | // it in chunks so that you can monitor the progress of the download, 73 | // and trigger synchronized events along the way. 74 | Cli.Get(Url, FS); 75 | 76 | //As long as we get this far, it means the file downloaded successfully 77 | // without any exceptions. Therefore, we will toggle the result. 78 | Result:= True; 79 | 80 | finally 81 | FreeAndNil(FS); 82 | end; 83 | finally 84 | FreeAndNil(Cli); 85 | //I use FreeAndNil() instead of .Free just because the Delphi code insight 86 | // often likes to lie and complain that .Free does not exist. 87 | end; 88 | 89 | end; 90 | 91 | procedure DownloadFileAnonymous(const URL: String; const Filename: String; 92 | const OnFinished: TDownloadDoneEvent); 93 | var 94 | Success: Boolean; 95 | begin 96 | //An anonymous thread is one which we don't track at all. We don't even 97 | // declare a variable for it. Note the call to TThread.Synchronize, 98 | // which passes nil first, to define the current thread context. 99 | TThread.CreateAnonymousThread( 100 | procedure 101 | begin 102 | //Now we're working in the context of a new thread. 103 | //Whatever happens here does not affect the main UI thread... 104 | try 105 | //Let's actually download the file now. 106 | Success:= DownloadFile(URL, Filename); 107 | except 108 | on E: Exception do begin 109 | //You're gonna want to handle this. 110 | end; 111 | end; 112 | //...until you synchronize... 113 | TThread.Synchronize(nil, 114 | procedure 115 | begin 116 | //Now, we are working in the context of the VCL thread. 117 | // It's safe to trigger these events back to the caller. 118 | if Assigned(OnFinished) then 119 | OnFinished(nil, Success); 120 | end 121 | ); 122 | end 123 | ).Start; 124 | //Don't forget to call .Start at the end. That gets me every time too. 125 | // I even made the mistake of forgetting it while writing this example. 126 | // The code means nothing until you actually start it, the same as 127 | // when you call .Start on a regular TThread object. 128 | end; 129 | 130 | { TDownloadThread } 131 | 132 | constructor TDownloadThread.Create; 133 | begin 134 | inherited Create(True); 135 | //Code here does NOT run in the context of this thread, but by the calling thread. 136 | 137 | end; 138 | 139 | destructor TDownloadThread.Destroy; 140 | begin 141 | //Code here does NOT run in the context of this thread, but by the calling thread. 142 | 143 | inherited; 144 | end; 145 | 146 | procedure TDownloadThread.Execute; 147 | begin 148 | //The actual thread's work starts here. Remember, all code placed here, 149 | // and all code which is accessed from here, runs in the context of THIS thread. 150 | // Note how this entire unit does not even contain ANYTHING related to the UI/VCL. 151 | //Some threads perform an infinite loop, which break when the thread is terminated. 152 | // In this case, we only download once, so there will be no loop. 153 | 154 | try 155 | //Here is where we call the main function to download the file. 156 | FSuccess:= DownloadFile(FUrl, FFilename); 157 | except 158 | on E: Exception do begin 159 | //Here, you would handle any exception(s) and synchronize other events accordingly. 160 | // In the case of this demo, I will not be handling this as it's irrelevant to the purpose. 161 | // But you would need to make sure you handle this. 162 | end; 163 | end; 164 | 165 | //Here's the important part. We SYNCHRONIZE this event to inform the calling thread 166 | // that the download has finished. You cannot trigger the event directly, 167 | // because that would in turn run in the context of THIS thread. But you need 168 | // to make sure it runs in the context of the MAIN thread. 169 | Synchronize(SYNC_OnFinished); 170 | 171 | end; 172 | 173 | procedure TDownloadThread.SetFilename(const Value: String); 174 | begin 175 | FFilename := Value; 176 | end; 177 | 178 | procedure TDownloadThread.SetURL(const Value: String); 179 | begin 180 | FURL := Value; 181 | end; 182 | 183 | procedure TDownloadThread.SYNC_OnFinished; 184 | begin 185 | //This is the method called from "Synchronize()". All code run from "Synchronize()" 186 | // runs in the context of the Main VCL UI Thread, NOT from this thread. 187 | // This simply triggers the event which was assigned by the calling thread 188 | // to inform it that the download has completed. 189 | if Assigned(FOnFinished) then 190 | FOnFinished(Self, FSuccess); 191 | end; 192 | 193 | end. 194 | -------------------------------------------------------------------------------- /DemoDownload/uDemoDownload.pas: -------------------------------------------------------------------------------- 1 | unit uDemoDownload; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, 7 | System.SysUtils, System.Variants, System.Classes, 8 | Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, 9 | Vcl.Buttons, Vcl.ExtCtrls, 10 | ShellApi, 11 | uDemoBase, 12 | DownloadThread; 13 | 14 | type 15 | //Used to keep track of which mode is currently being usedl 16 | TDownloadMode = (dmDirect, dmThread, dmAnon); 17 | 18 | TfrmDemoDownload = class(TfrmDemoBase) 19 | Label4: TLabel; 20 | lblDownloadProgress: TLabel; 21 | Panel1: TPanel; 22 | Label1: TLabel; 23 | txtDownloadURL: TEdit; 24 | Panel2: TPanel; 25 | Label3: TLabel; 26 | btnDownloadSaveBrowse: TSpeedButton; 27 | txtDownloadFilename: TEdit; 28 | Panel3: TPanel; 29 | btnDownloadWithoutThread: TBitBtn; 30 | btnDownloadWithThreadClass: TBitBtn; 31 | btnDownloadWithAnonymousThread: TBitBtn; 32 | dlgDownloadSave: TSaveDialog; 33 | Label2: TLabel; 34 | Label12: TLabel; 35 | procedure btnDownloadSaveBrowseClick(Sender: TObject); 36 | procedure btnDownloadWithoutThreadClick(Sender: TObject); 37 | procedure btnDownloadWithThreadClassClick(Sender: TObject); 38 | procedure btnDownloadWithAnonymousThreadClick(Sender: TObject); 39 | procedure FormCreate(Sender: TObject); 40 | procedure Label2Click(Sender: TObject); 41 | private 42 | FMode: TDownloadMode; 43 | procedure DownloadFinished(Sender: TObject; const Success: Boolean); 44 | public 45 | procedure SetEnabledState(const Enabled: Boolean); override; 46 | end; 47 | 48 | var 49 | frmDemoDownload: TfrmDemoDownload; 50 | 51 | implementation 52 | 53 | {$R *.dfm} 54 | 55 | uses 56 | System.IOUtils; 57 | 58 | procedure TfrmDemoDownload.FormCreate(Sender: TObject); 59 | var 60 | Def: String; 61 | begin 62 | inherited; 63 | 64 | //Define default download directory and filename... 65 | Def:= TPath.Combine(TPath.GetHomePath, 'Thread Demo'); 66 | ForceDirectories(Def); 67 | Def:= TPath.Combine(Def, 'TestFile.zip'); 68 | Self.txtDownloadFilename.Text:= Def; 69 | 70 | end; 71 | 72 | procedure TfrmDemoDownload.Label2Click(Sender: TObject); 73 | var 74 | URL: string; 75 | begin 76 | Inherited; 77 | URL := 'https://www.thinkbroadband.com/download'; 78 | ShellExecute(0, 'open', PChar(URL), nil, nil, SW_SHOWNORMAL); 79 | end; 80 | 81 | procedure TfrmDemoDownload.SetEnabledState(const Enabled: Boolean); 82 | begin 83 | inherited; 84 | 85 | //Update UI based on current download state... 86 | Self.btnDownloadWithoutThread.Enabled:= Enabled; 87 | Self.btnDownloadWithThreadClass.Enabled:= Enabled; 88 | Self.btnDownloadWithAnonymousThread.Enabled:= Enabled; 89 | Self.txtDownloadURL.Enabled:= Enabled; 90 | Self.txtDownloadFilename.Enabled:= Enabled; 91 | Self.btnDownloadSaveBrowse.Enabled:= Enabled; 92 | if Enabled = False then begin 93 | case FMode of 94 | dmDirect: Self.lblDownloadProgress.Caption:= 'Downloading directly, this will freeze this window...'; 95 | dmThread: Self.lblDownloadProgress.Caption:= 'Downloading with thread class, UI is responsive...'; 96 | dmAnon: Self.lblDownloadProgress.Caption:= 'Downloading with anonymous thread, UI is responsive...'; 97 | end; 98 | end; 99 | 100 | //Make sure the UI updates before the process starts... 101 | Application.ProcessMessages; 102 | 103 | end; 104 | 105 | procedure TfrmDemoDownload.btnDownloadSaveBrowseClick(Sender: TObject); 106 | begin 107 | inherited; 108 | 109 | //Prompt user where to save downloaded file... 110 | dlgDownloadSave.FileName:= txtDownloadFilename.Text; 111 | if dlgDownloadSave.Execute then begin 112 | Self.txtDownloadFilename.Text:= Self.dlgDownloadSave.FileName; 113 | end; 114 | 115 | end; 116 | 117 | procedure TfrmDemoDownload.btnDownloadWithoutThreadClick(Sender: TObject); 118 | var 119 | Res: Boolean; 120 | begin 121 | inherited; 122 | 123 | //Download the file without using any thread... 124 | FMode:= TDownloadMode.dmDirect; 125 | 126 | Self.SetEnabledState(False); 127 | try 128 | //Once you start this, the UI will freeze to a death... 129 | Res:= DownloadFile(Self.txtDownloadURL.Text, Self.txtDownloadFilename.Text); 130 | finally 131 | SetEnabledState(True); 132 | end; 133 | 134 | //Signal UI that download is done... 135 | DownloadFinished(Self, Res); 136 | 137 | end; 138 | 139 | procedure TfrmDemoDownload.btnDownloadWithThreadClassClick(Sender: TObject); 140 | var 141 | T: TDownloadThread; 142 | begin 143 | inherited; 144 | 145 | //Download the file using a TThread class... 146 | FMode:= TDownloadMode.dmThread; 147 | SetEnabledState(False); 148 | 149 | T:= TDownloadThread.Create; 150 | T.URL:= txtDownloadURL.Text; 151 | T.Filename:= txtDownloadFilename.Text; 152 | T.OnFinished:= DownloadFinished; 153 | T.FreeOnTerminate:= True; 154 | T.Start; 155 | //Aaaaaand we need to FORGET about T from here on out. Trying to access 156 | // it is not allowed when FreeOnTerminate is enabled. Once it's started, 157 | // that's the point of no return. It's like sending a horse with a wagon 158 | // of dynamite out to a target. 159 | 160 | //The handler which was provided to T.OnFinished will be triggered 161 | // when it's done, and will run in the context of the main thread. 162 | 163 | end; 164 | 165 | procedure TfrmDemoDownload.btnDownloadWithAnonymousThreadClick(Sender: TObject); 166 | begin 167 | inherited; 168 | 169 | //Download the file using an anonymous thread... 170 | FMode:= TDownloadMode.dmAnon; 171 | SetEnabledState(False); 172 | DownloadThread.DownloadFileAnonymous(Self.txtDownloadURL.Text, Self.txtDownloadFilename.Text, 173 | DownloadFinished); 174 | //Absolutely nothing to track here, even if you wanted to. 175 | end; 176 | 177 | procedure TfrmDemoDownload.DownloadFinished(Sender: TObject; const Success: Boolean); 178 | begin 179 | //A download has completed. 180 | 181 | SetEnabledState(True); 182 | if Success then 183 | Self.lblDownloadProgress.Caption:= 'Download Complete!' 184 | else 185 | Self.lblDownloadProgress.Caption:= 'Download Failed!'; 186 | 187 | //Obviously you would want to know more information here. That's where the 188 | // next demo comes in. It will cover real-time feedback from a thread, 189 | // so you can update your UI safely. 190 | end; 191 | 192 | end. 193 | -------------------------------------------------------------------------------- /DemoHttpServer/HttpServerThread.pas: -------------------------------------------------------------------------------- 1 | unit HttpServerThread; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, System.SysUtils, 7 | Vcl.Buttons, IdTCPConnection, IdTCPClient, IdHTTP, IdBaseComponent, 8 | IdComponent, IdCustomTCPServer, IdCustomHTTPServer, IdHTTPServer, 9 | IdContext; 10 | 11 | type 12 | TSvrContext = class(TIdServerContext) 13 | private 14 | FReq: TIdHttpRequestInfo; 15 | FRes: TIdHttpResponseInfo; 16 | public 17 | procedure Init; 18 | procedure Uninit; 19 | procedure HandleCmd(AReq: TIdHttpRequestInfo; ARes: TIdHttpResponseInfo); 20 | end; 21 | 22 | TSvrThread = class(TThread) 23 | private 24 | FSvr: TIdHTTPServer; 25 | FPort: Integer; 26 | procedure SvrCommand(AContext: TIdContext; 27 | ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); 28 | procedure SvrConnect(AContext: TIdContext); 29 | procedure SvrDisconnect(AContext: TIdContext); 30 | procedure SetPort(const Value: Integer); 31 | protected 32 | procedure Execute; override; 33 | public 34 | constructor Create; reintroduce; 35 | property Port: Integer read FPort write SetPort; 36 | end; 37 | 38 | TCliThread = class(TThread) 39 | private 40 | FResource: String; 41 | procedure SetResource(const Value: String); 42 | protected 43 | procedure Execute; override; 44 | public 45 | constructor Create; reintroduce; 46 | property Resource: String read FResource write SetResource; 47 | end; 48 | 49 | implementation 50 | 51 | { TSvrContext } 52 | 53 | procedure TSvrContext.HandleCmd(AReq: TIdHttpRequestInfo; 54 | ARes: TIdHttpResponseInfo); 55 | var 56 | L: TStringList; 57 | X: Integer; 58 | procedure A(const S: String); 59 | begin 60 | L.Append(S); 61 | end; 62 | begin 63 | FReq:= AReq; 64 | FRes:= ARes; 65 | //TODO: Respond with massive amounts of random data... 66 | 67 | L:= TStringList.Create; 68 | try 69 | A(AReq.URI); 70 | A(''); 71 | for X := 1 to 10000 do begin 72 | A('XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'); 73 | end; 74 | ARes.ContentText:= L.Text; 75 | ARes.ContentType:= 'text/plain'; 76 | finally 77 | L.Free; 78 | end; 79 | 80 | end; 81 | 82 | procedure TSvrContext.Init; 83 | begin 84 | //This is where you can initialize things within the context of this thread. 85 | 86 | end; 87 | 88 | procedure TSvrContext.Uninit; 89 | begin 90 | //On the contrary, make sure anything initialized above is uninitialized here. 91 | 92 | end; 93 | 94 | { TSvrThread } 95 | 96 | constructor TSvrThread.Create; 97 | begin 98 | inherited Create(True); 99 | FPort:= 8008; 100 | end; 101 | 102 | procedure TSvrThread.Execute; 103 | begin 104 | FSvr:= TIdHTTPServer.Create(nil); 105 | try 106 | FSvr.ContextClass:= TSvrContext; 107 | FSvr.DefaultPort:= FPort; 108 | FSvr.OnCommandGet:= SvrCommand; 109 | FSvr.OnCommandOther:= SvrCommand; 110 | FSvr.OnConnect:= SvrConnect; 111 | FSvr.OnDisconnect:= SvrDisconnect; 112 | FSvr.Active:= True; 113 | try 114 | while not Terminated do begin 115 | try 116 | //Nothing... 117 | finally 118 | Sleep(1); 119 | end; 120 | end; 121 | finally 122 | FSvr.Active:= False; 123 | end; 124 | finally 125 | FSvr.Free; 126 | end; 127 | end; 128 | 129 | procedure TSvrThread.SetPort(const Value: Integer); 130 | begin 131 | FPort := Value; 132 | end; 133 | 134 | procedure TSvrThread.SvrConnect(AContext: TIdContext); 135 | var 136 | C: TSvrContext; 137 | begin 138 | C:= TSvrContext(AContext); 139 | C.Init; 140 | end; 141 | 142 | procedure TSvrThread.SvrDisconnect(AContext: TIdContext); 143 | var 144 | C: TSvrContext; 145 | begin 146 | C:= TSvrContext(AContext); 147 | C.Uninit; 148 | end; 149 | 150 | procedure TSvrThread.SvrCommand(AContext: TIdContext; 151 | ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); 152 | var 153 | C: TSvrContext; 154 | begin 155 | C:= TSvrContext(AContext); 156 | C.HandleCmd(ARequestInfo, AResponseInfo); 157 | end; 158 | 159 | { TCliThread } 160 | 161 | constructor TCliThread.Create; 162 | begin 163 | inherited Create(True); 164 | FResource:= '/GetSomething'; 165 | end; 166 | 167 | procedure TCliThread.Execute; 168 | var 169 | C: TIdHTTP; 170 | begin 171 | C:= TIdHTTP.Create(nil); 172 | try 173 | 174 | finally 175 | C.Free; 176 | end; 177 | Terminate; 178 | end; 179 | 180 | procedure TCliThread.SetResource(const Value: String); 181 | begin 182 | FResource := Value; 183 | end; 184 | 185 | end. 186 | -------------------------------------------------------------------------------- /DemoHttpServer/uDemoHttpServer.pas: -------------------------------------------------------------------------------- 1 | unit uDemoHttpServer; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls, Vcl.ExtCtrls, 8 | Vcl.Buttons, IdTCPConnection, IdTCPClient, IdHTTP, IdBaseComponent, 9 | IdComponent, IdCustomTCPServer, IdCustomHTTPServer, IdHTTPServer, 10 | IdContext, 11 | HttpServerThread, 12 | Vcl.Samples.Spin, Vcl.ComCtrls; 13 | 14 | type 15 | 16 | TfrmDemoHttpServer = class(TfrmDemoBase) 17 | pMain: TPanel; 18 | pSvr: TPanel; 19 | pCli: TPanel; 20 | Label2: TLabel; 21 | Label3: TLabel; 22 | Panel5: TPanel; 23 | btnSvrStart: TBitBtn; 24 | btnSvrStop: TBitBtn; 25 | Svr: TIdHTTPServer; 26 | Panel4: TPanel; 27 | Label4: TLabel; 28 | sePort: TSpinEdit; 29 | lstClients: TListView; 30 | Label5: TLabel; 31 | Label12: TLabel; 32 | lstConnections: TListView; 33 | procedure pMainResize(Sender: TObject); 34 | procedure FormCreate(Sender: TObject); 35 | procedure btnSvrStartClick(Sender: TObject); 36 | procedure btnSvrStopClick(Sender: TObject); 37 | procedure SvrConnect(AContext: TIdContext); 38 | procedure SvrDisconnect(AContext: TIdContext); 39 | private 40 | 41 | public 42 | procedure SetEnabledState(const Enabled: Boolean); override; 43 | end; 44 | 45 | var 46 | frmDemoHttpServer: TfrmDemoHttpServer; 47 | 48 | implementation 49 | 50 | {$R *.dfm} 51 | 52 | procedure TfrmDemoHttpServer.btnSvrStartClick(Sender: TObject); 53 | begin 54 | inherited; 55 | SetEnabledState(True); 56 | Svr.DefaultPort:= sePort.Value; 57 | Svr.Active:= True; 58 | end; 59 | 60 | procedure TfrmDemoHttpServer.btnSvrStopClick(Sender: TObject); 61 | begin 62 | inherited; 63 | SetEnabledState(False); 64 | Svr.Active:= False; 65 | end; 66 | 67 | procedure TfrmDemoHttpServer.FormCreate(Sender: TObject); 68 | begin 69 | inherited; 70 | pMain.Align:= alClient; 71 | lstClients.Align:= alClient; 72 | sePort.Align:= alLeft; 73 | end; 74 | 75 | procedure TfrmDemoHttpServer.pMainResize(Sender: TObject); 76 | var 77 | H: Integer; 78 | begin 79 | inherited; 80 | H:= (pMain.ClientWidth div 2) - 1; 81 | pSvr.Width:= H; 82 | pCli.Width:= H; 83 | end; 84 | 85 | procedure TfrmDemoHttpServer.SetEnabledState(const Enabled: Boolean); 86 | begin 87 | inherited; 88 | 89 | btnSvrStart.Enabled:= not Enabled; 90 | btnSvrStop.Enabled:= Enabled; 91 | sePort.Enabled:= not Enabled; 92 | 93 | end; 94 | 95 | procedure TfrmDemoHttpServer.SvrConnect(AContext: TIdContext); 96 | begin 97 | inherited; 98 | // 99 | end; 100 | 101 | procedure TfrmDemoHttpServer.SvrDisconnect(AContext: TIdContext); 102 | begin 103 | inherited; 104 | // 105 | end; 106 | 107 | end. 108 | -------------------------------------------------------------------------------- /DemoHurtMyCpu/CpuMonitor.pas: -------------------------------------------------------------------------------- 1 | unit CpuMonitor; 2 | 3 | (* 4 | Unit grabbed from the following Stack Overflow answer: 5 | https://stackoverflow.com/questions/33571061/get-the-percentage-of-total-cpu-usage 6 | 7 | Strictly speaking, this itself can be encapsulated inside of a thread with 8 | a delay which can trigger events, similar to a timer, informing of the 9 | latest processer usage of the computer. It's also anticipated to break 10 | down the usage of each individual CPU core, instead of overall. 11 | The mechanism used already supports monitoring the usage of a particular 12 | process, so it may be optimized to only this process. 13 | *) 14 | 15 | interface 16 | 17 | /// 18 | /// Acquires the current percentage of usage of the computer's processor(s). 19 | /// 20 | function GetTotalCpuUsagePct: Double; 21 | 22 | implementation 23 | 24 | uses 25 | System.SysUtils, System.DateUtils, System.Generics.Collections, 26 | Winapi.Windows, Winapi.PsAPI, Winapi.TlHelp32, Winapi.ShellAPI; 27 | 28 | type 29 | TProcessID = DWORD; 30 | 31 | TSystemTimesRec = record 32 | KernelTime: TFileTIme; 33 | UserTime: TFileTIme; 34 | end; 35 | 36 | TProcessTimesRec = record 37 | KernelTime: TFileTIme; 38 | UserTime: TFileTIme; 39 | end; 40 | 41 | TProcessCpuUsage = class 42 | LastSystemTimes: TSystemTimesRec; 43 | LastProcessTimes: TProcessTimesRec; 44 | ProcessCPUusagePercentage: Double; 45 | end; 46 | 47 | TProcessCpuUsageList = TObjectDictionary; 48 | 49 | var 50 | LatestProcessCpuUsageCache : TProcessCpuUsageList; 51 | //LastQueryTime : TDateTime; 52 | 53 | (* -------------------------------------------------------------------------- *) 54 | 55 | function GetRunningProcessIDs: TArray; 56 | var 57 | SnapProcHandle: THandle; 58 | ProcEntry: TProcessEntry32; 59 | NextProc: Boolean; 60 | begin 61 | SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); 62 | if SnapProcHandle <> INVALID_HANDLE_VALUE then 63 | begin 64 | try 65 | ProcEntry.dwSize := SizeOf(ProcEntry); 66 | NextProc := Process32First(SnapProcHandle, ProcEntry); 67 | while NextProc do 68 | begin 69 | SetLength(Result, Length(Result) + 1); 70 | Result[Length(Result) - 1] := ProcEntry.th32ProcessID; 71 | NextProc := Process32Next(SnapProcHandle, ProcEntry); 72 | end; 73 | finally 74 | CloseHandle(SnapProcHandle); 75 | end; 76 | TArray.Sort(Result); 77 | end; 78 | end; 79 | 80 | (* -------------------------------------------------------------------------- *) 81 | 82 | function GetProcessCpuUsagePct(ProcessID: TProcessID): Double; 83 | function SubtractFileTime(FileTime1: TFileTIme; FileTime2: TFileTIme): TFileTIme; 84 | begin 85 | Result := TFileTIme(Int64(FileTime1) - Int64(FileTime2)); 86 | end; 87 | 88 | var 89 | ProcessCpuUsage: TProcessCpuUsage; 90 | ProcessHandle: THandle; 91 | SystemTimes: TSystemTimesRec; 92 | SystemDiffTimes: TSystemTimesRec; 93 | ProcessDiffTimes: TProcessTimesRec; 94 | ProcessTimes: TProcessTimesRec; 95 | 96 | SystemTimesIdleTime: TFileTime; 97 | ProcessTimesCreationTime: TFileTime; 98 | ProcessTimesExitTime: TFileTime; 99 | begin 100 | Result := 0.0; 101 | 102 | LatestProcessCpuUsageCache.TryGetValue(ProcessID, ProcessCpuUsage); 103 | if ProcessCpuUsage = nil then 104 | begin 105 | ProcessCpuUsage := TProcessCpuUsage.Create; 106 | LatestProcessCpuUsageCache.Add(ProcessID, ProcessCpuUsage); 107 | end; 108 | // method from: 109 | // http://www.philosophicalgeek.com/2009/01/03/determine-cpu-usage-of-current-process-c-and-c/ 110 | ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID); 111 | if ProcessHandle <> 0 then 112 | begin 113 | try 114 | if GetSystemTimes(SystemTimesIdleTime, SystemTimes.KernelTime, SystemTimes.UserTime) then 115 | begin 116 | SystemDiffTimes.KernelTime := SubtractFileTime(SystemTimes.KernelTime, ProcessCpuUsage.LastSystemTimes.KernelTime); 117 | SystemDiffTimes.UserTime := SubtractFileTime(SystemTimes.UserTime, ProcessCpuUsage.LastSystemTimes.UserTime); 118 | ProcessCpuUsage.LastSystemTimes := SystemTimes; 119 | if GetProcessTimes(ProcessHandle, ProcessTimesCreationTime, ProcessTimesExitTime, ProcessTimes.KernelTime, ProcessTimes.UserTime) then 120 | begin 121 | ProcessDiffTimes.KernelTime := SubtractFileTime(ProcessTimes.KernelTime, ProcessCpuUsage.LastProcessTimes.KernelTime); 122 | ProcessDiffTimes.UserTime := SubtractFileTime(ProcessTimes.UserTime, ProcessCpuUsage.LastProcessTimes.UserTime); 123 | ProcessCpuUsage.LastProcessTimes := ProcessTimes; 124 | if (Int64(SystemDiffTimes.KernelTime) + Int64(SystemDiffTimes.UserTime)) > 0 then 125 | Result := (Int64(ProcessDiffTimes.KernelTime) + Int64(ProcessDiffTimes.UserTime)) / (Int64(SystemDiffTimes.KernelTime) + Int64(SystemDiffTimes.UserTime)) * 100; 126 | end; 127 | end; 128 | finally 129 | CloseHandle(ProcessHandle); 130 | end; 131 | end; 132 | end; 133 | 134 | (* -------------------------------------------------------------------------- *) 135 | 136 | procedure DeleteNonExistingProcessIDsFromCache(const RunningProcessIDs : TArray); 137 | var 138 | FoundKeyIdx: Integer; 139 | Keys: TArray; 140 | n: Integer; 141 | begin 142 | Keys := LatestProcessCpuUsageCache.Keys.ToArray; 143 | for n := Low(Keys) to High(Keys) do 144 | begin 145 | if not TArray.BinarySearch(RunningProcessIDs, Keys[n], FoundKeyIdx) then 146 | LatestProcessCpuUsageCache.Remove(Keys[n]); 147 | end; 148 | end; 149 | 150 | (* -------------------------------------------------------------------------- *) 151 | 152 | function GetTotalCpuUsagePct(): Double; 153 | var 154 | ProcessID: TProcessID; 155 | RunningProcessIDs : TArray; 156 | begin 157 | Result := 0.0; 158 | RunningProcessIDs := GetRunningProcessIDs; 159 | 160 | DeleteNonExistingProcessIDsFromCache(RunningProcessIDs); 161 | 162 | for ProcessID in RunningProcessIDs do 163 | Result := Result + GetProcessCpuUsagePct( ProcessID ); 164 | 165 | end; 166 | 167 | (* -------------------------------------------------------------------------- *) 168 | 169 | initialization 170 | LatestProcessCpuUsageCache := TProcessCpuUsageList.Create( [ doOwnsValues ] ); 171 | // init: 172 | GetTotalCpuUsagePct; 173 | finalization 174 | LatestProcessCpuUsageCache.Free; 175 | end. 176 | -------------------------------------------------------------------------------- /DemoHurtMyCpu/HurtMyCpuThread.pas: -------------------------------------------------------------------------------- 1 | unit HurtMyCpuThread; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, System.SysUtils, System.SyncObjs; 7 | 8 | type 9 | THurtMyCpuThread = class; 10 | 11 | TThreadRefEvent = procedure(ARef: THurtMyCpuThread) of object; 12 | 13 | TThreadIsTerminated = function: Boolean of object; 14 | 15 | /// 16 | /// A simple thread with the sole purpose of consuming 100% 17 | /// of a single processor core (or divided among them as Windows does). 18 | /// 19 | THurtMyCpuThread = class(TThread) 20 | private 21 | FCountTo: Int64; 22 | FCur: Int64; 23 | FLock: TCriticalSection; 24 | FOnDeleteRef: TThreadRefEvent; 25 | FOnAddRef: TThreadRefEvent; 26 | protected 27 | procedure Execute; override; 28 | public 29 | constructor Create(ACountTo: Int64); reintroduce; 30 | destructor Destroy; override; 31 | property Cur: Int64 read FCur; 32 | property CountTo: Int64 read FCountTo write FCountTo; 33 | procedure Lock; 34 | procedure Unlock; 35 | public 36 | property OnAddRef: TThreadRefEvent read FOnAddRef write FOnAddRef; 37 | property OnDeleteRef: TThreadRefEvent read FOnDeleteRef write FOnDeleteRef; 38 | end; 39 | 40 | implementation 41 | 42 | { THurtMyCpuThread } 43 | 44 | constructor THurtMyCpuThread.Create(ACountTo: Int64); 45 | begin 46 | inherited Create(True); 47 | FCountTo:= ACountTo; 48 | FLock:= TCriticalSection.Create; 49 | end; 50 | 51 | destructor THurtMyCpuThread.Destroy; 52 | begin 53 | FLock.Enter; 54 | try 55 | finally 56 | FLock.Leave; 57 | end; 58 | FreeAndNil(FLock); 59 | inherited; 60 | end; 61 | 62 | {$HINTS OFF} 63 | procedure THurtMyCpuThread.Execute; 64 | var 65 | X, Z: Int64; 66 | {$IFDEF DBL_LVL} 67 | Y: Int64; 68 | {$ENDIF} 69 | begin 70 | 71 | try 72 | Synchronize( 73 | procedure 74 | begin 75 | if Assigned(FOnAddRef) then 76 | FOnAddRef(Self); 77 | end); 78 | 79 | for X := 1 to FCountTo do begin 80 | if Terminated then Break; 81 | {$IFDEF DBL_LVL} 82 | for Y := 1 to MAXINT_JD do begin 83 | {$ENDIF} 84 | if Terminated then Break; 85 | Lock; 86 | try 87 | if Terminated then Break; 88 | 89 | //This is the calculation which actually hurts the CPU 90 | // by executing it rapidly with no delay over and over... 91 | Z:= Round(X/2); 92 | 93 | //TODO: Think of something heavier... 94 | 95 | FCur:= X; 96 | finally 97 | Unlock; 98 | end; 99 | {$IFDEF DBL_LVL} 100 | end; 101 | {$ENDIF} 102 | end; 103 | 104 | Synchronize( 105 | procedure 106 | begin 107 | if Assigned(FOnDeleteRef) then 108 | FOnDeleteRef(Self); 109 | end); 110 | 111 | finally 112 | FreeOnTerminate:= True; 113 | Terminate; 114 | end; 115 | 116 | end; 117 | {$HINTS ON} 118 | 119 | procedure THurtMyCpuThread.Lock; 120 | begin 121 | FLock.Enter; 122 | end; 123 | 124 | procedure THurtMyCpuThread.Unlock; 125 | begin 126 | FLock.Leave; 127 | end; 128 | 129 | end. 130 | -------------------------------------------------------------------------------- /DemoHurtMyCpu/uDemoHurtMyCpu.pas: -------------------------------------------------------------------------------- 1 | unit uDemoHurtMyCpu; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.ExtCtrls, Vcl.StdCtrls, 8 | Vcl.Buttons, Vcl.ComCtrls, 9 | System.SyncObjs, System.Generics.Collections, 10 | HurtMyCpuThread, 11 | CpuMonitor; 12 | 13 | type 14 | TfrmDemoHurtMyCpu = class(TfrmDemoBase) 15 | lblWarning: TLabel; 16 | lstThreads: TListView; 17 | Panel1: TPanel; 18 | Label1: TLabel; 19 | btnSpawn: TBitBtn; 20 | btnStop: TBitBtn; 21 | txtCountTo: TEdit; 22 | Tmr: TTimer; 23 | Label12: TLabel; 24 | Bevel1: TBevel; 25 | procedure FormCreate(Sender: TObject); 26 | procedure FormDestroy(Sender: TObject); 27 | procedure FormClose(Sender: TObject; var Action: TCloseAction); 28 | procedure btnSpawnClick(Sender: TObject); 29 | procedure btnStopClick(Sender: TObject); 30 | procedure TmrTimer(Sender: TObject); 31 | procedure lstThreadsCustomDrawSubItem(Sender: TCustomListView; 32 | Item: TListItem; SubItem: Integer; State: TCustomDrawState; 33 | var DefaultDraw: Boolean); 34 | procedure lstThreadsCustomDrawItem(Sender: TCustomListView; Item: TListItem; 35 | State: TCustomDrawState; var DefaultDraw: Boolean); 36 | procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); 37 | private 38 | FLock: TCriticalSection; 39 | FThreads: TObjectList; 40 | FTerminated: Boolean; 41 | procedure DoSpawn(const CountTo: Integer); 42 | public 43 | procedure AddRef(ARef: THurtMyCpuThread); 44 | procedure DeleteRef(ARef: THurtMyCpuThread); 45 | procedure UpdateRef(ARef: THurtMyCpuThread); 46 | function IsTerminated: Boolean; 47 | end; 48 | 49 | var 50 | frmDemoHurtMyCpu: TfrmDemoHurtMyCpu; 51 | 52 | implementation 53 | 54 | {$R *.dfm} 55 | 56 | uses 57 | UICommon; 58 | 59 | { TfrmDemoHurtMyCpu } 60 | 61 | procedure TfrmDemoHurtMyCpu.FormCreate(Sender: TObject); 62 | begin 63 | inherited; 64 | {$IFDEF DEBUG} 65 | ReportMemoryLeaksOnShutdown:= True; 66 | {$ENDIF} 67 | lblWarning.Caption:= 'WARNING: If you spawn more threads than you have CPU cores ('+IntToStr(System.CPUCount)+'), you could lock up your PC!'; 68 | lstThreads.Align:= alClient; 69 | FLock:= TCriticalSection.Create; 70 | FThreads:= TObjectList.Create(False); 71 | end; 72 | 73 | procedure TfrmDemoHurtMyCpu.FormDestroy(Sender: TObject); 74 | begin 75 | inherited; 76 | FreeAndNil(FThreads); 77 | FreeAndNil(FLock); 78 | end; 79 | 80 | function TfrmDemoHurtMyCpu.IsTerminated: Boolean; 81 | begin 82 | Result:= FTerminated; 83 | end; 84 | 85 | procedure TfrmDemoHurtMyCpu.FormClose(Sender: TObject; var Action: TCloseAction); 86 | begin 87 | inherited; 88 | FTerminated:= True; 89 | end; 90 | 91 | procedure TfrmDemoHurtMyCpu.FormCloseQuery(Sender: TObject; 92 | var CanClose: Boolean); 93 | begin 94 | inherited; 95 | Self.btnStopClick(nil); 96 | end; 97 | 98 | procedure TfrmDemoHurtMyCpu.lstThreadsCustomDrawItem(Sender: TCustomListView; 99 | Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean); 100 | begin 101 | inherited; 102 | // 103 | end; 104 | 105 | procedure TfrmDemoHurtMyCpu.lstThreadsCustomDrawSubItem(Sender: TCustomListView; 106 | Item: TListItem; SubItem: Integer; State: TCustomDrawState; 107 | var DefaultDraw: Boolean); 108 | var 109 | Perc: Single; 110 | R: TRect; 111 | T: THurtMyCpuThread; 112 | begin 113 | inherited; 114 | if (SubItem = 3) then begin 115 | DefaultDraw:= False; 116 | FLock.Enter; 117 | try 118 | T:= FThreads[Item.Index]; 119 | T.Lock; 120 | try 121 | Perc:= T.Cur / T.CountTo; 122 | finally 123 | T.Unlock; 124 | end; 125 | finally 126 | FLock.Leave; 127 | end; 128 | R:= ListViewCellRect(Sender, SubItem, Item.Index); 129 | DrawProgressBar(Sender.Canvas, R, Perc); 130 | SetBkMode(Sender.Canvas.Handle, TRANSPARENT); // <- will effect the next [sub]item 131 | end else begin 132 | DefaultDraw:= True; 133 | end; 134 | end; 135 | 136 | procedure TfrmDemoHurtMyCpu.btnSpawnClick(Sender: TObject); 137 | var 138 | T: String; 139 | I: Int64; 140 | begin 141 | T:= txtCountTo.Text; 142 | I:= StrToIntDef(T, 0); 143 | if (I > 0) and (I <= 2147483647) then 144 | DoSpawn(I) 145 | else 146 | raise Exception.Create('Invalid input for "Count To".'); 147 | end; 148 | 149 | procedure TfrmDemoHurtMyCpu.btnStopClick(Sender: TObject); 150 | var 151 | X: Integer; 152 | begin 153 | FLock.Enter; 154 | try 155 | for X := FThreads.Count-1 downto 0 do begin 156 | FThreads[X].Terminate; 157 | end; 158 | finally 159 | FLock.Leave; 160 | end; 161 | end; 162 | 163 | procedure TfrmDemoHurtMyCpu.TmrTimer(Sender: TObject); 164 | var 165 | I: TListItem; 166 | X: Integer; 167 | T: THurtMyCpuThread; 168 | begin 169 | //We do all UI updates inside of a timer, rather than at the moment 170 | // of receiving events from the threads. This is because when events 171 | // are received, the calling worker thread is temporarily blocked until 172 | // the synchronized event is done and returns. Instead, all we do in 173 | // those events is capture the information in a variable, then later 174 | // use it in the timer to update controls in the UI (which is heavier). 175 | 176 | //We also grab information about the current CPU usage, and update 177 | // a progress bar to reflect the current load. 178 | 179 | try 180 | 181 | FLock.Enter; 182 | try 183 | 184 | //Ensure count matches 185 | while lstThreads.Items.Count <> FThreads.Count do begin 186 | if lstThreads.Items.Count < FThreads.Count then begin 187 | //Add a new list item... 188 | I:= lstThreads.Items.Add; 189 | I.SubItems.Add(''); 190 | I.SubItems.Add(''); 191 | I.SubItems.Add(''); 192 | end else begin 193 | //Delete a list item 194 | if lstThreads.Items.Count > 0 then 195 | lstThreads.Items.Delete(0); 196 | end; 197 | end; 198 | 199 | //Update list items to match objects... 200 | for X := 0 to FThreads.Count-1 do begin 201 | T:= FThreads[X]; 202 | I:= lstThreads.Items[X]; 203 | T.Lock; 204 | try 205 | I.Caption:= IntToStr(T.ThreadID); 206 | I.SubItems[0]:= IntToStr(T.Cur); 207 | I.SubItems[1]:= IntToStr(T.CountTo); 208 | //I.SubItems[2]:= FormatFloat('0.000%', (T.Cur / T.CountTo) * 100); 209 | I.Update; 210 | finally 211 | T.Unlock; 212 | end; 213 | end; 214 | 215 | finally 216 | FLock.Leave; 217 | end; 218 | 219 | except 220 | on E: Exception do begin 221 | 222 | end; 223 | end; 224 | 225 | end; 226 | 227 | procedure TfrmDemoHurtMyCpu.AddRef(ARef: THurtMyCpuThread); 228 | begin 229 | FLock.Enter; 230 | try 231 | ARef.Lock; 232 | try 233 | FThreads.Add(ARef); 234 | finally 235 | ARef.Unlock; 236 | end; 237 | finally 238 | FLock.Leave; 239 | end; 240 | end; 241 | 242 | procedure TfrmDemoHurtMyCpu.DeleteRef(ARef: THurtMyCpuThread); 243 | begin 244 | FLock.Enter; 245 | try 246 | ARef.Lock; 247 | try 248 | FThreads.Delete(FThreads.IndexOf(ARef)); 249 | finally 250 | ARef.Unlock; 251 | end; 252 | finally 253 | FLock.Leave; 254 | end; 255 | end; 256 | 257 | procedure TfrmDemoHurtMyCpu.UpdateRef(ARef: THurtMyCpuThread); 258 | begin 259 | FLock.Enter; 260 | try 261 | 262 | finally 263 | FLock.Leave; 264 | end; 265 | end; 266 | 267 | procedure TfrmDemoHurtMyCpu.DoSpawn(const CountTo: Integer); 268 | var 269 | T: THurtMyCpuThread; 270 | begin 271 | //Creates an actual instance of a thread which consumes 100% of a CPU core. 272 | T:= THurtMyCpuThread.Create(CountTo); 273 | T.OnAddRef:= AddRef; 274 | T.OnDeleteRef:= DeleteRef; 275 | T.Start; 276 | end; 277 | 278 | end. 279 | -------------------------------------------------------------------------------- /DemoOmniThreads/uDemoOmniThreads.pas: -------------------------------------------------------------------------------- 1 | unit uDemoOmniThreads; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls; 8 | 9 | type 10 | TfrmDemoOmniThreads = class(TfrmDemoBase) 11 | Label1: TLabel; 12 | Label12: TLabel; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | frmDemoOmniThreads: TfrmDemoOmniThreads; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /DemoProgress/ProgressThread.pas: -------------------------------------------------------------------------------- 1 | unit ProgressThread; 2 | 3 | (* 4 | This unit demonstrates reporting progress of a lengthy task. 5 | It's done in 3 different ways: 6 | - Directly, without any additional thread. 7 | - Using a TThread class. 8 | - Using an Anonymous Thread. 9 | *) 10 | 11 | interface 12 | 13 | uses 14 | System.Classes, System.SysUtils, System.Math; 15 | 16 | type 17 | 18 | TProgressEvent = procedure(Sender: TObject; const Current, Total: Integer; 19 | const Msg: String) of object; 20 | 21 | TProgressThread = class(TThread) 22 | private 23 | FDelay: Integer; 24 | FCurrent: Integer; 25 | FTotal: Integer; 26 | FMessage: String; 27 | FOnProgress: TProgressEvent; 28 | procedure TaskProgress(Sender: TObject; const Current, Total: Integer; 29 | const Msg: String); 30 | protected 31 | procedure Execute; override; 32 | procedure SYNC_OnProgress; 33 | public 34 | constructor Create(ATotal: Integer; ADelay: Integer = 1000); reintroduce; 35 | destructor Destroy; override; 36 | property OnProgress: TProgressEvent read FOnProgress write FOnProgress; 37 | end; 38 | 39 | procedure DoLongTask(ATotal: Integer; ADelay: Integer = 1000; 40 | AOnProgress: TProgressEvent = nil); 41 | 42 | implementation 43 | 44 | procedure DoLongTask(ATotal: Integer; ADelay: Integer = 1000; 45 | AOnProgress: TProgressEvent = nil); 46 | var 47 | X: Integer; 48 | Msg: String; 49 | begin 50 | //This is the root function used to imitate a long task. 51 | // It does not have anything related to any thread. That will all 52 | // be handled outside of this function in various different ways. 53 | for X := 1 to ATotal do begin 54 | Sleep(ADelay); 55 | //We write some fields which will be used. We can't pass these as parameters. 56 | Msg:= 'Currently at '+IntToStr(X)+' of '+IntToStr(ATotal); 57 | 58 | AOnProgress(nil, X, ATotal, Msg); 59 | 60 | end; 61 | AOnProgress(nil, ATotal, ATotal, 'Complete'); 62 | end; 63 | 64 | procedure DoLongTaskAnonymous(ATotal: Integer; ADelay: Integer; 65 | AOnProgress: TProgressEvent); 66 | begin 67 | 68 | { 69 | TThread.CreateAnonymousThread( 70 | procedure 71 | begin 72 | 73 | DoLongTask(ATotal, ADelay, 74 | procedure(Sender: TObject; const Current, Total: Integer; const Msg: String) 75 | begin 76 | TThread.Synchronize(nil, 77 | procedure 78 | begin 79 | if Assigned(AOnProgress) then 80 | AOnProgress(nil, Current, Total, Msg); 81 | end); 82 | end); 83 | 84 | //TODO: Properly implement anonymous thread 85 | 86 | end); 87 | } 88 | 89 | end; 90 | 91 | { TProgressThread } 92 | 93 | constructor TProgressThread.Create(ATotal: Integer; ADelay: Integer = 1000); 94 | begin 95 | inherited Create(True); 96 | FTotal:= ATotal; 97 | FDelay:= ADelay; 98 | end; 99 | 100 | destructor TProgressThread.Destroy; 101 | begin 102 | 103 | inherited; 104 | end; 105 | 106 | procedure TProgressThread.Execute; 107 | begin 108 | //Here, we pass our internal handler, rather than the one provided by caller. 109 | // This is because we will need to synchronize it. 110 | DoLongTask(FTotal, FDelay, TaskProgress); 111 | end; 112 | 113 | procedure TProgressThread.TaskProgress(Sender: TObject; const Current, 114 | Total: Integer; const Msg: String); 115 | begin 116 | //Received event from long task, redirect this event through synchronize 117 | FCurrent:= Current; 118 | FTotal:= Total; 119 | FMessage:= Msg; 120 | //Here we call the REAL event via synchronize, so that it runs 121 | // in the context of the main thread, not this one. 122 | Synchronize(SYNC_OnProgress); 123 | end; 124 | 125 | procedure TProgressThread.SYNC_OnProgress; 126 | begin 127 | //Now we're sure we are running in the context of the main thread. 128 | if Assigned(FOnProgress) then 129 | FOnProgress(Self, FCurrent, FTotal, FMessage); 130 | end; 131 | 132 | end. 133 | -------------------------------------------------------------------------------- /DemoProgress/uDemoProgress.pas: -------------------------------------------------------------------------------- 1 | unit uDemoProgress; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls, Vcl.Buttons, 8 | Vcl.ExtCtrls, Vcl.ComCtrls, 9 | 10 | ProgressThread; 11 | 12 | type 13 | TfrmDemoProgress = class(TfrmDemoBase) 14 | lblProgMsg: TLabel; 15 | Prog: TProgressBar; 16 | Panel5: TPanel; 17 | btnProgressNoThread: TBitBtn; 18 | btnProgressThreadClass: TBitBtn; 19 | btnProgressAnonymous: TBitBtn; 20 | tmrProgress: TTimer; 21 | Label4: TLabel; 22 | Label12: TLabel; 23 | procedure btnProgressNoThreadClick(Sender: TObject); 24 | procedure btnProgressThreadClassClick(Sender: TObject); 25 | procedure btnProgressAnonymousClick(Sender: TObject); 26 | procedure tmrProgressTimer(Sender: TObject); 27 | private 28 | FProgCur: Integer; 29 | FProgTot: Integer; 30 | FProgMsg: String; 31 | procedure ThreadProgress(Sender: TObject; const Current, Total: Integer; 32 | const Msg: String); 33 | public 34 | procedure SetEnabledState(const Enabled: Boolean); override; 35 | end; 36 | 37 | var 38 | frmDemoProgress: TfrmDemoProgress; 39 | 40 | implementation 41 | 42 | {$R *.dfm} 43 | 44 | { TfrmDemoBase1 } 45 | 46 | procedure TfrmDemoProgress.SetEnabledState(const Enabled: Boolean); 47 | begin 48 | inherited; 49 | 50 | //Update UI based on current progress state... 51 | if Enabled = False then 52 | Self.lblProgMsg.Caption:= 'Doing Long Task...'; 53 | 54 | Self.btnProgressNoThread.Enabled:= Enabled; 55 | Self.btnProgressThreadClass.Enabled:= Enabled; 56 | Self.btnProgressAnonymous.Enabled:= False; //TODO: Implement... Enabled; 57 | 58 | //Make sure the UI updates before the process starts... 59 | Application.ProcessMessages; 60 | end; 61 | 62 | procedure TfrmDemoProgress.btnProgressNoThreadClick(Sender: TObject); 63 | begin 64 | inherited; 65 | 66 | //Do long task without another thread... 67 | Self.SetEnabledState(False); 68 | try 69 | DoLongTask(100, 100, ThreadProgress); 70 | finally 71 | Self.SetEnabledState(True); 72 | end; 73 | 74 | end; 75 | 76 | procedure TfrmDemoProgress.btnProgressThreadClassClick(Sender: TObject); 77 | var 78 | T: TProgressThread; 79 | begin 80 | inherited; 81 | 82 | //Do long task in a thread class... 83 | Self.SetEnabledState(False); 84 | T:= TProgressThread.Create(100, 100); 85 | T.OnProgress:= Self.ThreadProgress; 86 | T.FreeOnTerminate:= True; 87 | T.Start; 88 | 89 | end; 90 | 91 | procedure TfrmDemoProgress.btnProgressAnonymousClick(Sender: TObject); 92 | begin 93 | inherited; 94 | 95 | //Do long task in an anonymous thread... 96 | 97 | end; 98 | 99 | procedure TfrmDemoProgress.ThreadProgress(Sender: TObject; const Current, 100 | Total: Integer; const Msg: String); 101 | begin 102 | //Don't directly update the UI here, actually just copy the values 103 | // to local variables, and use a timer to update the UI periodically. 104 | // This way, the thread won't have to be blocked while the UI is updated. 105 | FProgCur:= Current; 106 | FProgTot:= Total; 107 | FProgMsg:= Msg; 108 | if Current = Total then begin 109 | Self.SetEnabledState(True); 110 | Self.lblProgMsg.Caption:= 'Long task complete!'; 111 | end; 112 | Application.ProcessMessages; //NONO! This is known as a "poor man's thread", 113 | // but isn't actually a thread at all! Just a problem causer! 114 | // This is the reason why you would want to use a thread. 115 | end; 116 | 117 | procedure TfrmDemoProgress.tmrProgressTimer(Sender: TObject); 118 | begin 119 | inherited; 120 | 121 | //Update the UI with the progress... 122 | if Prog.Max <> FProgTot then 123 | Prog.Max:= FProgTot; 124 | Prog.Position:= FProgCur; 125 | if FProgCur <> FProgTot then begin 126 | lblProgMsg.Caption:= FProgMsg; 127 | end; 128 | end; 129 | 130 | end. 131 | -------------------------------------------------------------------------------- /DemoQueues/uDemoThreadQueue.pas: -------------------------------------------------------------------------------- 1 | unit uDemoThreadQueue; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls; 8 | 9 | type 10 | TfrmDemoThreadQueue = class(TfrmDemoBase) 11 | Label1: TLabel; 12 | Label12: TLabel; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | frmDemoThreadQueue: TfrmDemoThreadQueue; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /DemoThreadPools/ThreadPoolThread.pas: -------------------------------------------------------------------------------- 1 | unit ThreadPoolThread; 2 | 3 | (* 4 | Demonstrates the concept of a thread pool, allowing multiple tasks to 5 | be evenly split up between multiple different threads. 6 | 7 | This thread pool is very abstract, allowing it to be used for virtually any purpose. 8 | It is similar to executing anonymous threads, but with a little more control. 9 | 10 | How to use: 11 | Create an instance of TThreadPool. Assign its ThreadCount to your desired 12 | number of threads. Use NewTask to create a new task to be executed 13 | within the thread pool. The next available thread will automatically 14 | pull the task from the queue and execute it. When calling NewTask, 15 | you can optionally specify the priority and whether to initialize COM. 16 | 17 | *) 18 | 19 | interface 20 | 21 | uses 22 | System.Classes, System.SysUtils, System.Generics.Collections, 23 | System.SyncObjs, Winapi.ActiveX; 24 | 25 | type 26 | TThreadPoolTask = class; 27 | TThreadPoolThread = class; 28 | TThreadPool = class; 29 | 30 | TThreadPoolProc = procedure; 31 | 32 | TThreadPoolTask = class(TObject) 33 | private 34 | FProc: TThreadPoolProc; 35 | FPriority: TThreadPriority; 36 | FNeedsCom: Boolean; 37 | procedure SetPriority(const Value: TThreadPriority); 38 | procedure SetNeedsCom(const Value: Boolean); 39 | public 40 | constructor Create; 41 | destructor Destroy; override; 42 | property Priority: TThreadPriority read FPriority write SetPriority; 43 | property NeedsCom: Boolean read FNeedsCom write SetNeedsCom; 44 | end; 45 | 46 | TThreadPoolThread = class(TThread) 47 | private 48 | FOwner: TThreadPool; 49 | procedure Process; 50 | protected 51 | procedure Execute; override; 52 | public 53 | constructor Create(AOwner: TThreadPool); 54 | destructor Destroy; override; 55 | end; 56 | 57 | TThreadPool = class(TComponent) 58 | private 59 | FThreads: TObjectList; 60 | FTasks: TObjectList; 61 | FTasksLock: TCriticalSection; 62 | FThreadCount: Integer; 63 | procedure SetThreadCount(const Value: Integer); 64 | procedure EnsureThreadCount; 65 | protected 66 | function NextTask(const Remove: Boolean = True): TThreadPoolTask; 67 | public 68 | constructor Create(AOwner: TComponent); override; 69 | destructor Destroy; override; 70 | property ThreadCount: Integer read FThreadCount write SetThreadCount; 71 | function NewTask(AProc: TThreadPoolProc; APriority: TThreadPriority = tpNormal; 72 | ANeedsCom: Boolean = False): TThreadPoolTask; 73 | procedure ClearTaskQueue; 74 | end; 75 | 76 | implementation 77 | 78 | { TThreadPoolTask } 79 | 80 | constructor TThreadPoolTask.Create; 81 | begin 82 | Self.FPriority:= TThreadPriority.tpNormal; 83 | Self.FNeedsCom:= False; 84 | end; 85 | 86 | destructor TThreadPoolTask.Destroy; 87 | begin 88 | 89 | inherited; 90 | end; 91 | 92 | procedure TThreadPoolTask.SetNeedsCom(const Value: Boolean); 93 | begin 94 | FNeedsCom := Value; 95 | end; 96 | 97 | procedure TThreadPoolTask.SetPriority(const Value: TThreadPriority); 98 | begin 99 | FPriority := Value; 100 | end; 101 | 102 | { TThreadPoolThread } 103 | 104 | constructor TThreadPoolThread.Create(AOwner: TThreadPool); 105 | begin 106 | inherited Create(True); 107 | FOwner:= AOwner; 108 | end; 109 | 110 | destructor TThreadPoolThread.Destroy; 111 | begin 112 | 113 | inherited; 114 | end; 115 | 116 | procedure TThreadPoolThread.Execute; 117 | begin 118 | while not Terminated do begin 119 | try 120 | try 121 | Process; 122 | finally 123 | Sleep(10); 124 | end; 125 | except 126 | on E: Exception do begin 127 | //TODO: Implement OnException callback event... 128 | 129 | end; 130 | end; 131 | end; 132 | end; 133 | 134 | procedure TThreadPoolThread.Process; 135 | var 136 | T: TThreadPoolTask; 137 | begin 138 | T:= FOwner.NextTask; 139 | if T <> nil then begin 140 | try 141 | Self.Priority:= T.Priority; 142 | 143 | if T.NeedsCom then 144 | CoInitialize(nil); 145 | try 146 | 147 | //EXECUTE PROCEDURE 148 | T.FProc; 149 | 150 | finally 151 | if T.NeedsCom then 152 | CoUninitialize; 153 | end; 154 | 155 | except 156 | on E: Exception do begin 157 | raise Exception.Create('Failed to process thread pool task: '+E.Message); 158 | end; 159 | end; 160 | end; 161 | end; 162 | 163 | { TThreadPool } 164 | 165 | constructor TThreadPool.Create(AOwner: TComponent); 166 | begin 167 | inherited; 168 | FTasksLock:= TCriticalSection.Create; 169 | FThreads:= TObjectList.Create(False); 170 | FTasks:= TObjectList.Create(False); 171 | 172 | end; 173 | 174 | destructor TThreadPool.Destroy; 175 | begin 176 | ClearTaskQueue; 177 | SetThreadCount(0); 178 | 179 | FreeAndNil(FTasks); 180 | FreeAndNil(FThreads); 181 | FreeAndNil(FTasksLock); 182 | inherited; 183 | end; 184 | 185 | procedure TThreadPool.SetThreadCount(const Value: Integer); 186 | begin 187 | FThreadCount := Value; 188 | EnsureThreadCount; 189 | end; 190 | 191 | procedure TThreadPool.EnsureThreadCount; 192 | 193 | procedure AddThread; 194 | var 195 | T: TThreadPoolThread; 196 | begin 197 | T:= TThreadPoolThread.Create(Self); 198 | //TODO... 199 | FThreads.Add(T); 200 | T.Start; 201 | end; 202 | 203 | procedure DeleteThread; 204 | var 205 | T: TThreadPoolThread; 206 | begin 207 | //TODO: Find an idle thread instead of forcibly tasking the first one 208 | T:= FThreads[0]; 209 | T.FreeOnTerminate:= True; 210 | T.Terminate; 211 | FThreads.Delete(0); 212 | end; 213 | 214 | begin 215 | while FThreads.Count <> FThreadCount do begin 216 | if FThreads.Count > FThreadCount then begin 217 | DeleteThread; 218 | end else 219 | if FThreads.Count < FThreadCount then begin 220 | AddThread; 221 | end; 222 | end; 223 | end; 224 | 225 | procedure TThreadPool.ClearTaskQueue; 226 | begin 227 | FTasksLock.Enter; 228 | try 229 | while FTasks.Count > 0 do begin 230 | FTasks[0].Free; 231 | FTasks.Delete(0); 232 | end; 233 | finally 234 | FTasksLock.Leave; 235 | end; 236 | end; 237 | 238 | function TThreadPool.NewTask(AProc: TThreadPoolProc; 239 | APriority: TThreadPriority = tpNormal; ANeedsCom: Boolean = False): TThreadPoolTask; 240 | begin 241 | //Returns a new task. 242 | //TODO: Is there any reason to return an object: Might be dangerous... 243 | Result:= TThreadPoolTask.Create; 244 | Result.FProc:= AProc; 245 | Result.FPriority:= APriority; 246 | Result.FNeedsCom:= ANeedsCom; 247 | FTasksLock.Enter; 248 | try 249 | FTasks.Add(Result); 250 | finally 251 | FTasksLock.Leave; 252 | end; 253 | end; 254 | 255 | function TThreadPool.NextTask(const Remove: Boolean): TThreadPoolTask; 256 | begin 257 | //Returns the next task in the queue. Returns nil if empty. 258 | Result:= nil; 259 | FTasksLock.Enter; 260 | try 261 | if FTasks.Count > 0 then begin 262 | Result:= FTasks[0]; 263 | if Remove then 264 | FTasks.Delete(0); 265 | end; 266 | finally 267 | FTasksLock.Leave; 268 | end; 269 | end; 270 | 271 | end. 272 | -------------------------------------------------------------------------------- /DemoThreadPools/uDemoThreadPools.pas: -------------------------------------------------------------------------------- 1 | unit uDemoThreadPools; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls; 8 | 9 | type 10 | TfrmDemoThreadPools = class(TfrmDemoBase) 11 | Label1: TLabel; 12 | Label12: TLabel; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | frmDemoThreadPools: TfrmDemoThreadPools; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /DemoWindowsMessages/uDemoWindowsMessages.pas: -------------------------------------------------------------------------------- 1 | unit uDemoWindowsMessages; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uDemoBase, Vcl.StdCtrls; 8 | 9 | type 10 | TfrmDemoWindowsMessages = class(TfrmDemoBase) 11 | Label1: TLabel; 12 | Label12: TLabel; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | frmDemoWindowsMessages: TfrmDemoWindowsMessages; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /Icons/Camera-256.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/Icons/Camera-256.ico -------------------------------------------------------------------------------- /Icons/webcam-256.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/Icons/webcam-256.ico -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Delphi Thread Demo 2 | Demonstrating different ways to use threads in Delphi 3 | 4 | ![Thread](/ThreadIcon.png "Thread") 5 | 6 | ## Can I Use VCL From a Thread? 7 | 8 | # NO! 9 | 10 | ### And the same applies for Firemonkey, or pretty much any framework in any programming language. 11 | 12 | Far too many Delphi users make the mistake of thinking a thread is some sort of magic that will improve the performance of their application. Unfortunately, this is far from true. The #1 biggest mistake when trying to implement a thread is making it directly access visual controls of the application. But these visual controls can only work in the context of the application's main thread. Using another thread to update controls in the user interface must be very carefully planned and implemented. And in most cases, it probably isn't the right solution to the problem at all. 13 | 14 | Simply put, the VCL framework of Delphi is not thread safe. While there are many ways to integrate a thread into your UI, there is no single one-size-fits-all solution. It will always vary depending on what you are trying to accomplish. Most of the time, people want to accomplish better performance (speed). But that is very rarely ever done by using a thread. Instead, the most common scenarios where a thread is integrated into a user interface is to keep that UI responsive during a long task. 15 | 16 | ### Let's take a look at what a thread actually is. 17 | 18 | For this, we will imagine a simple application with only a single button which downloads a file from the internet when clicked. The application already has one main thread which is used for the entire UI. On the Windows platform, this means sending/receiving Windows messages, drawing to a control canvas, recognizing user interaction, etc. This thread is essentially a giant loop which is spinning around really fast. For every revolution of this spinning thread, certain pieces of code are executed. 19 | 20 | In a single threaded environment, this file download would block this loop from spinning, until the download is finished. During this time, this thread is no longer able to do any UI updates, detect user clicks, or anything. This is what causes Windows to put (Not Responding) in the title of such forms, because, well, just like it says, it's not responding. 21 | 22 | This is where additional threads come in. It needs to respond to Windows. Instead of blocking the main UI thread with this giant file download, you could put that file download into another thread. It's just that simple, right? 23 | 24 | ### Not so much. 25 | 26 | You may ask yourself "How do I monitor the progress?" or "How do I get notified when it's done?" This would mean the download thread needs to somehow interact with the main thread. This is exactly where the confusion comes in. One thread cannot simply interfere with another thread, because there's no telling at what point one thread is actually at. There's two separate loops now, and when you want to update the UI, that UI thread could be anywhere doing anything. Most importantly, suppose the main UI thread is in the process of writing a string to the same control property which your other thread also wants to write to. Now you have two threads attempting to write to the same memory address, which can result in unpredictable issues. 27 | 28 | ### So how do I do it then? 29 | 30 | By synchronizing. Delphi's TThread class has a method Synchronize() which allows a thread to interact with the main UI thread only at a moment when it will actually behave properly, when it actually expects such an occurance. Code which is synchronized from another thread doesn't actually run in the context of that thread - it always runs in the context of the main UI thread. That's the idea of Synchronize(), is to execute code in the UI thread. 31 | 32 | So in the end, you don't actually use the VCL from the thread. Instead, your thread sends a signal to the main thread, and only when the main thread is ready will it execute that code. Meanwhile, your secondary thread then gets blocked while it waits for the main thread to finish. 33 | 34 | Then there's the mistake of thinking a large UI operation would be better off in a thread. Let's say you have a list where you want to populate millions of items. Of course that will take time, and during this time your application will be not responding. Again. So just move that code to a thread, right? 35 | 36 | ### Wrong. 37 | 38 | Again, any UI interaction must be done from the main thread, and the main thread only. Threads are useful if you need to perform lengthy calculations, process massive amounts of data, wait for a response from a remote resource, or otherwise anything which is both time consuming and not directly related to the UI. 39 | 40 | ### How do I know if I'm doing it right? 41 | 42 | That's hard to say. But there is a common practice which is highly advised when writing a thread: Put your thread code in a unit of its own. This unit should be isolated from any other UI unit. It should not even have any VCL related unit in its uses clause. The thread shouldn't even know how it's being used. It should be essentially a dummy, with the sole purpose of performing your lengthy task. When it comes to UI updates from a thread, this is best accomplished by synchronized events. 43 | 44 | ### What's a synchronized event? 45 | 46 | Exactly what it sounds like. It's an event which is synchronized, as explained earlier. An event is simply a pointer to a procedure which you can assign to the thread before it starts. Inside the thread, when you need to update the UI, you would then use Synchronize() to trigger this event. With this design, the thread would never ever have to know that it's even being used by a UI. At the same time, you also inadvertently accomplish abstraction. The thread becomes re-usable. You can plug it into some other project which might not even have a user interface (let's say a Windows Service). 47 | 48 | ### Where else can I learn? 49 | 50 | Here's some direct links to related resources about VCL Thread Safety, in case you don't want to search... 51 | 52 | 59 | 60 | ## How does this demo application work? 61 | 62 | 63 | This application demonstrates the usage of threads in Delphi. Since there are many different things to know, they are divided into different sections for different purposes. Each topic has at least 1 form unit (embedded into a tab sheet), and at least 1 stand-alone unit containing its functionality apart from the user interface. This is done on purpose, to show that threads *should* be isolated from any UI. 64 | 65 | The main form itself does not actually have any logic in it. All it does is embeds the forms into tabs. In the `FormCreate()` event handler, it makes numerous calls to `EmbedForm()` which instantiates a form for each tab sheet. 66 | 67 | Actually using the application is very simple. You just navigate to one of the tabs, and each one will have its own instructions. 68 | 69 | ### Home 70 | 71 | ![Home](/Screenshots/SS-Home.png "Home") 72 | 73 | ### Downloading 74 | 75 | ![Downloading](/Screenshots/SS-Downloading.png "Downloading") 76 | 77 | Shows how a file can be downloaded from the internet in a thread. There is a single universal function defined `DownloadFile()` which performs the download. The UI has 3 buttons: 78 | 79 | - Download Without Thread 80 | - Download With Thread Class 81 | - Download With Anonymous Thread 82 | 83 | By default, the URL to be downloaded is a test file provided by ThinkBroadband.com, but you can use any URL you wish. You can also choose the location to save the file to. This is a very simple demo, so the filename/extension of the local filename needs to be adjusted to your needs - it won't automatically change for the URL you're downloading (as browsers typically do). 84 | 85 | ### Progress Bar 86 | 87 | ![Progress Bar](/Screenshots/SS-ProgressBar.png "Progress Bar") 88 | 89 | Shows how to update a progress bar from a thread which is performing a lengthy task. 90 | 91 | ### Critical Sections 92 | 93 | #### Coming Soon 94 | 95 | ### Windows Messages 96 | 97 | #### Coming Soon 98 | 99 | ### Queues 100 | 101 | #### Coming Soon 102 | 103 | ### Database 104 | 105 | ![Database](/Screenshots/SS-Database.png "Database") 106 | 107 | Demonstrates using a database connection within a thread and synchronizing data to the UI thread. 108 | 109 | ### HTTP Server 110 | 111 | #### Coming Soon 112 | 113 | ### Thread Pools 114 | 115 | #### Coming Soon 116 | 117 | ### Omni Threads 118 | 119 | #### Coming Soon 120 | 121 | ### Hurt My CPU 122 | 123 | ![Hurt My CPU](/Screenshots/SS-HurtMyCpu.png "Hurt My CPU") 124 | 125 | Demonstrates multiple threads consuming massive CPU cycles to load test your processor. 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /Screenshots/SS-Database.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/Screenshots/SS-Database.png -------------------------------------------------------------------------------- /Screenshots/SS-Downloading.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/Screenshots/SS-Downloading.png -------------------------------------------------------------------------------- /Screenshots/SS-Home.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/Screenshots/SS-Home.png -------------------------------------------------------------------------------- /Screenshots/SS-HurtMyCpu.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/Screenshots/SS-HurtMyCpu.png -------------------------------------------------------------------------------- /Screenshots/SS-ProgressBar.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/Screenshots/SS-ProgressBar.png -------------------------------------------------------------------------------- /ThreadDemo.dpr: -------------------------------------------------------------------------------- 1 | program ThreadDemo; 2 | 3 | uses 4 | Vcl.Forms, 5 | uMain in 'uMain.pas' {frmMain}, 6 | Vcl.Themes, 7 | Vcl.Styles, 8 | Common in 'Common\Common.pas', 9 | UICommon in 'Common\UICommon.pas', 10 | uDemoBase in 'Common\uDemoBase.pas' {frmDemoBase}, 11 | DownloadThread in 'DemoDownload\DownloadThread.pas', 12 | uDemoDownload in 'DemoDownload\uDemoDownload.pas' {frmDemoDownload}, 13 | DatabaseThread in 'DemoDatabase\DatabaseThread.pas', 14 | uDemoDatabase in 'DemoDatabase\uDemoDatabase.pas' {frmDemoDatabase}, 15 | CriticalSectionThread in 'DemoCriticalSections\CriticalSectionThread.pas', 16 | uDemoCriticalSections in 'DemoCriticalSections\uDemoCriticalSections.pas' {frmDemoCriticalSections}, 17 | HttpServerThread in 'DemoHttpServer\HttpServerThread.pas', 18 | uDemoHttpServer in 'DemoHttpServer\uDemoHttpServer.pas' {frmDemoHttpServer}, 19 | CpuMonitor in 'DemoHurtMyCpu\CpuMonitor.pas', 20 | HurtMyCpuThread in 'DemoHurtMyCpu\HurtMyCpuThread.pas', 21 | uDemoHurtMyCpu in 'DemoHurtMyCpu\uDemoHurtMyCpu.pas' {frmDemoHurtMyCpu}, 22 | uDemoOmniThreads in 'DemoOmniThreads\uDemoOmniThreads.pas' {frmDemoOmniThreads}, 23 | ProgressThread in 'DemoProgress\ProgressThread.pas', 24 | uDemoProgress in 'DemoProgress\uDemoProgress.pas' {frmDemoProgress}, 25 | uDemoThreadQueue in 'DemoQueues\uDemoThreadQueue.pas' {frmDemoThreadQueue}, 26 | ThreadPoolThread in 'DemoThreadPools\ThreadPoolThread.pas', 27 | uDemoThreadPools in 'DemoThreadPools\uDemoThreadPools.pas' {frmDemoThreadPools}, 28 | uDemoWindowsMessages in 'DemoWindowsMessages\uDemoWindowsMessages.pas' {frmDemoWindowsMessages}, 29 | uDemoCapture in 'DemoCapture\uDemoCapture.pas' {frmDemoCapture}; 30 | 31 | {$R *.res} 32 | 33 | begin 34 | Application.Initialize; 35 | Application.MainFormOnTaskbar := True; 36 | TStyleManager.TrySetStyle('Light'); 37 | Application.Title := 'JD Thread Demo'; 38 | Application.CreateForm(TfrmMain, frmMain); 39 | Application.Run; 40 | end. 41 | -------------------------------------------------------------------------------- /ThreadDemo.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {2F599B3D-D581-46FB-BF05-7B1791DBA06A} 4 | 18.2 5 | VCL 6 | ThreadDemo.dpr 7 | True 8 | Release 9 | Win32 10 | 1 11 | Application 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Base 40 | true 41 | 42 | 43 | true 44 | Cfg_2 45 | true 46 | true 47 | 48 | 49 | Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Light.vsf;Windows10|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10.vsf;"Windows10 Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Dark.vsf" 50 | 1033 51 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 52 | ThreadDemo 53 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 54 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 55 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 56 | $(BDS)\bin\delphi_PROJECTICON.ico 57 | .\$(Platform)\$(Config) 58 | .\$(Platform)\$(Config) 59 | false 60 | false 61 | false 62 | false 63 | false 64 | 65 | 66 | ThreadIcon.ico 67 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 68 | $(BDS)\bin\default_app.manifest 69 | DBXSqliteDriver;RESTComponents;fmxase;DBXDb2Driver;DBXInterBaseDriver;vclactnband;vclFireDAC;emsclientfiredac;tethering;svnui;DataSnapFireDAC;JDLibComponents;FireDACADSDriver;JvGlobus;JvPluginSystem;DBXMSSQLDriver;JvMM;DatasnapConnectorsFreePascal;FireDACMSSQLDriver;vcltouch;JvBands;vcldb;bindcompfmx;svn;Intraweb;DBXOracleDriver;JvJans;JvNet;inetdb;JvAppFrm;WUndergroundComponents;FmxTeeUI;emsedge;JvDotNetCtrls;FireDACIBDriver;fmx;fmxdae;frx24;JvWizards;FireDACDBXDriver;IndyCore;dbexpress;vclx;CayanComponentsDX10;JvPageComps;dsnap;emsclient;DataSnapCommon;FireDACCommon;JvDB;RESTBackendComponents;DataSnapConnectors;VCLRESTComponents;soapserver;JclDeveloperTools;JDCountdownComps;vclie;bindengine;DBXMySQLDriver;CloudService;FireDACOracleDriver;FireDACMySQLDriver;DBXFirebirdDriver;JvCmp;JvHMI;FireDACCommonODBC;FireDACCommonDriver;FloatBarComponents;DataSnapClient;PhoenixComponentsDX10_1Berlin;inet;IndyIPCommon;bindcompdbx;JvCustom;vcl;IndyIPServer;DBXSybaseASEDriver;JvXPCtrls;IndySystem;FireDACDb2Driver;dsnapcon;FireDACMSAccDriver;fmxFireDAC;FireDACInfxDriver;vclimg;TeeDB;FireDAC;Jcl;JvCore;emshosting;JvCrypt;FireDACSqliteDriver;FireDACPgDriver;FireDACASADriver;ChromeTabs_R;DBXOdbcDriver;FireDACTDataDriver;FMXTee;soaprtl;DbxCommonDriver;JvDlgs;JvRuntimeDesign;JvManagedThreads;Tee;DataSnapServer;xmlrtl;soapmidas;DataSnapNativeClient;fmxobj;vclwinx;FireDACDSDriver;rtl;JvTimeFramework;DbxClientDriver;dclCayanComponentsDX10;DBXSybaseASADriver;frxTee24;CustomIPTransport;vcldsnap;DclJDLibComponents;JvSystem;JvStdCtrls;DCEF_DX10;MSWordComponents;bindcomp;appanalytics;DBXInformixDriver;IndyIPClient;JDCircuitComponents;bindcompvcl;SynEdit_R;frxe24;TeeUI;vclribbon;dbxcds;VclSmp;JvDocking;adortl;FireDACODBCDriver;WinSvcMgrComps;JvPascalInterpreter;JclVcl;DataSnapIndy10ServerTransport;frxDB24;dsnapxml;DataSnapProviderClient;dbrtl;IndyProtocols;inetdbxpress;FireDACMongoDBDriver;PowerPDFDR;JvControls;JvPrintPreview;JclContainers;DataSnapServerMidas;$(DCC_UsePackage) 70 | true 71 | Debug 72 | 73 | 74 | DBXSqliteDriver;RESTComponents;fmxase;DBXDb2Driver;DBXInterBaseDriver;vclactnband;vclFireDAC;emsclientfiredac;tethering;DataSnapFireDAC;JDLibComponents;FireDACADSDriver;DBXMSSQLDriver;DatasnapConnectorsFreePascal;FireDACMSSQLDriver;vcltouch;vcldb;bindcompfmx;Intraweb;DBXOracleDriver;inetdb;FmxTeeUI;emsedge;FireDACIBDriver;fmx;fmxdae;FireDACDBXDriver;IndyCore;dbexpress;vclx;CayanComponentsDX10;dsnap;emsclient;DataSnapCommon;FireDACCommon;RESTBackendComponents;DataSnapConnectors;VCLRESTComponents;soapserver;JclDeveloperTools;vclie;bindengine;DBXMySQLDriver;CloudService;FireDACOracleDriver;FireDACMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;FireDACCommonDriver;DataSnapClient;inet;IndyIPCommon;bindcompdbx;vcl;IndyIPServer;DBXSybaseASEDriver;IndySystem;FireDACDb2Driver;dsnapcon;FireDACMSAccDriver;fmxFireDAC;FireDACInfxDriver;vclimg;TeeDB;FireDAC;Jcl;emshosting;FireDACSqliteDriver;FireDACPgDriver;FireDACASADriver;ChromeTabs_R;DBXOdbcDriver;FireDACTDataDriver;FMXTee;soaprtl;DbxCommonDriver;Tee;DataSnapServer;xmlrtl;soapmidas;DataSnapNativeClient;fmxobj;vclwinx;FireDACDSDriver;rtl;DbxClientDriver;DBXSybaseASADriver;CustomIPTransport;vcldsnap;DCEF_DX10;bindcomp;appanalytics;DBXInformixDriver;IndyIPClient;bindcompvcl;SynEdit_R;TeeUI;vclribbon;dbxcds;VclSmp;adortl;FireDACODBCDriver;JclVcl;DataSnapIndy10ServerTransport;dsnapxml;DataSnapProviderClient;dbrtl;IndyProtocols;inetdbxpress;FireDACMongoDBDriver;PowerPDFDR;JclContainers;DataSnapServerMidas;$(DCC_UsePackage) 75 | 76 | 77 | 1033 78 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 79 | DEBUG;$(DCC_Define) 80 | true 81 | false 82 | true 83 | true 84 | true 85 | 86 | 87 | ThreadIcon.ico 88 | true 89 | true 90 | true 91 | false 92 | 93 | 94 | 1033 95 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 96 | false 97 | RELEASE;$(DCC_Define) 98 | 0 99 | 0 100 | 101 | 102 | true 103 | ThreadIcon.ico 104 | true 105 | true 106 | 107 | 108 | 109 | MainSource 110 | 111 | 112 |
frmMain
113 | dfm 114 | 115 | 116 | 117 | 118 |
frmDemoBase
119 | dfm 120 | 121 | 122 | 123 |
frmDemoDownload
124 | dfm 125 | 126 | 127 | 128 |
frmDemoDatabase
129 | dfm 130 | 131 | 132 | 133 |
frmDemoCriticalSections
134 | dfm 135 | 136 | 137 | 138 |
frmDemoHttpServer
139 | dfm 140 | 141 | 142 | 143 | 144 |
frmDemoHurtMyCpu
145 | dfm 146 | 147 | 148 |
frmDemoOmniThreads
149 | dfm 150 | 151 | 152 | 153 |
frmDemoProgress
154 | dfm 155 | 156 | 157 |
frmDemoThreadQueue
158 | dfm 159 | 160 | 161 | 162 |
frmDemoThreadPools
163 | dfm 164 | 165 | 166 |
frmDemoWindowsMessages
167 | dfm 168 | 169 | 170 |
frmDemoCapture
171 | dfm 172 | 173 | 174 | Cfg_2 175 | Base 176 | 177 | 178 | Base 179 | 180 | 181 | Cfg_1 182 | Base 183 | 184 | 185 | 186 | Delphi.Personality.12 187 | Application 188 | 189 | 190 | 191 | ThreadDemo.dpr 192 | 193 | 194 | Microsoft Office 2000 Sample Automation Server Wrapper Components 195 | Microsoft Office XP Sample Automation Server Wrapper Components 196 | 197 | 198 | 199 | 200 | 201 | ThreadDemo.exe 202 | true 203 | 204 | 205 | 206 | 207 | ThreadDemo.exe 208 | true 209 | 210 | 211 | 212 | 213 | 0 214 | .dll;.bpl 215 | 216 | 217 | 1 218 | .dylib 219 | 220 | 221 | Contents\MacOS 222 | 1 223 | .dylib 224 | 225 | 226 | 1 227 | .dylib 228 | 229 | 230 | 1 231 | .dylib 232 | 233 | 234 | 235 | 236 | Contents\Resources 237 | 1 238 | 239 | 240 | 241 | 242 | classes 243 | 1 244 | 245 | 246 | 247 | 248 | Contents\MacOS 249 | 0 250 | 251 | 252 | 1 253 | 254 | 255 | Contents\MacOS 256 | 1 257 | 258 | 259 | 260 | 261 | 1 262 | 263 | 264 | 1 265 | 266 | 267 | 1 268 | 269 | 270 | 271 | 272 | res\drawable-xxhdpi 273 | 1 274 | 275 | 276 | 277 | 278 | library\lib\mips 279 | 1 280 | 281 | 282 | 283 | 284 | 1 285 | 286 | 287 | 1 288 | 289 | 290 | 0 291 | 292 | 293 | 1 294 | 295 | 296 | Contents\MacOS 297 | 1 298 | 299 | 300 | library\lib\armeabi-v7a 301 | 1 302 | 303 | 304 | 1 305 | 306 | 307 | 308 | 309 | 0 310 | 311 | 312 | Contents\MacOS 313 | 1 314 | .framework 315 | 316 | 317 | 318 | 319 | 1 320 | 321 | 322 | 1 323 | 324 | 325 | 326 | 327 | 1 328 | 329 | 330 | 1 331 | 332 | 333 | 1 334 | 335 | 336 | 337 | 338 | 1 339 | 340 | 341 | 1 342 | 343 | 344 | 1 345 | 346 | 347 | 348 | 349 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 350 | 1 351 | 352 | 353 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 354 | 1 355 | 356 | 357 | 358 | 359 | 1 360 | 361 | 362 | 1 363 | 364 | 365 | 1 366 | 367 | 368 | 369 | 370 | 1 371 | 372 | 373 | 1 374 | 375 | 376 | 1 377 | 378 | 379 | 380 | 381 | library\lib\armeabi 382 | 1 383 | 384 | 385 | 386 | 387 | 0 388 | 389 | 390 | 1 391 | 392 | 393 | Contents\MacOS 394 | 1 395 | 396 | 397 | 398 | 399 | 1 400 | 401 | 402 | 1 403 | 404 | 405 | 1 406 | 407 | 408 | 409 | 410 | res\drawable-normal 411 | 1 412 | 413 | 414 | 415 | 416 | res\drawable-xhdpi 417 | 1 418 | 419 | 420 | 421 | 422 | res\drawable-large 423 | 1 424 | 425 | 426 | 427 | 428 | 1 429 | 430 | 431 | 1 432 | 433 | 434 | 1 435 | 436 | 437 | 438 | 439 | Assets 440 | 1 441 | 442 | 443 | Assets 444 | 1 445 | 446 | 447 | 448 | 449 | ..\ 450 | 1 451 | 452 | 453 | ..\ 454 | 1 455 | 456 | 457 | 458 | 459 | res\drawable-hdpi 460 | 1 461 | 462 | 463 | 464 | 465 | library\lib\armeabi-v7a 466 | 1 467 | 468 | 469 | 470 | 471 | Contents 472 | 1 473 | 474 | 475 | 476 | 477 | ..\ 478 | 1 479 | 480 | 481 | 482 | 483 | Assets 484 | 1 485 | 486 | 487 | Assets 488 | 1 489 | 490 | 491 | 492 | 493 | 1 494 | 495 | 496 | 1 497 | 498 | 499 | 1 500 | 501 | 502 | 503 | 504 | res\values 505 | 1 506 | 507 | 508 | 509 | 510 | res\drawable-small 511 | 1 512 | 513 | 514 | 515 | 516 | res\drawable 517 | 1 518 | 519 | 520 | 521 | 522 | 1 523 | 524 | 525 | 1 526 | 527 | 528 | 1 529 | 530 | 531 | 532 | 533 | 1 534 | 535 | 536 | 537 | 538 | res\drawable 539 | 1 540 | 541 | 542 | 543 | 544 | 0 545 | 546 | 547 | 0 548 | 549 | 550 | Contents\Resources\StartUp\ 551 | 0 552 | 553 | 554 | 0 555 | 556 | 557 | 0 558 | 559 | 560 | 0 561 | 562 | 563 | 564 | 565 | library\lib\armeabi-v7a 566 | 1 567 | 568 | 569 | 570 | 571 | 0 572 | .bpl 573 | 574 | 575 | 1 576 | .dylib 577 | 578 | 579 | Contents\MacOS 580 | 1 581 | .dylib 582 | 583 | 584 | 1 585 | .dylib 586 | 587 | 588 | 1 589 | .dylib 590 | 591 | 592 | 593 | 594 | res\drawable-mdpi 595 | 1 596 | 597 | 598 | 599 | 600 | res\drawable-xlarge 601 | 1 602 | 603 | 604 | 605 | 606 | res\drawable-ldpi 607 | 1 608 | 609 | 610 | 611 | 612 | 1 613 | 614 | 615 | 1 616 | 617 | 618 | 619 | 620 | 621 | 622 | 623 | 624 | 625 | 626 | 627 | 628 | True 629 | False 630 | 631 | 632 | 12 633 | 634 | 635 | 636 | 637 | 638 | -------------------------------------------------------------------------------- /ThreadDemo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/ThreadDemo.res -------------------------------------------------------------------------------- /ThreadIcon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/ThreadIcon.ico -------------------------------------------------------------------------------- /ThreadIcon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/djjd47130/DelphiThreadDemo/5acd8b40a10ccc3abd0e76d99e85dd3cf74306f0/ThreadIcon.png -------------------------------------------------------------------------------- /uMain.dfm: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | Caption = 'JD Thread Demo' 5 | ClientHeight = 558 6 | ClientWidth = 959 7 | Color = clWhite 8 | Constraints.MinHeight = 500 9 | Constraints.MinWidth = 820 10 | DoubleBuffered = True 11 | Font.Charset = DEFAULT_CHARSET 12 | Font.Color = clWindowText 13 | Font.Height = -11 14 | Font.Name = 'Tahoma' 15 | Font.Style = [] 16 | OldCreateOrder = False 17 | Position = poScreenCenter 18 | OnCreate = FormCreate 19 | OnResize = FormResize 20 | OnShow = FormShow 21 | PixelsPerInch = 96 22 | TextHeight = 13 23 | object pbCPU: TPaintBox 24 | AlignWithMargins = True 25 | Left = 5 26 | Top = 504 27 | Width = 949 28 | Height = 28 29 | Hint = 'Current CPU load' 30 | Margins.Left = 5 31 | Margins.Top = 5 32 | Margins.Right = 5 33 | Margins.Bottom = 5 34 | Align = alBottom 35 | OnPaint = pbCPUPaint 36 | ExplicitLeft = 3 37 | ExplicitTop = 507 38 | ExplicitWidth = 953 39 | end 40 | object Pages: TPageControl 41 | Left = 0 42 | Top = 0 43 | Width = 959 44 | Height = 449 45 | ActivePage = TabSheet8 46 | Align = alTop 47 | Anchors = [akLeft, akTop, akRight, akBottom] 48 | Images = imgPagesSmall 49 | TabHeight = 28 50 | TabOrder = 0 51 | OnChange = PagesChange 52 | object TabSheet8: TTabSheet 53 | Hint = 'Home page' 54 | Caption = ' Home ' 55 | ExplicitLeft = 3 56 | ExplicitTop = 38 57 | object Label11: TLabel 58 | AlignWithMargins = True 59 | Left = 5 60 | Top = 5 61 | Width = 941 62 | Height = 52 63 | Margins.Left = 5 64 | Margins.Top = 5 65 | Margins.Right = 5 66 | Margins.Bottom = 5 67 | Align = alTop 68 | Alignment = taCenter 69 | AutoSize = False 70 | Caption = 'JD Thread Demo Application' 71 | Font.Charset = DEFAULT_CHARSET 72 | Font.Color = clWindowText 73 | Font.Height = -35 74 | Font.Name = 'Tahoma' 75 | Font.Style = [fsBold] 76 | ParentFont = False 77 | Layout = tlCenter 78 | ExplicitWidth = 666 79 | end 80 | object Label12: TLabel 81 | AlignWithMargins = True 82 | Left = 10 83 | Top = 72 84 | Width = 931 85 | Height = 41 86 | Margins.Left = 10 87 | Margins.Top = 10 88 | Margins.Right = 10 89 | Margins.Bottom = 10 90 | Align = alTop 91 | Alignment = taCenter 92 | AutoSize = False 93 | Caption = 'How to implement threads in Delphi for various purposes' 94 | Font.Charset = DEFAULT_CHARSET 95 | Font.Color = clWindowText 96 | Font.Height = -21 97 | Font.Name = 'Tahoma' 98 | Font.Style = [] 99 | ParentFont = False 100 | Layout = tlCenter 101 | WordWrap = True 102 | ExplicitWidth = 726 103 | end 104 | object Label2: TLabel 105 | AlignWithMargins = True 106 | Left = 3 107 | Top = 395 108 | Width = 945 109 | Height = 13 110 | Cursor = crHandPoint 111 | Hint = 'Click to open the GitHub repository page' 112 | Align = alBottom 113 | Alignment = taCenter 114 | Caption = 'Created by Jerry Dodge for "Can I Use VCL From Threads?"' 115 | Font.Charset = DEFAULT_CHARSET 116 | Font.Color = 16744448 117 | Font.Height = -11 118 | Font.Name = 'Tahoma' 119 | Font.Style = [fsUnderline] 120 | ParentFont = False 121 | Layout = tlCenter 122 | StyleElements = [seClient, seBorder] 123 | OnClick = StatClick 124 | ExplicitTop = 435 125 | ExplicitWidth = 286 126 | end 127 | object pMain: TGridPanel 128 | AlignWithMargins = True 129 | Left = 3 130 | Top = 126 131 | Width = 945 132 | Height = 263 133 | Align = alClient 134 | BevelOuter = bvNone 135 | ColumnCollection = < 136 | item 137 | SizeStyle = ssAbsolute 138 | Value = 100.000000000000000000 139 | end 140 | item 141 | SizeStyle = ssAbsolute 142 | Value = 400.000000000000000000 143 | end 144 | item 145 | SizeStyle = ssAbsolute 146 | Value = 100.000000000000000000 147 | end> 148 | ControlCollection = < 149 | item 150 | Column = 1 151 | Control = lstMenu 152 | Row = 0 153 | end> 154 | RowCollection = < 155 | item 156 | Value = 100.000000000000000000 157 | end> 158 | TabOrder = 0 159 | ExplicitHeight = 303 160 | object lstMenu: TListView 161 | AlignWithMargins = True 162 | Left = 103 163 | Top = 3 164 | Width = 394 165 | Height = 257 166 | Hint = 'Click any item to open its demo screen' 167 | Align = alClient 168 | BorderStyle = bsNone 169 | Columns = < 170 | item 171 | AutoSize = True 172 | Caption = 'Item' 173 | end> 174 | Font.Charset = DEFAULT_CHARSET 175 | Font.Color = 16744448 176 | Font.Height = -16 177 | Font.Name = 'Tahoma' 178 | Font.Style = [fsBold] 179 | HotTrackStyles = [htHandPoint, htUnderlineHot] 180 | IconOptions.AutoArrange = True 181 | Items.ItemData = { 182 | 05A40100000600000000000000FFFFFFFFFFFFFFFF00000000FFFFFFFF000000 183 | 00094D00610069006E0020004D0065006E00750000000000FFFFFFFFFFFFFFFF 184 | 00000000FFFFFFFF000000001F4C0069007300740020006900740065006D0073 185 | 002000640079006E0061006D006900630061006C006C00790020007200650070 186 | 006C00610063006500640000000000FFFFFFFFFFFFFFFF00000000FFFFFFFF00 187 | 0000001E6200790020007400690074006C006500730020006F00660020006500 188 | 610063006800200063006F006E00740065006E007400200066006F0072006D00 189 | 00000000FFFFFFFFFFFFFFFF00000000FFFFFFFF000000000000000000FFFFFF 190 | FFFFFFFFFF00000000FFFFFFFF000000001E4C00690073007400200069007300 191 | 20006100750074006F006D00610074006900630061006C006C00790020006300 192 | 65006E007400650072006500640000000000FFFFFFFFFFFFFFFF00000000FFFF 193 | FFFF0000000020770069007400680069006E002000690074007300200063006F 194 | 006E007400610069006E0065007200200069006E002000720075006E00740069 195 | 006D0065002E00} 196 | LargeImages = imgPagesLarge 197 | StyleElements = [seClient, seBorder] 198 | ReadOnly = True 199 | RowSelect = True 200 | ParentFont = False 201 | ShowColumnHeaders = False 202 | SmallImages = imgPagesSmall 203 | TabOrder = 0 204 | ViewStyle = vsReport 205 | OnSelectItem = lstMenuSelectItem 206 | ExplicitHeight = 297 207 | end 208 | end 209 | end 210 | end 211 | object Stat: TStatusBar 212 | Left = 0 213 | Top = 537 214 | Width = 959 215 | Height = 21 216 | Cursor = crHandPoint 217 | Hint = 'Don'#39't point at me like that!' 218 | AutoHint = True 219 | Panels = < 220 | item 221 | Width = 50 222 | end> 223 | end 224 | object imgPagesSmall: TImageList 225 | Height = 24 226 | Width = 24 227 | Left = 128 228 | end 229 | object imgPagesLarge: TImageList 230 | Height = 48 231 | Width = 48 232 | Left = 208 233 | end 234 | object Tmr: TTimer 235 | Interval = 250 236 | OnTimer = TmrTimer 237 | Left = 16 238 | Top = 168 239 | end 240 | end 241 | -------------------------------------------------------------------------------- /uMain.pas: -------------------------------------------------------------------------------- 1 | unit uMain; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, Winapi.ShellApi, 7 | System.SysUtils, System.Variants, System.Classes, System.ImageList, 8 | Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, 9 | Vcl.ComCtrls, Vcl.ExtCtrls, Vcl.ImgList, 10 | 11 | UICommon, 12 | CpuMonitor, 13 | 14 | uDemoBase, 15 | uDemoDownload, 16 | uDemoProgress, 17 | uDemoCriticalSections, 18 | uDemoWindowsMessages, 19 | uDemoThreadPools, 20 | uDemoDatabase, 21 | uDemoHttpServer, 22 | uDemoThreadQueue, 23 | uDemoOmniThreads, 24 | uDemoHurtMyCpu, 25 | uDemoCapture 26 | ; 27 | 28 | type 29 | TfrmMain = class(TForm) 30 | Pages: TPageControl; 31 | TabSheet8: TTabSheet; 32 | Label11: TLabel; 33 | Label12: TLabel; 34 | pMain: TGridPanel; 35 | lstMenu: TListView; 36 | Stat: TStatusBar; 37 | imgPagesSmall: TImageList; 38 | imgPagesLarge: TImageList; 39 | Label2: TLabel; 40 | pbCPU: TPaintBox; 41 | Tmr: TTimer; 42 | procedure FormCreate(Sender: TObject); 43 | procedure PagesChange(Sender: TObject); 44 | procedure lstMenuSelectItem(Sender: TObject; Item: TListItem; 45 | Selected: Boolean); 46 | procedure FormShow(Sender: TObject); 47 | procedure FormResize(Sender: TObject); 48 | procedure StatClick(Sender: TObject); 49 | procedure pbCPUPaint(Sender: TObject); 50 | procedure TmrTimer(Sender: TObject); 51 | private 52 | FCpu: Double; 53 | procedure EmbedForm(AFormClass: TDemoFormClass; 54 | ACaption: String); 55 | procedure PopulateMenu; 56 | function MenuWidth: Integer; 57 | procedure EmbedAllForms; 58 | public 59 | end; 60 | 61 | var 62 | frmMain: TfrmMain; 63 | 64 | implementation 65 | 66 | {$R *.dfm} 67 | 68 | procedure TfrmMain.FormCreate(Sender: TObject); 69 | begin 70 | {$IFDEF DEBUG} 71 | ReportMemoryLeaksOnShutdown:= True; 72 | {$ENDIF} 73 | Pages.Align:= alClient; 74 | EmbedAllForms; 75 | Pages.ActivePageIndex:= 0; 76 | PagesChange(nil); 77 | Width:= 1200; 78 | Height:= 720; 79 | end; 80 | 81 | procedure TfrmMain.FormShow(Sender: TObject); 82 | begin 83 | PopulateMenu; 84 | end; 85 | 86 | procedure TfrmMain.EmbedAllForms; 87 | begin 88 | imgPagesSmall.Clear; 89 | imgPagesLarge.Clear; 90 | imgPagesSmall.AddIcon(Application.Icon); 91 | imgPagesLarge.AddIcon(Application.Icon); 92 | EmbedForm(TfrmDemoDownload, 'Download'); 93 | EmbedForm(TfrmDemoProgress, 'Progress'); 94 | EmbedForm(TfrmDemoCriticalSections, 'Critical Section'); 95 | EmbedForm(TfrmDemoWindowsMessages, 'Windows Messages'); 96 | EmbedForm(TfrmDemoThreadQueue, 'Queues'); 97 | EmbedForm(TfrmDemoDatabase, 'Database'); 98 | EmbedForm(TfrmDemoHttpServer, 'HTTP Server'); 99 | EmbedForm(TfrmDemoThreadPools, 'Thread Pool'); 100 | EmbedForm(TfrmDemoOmniThreads, 'Omni Thread'); 101 | EmbedForm(TfrmDemoHurtMyCpu, 'Hurt My CPU'); 102 | EmbedForm(TfrmDemoCapture, 'Capture'); 103 | end; 104 | 105 | procedure TfrmMain.EmbedForm(AFormClass: TDemoFormClass; 106 | ACaption: String); 107 | var 108 | T: TTabSheet; 109 | F: TfrmDemoBase; 110 | begin 111 | //Create new tab sheet... 112 | T:= TTabSheet.Create(Pages); 113 | T.PageControl:= Pages; 114 | T.Caption:= ACaption; 115 | //Create an instance of given form class and embed in given tab sheet... 116 | F:= TfrmDemoBase(AFormClass.Create(T)); 117 | F.Parent:= T; 118 | F.Align:= alClient; 119 | F.Show; 120 | //Add image to tab... 121 | //TODO: For some reason AddIcon is being dicky with choosing the right size... 122 | imgPagesSmall.AddIcon(F.Icon); 123 | imgPagesLarge.AddIcon(F.Icon); 124 | T.ImageIndex:= imgPagesSmall.Count-1; 125 | T.Hint:= F.Caption; 126 | end; 127 | 128 | procedure TfrmMain.FormResize(Sender: TObject); 129 | var 130 | W: Double; 131 | begin 132 | W:= (pMain.Width - lstMenu.Width) / 2; 133 | pMain.ColumnCollection[1].Value:= MenuWidth; 134 | pMain.ColumnCollection[0].Value:= W; 135 | pMain.ColumnCollection[2].Value:= W; 136 | end; 137 | 138 | function TfrmMain.MenuWidth: Integer; 139 | var 140 | X, W: Integer; 141 | I: TListItem; 142 | begin 143 | Result:= 0; 144 | lstMenu.Canvas.Font.Assign(lstMenu.Font); 145 | for X := 0 to lstMenu.Items.Count-1 do begin 146 | I:= lstMenu.Items[X]; 147 | W:= lstMenu.Canvas.TextWidth(I.Caption); 148 | if W > Result then 149 | Result:= W; 150 | end; 151 | Result:= Result + 42; 152 | end; 153 | 154 | procedure TfrmMain.PopulateMenu; 155 | var 156 | X: Integer; 157 | F: TfrmDemoBase; 158 | I: TListItem; 159 | begin 160 | lstMenu.Items.Clear; 161 | for X := 1 to Pages.PageCount-1 do begin 162 | F:= TfrmDemoBase(Pages.Pages[X].Controls[0]); 163 | I:= lstMenu.Items.Add; 164 | I.Caption:= F.Caption; 165 | I.ImageIndex:= X; 166 | end; 167 | FormResize(nil); 168 | end; 169 | 170 | procedure TfrmMain.StatClick(Sender: TObject); 171 | var 172 | URL: string; 173 | begin 174 | URL := 'https://github.com/djjd47130/DelphiThreadDemo'; 175 | ShellExecute(0, 'open', PChar(URL), nil, nil, SW_SHOWNORMAL); 176 | end; 177 | 178 | procedure TfrmMain.TmrTimer(Sender: TObject); 179 | begin 180 | FCpu:= GetTotalCpuUsagePct; 181 | FCpu:= FCpu / 100; 182 | pbCPU.Invalidate; 183 | end; 184 | 185 | procedure TfrmMain.lstMenuSelectItem(Sender: TObject; Item: TListItem; 186 | Selected: Boolean); 187 | begin 188 | if Selected then begin 189 | Pages.ActivePageIndex:= Item.Index + 1; 190 | lstMenu.ItemIndex:= -1; 191 | PagesChange(nil); 192 | end; 193 | end; 194 | 195 | procedure TfrmMain.PagesChange(Sender: TObject); 196 | var 197 | F: TfrmDemoBase; 198 | S: String; 199 | begin 200 | if Pages.ActivePageIndex = 0 then begin 201 | S:= 'Home'; 202 | end else begin 203 | F:= TfrmDemoBase(Pages.ActivePage.Controls[0]); 204 | S:= F.Caption; 205 | end; 206 | Caption:= 'JD Thread Demo - ' + S; 207 | end; 208 | 209 | procedure TfrmMain.pbCPUPaint(Sender: TObject); 210 | begin 211 | DrawProgressBar(pbCPU.Canvas, pbCPU.Canvas.ClipRect, FCPU, clGray, clNavy, 'CPU Usage'); 212 | end; 213 | 214 | end. 215 | --------------------------------------------------------------------------------