├── .gitattributes ├── .gitignore ├── LICENSE.md ├── Part2 ├── 12 Collections │ ├── CollectionsMainF.dfm │ ├── CollectionsMainF.pas │ ├── CollectionsTest.dpr │ └── CollectionsTest.dproj ├── 13 Parallel Collections │ ├── DependentParallelCollections.dpr │ ├── DependentParallelCollections.dproj │ ├── DependentParallelCollectionsMainF.dfm │ ├── DependentParallelCollectionsMainF.pas │ ├── ParallelCollections.dpr │ ├── ParallelCollections.dproj │ ├── ParallelCollectionsMainF.dfm │ └── ParallelCollectionsMainF.pas ├── 5 FPCR │ ├── BrokenMath.dpr │ ├── BrokenMath.dproj │ ├── SafeMath.dpr │ └── SafeMath.dproj ├── 7.1 Parameters │ ├── Parameters.dpr │ ├── Parameters.dproj │ ├── ParametersMainF.dfm │ └── ParametersMainF.pas └── 8 Singletons │ ├── SingletonClassProp.pas │ ├── SingletonClasses.pas │ ├── SingletonLazy.pas │ ├── SingletonLocal.pas │ ├── Singletons.dpr │ ├── Singletons.dproj │ ├── SingletonsMainF.dfm │ └── SingletonsMainF.pas ├── Part3 ├── 16 Serialization │ ├── Serialization.dpr │ ├── Serialization.dproj │ ├── SerializationMainF.dfm │ └── SerializationMainF.pas ├── 17 SystemNet │ ├── NetClient.dpr │ ├── NetClient.dproj │ ├── NetClientMainF.dfm │ └── NetClientMainF.pas ├── 19 Indy │ ├── Indy.dpr │ ├── Indy.dproj │ ├── IndyMainF.dfm │ └── IndyMainF.pas ├── 20 REST │ ├── RESTDemo.dpr │ ├── RESTDemo.dproj │ ├── RESTMainF.dfm │ └── RESTMainF.pas └── 21 Regular expressions │ └── RegEx.dpr ├── Part5 ├── 27 Resource consumption │ ├── Resources.dpr │ ├── Resources.dproj │ ├── ResourcesMainF.dfm │ └── ResourcesMainF.pas └── 30 VCL │ ├── Images.dpr │ ├── Images.dproj │ ├── ImagesMainF.dfm │ └── ImagesMainF.pas ├── Part6 ├── 33 Logging │ ├── Logging.dpr │ ├── Logging.dproj │ └── NX.Log.pas ├── 34 Cancellation tokens │ ├── NX.Tokens.pas │ ├── Tokens.dpr │ ├── Tokens.dproj │ ├── TokensMainF.dfm │ └── TokensMainF.pas ├── 35 Event bus │ ├── Horizon.dpr │ ├── Horizon.dproj │ ├── HorizonMainF.dfm │ ├── HorizonMainF.pas │ └── NX.Horizon.pas └── 36 Measuring performance │ ├── NX.Chronos.pas │ ├── ZeroThread.dpr │ └── ZeroThread.dproj └── README.md /.gitattributes: -------------------------------------------------------------------------------- 1 | # Set the default behavior, in case people don't have core.autocrlf set. 2 | * binary 3 | 4 | # Declare text files that will always have CRLF line endings on checkout 5 | *.gitattributes text eol=lf diff 6 | *.gitignore text eol=lf diff 7 | 8 | *.txt text eol=crlf diff 9 | *.md text eol=crlf diff 10 | *.xml text eol=crlf diff 11 | *.json text eol=crlf diff 12 | *.manifest text eol=crlf diff 13 | *.rc text eol=crlf diff 14 | *.bat text eol=crlf diff 15 | 16 | *.pas text eol=crlf diff 17 | *.inc text eol=crlf diff 18 | *.dfm text eol=crlf diff 19 | *.fmx text eol=crlf diff 20 | *.dpr text eol=crlf diff 21 | *.dpk text eol=crlf diff 22 | *.dproj text eol=crlf diff 23 | *.groupproj text eol=crlf diff 24 | *.deployproj text eol=crlf diff 25 | *.plist text eol=lf diff 26 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Delphi compiler-generated binaries (safe to delete) 2 | *.exe 3 | *.dll 4 | *.bpl 5 | *.bpi 6 | *.dcp 7 | *.so 8 | *.apk 9 | *.drc 10 | *.map 11 | *.dres 12 | *.rsm 13 | *.tds 14 | *.dcu 15 | *.lib 16 | *.a 17 | *.o 18 | *.ocx 19 | 20 | # Delphi autogenerated files (duplicated info) 21 | *.cfg 22 | *.hpp 23 | *Resource.rc 24 | 25 | # Delphi local files (user-specific info) 26 | *.local 27 | *.identcache 28 | *.projdata 29 | *.tvsconfig 30 | *.dsk 31 | *.stat 32 | 33 | # Delphi history and backups 34 | __history/ 35 | __recovery/ 36 | *.~* 37 | 38 | # Delphi build folders 39 | Win32/ 40 | Win64/ 41 | OSX32/ 42 | OSX64/ 43 | Linux64/ 44 | Android/ 45 | Android64 46 | iOSDevice64/ 47 | iOSDevice32/ 48 | iOSSimulator/ 49 | 50 | # VCS 51 | .hg/ -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Code examples from Delphi Thread Safety Patterns book 4 | Copyright (c) 2022 Dalija Prasnikar, Neven Prasnikar Jr. 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this repository - code examples (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /Part2/12 Collections/CollectionsMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 366 6 | ClientWidth = 506 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 494 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | ExplicitWidth = 799 27 | object Button1: TButton 28 | Left = 8 29 | Top = 6 30 | Width = 80 31 | Height = 25 32 | Caption = 'Unsafe Array' 33 | TabOrder = 0 34 | OnClick = Button1Click 35 | end 36 | object Button2: TButton 37 | Left = 94 38 | Top = 6 39 | Width = 80 40 | Height = 25 41 | Caption = 'Safe Array' 42 | TabOrder = 1 43 | OnClick = Button2Click 44 | end 45 | object Button3: TButton 46 | Left = 180 47 | Top = 6 48 | Width = 75 49 | Height = 25 50 | Caption = 'Safe List' 51 | TabOrder = 2 52 | OnClick = Button3Click 53 | end 54 | object Button4: TButton 55 | Left = 261 56 | Top = 6 57 | Width = 80 58 | Height = 25 59 | Caption = 'List Wrapper' 60 | TabOrder = 3 61 | OnClick = Button4Click 62 | end 63 | end 64 | object Memo: TMemo 65 | Left = 6 66 | Top = 41 67 | Width = 494 68 | Height = 319 69 | Align = alClient 70 | TabOrder = 1 71 | ExplicitWidth = 799 72 | ExplicitHeight = 309 73 | end 74 | end 75 | -------------------------------------------------------------------------------- /Part2/12 Collections/CollectionsMainF.pas: -------------------------------------------------------------------------------- 1 | unit CollectionsMainF; 2 | 3 | interface 4 | 5 | {$R+} // turn on range checking 6 | 7 | uses 8 | Winapi.Windows, 9 | Winapi.Messages, 10 | System.SysUtils, 11 | System.Variants, 12 | System.Classes, 13 | System.SyncObjs, 14 | System.Generics.Collections, 15 | Vcl.Graphics, 16 | Vcl.Controls, 17 | Vcl.Forms, 18 | Vcl.Dialogs, 19 | Vcl.StdCtrls, 20 | Vcl.ExtCtrls; 21 | 22 | type 23 | TMainForm = class(TForm) 24 | Panel1: TPanel; 25 | Button1: TButton; 26 | Memo: TMemo; 27 | Button2: TButton; 28 | Button3: TButton; 29 | Button4: TButton; 30 | procedure Button1Click(Sender: TObject); 31 | procedure Button2Click(Sender: TObject); 32 | procedure Button3Click(Sender: TObject); 33 | procedure Button4Click(Sender: TObject); 34 | private 35 | public 36 | procedure ShowException(Msg: string); 37 | end; 38 | 39 | // Various thread-safe collections 40 | 41 | TThreadList = class 42 | private 43 | FList: TList; 44 | // FLock is a custom managed record 45 | // which is automatically initialized 46 | FLock: TLightweightMREW; 47 | function GetCount: Integer; 48 | function GetItem(Index: Integer): T; 49 | procedure SetCount(const Value: Integer); 50 | procedure SetItem(Index: Integer; const Value: T); 51 | public 52 | constructor Create; 53 | destructor Destroy; override; 54 | procedure Clear; 55 | function Add(const Value: T): Integer; 56 | procedure Delete(Index: Integer); 57 | function Contains(const Value: T): Boolean; 58 | 59 | function BeginRead: TList; 60 | procedure EndRead; 61 | 62 | function BeginWrite: TList; 63 | procedure EndWrite; 64 | 65 | procedure Enumerate(const AProc: TProc); 66 | 67 | property Count: Integer read GetCount write SetCount; 68 | property Items[Index: Integer]: T read GetItem write SetItem; default; 69 | 70 | type 71 | TEnumerator = class(TEnumerator) 72 | private 73 | FList: TThreadList; 74 | FIndex: Integer; 75 | function GetCurrent: T; inline; 76 | protected 77 | function DoGetCurrent: T; override; 78 | function DoMoveNext: Boolean; override; 79 | public 80 | constructor Create(const AList: TThreadList); 81 | destructor Destroy; override; 82 | function MoveNext: Boolean; inline; 83 | property Current: T read GetCurrent; 84 | end; 85 | 86 | function GetEnumerator: TEnumerator; inline; 87 | end; 88 | 89 | IList = interface 90 | function BeginRead: TList; 91 | procedure EndRead; 92 | function BeginWrite: TList; 93 | procedure EndWrite; 94 | end; 95 | 96 | TIntfThreadList = class(TInterfacedObject, IList) 97 | protected 98 | FLock: TLightweightMREW; 99 | FList: TList; 100 | public 101 | constructor Create; 102 | destructor Destroy; override; 103 | function BeginRead: TList; 104 | procedure EndRead; 105 | function BeginWrite: TList; 106 | procedure EndWrite; 107 | end; 108 | 109 | TThreadDictionary = class 110 | protected 111 | FLock: TLightweightMREW; 112 | FDict: TDictionary; 113 | public 114 | constructor Create; 115 | destructor Destroy; override; 116 | function BeginRead: TDictionary; 117 | procedure EndRead; 118 | function BeginWrite: TDictionary; 119 | procedure EndWrite; 120 | end; 121 | 122 | TThreadObjectDictionary = class 123 | protected 124 | FLock: TLightweightMREW; 125 | FDict: TDictionary; 126 | public 127 | constructor Create; 128 | destructor Destroy; override; 129 | function BeginRead: TDictionary; 130 | procedure EndRead; 131 | function BeginWrite: TDictionary; 132 | procedure EndWrite; 133 | end; 134 | 135 | var 136 | MainForm: TMainForm; 137 | 138 | implementation 139 | 140 | {$R *.dfm} 141 | 142 | procedure TMainForm.ShowException(Msg: string); 143 | begin 144 | TThread.Synchronize(nil, 145 | procedure 146 | begin 147 | ShowMessage(Msg); 148 | end); 149 | end; 150 | 151 | // thread-unsafe 152 | procedure TMainForm.Button1Click(Sender: TObject); 153 | var 154 | List: array of Integer; 155 | begin 156 | Memo.Lines.Clear; 157 | Memo.Lines.Add('Running thread-unsafe'); 158 | TThread.CreateAnonymousThread( 159 | procedure 160 | var 161 | i: Integer; 162 | Len: Integer; 163 | begin 164 | try 165 | for i := 0 to 200 do 166 | begin 167 | Len := Length(List); 168 | SetLength(List, Len + 1); 169 | List[Len] := Len; 170 | end; 171 | TThread.Queue(nil, 172 | procedure 173 | begin 174 | Memo.Lines.Add('DONE 1'); 175 | end); 176 | except 177 | on E: Exception do 178 | ShowException(E.Message); 179 | end; 180 | end).Start; 181 | 182 | TThread.CreateAnonymousThread( 183 | procedure 184 | var 185 | i: Integer; 186 | Len: Integer; 187 | begin 188 | try 189 | for i := 0 to 20 do 190 | begin 191 | Sleep(10); 192 | Len := Length(List); 193 | if Len > 0 then 194 | SetLength(List, Len -1); 195 | end; 196 | TThread.Queue(nil, 197 | procedure 198 | begin 199 | Memo.Lines.Add('DONE 2'); 200 | end); 201 | except 202 | on E: Exception do 203 | ShowException(E.Message); 204 | end; 205 | end).Start; 206 | 207 | TThread.CreateAnonymousThread( 208 | procedure 209 | var 210 | i: Integer; 211 | Idx: Integer; 212 | begin 213 | try 214 | for i := 0 to 20 do 215 | begin 216 | for Idx := 0 to High(List) do 217 | OutputDebugString(PChar(List[Idx].ToString)); 218 | end; 219 | TThread.Queue(nil, 220 | procedure 221 | begin 222 | Memo.Lines.Add('DONE 3'); 223 | end); 224 | except 225 | on E: Exception do 226 | ShowException(E.Message); 227 | end; 228 | end).Start; 229 | end; 230 | 231 | // thread-safe using lock 232 | procedure TMainForm.Button2Click(Sender: TObject); 233 | var 234 | List: array of Integer; 235 | Lock: IReadWriteSync; 236 | begin 237 | Memo.Lines.Clear; 238 | Memo.Lines.Add('Running lock'); 239 | Lock := TSimpleRWSync.Create; 240 | TThread.CreateAnonymousThread( 241 | procedure 242 | var 243 | i: Integer; 244 | Len: Integer; 245 | begin 246 | try 247 | for i := 0 to 200 do 248 | begin 249 | Lock.BeginWrite; 250 | try 251 | Len := Length(List); 252 | SetLength(List, Len + 1); 253 | List[Len] := Len; 254 | finally 255 | Lock.EndWrite; 256 | end; 257 | end; 258 | TThread.Queue(nil, 259 | procedure 260 | begin 261 | Memo.Lines.Add('DONE 1'); 262 | end); 263 | except 264 | on E: Exception do 265 | ShowException(E.Message); 266 | end; 267 | end).Start; 268 | 269 | TThread.CreateAnonymousThread( 270 | procedure 271 | var 272 | i: Integer; 273 | Len: Integer; 274 | begin 275 | try 276 | for i := 0 to 20 do 277 | begin 278 | Sleep(10); 279 | Lock.BeginWrite; 280 | try 281 | Len := Length(List); 282 | if Len > 0 then 283 | SetLength(List, Len -1); 284 | finally 285 | Lock.EndWrite; 286 | end; 287 | end; 288 | TThread.Queue(nil, 289 | procedure 290 | begin 291 | Memo.Lines.Add('DONE 2'); 292 | end); 293 | except 294 | on E: Exception do 295 | ShowException(E.Message); 296 | end; 297 | end).Start; 298 | 299 | TThread.CreateAnonymousThread( 300 | procedure 301 | var 302 | i: Integer; 303 | Idx: Integer; 304 | c: PChar; 305 | begin 306 | try 307 | for i := 0 to 20 do 308 | begin 309 | Lock.BeginRead; 310 | try 311 | for Idx := 0 to High(List) do 312 | OutputDebugString(PChar(List[Idx].ToString)); 313 | finally 314 | Lock.EndRead; 315 | end; 316 | end; 317 | TThread.Queue(nil, 318 | procedure 319 | begin 320 | Memo.Lines.Add('DONE 3'); 321 | end); 322 | except 323 | on E: Exception do 324 | ShowException(E.Message); 325 | end; 326 | end).Start; 327 | end; 328 | 329 | // thread-safe using monitor 330 | procedure TMainForm.Button3Click(Sender: TObject); 331 | var 332 | List: TList; 333 | begin 334 | Memo.Lines.Clear; 335 | Memo.Lines.Add('Running monitor'); 336 | // this list will be leaked 337 | List := TList.Create; 338 | TThread.CreateAnonymousThread( 339 | procedure 340 | var 341 | i: Integer; 342 | begin 343 | try 344 | for i := 0 to 200 do 345 | begin 346 | System.TMonitor.Enter(List); 347 | try 348 | List.Add(List.Count); 349 | finally 350 | System.TMonitor.Exit(List); 351 | end; 352 | end; 353 | TThread.Queue(nil, 354 | procedure 355 | begin 356 | Memo.Lines.Add('DONE 1'); 357 | end); 358 | except 359 | on E: Exception do 360 | ShowException(E.Message); 361 | end; 362 | end).Start; 363 | 364 | TThread.CreateAnonymousThread( 365 | procedure 366 | var 367 | i: Integer; 368 | begin 369 | try 370 | for i := 0 to 20 do 371 | begin 372 | Sleep(10); 373 | System.TMonitor.Enter(List); 374 | try 375 | if List.Count > 0 then 376 | List.Delete(List.Count - 1); 377 | finally 378 | System.TMonitor.Exit(List); 379 | end; 380 | end; 381 | TThread.Queue(nil, 382 | procedure 383 | begin 384 | Memo.Lines.Add('DONE 2'); 385 | end); 386 | except 387 | on E: Exception do 388 | ShowException(E.Message); 389 | end; 390 | end).Start; 391 | 392 | TThread.CreateAnonymousThread( 393 | procedure 394 | var 395 | i: Integer; 396 | Idx: Integer; 397 | begin 398 | try 399 | for i := 0 to 20 do 400 | begin 401 | System.TMonitor.Enter(List); 402 | try 403 | for Idx := 0 to List.Count - 1 do 404 | OutputDebugString(PChar(List[Idx].ToString)); 405 | finally 406 | System.TMonitor.Exit(List); 407 | end; 408 | end; 409 | TThread.Queue(nil, 410 | procedure 411 | begin 412 | Memo.Lines.Add('DONE 3'); 413 | end); 414 | except 415 | on E: Exception do 416 | ShowException(E.Message); 417 | end; 418 | end).Start; 419 | end; 420 | 421 | // thread-safe list wrapper 422 | procedure TMainForm.Button4Click(Sender: TObject); 423 | var 424 | List: TThreadList; 425 | begin 426 | Memo.Lines.Clear; 427 | Memo.Lines.Add('Running list wrapper'); 428 | // this list will be leaked 429 | List := TThreadList.Create; 430 | TThread.CreateAnonymousThread( 431 | procedure 432 | var 433 | i: Integer; 434 | begin 435 | try 436 | for i := 0 to 200 do 437 | List.Add(List.Count); 438 | TThread.Queue(nil, 439 | procedure 440 | begin 441 | Memo.Lines.Add('DONE 1'); 442 | end); 443 | except 444 | on E: Exception do 445 | ShowException(E.Message); 446 | end; 447 | end).Start; 448 | 449 | TThread.CreateAnonymousThread( 450 | procedure 451 | var 452 | i: Integer; 453 | TempList: TList; 454 | begin 455 | try 456 | for i := 0 to 20 do 457 | begin 458 | Sleep(10); 459 | TempList := List.BeginRead; 460 | try 461 | if TempList.Count > 0 then 462 | TempList.Delete(TempList.Count - 1); 463 | finally 464 | List.EndRead; 465 | end; 466 | end; 467 | TThread.Queue(nil, 468 | procedure 469 | begin 470 | Memo.Lines.Add('DONE 2'); 471 | end); 472 | except 473 | on E: Exception do 474 | ShowException(E.Message); 475 | end; 476 | end).Start; 477 | 478 | TThread.CreateAnonymousThread( 479 | procedure 480 | var 481 | i: Integer; 482 | Value: Integer; 483 | begin 484 | try 485 | for i := 0 to 20 do 486 | begin 487 | for Value in List do 488 | begin 489 | OutputDebugString(PWideChar(Value.ToString)); 490 | end; 491 | end; 492 | TThread.Queue(nil, 493 | procedure 494 | begin 495 | Memo.Lines.Add('DONE 3'); 496 | end); 497 | except 498 | on E: Exception do 499 | ShowException(E.Message); 500 | end; 501 | end).Start; 502 | end; 503 | 504 | { TThreadList } 505 | 506 | constructor TThreadList.Create; 507 | begin 508 | FList := TList.Create; 509 | end; 510 | 511 | destructor TThreadList.Destroy; 512 | begin 513 | FList.Free; 514 | inherited; 515 | end; 516 | 517 | function TThreadList.GetCount: Integer; 518 | begin 519 | FLock.BeginRead; 520 | try 521 | Result := FList.Count; 522 | finally 523 | FLock.EndRead; 524 | end; 525 | end; 526 | 527 | procedure TThreadList.SetCount(const Value: Integer); 528 | begin 529 | FLock.BeginWrite; 530 | try 531 | FList.Count := Value; 532 | finally 533 | FLock.EndWrite; 534 | end; 535 | end; 536 | 537 | function TThreadList.GetItem(Index: Integer): T; 538 | begin 539 | FLock.BeginRead; 540 | try 541 | Result := FList.Items[Index]; 542 | finally 543 | FLock.EndRead; 544 | end; 545 | end; 546 | 547 | procedure TThreadList.SetItem(Index: Integer; const Value: T); 548 | begin 549 | FLock.BeginWrite; 550 | try 551 | FList.Items[Index] := Value; 552 | finally 553 | FLock.EndWrite; 554 | end; 555 | end; 556 | 557 | procedure TThreadList.Clear; 558 | begin 559 | FLock.BeginWrite; 560 | try 561 | FList.Clear; 562 | finally 563 | FLock.EndWrite; 564 | end; 565 | end; 566 | 567 | function TThreadList.Add(const Value: T): Integer; 568 | begin 569 | FLock.BeginWrite; 570 | try 571 | Result := FList.Add(Value); 572 | finally 573 | FLock.EndWrite; 574 | end; 575 | end; 576 | 577 | procedure TThreadList.Delete(Index: Integer); 578 | begin 579 | FLock.BeginWrite; 580 | try 581 | FList.Delete(Index); 582 | finally 583 | FLock.EndWrite; 584 | end; 585 | end; 586 | 587 | function TThreadList.Contains(const Value: T): Boolean; 588 | begin 589 | FLock.BeginRead; 590 | try 591 | Result := FList.Contains(Value); 592 | finally 593 | FLock.EndRead; 594 | end; 595 | end; 596 | 597 | function TThreadList.BeginRead: TList; 598 | begin 599 | FLock.BeginRead; 600 | Result := FList; 601 | end; 602 | 603 | procedure TThreadList.EndRead; 604 | begin 605 | FLock.EndRead; 606 | end; 607 | 608 | function TThreadList.BeginWrite: TList; 609 | begin 610 | FLock.BeginWrite; 611 | Result := FList; 612 | end; 613 | 614 | procedure TThreadList.EndWrite; 615 | begin 616 | FLock.EndWrite; 617 | end; 618 | 619 | procedure TThreadList.Enumerate(const AProc: TProc); 620 | var 621 | Idx: Integer; 622 | begin 623 | FLock.BeginRead; 624 | try 625 | for Idx := 0 to FList.Count - 1 do 626 | AProc(FList.List[Idx]); 627 | finally 628 | FLock.EndRead; 629 | end; 630 | end; 631 | 632 | { TThreadList.TEnumerator } 633 | 634 | constructor TThreadList.TEnumerator.Create(const AList: TThreadList); 635 | begin 636 | inherited Create; 637 | FList := AList; 638 | FIndex := -1; 639 | FList.FLock.BeginRead; 640 | end; 641 | 642 | destructor TThreadList.TEnumerator.Destroy; 643 | begin 644 | FList.FLock.EndRead; 645 | inherited; 646 | end; 647 | 648 | function TThreadList.TEnumerator.GetCurrent: T; 649 | begin 650 | Result := FList.FList.List[FIndex]; 651 | end; 652 | 653 | function TThreadList.TEnumerator.MoveNext: Boolean; 654 | begin 655 | Inc(FIndex); 656 | Result := FIndex < FList.FList.Count; 657 | end; 658 | 659 | function TThreadList.TEnumerator.DoGetCurrent: T; 660 | begin 661 | Result := Current; 662 | end; 663 | 664 | function TThreadList.TEnumerator.DoMoveNext: Boolean; 665 | begin 666 | Result := MoveNext; 667 | end; 668 | 669 | function TThreadList.GetEnumerator: TEnumerator; 670 | begin 671 | Result := TEnumerator.Create(Self); 672 | end; 673 | 674 | { TIntfThreadList } 675 | 676 | constructor TIntfThreadList.Create; 677 | begin 678 | FList := TList.Create; 679 | end; 680 | 681 | destructor TIntfThreadList.Destroy; 682 | begin 683 | FList.Free; 684 | inherited; 685 | end; 686 | 687 | function TIntfThreadList.BeginRead: TList; 688 | begin 689 | FLock.BeginRead; 690 | Result := FList; 691 | end; 692 | 693 | function TIntfThreadList.BeginWrite: TList; 694 | begin 695 | FLock.BeginWrite; 696 | Result := FList; 697 | end; 698 | 699 | procedure TIntfThreadList.EndRead; 700 | begin 701 | FLock.EndRead; 702 | end; 703 | 704 | procedure TIntfThreadList.EndWrite; 705 | begin 706 | FLock.EndWrite; 707 | end; 708 | 709 | { TThreadDictionary } 710 | 711 | constructor TThreadDictionary.Create; 712 | begin 713 | FDict := TDictionary.Create; 714 | end; 715 | 716 | destructor TThreadDictionary.Destroy; 717 | begin 718 | FDict.Free; 719 | inherited; 720 | end; 721 | 722 | function TThreadDictionary.BeginRead: TDictionary; 723 | begin 724 | FLock.BeginRead; 725 | Result := FDict; 726 | end; 727 | 728 | function TThreadDictionary.BeginWrite: TDictionary; 729 | begin 730 | FLock.BeginWrite; 731 | Result := FDict; 732 | end; 733 | 734 | procedure TThreadDictionary.EndRead; 735 | begin 736 | FLock.EndRead; 737 | end; 738 | 739 | procedure TThreadDictionary.EndWrite; 740 | begin 741 | FLock.EndWrite; 742 | end; 743 | 744 | { TThreadObjectDictionary } 745 | 746 | constructor TThreadObjectDictionary.Create; 747 | begin 748 | FDict := TObjectDictionary.Create([doOwnsValues]); 749 | end; 750 | 751 | destructor TThreadObjectDictionary.Destroy; 752 | begin 753 | FDict.Free; 754 | inherited; 755 | end; 756 | 757 | function TThreadObjectDictionary.BeginRead: TDictionary; 758 | begin 759 | FLock.BeginRead; 760 | Result := FDict; 761 | end; 762 | 763 | function TThreadObjectDictionary.BeginWrite: TDictionary; 764 | begin 765 | FLock.BeginWrite; 766 | Result := FDict; 767 | end; 768 | 769 | procedure TThreadObjectDictionary.EndRead; 770 | begin 771 | FLock.EndRead; 772 | end; 773 | 774 | procedure TThreadObjectDictionary.EndWrite; 775 | begin 776 | FLock.EndWrite; 777 | end; 778 | 779 | end. 780 | -------------------------------------------------------------------------------- /Part2/12 Collections/CollectionsTest.dpr: -------------------------------------------------------------------------------- 1 | program CollectionsTest; 2 | 3 | uses 4 | Vcl.Forms, 5 | CollectionsMainF in 'CollectionsMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part2/13 Parallel Collections/DependentParallelCollections.dpr: -------------------------------------------------------------------------------- 1 | program DependentParallelCollections; 2 | 3 | uses 4 | Vcl.Forms, 5 | DependentParallelCollectionsMainF in 'DependentParallelCollectionsMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part2/13 Parallel Collections/DependentParallelCollectionsMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 398 6 | ClientWidth = 619 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 607 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 0 28 | Top = 4 29 | Width = 90 30 | Height = 25 31 | Caption = 'Single Thread' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | object Button2: TButton 36 | Left = 96 37 | Top = 4 38 | Width = 100 39 | Height = 25 40 | Caption = 'Parallel For Lock' 41 | TabOrder = 1 42 | OnClick = Button2Click 43 | end 44 | object Button3: TButton 45 | Left = 202 46 | Top = 4 47 | Width = 120 48 | Height = 25 49 | Caption = 'Parallel For Lock 2' 50 | TabOrder = 2 51 | OnClick = Button3Click 52 | end 53 | object Button4: TButton 54 | Left = 328 55 | Top = 4 56 | Width = 120 57 | Height = 25 58 | Caption = 'Parallel For Lock Free' 59 | TabOrder = 3 60 | OnClick = Button4Click 61 | end 62 | end 63 | object Memo: TMemo 64 | Left = 6 65 | Top = 41 66 | Width = 607 67 | Height = 351 68 | Align = alClient 69 | TabOrder = 1 70 | end 71 | end 72 | -------------------------------------------------------------------------------- /Part2/13 Parallel Collections/DependentParallelCollectionsMainF.pas: -------------------------------------------------------------------------------- 1 | unit DependentParallelCollectionsMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Classes, 10 | System.Threading, 11 | System.Generics.Collections, 12 | System.Diagnostics, 13 | System.Math, 14 | System.SyncObjs, 15 | Vcl.Graphics, 16 | Vcl.Controls, 17 | Vcl.Forms, 18 | Vcl.Dialogs, 19 | Vcl.StdCtrls, 20 | Vcl.ExtCtrls; 21 | 22 | type 23 | TMainForm = class(TForm) 24 | Panel1: TPanel; 25 | Button1: TButton; 26 | Memo: TMemo; 27 | Button2: TButton; 28 | Button3: TButton; 29 | Button4: TButton; 30 | procedure Button1Click(Sender: TObject); 31 | procedure Button2Click(Sender: TObject); 32 | procedure Button3Click(Sender: TObject); 33 | procedure Button4Click(Sender: TObject); 34 | private 35 | public 36 | end; 37 | 38 | var 39 | MainForm: TMainForm; 40 | 41 | implementation 42 | 43 | {$R *.dfm} 44 | 45 | procedure PopulateList(List: TList>); 46 | var 47 | i, j: Integer; 48 | a: TArray; 49 | begin 50 | for i := 0 to 10000 do 51 | begin 52 | SetLength(a, 10000); 53 | for j := 0 to High(a) do 54 | a[j] := Random(10000); 55 | List.Add(a); 56 | end; 57 | end; 58 | 59 | 60 | procedure SortItemsAndSumForLoop(List: TList>); 61 | var 62 | i, j: Integer; 63 | Sorted: TArray; 64 | Total: Int64; 65 | begin 66 | Total := 0; 67 | for i := 0 to List.Count - 1 do 68 | begin 69 | Sorted := List[i]; 70 | TArray.Sort(Sorted); 71 | for j := 0 to High(Sorted) do 72 | Total := Total + Sorted[j]; 73 | end; 74 | end; 75 | 76 | procedure TMainForm.Button1Click(Sender: TObject); 77 | var 78 | List: TList>; 79 | t: TStopwatch; 80 | begin 81 | Memo.Lines.Add('Running for loop in single thread...'); 82 | List := TList>.Create; 83 | try 84 | PopulateList(List); 85 | t := TStopwatch.StartNew; 86 | SortItemsAndSumForLoop(List); 87 | t.Stop; 88 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 89 | finally 90 | List.Free; 91 | end; 92 | end; 93 | 94 | 95 | procedure SortItemsAndSumParallelFor(List: TList>); 96 | var 97 | Total: Int64; 98 | Lock: TCriticalSection; 99 | begin 100 | Total := 0; 101 | Lock := TCriticalSection.Create; 102 | try 103 | TParallel.For(0, List.Count - 1, 104 | procedure(TaskIndex: Integer) 105 | var 106 | Sorted: TArray; 107 | i: integer; 108 | begin 109 | Sorted := List[TaskIndex]; 110 | TArray.Sort(Sorted); 111 | Lock.Enter; 112 | try 113 | for i := 0 to High(Sorted) do 114 | Total := Total + Sorted[i]; 115 | finally 116 | Lock.Leave; 117 | end; 118 | end); 119 | finally 120 | Lock.Free; 121 | end; 122 | end; 123 | 124 | procedure TMainForm.Button2Click(Sender: TObject); 125 | var 126 | List: TList>; 127 | t: TStopwatch; 128 | begin 129 | Memo.Lines.Add('Running parallel for with full lock ...'); 130 | List := TList>.Create; 131 | try 132 | PopulateList(List); 133 | t := TStopwatch.StartNew; 134 | SortItemsAndSumParallelFor(List); 135 | t.Stop; 136 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 137 | finally 138 | List.Free; 139 | end; 140 | end; 141 | 142 | 143 | 144 | procedure SortItemsAndSumParallelFor2(List: TList>); 145 | var 146 | Total: Int64; 147 | Lock: TCriticalSection; 148 | begin 149 | Total := 0; 150 | Lock := TCriticalSection.Create; 151 | try 152 | TParallel.For(0, List.Count - 1, 153 | procedure(TaskIndex: Integer) 154 | var 155 | Sorted: TArray; 156 | TempTotal: Int64; 157 | i: Integer; 158 | begin 159 | Sorted := List[TaskIndex]; 160 | TArray.Sort(Sorted); 161 | TempTotal := 0; 162 | for i := 0 to High(Sorted) do 163 | TempTotal := TempTotal + Sorted[i]; 164 | Lock.Enter; 165 | try 166 | Total := Total + TempTotal; 167 | finally 168 | Lock.Leave; 169 | end; 170 | end); 171 | finally 172 | Lock.Free; 173 | end; 174 | end; 175 | 176 | procedure TMainForm.Button3Click(Sender: TObject); 177 | var 178 | List: TList>; 179 | t: TStopwatch; 180 | begin 181 | Memo.Lines.Add('Running parallel for with temporary total...'); 182 | List := TList>.Create; 183 | try 184 | PopulateList(List); 185 | t := TStopwatch.StartNew; 186 | SortItemsAndSumParallelFor2(List); 187 | t.Stop; 188 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 189 | finally 190 | List.Free; 191 | end; 192 | end; 193 | 194 | 195 | 196 | procedure SortItemsAndSumParallelForLockFree(List: TList>); 197 | var 198 | Total: Int64; 199 | begin 200 | Total := 0; 201 | TParallel.For(0, List.Count - 1, 202 | procedure(TaskIndex: Integer) 203 | var 204 | Sorted: TArray; 205 | TempTotal: Int64; 206 | i: integer; 207 | begin 208 | Sorted := List[TaskIndex]; 209 | TArray.Sort(Sorted); 210 | TempTotal := 0; 211 | for i := 0 to High(Sorted) do 212 | TempTotal := TempTotal + Sorted[i]; 213 | TInterlocked.Add(Total, TempTotal); 214 | end); 215 | end; 216 | 217 | procedure TMainForm.Button4Click(Sender: TObject); 218 | var 219 | List: TList>; 220 | t: TStopwatch; 221 | begin 222 | Memo.Lines.Add('Running parallel for lock free...'); 223 | List := TList>.Create; 224 | try 225 | PopulateList(List); 226 | t := TStopwatch.StartNew; 227 | SortItemsAndSumParallelForLockFree(List); 228 | t.Stop; 229 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 230 | finally 231 | List.Free; 232 | end; 233 | end; 234 | 235 | 236 | initialization 237 | 238 | Randomize; 239 | 240 | end. 241 | -------------------------------------------------------------------------------- /Part2/13 Parallel Collections/ParallelCollections.dpr: -------------------------------------------------------------------------------- 1 | program ParallelCollections; 2 | 3 | uses 4 | Vcl.Forms, 5 | ParallelCollectionsMainF in 'ParallelCollectionsMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part2/13 Parallel Collections/ParallelCollectionsMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 398 6 | ClientWidth = 619 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 607 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 0 28 | Top = 4 29 | Width = 90 30 | Height = 25 31 | Caption = 'Single Thread' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | object Button2: TButton 36 | Left = 96 37 | Top = 4 38 | Width = 100 39 | Height = 25 40 | Caption = 'Multiple Threads' 41 | TabOrder = 1 42 | OnClick = Button2Click 43 | end 44 | object Button3: TButton 45 | Left = 202 46 | Top = 4 47 | Width = 90 48 | Height = 25 49 | Caption = 'Multiple Tasks' 50 | TabOrder = 2 51 | OnClick = Button3Click 52 | end 53 | object Button4: TButton 54 | Left = 298 55 | Top = 4 56 | Width = 90 57 | Height = 25 58 | Caption = 'Parallel For' 59 | TabOrder = 3 60 | OnClick = Button4Click 61 | end 62 | object Button5: TButton 63 | Left = 394 64 | Top = 4 65 | Width = 90 66 | Height = 25 67 | Caption = 'Batch Threads' 68 | TabOrder = 4 69 | OnClick = Button5Click 70 | end 71 | end 72 | object Memo: TMemo 73 | Left = 6 74 | Top = 41 75 | Width = 607 76 | Height = 351 77 | Align = alClient 78 | TabOrder = 1 79 | end 80 | end 81 | -------------------------------------------------------------------------------- /Part2/13 Parallel Collections/ParallelCollectionsMainF.pas: -------------------------------------------------------------------------------- 1 | unit ParallelCollectionsMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Classes, 10 | System.Threading, 11 | System.Generics.Collections, 12 | System.Diagnostics, 13 | System.Math, 14 | System.SyncObjs, 15 | Vcl.Graphics, 16 | Vcl.Controls, 17 | Vcl.Forms, 18 | Vcl.Dialogs, 19 | Vcl.StdCtrls, 20 | Vcl.ExtCtrls; 21 | 22 | type 23 | TMainForm = class(TForm) 24 | Panel1: TPanel; 25 | Button1: TButton; 26 | Memo: TMemo; 27 | Button2: TButton; 28 | Button3: TButton; 29 | Button4: TButton; 30 | Button5: TButton; 31 | procedure Button1Click(Sender: TObject); 32 | procedure Button2Click(Sender: TObject); 33 | procedure Button3Click(Sender: TObject); 34 | procedure Button4Click(Sender: TObject); 35 | procedure Button5Click(Sender: TObject); 36 | private 37 | public 38 | end; 39 | 40 | var 41 | MainForm: TMainForm; 42 | 43 | implementation 44 | 45 | {$R *.dfm} 46 | 47 | procedure PopulateList(List: TList>); 48 | var 49 | i, j: Integer; 50 | a: TArray; 51 | begin 52 | for i := 0 to 10000 do 53 | begin 54 | SetLength(a, 10000); 55 | for j := 0 to High(a) do 56 | a[j] := Random(10000); 57 | List.Add(a); 58 | end; 59 | end; 60 | 61 | 62 | 63 | procedure SortItemsForLoop(List: TList>); 64 | var 65 | i: Integer; 66 | Sorted: TArray; 67 | begin 68 | for i := 0 to List.Count - 1 do 69 | begin 70 | Sorted := List[i]; 71 | TArray.Sort(Sorted); 72 | end; 73 | end; 74 | 75 | procedure TMainForm.Button1Click(Sender: TObject); 76 | var 77 | List: TList>; 78 | t: TStopwatch; 79 | begin 80 | Memo.Lines.Add('Running for loop in single thread...'); 81 | List := TList>.Create; 82 | try 83 | PopulateList(List); 84 | t := TStopwatch.StartNew; 85 | SortItemsForLoop(List); 86 | t.Stop; 87 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 88 | finally 89 | List.Free; 90 | end; 91 | end; 92 | 93 | 94 | 95 | procedure SortItemsThreads(List: TList>); 96 | var 97 | Finished: Integer; 98 | 99 | procedure RunThread(Sorted: TArray); 100 | begin 101 | TThread.CreateAnonymousThread( 102 | procedure 103 | begin 104 | TArray.Sort(Sorted); 105 | TInterlocked.Decrement(Finished); 106 | end).Start; 107 | end; 108 | 109 | var 110 | i: Integer; 111 | begin 112 | Finished := List.Count; 113 | for i := 0 to List.Count - 1 do 114 | RunThread(List[i]); 115 | 116 | while Finished > 0 do 117 | begin 118 | Sleep(100); 119 | Application.ProcessMessages; 120 | end; 121 | end; 122 | 123 | procedure TMainForm.Button2Click(Sender: TObject); 124 | var 125 | List: TList>; 126 | t: TStopwatch; 127 | begin 128 | Memo.Lines.Add('Running multiple threads - can crash ...'); 129 | List := TList>.Create; 130 | try 131 | PopulateList(List); 132 | t := TStopwatch.StartNew; 133 | SortItemsThreads(List); 134 | t.Stop; 135 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 136 | finally 137 | List.Free; 138 | end; 139 | end; 140 | 141 | 142 | 143 | procedure SortItemsTasks(List: TList>); 144 | var 145 | Finished: Integer; 146 | 147 | procedure RunTask(Sorted: TArray); 148 | begin 149 | TTask.Run( 150 | procedure 151 | begin 152 | TArray.Sort(Sorted); 153 | TInterlocked.Decrement(Finished); 154 | end); 155 | end; 156 | 157 | var 158 | i: Integer; 159 | begin 160 | Finished := List.Count; 161 | for i := 0 to List.Count - 1 do 162 | RunTask(List[i]); 163 | 164 | while Finished > 0 do 165 | begin 166 | Sleep(100); 167 | Application.ProcessMessages; 168 | end; 169 | end; 170 | 171 | procedure TMainForm.Button3Click(Sender: TObject); 172 | var 173 | List: TList>; 174 | t: TStopwatch; 175 | begin 176 | Memo.Lines.Add('Running multiple tasks...'); 177 | List := TList>.Create; 178 | try 179 | PopulateList(List); 180 | t := TStopwatch.StartNew; 181 | SortItemsTasks(List); 182 | t.Stop; 183 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 184 | finally 185 | List.Free; 186 | end; 187 | end; 188 | 189 | 190 | 191 | procedure SortItemsParallelLoop(List: TList>); 192 | begin 193 | TParallel.For(10, 0, List.Count - 1, 194 | procedure(TaskIndex: Integer) 195 | begin 196 | TArray.Sort(List[TaskIndex]); 197 | end); 198 | end; 199 | 200 | procedure TMainForm.Button4Click(Sender: TObject); 201 | var 202 | List: TList>; 203 | t: TStopwatch; 204 | begin 205 | Memo.Lines.Add('Running parallel for loop...'); 206 | List := TList>.Create; 207 | try 208 | PopulateList(List); 209 | t := TStopwatch.StartNew; 210 | SortItemsParallelLoop(List); 211 | t.Stop; 212 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 213 | finally 214 | List.Free; 215 | end; 216 | end; 217 | 218 | 219 | 220 | procedure SortItemsParallelThreads(List: TList>); 221 | var 222 | Finished: Integer; 223 | 224 | procedure SortItemsBatch(List: TList>; L, H: Integer); 225 | begin 226 | TThread.CreateAnonymousThread( 227 | procedure 228 | var 229 | i: Integer; 230 | Sorted: TArray; 231 | begin 232 | for i := L to H do 233 | begin 234 | Sorted := List[i]; 235 | TArray.Sort(Sorted); 236 | TInterlocked.Decrement(Finished); 237 | end; 238 | end).Start; 239 | end; 240 | 241 | var 242 | i: Integer; 243 | Stride: Integer; 244 | L, H: Integer; 245 | begin 246 | Finished := List.Count; 247 | 248 | if List.Count <= CPUCount then 249 | Stride := 1 250 | else 251 | Stride := List.Count div CPUCount; 252 | 253 | for i := 0 to List.Count div Stride do 254 | begin 255 | L := i * Stride; 256 | H := (i + 1) * Stride - 1; 257 | if H >= List.Count then 258 | H := List.Count - 1; 259 | if L <= H then 260 | SortItemsBatch(List, L, H); 261 | end; 262 | 263 | while Finished > 0 do 264 | begin 265 | Sleep(100); 266 | Application.ProcessMessages; 267 | end; 268 | end; 269 | 270 | procedure TMainForm.Button5Click(Sender: TObject); 271 | var 272 | List: TList>; 273 | t: TStopwatch; 274 | begin 275 | Memo.Lines.Add('Running multiple batch threads...'); 276 | List := TList>.Create; 277 | try 278 | PopulateList(List); 279 | t := TStopwatch.StartNew; 280 | SortItemsParallelThreads(List); 281 | t.Stop; 282 | Memo.Lines.Add('Finished in ms ' + t.ElapsedMilliseconds.ToString); 283 | finally 284 | List.Free; 285 | end; 286 | end; 287 | 288 | 289 | initialization 290 | 291 | Randomize; 292 | 293 | end. 294 | -------------------------------------------------------------------------------- /Part2/5 FPCR/BrokenMath.dpr: -------------------------------------------------------------------------------- 1 | program BrokenMath; 2 | 3 | {$APPTYPE CONSOLE} 4 | {$R *.res} 5 | 6 | uses 7 | System.SysUtils, 8 | System.Classes, 9 | System.Math; 10 | 11 | // Note: Writing to console is not thread-safe and the output can be garbled. 12 | // However, this doesn't have direct impact on showing FPCR issue as the bug 13 | // will appear before we write the message and if we end up in broken code 14 | // path the content of the message itself is not important 15 | 16 | 17 | procedure BrokenExceptionMask; 18 | var 19 | OK: Boolean; 20 | begin 21 | OK := True; 22 | TThread.CreateAnonymousThread( 23 | procedure 24 | var 25 | i: integer; 26 | f, d: Double; 27 | m: TArithmeticExceptionMask; 28 | begin 29 | i := 0; 30 | d := 0; 31 | while OK do 32 | begin 33 | Inc(i); 34 | m := SetExceptionMask([TArithmeticException.exPrecision]); 35 | try 36 | f := 10 / d; 37 | // if it ends here - broken 38 | OK := False; 39 | Writeln('BROKEN FLOAT 1 ' + i.ToString); 40 | except 41 | end; 42 | end; 43 | end).Start; 44 | TThread.CreateAnonymousThread( 45 | procedure 46 | var 47 | i: integer; 48 | f, d: Double; 49 | m: TArithmeticExceptionMask; 50 | begin 51 | i := 0; 52 | d := 0; 53 | while OK do 54 | begin 55 | Inc(i); 56 | m := SetExceptionMask([TArithmeticException.exZeroDivide]); 57 | try 58 | f := 10 / d; 59 | except 60 | // if it ends here - broken 61 | OK := False; 62 | Writeln('BROKEN FLOAT 2 ' + i.ToString); 63 | end; 64 | end; 65 | end).Start; 66 | 67 | // run infinite loop until code breaks 68 | while OK do; 69 | end; 70 | 71 | procedure BrokenExceptionMaskMain; 72 | var 73 | OK: Boolean; 74 | i: integer; 75 | f, d: Double; 76 | begin 77 | OK := True; 78 | i := 0; 79 | d := 0; 80 | TThread.CreateAnonymousThread( 81 | procedure 82 | var 83 | i: integer; 84 | f, d: Double; 85 | begin 86 | i := 0; 87 | d := 0; 88 | while OK do 89 | try 90 | Inc(i); 91 | SetExceptionMask([TArithmeticException.exPrecision]); 92 | f := 10 / d; 93 | // if it ends here - broken 94 | OK := False; 95 | Writeln('BROKEN FLOAT 1 ' + i.ToString); 96 | except 97 | end; 98 | end).Start; 99 | 100 | // run infinite loop until code breaks 101 | while OK do 102 | try 103 | Inc(i); 104 | SetExceptionMask([TArithmeticException.exZeroDivide]); 105 | f := 10 / d; 106 | except 107 | // if it ends here - broken 108 | OK := False; 109 | Writeln('BROKEN FLOAT MAIN ' + i.ToString); 110 | end; 111 | end; 112 | 113 | begin 114 | try 115 | BrokenExceptionMask; 116 | // BrokenExceptionMaskMain; 117 | except 118 | on E: Exception do Writeln(E.ClassName, ': ', E.Message); 119 | end; 120 | Writeln; 121 | Writeln('DONE'); 122 | Readln; 123 | end. 124 | -------------------------------------------------------------------------------- /Part2/5 FPCR/SafeMath.dpr: -------------------------------------------------------------------------------- 1 | program SafeMath; 2 | 3 | {$APPTYPE CONSOLE} 4 | {$R *.res} 5 | 6 | uses 7 | System.SysUtils; 8 | 9 | // Thread safe implementations of FPCR functions 10 | // that can be used for patching RTL 11 | 12 | {$IFDEF MSWINDOWS} 13 | procedure SafeSet8087CW(NewCW: Word); 14 | var 15 | CW: Word; 16 | asm 17 | MOV CW, AX 18 | FNCLEX // don't raise pending exceptions enabled by the new flags 19 | FLDCW CW 20 | end; 21 | 22 | procedure SafeSetMXCSR(NewMXCSR: LongWord); 23 | var 24 | MXCSR: LongWord; 25 | asm 26 | AND EAX, $FFC0 //Remove flag bits 27 | MOV MXCSR, EAX 28 | LDMXCSR MXCSR 29 | end; 30 | 31 | procedure SetDefault8087CW(NewCW: Word); 32 | var 33 | CW: Word; 34 | asm 35 | MOV CW, AX 36 | MOV Default8087CW, AX 37 | FNCLEX // don't raise pending exceptions enabled by the new flags 38 | FLDCW CW 39 | end; 40 | 41 | procedure SetDefaultMXCSR(NewMXCSR: LongWord); 42 | var 43 | MXCSR: LongWord; 44 | asm 45 | AND EAX, $FFC0 // Remove flag bits 46 | MOV MXCSR, EAX 47 | MOV DefaultMXCSR, EAX 48 | LDMXCSR MXCSR 49 | end; 50 | 51 | procedure _FpuClear; 52 | asm 53 | FNSTCW [ESP-$02] 54 | FNINIT 55 | FLDCW [ESP-$02] 56 | {$IF Defined(CPUX86)} 57 | 58 | CMP System.TestSSE, 0 59 | JE @Exit 60 | {$ENDIF} 61 | 62 | STMXCSR [ESP-$04] 63 | AND [ESP-$04], $FFC0 //Remove flag bits 64 | LDMXCSR [ESP-$04] 65 | @Exit: 66 | end; 67 | {$ENDIF} 68 | 69 | {$IFDEF POSIX} 70 | procedure _FpuClear; 71 | begin 72 | FClearExcept; 73 | end; 74 | {$ENDIF} 75 | 76 | begin 77 | Writeln('DONE'); 78 | Readln; 79 | end. 80 | -------------------------------------------------------------------------------- /Part2/7.1 Parameters/Parameters.dpr: -------------------------------------------------------------------------------- 1 | program Parameters; 2 | 3 | uses 4 | Vcl.Forms, 5 | ParametersMainF in 'ParametersMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part2/7.1 Parameters/ParametersMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 281 6 | ClientWidth = 464 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 452 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 8 28 | Top = 6 29 | Width = 75 30 | Height = 25 31 | Caption = 'Int Param' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | object CancelBtn: TButton 36 | Left = 364 37 | Top = 4 38 | Width = 75 39 | Height = 25 40 | Caption = 'Cancel' 41 | TabOrder = 1 42 | OnClick = CancelBtnClick 43 | end 44 | object Button2: TButton 45 | Left = 89 46 | Top = 6 47 | Width = 75 48 | Height = 25 49 | Caption = 'Int64 Param' 50 | TabOrder = 2 51 | OnClick = Button2Click 52 | end 53 | end 54 | object Memo: TMemo 55 | Left = 6 56 | Top = 41 57 | Width = 452 58 | Height = 234 59 | Align = alClient 60 | TabOrder = 1 61 | end 62 | end 63 | -------------------------------------------------------------------------------- /Part2/7.1 Parameters/ParametersMainF.pas: -------------------------------------------------------------------------------- 1 | unit ParametersMainF; 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, Vcl.StdCtrls, Vcl.ExtCtrls; 8 | 9 | type 10 | TMainForm = class(TForm) 11 | Panel1: TPanel; 12 | Button1: TButton; 13 | Memo: TMemo; 14 | CancelBtn: TButton; 15 | Button2: TButton; 16 | procedure Button1Click(Sender: TObject); 17 | procedure CancelBtnClick(Sender: TObject); 18 | procedure Button2Click(Sender: TObject); 19 | private 20 | public 21 | Canceled: Boolean; 22 | end; 23 | 24 | var 25 | MainForm: TMainForm; 26 | 27 | implementation 28 | 29 | {$R *.dfm} 30 | 31 | function IntValue(Value: Integer): Integer; 32 | begin 33 | Result := Value; 34 | end; 35 | 36 | procedure TMainForm.Button1Click(Sender: TObject); 37 | var 38 | Value: Integer; 39 | begin 40 | Memo.Lines.Add('Working'); 41 | Canceled := False; 42 | TThread.CreateAnonymousThread( 43 | procedure 44 | begin 45 | while not Canceled do 46 | begin 47 | Value := -1; 48 | end; 49 | end).Start; 50 | 51 | TThread.CreateAnonymousThread( 52 | procedure 53 | var 54 | ValueCopy: Integer; 55 | begin 56 | while not Canceled do 57 | begin 58 | Value := 0; 59 | ValueCopy := IntValue(Value); 60 | if ValueCopy <> 0 then 61 | begin 62 | Canceled := True; 63 | TThread.Synchronize(nil, 64 | procedure 65 | begin 66 | Memo.Lines.Add('Not zero ' + ValueCopy.ToHexString); 67 | end); 68 | end; 69 | end; 70 | end).Start; 71 | end; 72 | 73 | function Int64Value(Value: Int64): Int64; 74 | begin 75 | Result := Value; 76 | end; 77 | 78 | procedure TMainForm.Button2Click(Sender: TObject); 79 | var 80 | Value: Int64; 81 | begin 82 | Memo.Lines.Add('Working'); 83 | Canceled := False; 84 | TThread.CreateAnonymousThread( 85 | procedure 86 | begin 87 | while not Canceled do 88 | begin 89 | Value := -1; 90 | end; 91 | end).Start; 92 | 93 | TThread.CreateAnonymousThread( 94 | procedure 95 | var 96 | ValueCopy: Int64; 97 | begin 98 | while not Canceled do 99 | begin 100 | Value := 0; 101 | ValueCopy := Int64Value(Value); 102 | if (ValueCopy <> 0) and (ValueCopy <> -1) then 103 | begin 104 | Canceled := True; 105 | TThread.Synchronize(nil, 106 | procedure 107 | begin 108 | Memo.Lines.Add('Not zero ' + ValueCopy.ToHexString); 109 | end); 110 | end; 111 | end; 112 | end).Start; 113 | end; 114 | 115 | procedure TMainForm.CancelBtnClick(Sender: TObject); 116 | begin 117 | Canceled := True; 118 | Memo.Lines.Add('Canceled'); 119 | end; 120 | 121 | end. 122 | 123 | -------------------------------------------------------------------------------- /Part2/8 Singletons/SingletonClassProp.pas: -------------------------------------------------------------------------------- 1 | unit SingletonClassProp; 2 | 3 | interface 4 | 5 | type 6 | TFoo = class 7 | private 8 | class var FInstance: TFoo; 9 | class constructor ClassCreate; 10 | class destructor ClassDestroy; 11 | public 12 | class property Instance: TFoo read FInstance; 13 | end; 14 | 15 | implementation 16 | 17 | class constructor TFoo.ClassCreate; 18 | begin 19 | FInstance := TFoo.Create; 20 | end; 21 | 22 | class destructor TFoo.ClassDestroy; 23 | begin 24 | FInstance.Free; 25 | end; 26 | 27 | end. 28 | -------------------------------------------------------------------------------- /Part2/8 Singletons/SingletonClasses.pas: -------------------------------------------------------------------------------- 1 | unit SingletonClasses; 2 | 3 | interface 4 | 5 | type 6 | IFoo = interface 7 | end; 8 | 9 | TFoo = class(TInterfacedObject, IFoo); 10 | 11 | TFooObject = class 12 | end; 13 | 14 | implementation 15 | 16 | end. 17 | -------------------------------------------------------------------------------- /Part2/8 Singletons/SingletonLazy.pas: -------------------------------------------------------------------------------- 1 | unit SingletonLazy; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | System.SysUtils, 8 | System.SyncObjs, 9 | SingletonClasses; 10 | 11 | type 12 | TSingletonLock = class 13 | private 14 | class var FInstance: TFooObject; 15 | class var FLock: TCriticalSection; 16 | class constructor ClassCreate; 17 | class destructor ClassDestroy; 18 | class function GetInstance: TFooObject; static; 19 | public 20 | class property Instance: TFooObject read GetInstance; 21 | end; 22 | 23 | TSingletonDoubleLock = class 24 | private 25 | class var FInstance: TFooObject; 26 | class var FLock: TCriticalSection; 27 | class constructor ClassCreate; 28 | class destructor ClassDestroy; 29 | class function GetInstance: TFooObject; static; 30 | public 31 | class property Instance: TFooObject read GetInstance; 32 | end; 33 | 34 | TSingletonLockFree = class 35 | private 36 | class var FInstance: TFooObject; 37 | class destructor ClassDestroy; 38 | class function GetInstance: TFooObject; static; 39 | public 40 | class property Instance: TFooObject read GetInstance; 41 | end; 42 | 43 | TSingletonLockFreeIntf = class 44 | public 45 | class var FInstance: IFoo; 46 | class function GetInstance: IFoo; static; 47 | public 48 | class property Instance: IFoo read GetInstance; 49 | end; 50 | 51 | TSingletonFlag = class 52 | private 53 | class var FInstance: IFoo; 54 | class var FFlag: Integer; 55 | class function GetInstance: IFoo; static; 56 | public 57 | class property Instance: IFoo read GetInstance; 58 | end; 59 | 60 | TWriteableInstance = class 61 | private 62 | class var FInstance: TFooObject; 63 | class var FLock: TCriticalSection; 64 | class constructor ClassCreate; 65 | class destructor ClassDestroy; 66 | class function GetInstance: TFooObject; static; 67 | class procedure SetInstance(Value: TFooObject); static; 68 | public 69 | class property Instance: TFooObject read GetInstance write SetInstance; 70 | end; 71 | 72 | implementation 73 | 74 | { TSingletonLock } 75 | 76 | class constructor TSingletonLock.ClassCreate; 77 | begin 78 | FLock := TCriticalSection.Create; 79 | end; 80 | 81 | class destructor TSingletonLock.ClassDestroy; 82 | begin 83 | FInstance.Free; 84 | FLock.Free; 85 | end; 86 | 87 | class function TSingletonLock.GetInstance: TFooObject; 88 | begin 89 | FLock.Enter; 90 | try 91 | if FInstance = nil then 92 | FInstance := TFooObject.Create; 93 | Result := FInstance; 94 | finally 95 | FLock.Leave; 96 | end; 97 | end; 98 | 99 | { TSingletonDoubleLock } 100 | 101 | class constructor TSingletonDoubleLock.ClassCreate; 102 | begin 103 | FLock := TCriticalSection.Create; 104 | end; 105 | 106 | class destructor TSingletonDoubleLock.ClassDestroy; 107 | begin 108 | FInstance.Free; 109 | FLock.Free; 110 | end; 111 | 112 | class function TSingletonDoubleLock.GetInstance: TFooObject; 113 | begin 114 | if FInstance = nil then 115 | begin 116 | FLock.Enter; 117 | try 118 | if FInstance = nil then 119 | FInstance := TFooObject.Create; 120 | finally 121 | FLock.Leave; 122 | end; 123 | end; 124 | Result := FInstance; 125 | end; 126 | 127 | { TSingletonLockFree } 128 | 129 | class destructor TSingletonLockFree.ClassDestroy; 130 | begin 131 | FInstance.Free; 132 | end; 133 | 134 | class function TSingletonLockFree.GetInstance: TFooObject; 135 | var 136 | LInstance: TFooObject; 137 | begin 138 | if FInstance = nil then 139 | begin 140 | LInstance := TFooObject.Create; 141 | if TInterlocked.CompareExchange(FInstance, LInstance, nil) <> nil then 142 | LInstance.Free; 143 | end; 144 | Result := FInstance; 145 | end; 146 | 147 | 148 | { TSingletonLockFreeIntf } 149 | 150 | class function TSingletonLockFreeIntf.GetInstance: IFoo; 151 | begin 152 | if FInstance = nil then 153 | begin 154 | Result := TFoo.Create; 155 | if TInterlocked.CompareExchange(Pointer(FInstance), Pointer(Result), nil) = nil then 156 | Pointer(Result) := nil; 157 | end; 158 | Result := FInstance; 159 | end; 160 | 161 | { TSingletonFlag } 162 | 163 | class function TSingletonFlag.GetInstance: IFoo; 164 | begin 165 | while FInstance = nil do 166 | begin 167 | if TInterlocked.CompareExchange(FFlag, 1, 0) = 0 then 168 | FInstance := TFoo.Create 169 | else 170 | YieldProcessor; 171 | end; 172 | Result := FInstance; 173 | end; 174 | 175 | { TWriteableInstance } 176 | 177 | class constructor TWriteableInstance.ClassCreate; 178 | begin 179 | FLock := TCriticalSection.Create; 180 | end; 181 | 182 | class destructor TWriteableInstance.ClassDestroy; 183 | begin 184 | FInstance.Free; 185 | FLock.Free; 186 | end; 187 | 188 | class function TWriteableInstance.GetInstance: TFooObject; 189 | begin 190 | FLock.Enter; 191 | try 192 | Result := FInstance; 193 | finally 194 | FLock.Leave; 195 | end; 196 | end; 197 | 198 | class procedure TWriteableInstance.SetInstance(Value: TFooObject); 199 | begin 200 | FLock.Enter; 201 | try 202 | FInstance.Free; 203 | FInstance := Value; 204 | finally 205 | FLock.Leave; 206 | end; 207 | end; 208 | 209 | end. 210 | -------------------------------------------------------------------------------- /Part2/8 Singletons/SingletonLocal.pas: -------------------------------------------------------------------------------- 1 | unit SingletonLocal; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | SingletonClasses; 8 | 9 | function LocalObject: TFooObject; 10 | function LocalInterface: IFoo; 11 | 12 | implementation 13 | 14 | var 15 | Foo: IFoo; 16 | FooObj: TFooObject; 17 | 18 | function LocalObject: TFooObject; 19 | begin 20 | Result := FooObj; 21 | end; 22 | 23 | function LocalInterface: IFoo; 24 | begin 25 | Result := Foo; 26 | end; 27 | 28 | initialization 29 | 30 | Foo := TFoo.Create; 31 | FooObj := TFooObject.Create; 32 | 33 | finalization 34 | 35 | FooObj.Free; 36 | 37 | end. 38 | -------------------------------------------------------------------------------- /Part2/8 Singletons/Singletons.dpr: -------------------------------------------------------------------------------- 1 | program Singletons; 2 | 3 | uses 4 | Vcl.Forms, 5 | SingletonsMainF in 'SingletonsMainF.pas' {MainForm}, 6 | SingletonLocal in 'SingletonLocal.pas', 7 | SingletonClasses in 'SingletonClasses.pas', 8 | SingletonClassProp in 'SingletonClassProp.pas', 9 | SingletonLazy in 'SingletonLazy.pas'; 10 | 11 | {$R *.res} 12 | 13 | begin 14 | ReportMemoryLeaksOnShutdown := True; 15 | Application.Initialize; 16 | Application.MainFormOnTaskbar := True; 17 | Application.CreateForm(TMainForm, MainForm); 18 | Application.Run; 19 | end. 20 | 21 | -------------------------------------------------------------------------------- /Part2/8 Singletons/Singletons.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {823A6FF8-0445-46AF-80E4-F910DFB8EE48} 4 | Singletons.dpr 5 | True 6 | Debug 7 | 693377 8 | Application 9 | VCL 10 | 19.5 11 | Win32 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 | Base 34 | true 35 | 36 | 37 | true 38 | Base 39 | true 40 | 41 | 42 | true 43 | Cfg_1 44 | true 45 | true 46 | 47 | 48 | true 49 | Base 50 | true 51 | 52 | 53 | true 54 | Cfg_2 55 | true 56 | true 57 | 58 | 59 | true 60 | Cfg_2 61 | true 62 | true 63 | 64 | 65 | true 66 | Cfg_2 67 | true 68 | true 69 | 70 | 71 | true 72 | Cfg_2 73 | true 74 | true 75 | 76 | 77 | true 78 | Cfg_2 79 | true 80 | true 81 | 82 | 83 | false 84 | false 85 | false 86 | false 87 | false 88 | 00400000 89 | Singletons 90 | Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) 91 | 1050 92 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= 93 | 94 | 95 | $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png 96 | annotation-1.2.0.dex.jar;asynclayoutinflater-1.0.0.dex.jar;billing-4.0.0.dex.jar;browser-1.0.0.dex.jar;cloud-messaging.dex.jar;collection-1.0.0.dex.jar;coordinatorlayout-1.0.0.dex.jar;core-1.5.0-rc02.dex.jar;core-common-2.0.1.dex.jar;core-runtime-2.0.1.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;firebase-annotations-16.0.0.dex.jar;firebase-common-20.0.0.dex.jar;firebase-components-17.0.0.dex.jar;firebase-datatransport-18.0.0.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.0.0.dex.jar;firebase-installations-interop-17.0.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-22.0.0.dex.jar;fmx.dex.jar;fragment-1.0.0.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;legacy-support-core-ui-1.0.0.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.0.0.dex.jar;lifecycle-livedata-2.0.0.dex.jar;lifecycle-livedata-core-2.0.0.dex.jar;lifecycle-runtime-2.0.0.dex.jar;lifecycle-service-2.0.0.dex.jar;lifecycle-viewmodel-2.0.0.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;play-services-ads-20.1.0.dex.jar;play-services-ads-base-20.1.0.dex.jar;play-services-ads-identifier-17.0.0.dex.jar;play-services-ads-lite-20.1.0.dex.jar;play-services-base-17.5.0.dex.jar;play-services-basement-17.6.0.dex.jar;play-services-cloud-messaging-16.0.0.dex.jar;play-services-drive-17.0.0.dex.jar;play-services-games-21.0.0.dex.jar;play-services-location-18.0.0.dex.jar;play-services-maps-17.0.1.dex.jar;play-services-measurement-base-18.0.0.dex.jar;play-services-measurement-sdk-api-18.0.0.dex.jar;play-services-places-placereport-17.0.0.dex.jar;play-services-stats-17.0.0.dex.jar;play-services-tasks-17.2.0.dex.jar;print-1.0.0.dex.jar;room-common-2.1.0.dex.jar;room-runtime-2.1.0.dex.jar;slidingpanelayout-1.0.0.dex.jar;sqlite-2.0.1.dex.jar;sqlite-framework-2.0.1.dex.jar;swiperefreshlayout-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.0.0.dex.jar;transport-runtime-3.0.0.dex.jar;user-messaging-platform-1.0.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.1.0.dex.jar 97 | 98 | 99 | $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_1024x1024.png 100 | 101 | 102 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 103 | Debug 104 | true 105 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) 106 | 1033 107 | $(BDS)\bin\default_app.manifest 108 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 109 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 110 | 111 | 112 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 113 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 114 | 115 | 116 | RELEASE;$(DCC_Define) 117 | 0 118 | false 119 | 0 120 | 121 | 122 | PerMonitorV2 123 | 124 | 125 | DEBUG;$(DCC_Define) 126 | false 127 | true 128 | true 129 | true 130 | 131 | 132 | Debug 133 | 134 | 135 | Debug 136 | 137 | 138 | Debug 139 | 140 | 141 | Debug 142 | 143 | 144 | PerMonitorV2 145 | 146 | 147 | 148 | MainSource 149 | 150 | 151 |
MainForm
152 | 153 | 154 | 155 | 156 | 157 | 158 | Base 159 | 160 | 161 | Cfg_1 162 | Base 163 | 164 | 165 | Cfg_2 166 | Base 167 | 168 | 169 | 170 | Delphi.Personality.12 171 | 172 | 173 | 174 | 175 | Singletons.dpr 176 | 177 | 178 | 179 | True 180 | True 181 | True 182 | True 183 | True 184 | True 185 | True 186 | False 187 | 188 | 189 | 12 190 | 191 | 192 | 193 | 194 | -------------------------------------------------------------------------------- /Part2/8 Singletons/SingletonsMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 281 6 | ClientWidth = 464 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 452 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 8 28 | Top = 6 29 | Width = 113 30 | Height = 25 31 | Caption = 'Create Singleton' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | end 36 | object Memo: TMemo 37 | Left = 6 38 | Top = 41 39 | Width = 452 40 | Height = 234 41 | Align = alClient 42 | TabOrder = 1 43 | end 44 | end 45 | -------------------------------------------------------------------------------- /Part2/8 Singletons/SingletonsMainF.pas: -------------------------------------------------------------------------------- 1 | unit SingletonsMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | Vcl.Graphics, 12 | Vcl.Controls, 13 | Vcl.Forms, 14 | Vcl.Dialogs, 15 | Vcl.StdCtrls, 16 | Vcl.ExtCtrls, 17 | SingletonClasses, 18 | SingletonLocal, 19 | SingletonClassProp, 20 | SingletonLazy; 21 | 22 | type 23 | TMainForm = class(TForm) 24 | Panel1: TPanel; 25 | Button1: TButton; 26 | Memo: TMemo; 27 | procedure Button1Click(Sender: TObject); 28 | private 29 | public 30 | end; 31 | 32 | var 33 | MainForm: TMainForm; 34 | 35 | implementation 36 | 37 | {$R *.dfm} 38 | 39 | procedure TMainForm.Button1Click(Sender: TObject); 40 | begin 41 | // Any of the provided singleton classes can be safely 42 | // accessed from multiple threads. 43 | // That safety is only valid for retrieving singleton reference - f 44 | // Whether working with data stored in instance itself is thread-safe 45 | // depends on the safety of TFoo and TFooObject classes 46 | TThread.CreateAnonymousThread( 47 | procedure 48 | begin 49 | var f := TSingletonFlag.Instance; 50 | end).Start; 51 | var f := TSingletonFlag.Instance; 52 | end; 53 | 54 | end. 55 | -------------------------------------------------------------------------------- /Part3/16 Serialization/Serialization.dpr: -------------------------------------------------------------------------------- 1 | program Serialization; 2 | 3 | uses 4 | Vcl.Forms, 5 | SerializationMainF in 'SerializationMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | ReportMemoryLeaksOnShutdown := True; 11 | Application.Initialize; 12 | Application.MainFormOnTaskbar := True; 13 | Application.CreateForm(TMainForm, MainForm); 14 | Application.Run; 15 | end. 16 | 17 | -------------------------------------------------------------------------------- /Part3/16 Serialization/SerializationMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'Serialization' 5 | ClientHeight = 358 6 | ClientWidth = 703 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 691 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | ExplicitWidth = 776 27 | object Button1: TButton 28 | Left = 0 29 | Top = 4 30 | Width = 110 31 | Height = 25 32 | Caption = 'Data Handover' 33 | TabOrder = 0 34 | OnClick = Button1Click 35 | end 36 | object Button2: TButton 37 | Left = 116 38 | Top = 4 39 | Width = 110 40 | Height = 25 41 | Caption = 'Data Handover ARC' 42 | TabOrder = 1 43 | OnClick = Button2Click 44 | end 45 | object Button3: TButton 46 | Left = 232 47 | Top = 4 48 | Width = 110 49 | Height = 25 50 | Caption = 'Read-only Data' 51 | TabOrder = 2 52 | OnClick = Button3Click 53 | end 54 | object Button4: TButton 55 | Left = 348 56 | Top = 4 57 | Width = 80 58 | Height = 25 59 | Caption = 'TMonitor' 60 | TabOrder = 3 61 | OnClick = Button4Click 62 | end 63 | object Button5: TButton 64 | Left = 434 65 | Top = 4 66 | Width = 80 67 | Height = 25 68 | Caption = 'TNetEncoding' 69 | TabOrder = 4 70 | OnClick = Button5Click 71 | end 72 | object Button6: TButton 73 | Left = 517 74 | Top = 4 75 | Width = 80 76 | Height = 25 77 | Caption = 'JSON' 78 | TabOrder = 5 79 | OnClick = Button6Click 80 | end 81 | object Button7: TButton 82 | Left = 603 83 | Top = 4 84 | Width = 80 85 | Height = 25 86 | Caption = 'XML' 87 | TabOrder = 6 88 | OnClick = Button7Click 89 | end 90 | end 91 | object Memo: TMemo 92 | Left = 6 93 | Top = 41 94 | Width = 691 95 | Height = 311 96 | Align = alClient 97 | TabOrder = 1 98 | ExplicitWidth = 776 99 | end 100 | end 101 | -------------------------------------------------------------------------------- /Part3/16 Serialization/SerializationMainF.pas: -------------------------------------------------------------------------------- 1 | unit SerializationMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | System.SyncObjs, 12 | System.NetEncoding, 13 | System.JSON, 14 | Winapi.ActiveX, 15 | REST.Json, 16 | Xml.XMLDoc, 17 | Xml.XMLIntf, 18 | Xml.XMLSchema, 19 | Vcl.Controls, 20 | Vcl.Forms, 21 | Vcl.Dialogs, 22 | Vcl.StdCtrls, 23 | Vcl.ExtCtrls; 24 | 25 | type 26 | TMainForm = class(TForm) 27 | Panel1: TPanel; 28 | Button1: TButton; 29 | Memo: TMemo; 30 | Button2: TButton; 31 | Button3: TButton; 32 | Button4: TButton; 33 | Button5: TButton; 34 | Button6: TButton; 35 | Button7: TButton; 36 | procedure Button1Click(Sender: TObject); 37 | procedure Button2Click(Sender: TObject); 38 | procedure Button3Click(Sender: TObject); 39 | procedure Button4Click(Sender: TObject); 40 | procedure Button5Click(Sender: TObject); 41 | procedure Button6Click(Sender: TObject); 42 | procedure Button7Click(Sender: TObject); 43 | procedure Button8Click(Sender: TObject); 44 | private 45 | public 46 | end; 47 | 48 | {$M+} 49 | TFoo = class 50 | private 51 | FData: string; 52 | published 53 | property Data: string read FData write FData; 54 | end; 55 | 56 | IFoo = interface 57 | function GetData: string; 58 | procedure SetData(const Value: string); 59 | property Data: string read GetData write SetData; 60 | end; 61 | 62 | {$M+} 63 | TInterfacedFoo = class(TInterfacedObject, IFoo) 64 | private 65 | FData: string; 66 | function GetData: string; 67 | procedure SetData(const Value: string); 68 | published 69 | property Data: string read GetData write SetData; 70 | end; 71 | 72 | IValues = interface 73 | function GetValue1: string; 74 | function GetValue2: string; 75 | procedure SetValue1(const Value: string); 76 | procedure SetValue2(const Value: string); 77 | property Value1: string read GetValue1 write SetValue1; 78 | property Value2: string read GetValue2 write SetValue2; 79 | end; 80 | 81 | TThreadValues = class(TInterfacedObject, IValues) 82 | private 83 | FLock: TCriticalSection; 84 | FValue1: string; 85 | FValue2: string; 86 | function GetValue1: string; 87 | function GetValue2: string; 88 | procedure SetValue1(const Value: string); 89 | procedure SetValue2(const Value: string); 90 | public 91 | constructor Create; 92 | destructor Destroy; override; 93 | published 94 | property Value1: string read GetValue1 write SetValue1; 95 | property Value2: string read GetValue2 write SetValue2; 96 | end; 97 | 98 | TValues = class(TInterfacedObject, IValues) 99 | private 100 | FValue1: string; 101 | FValue2: string; 102 | function GetValue1: string; 103 | function GetValue2: string; 104 | procedure SetValue1(const Value: string); 105 | procedure SetValue2(const Value: string); 106 | published 107 | property Value1: string read GetValue1 write SetValue1; 108 | property Value2: string read GetValue2 write SetValue2; 109 | end; 110 | 111 | 112 | {$M+} 113 | TBar = class 114 | private 115 | FData: string; 116 | FNumber: Double; 117 | published 118 | property Data: string read FData write FData; 119 | property Number: Double read FNumber write FNumber; 120 | end; 121 | 122 | 123 | var 124 | MainForm: TMainForm; 125 | 126 | implementation 127 | 128 | {$R *.dfm} 129 | 130 | { TInterfacedFoo } 131 | 132 | function TInterfacedFoo.GetData: string; 133 | begin 134 | Result := FData; 135 | end; 136 | 137 | procedure TInterfacedFoo.SetData(const Value: string); 138 | begin 139 | FData := Value; 140 | end; 141 | 142 | { TThreadValues } 143 | 144 | constructor TThreadValues.Create; 145 | begin 146 | FLock := TCriticalSection.Create; 147 | end; 148 | 149 | destructor TThreadValues.Destroy; 150 | begin 151 | FLock.Free; 152 | inherited; 153 | end; 154 | 155 | function TThreadValues.GetValue1: string; 156 | begin 157 | FLock.Enter; 158 | try 159 | Result := FValue1; 160 | finally 161 | FLock.Leave; 162 | end; 163 | end; 164 | 165 | function TThreadValues.GetValue2: string; 166 | begin 167 | FLock.Enter; 168 | try 169 | Result := FValue2; 170 | finally 171 | FLock.Leave; 172 | end; 173 | end; 174 | 175 | procedure TThreadValues.SetValue1(const Value: string); 176 | begin 177 | FLock.Enter; 178 | try 179 | FValue1 := Value; 180 | finally 181 | FLock.Leave; 182 | end; 183 | end; 184 | 185 | procedure TThreadValues.SetValue2(const Value: string); 186 | begin 187 | FLock.Enter; 188 | try 189 | FValue2 := Value; 190 | finally 191 | FLock.Leave; 192 | end; 193 | end; 194 | 195 | { TValues } 196 | 197 | function TValues.GetValue1: string; 198 | begin 199 | Result := FValue1; 200 | end; 201 | 202 | function TValues.GetValue2: string; 203 | begin 204 | Result := FValue2; 205 | end; 206 | 207 | procedure TValues.SetValue1(const Value: string); 208 | begin 209 | FValue1 := Value; 210 | end; 211 | 212 | procedure TValues.SetValue2(const Value: string); 213 | begin 214 | FValue2 := Value; 215 | end; 216 | 217 | 218 | // fake serialization function 219 | function Convert(const aData: TObject): string; 220 | begin 221 | Result := aData.ClassName; 222 | end; 223 | 224 | function ConvertJSON(const aData: TObject): string; 225 | begin 226 | Result := TJson.ObjectToJsonString(aData); 227 | end; 228 | 229 | // simplified XML serialization for IFoo 230 | function ConvertFooXML(const aData: IFoo): string; 231 | begin 232 | Result := ''#13#10' ' + aData.Data + ''#13#10''; 233 | end; 234 | 235 | // simplified XML serialization for IValues 236 | function ConvertValuesXML(const aData: IValues): string; 237 | begin 238 | Result := ''#13#10' ' + aData.Value1 + ''#13#10 + 239 | ' ' + aData.Value2 + ''#13#10''; 240 | end; 241 | 242 | procedure TMainForm.Button1Click(Sender: TObject); 243 | var 244 | Foo: TFoo; 245 | begin 246 | Memo.Lines.Clear; 247 | Foo := TFoo.Create; 248 | try 249 | Foo.Data := 'abc'; 250 | TThread.CreateAnonymousThread( 251 | procedure 252 | var 253 | Converted: string; 254 | begin 255 | try 256 | Converted := Convert(Foo); 257 | TThread.Synchronize(nil, 258 | procedure 259 | begin 260 | Memo.Lines.Add(Converted); 261 | end); 262 | finally 263 | Foo.Free; 264 | end; 265 | end).Start; 266 | except 267 | Foo.Free; 268 | raise; 269 | end; 270 | end; 271 | 272 | procedure TMainForm.Button2Click(Sender: TObject); 273 | var 274 | Foo: IFoo; 275 | begin 276 | Memo.Lines.Clear; 277 | Foo := TInterfacedFoo.Create; 278 | Foo.Data := 'abc'; 279 | 280 | TThread.CreateAnonymousThread( 281 | procedure 282 | var 283 | Converted: string; 284 | begin 285 | Converted := Convert(TObject(Foo)); 286 | TThread.Synchronize(nil, 287 | procedure 288 | begin 289 | Memo.Lines.Add(Converted); 290 | end); 291 | end).Start; 292 | end; 293 | 294 | procedure TMainForm.Button3Click(Sender: TObject); 295 | var 296 | Foo: IFoo; 297 | begin 298 | Memo.Lines.Clear; 299 | Foo := TInterfacedFoo.Create; 300 | Foo.Data := 'abc'; 301 | 302 | TThread.CreateAnonymousThread( 303 | procedure 304 | var 305 | JSON: string; 306 | begin 307 | JSON := ConvertJSON(TObject(Foo)); 308 | TThread.Synchronize(nil, 309 | procedure 310 | begin 311 | Memo.Lines.Add(JSON); 312 | end); 313 | end).Start; 314 | 315 | TThread.CreateAnonymousThread( 316 | procedure 317 | var 318 | XML: string; 319 | begin 320 | XML := ConvertFooXML(Foo); 321 | TThread.Synchronize(nil, 322 | procedure 323 | begin 324 | Memo.Lines.Add(XML); 325 | end); 326 | end).Start; 327 | 328 | Memo.Lines.Add(Foo.Data); 329 | end; 330 | 331 | procedure TMainForm.Button4Click(Sender: TObject); 332 | var 333 | Obj: IValues; 334 | begin 335 | Memo.Lines.Clear; 336 | // immediate initialization after object is constructed does not have to be protected 337 | // because at that point Obj instance is accessible only from single thread 338 | Obj := TThreadValues.Create; 339 | Obj.Value1 := 'abc'; 340 | Obj.Value2 := '123'; 341 | 342 | TThread.CreateAnonymousThread( 343 | procedure 344 | var 345 | XML: string; 346 | begin 347 | System.TMonitor.Enter(TObject(Obj)); 348 | try 349 | XML := ConvertValuesXML(Obj); 350 | finally 351 | System.TMonitor.Exit(TObject(Obj)); 352 | end; 353 | TThread.Synchronize(nil, 354 | procedure 355 | begin 356 | Memo.Lines.Add(XML); 357 | end); 358 | end).Start; 359 | 360 | // Changing Sleep value we can influence order of execution 361 | // and the result of the serialization 362 | Sleep(13); 363 | 364 | System.TMonitor.Enter(TObject(Obj)); 365 | try 366 | Obj.Value1 := '000'; 367 | Obj.Value2 := '444'; 368 | finally 369 | System.TMonitor.Exit(TObject(Obj)); 370 | end; 371 | end; 372 | 373 | procedure TMainForm.Button5Click(Sender: TObject); 374 | begin 375 | Memo.Lines.Clear; 376 | 377 | TThread.CreateAnonymousThread( 378 | procedure 379 | var 380 | Data1: string; 381 | Result1: string; 382 | begin 383 | Data1 := 'First'; 384 | Result1 := TNetEncoding.Base64.Encode(Data1); 385 | TThread.Synchronize(nil, 386 | procedure 387 | begin 388 | Memo.Lines.Add(Result1); 389 | end); 390 | end).Start; 391 | 392 | TThread.CreateAnonymousThread( 393 | procedure 394 | var 395 | Data2: string; 396 | Result2: string; 397 | begin 398 | Data2 := 'Second'; 399 | Result2 := TNetEncoding.Base64.Encode(Data2); 400 | TThread.Synchronize(nil, 401 | procedure 402 | begin 403 | Memo.Lines.Add(Result2); 404 | end); 405 | end).Start; 406 | end; 407 | 408 | procedure TMainForm.Button6Click(Sender: TObject); 409 | begin 410 | Memo.Lines.Clear; 411 | TThread.CreateAnonymousThread( 412 | procedure 413 | var 414 | Obj: TFoo; 415 | JSON: string; 416 | begin 417 | Obj := TFoo.Create; 418 | try 419 | Obj.Data := 'abc'; 420 | JSON := TJson.ObjectToJsonString(Obj); 421 | finally 422 | Obj.Free; 423 | end; 424 | 425 | Obj := nil; 426 | try 427 | Obj := TJson.JsonToObject(JSON); 428 | finally 429 | Obj.Free; 430 | end; 431 | 432 | TThread.Synchronize(nil, 433 | procedure 434 | begin 435 | Memo.Lines.Add(JSON); 436 | end); 437 | end).Start; 438 | end; 439 | 440 | procedure TMainForm.Button7Click(Sender: TObject); 441 | var 442 | Source: string; 443 | begin 444 | Source := '12.45'; 445 | TThread.CreateAnonymousThread( 446 | procedure 447 | var 448 | Doc: IXMLDocument; 449 | XML: string; 450 | begin 451 | {$IFDEF MSWINDOWS} 452 | CoInitialize(nil); 453 | try 454 | {$ENDIF} 455 | Doc := TXMLDocument.Create(nil); 456 | Doc.LoadFromXML(Source); 457 | 458 | Doc.SaveToXML(XML); 459 | {$IFDEF MSWINDOWS} 460 | finally 461 | CoUninitialize; 462 | end; 463 | {$ENDIF} 464 | TThread.Synchronize(nil, 465 | procedure 466 | begin 467 | Memo.Lines.Add(XML); 468 | end); 469 | end).Start; 470 | end; 471 | 472 | procedure TMainForm.Button8Click(Sender: TObject); 473 | var 474 | Source: string; 475 | begin 476 | Source := '12.45'; 477 | TThread.CreateAnonymousThread( 478 | procedure 479 | var 480 | Doc: IXMLDocument; 481 | XML: string; 482 | begin 483 | {$IFDEF MSWINDOWS} 484 | CoInitialize(nil); 485 | try 486 | {$ENDIF} 487 | 488 | Doc := TXMLDocument.Create(nil); 489 | Doc.LoadFromXML(Source); 490 | 491 | Doc.SaveToXML(XML); 492 | {$IFDEF MSWINDOWS} 493 | finally 494 | CoUninitialize; 495 | end; 496 | {$ENDIF} 497 | TThread.Synchronize(nil, 498 | procedure 499 | begin 500 | Memo.Lines.Add(XML); 501 | end); 502 | end).Start; 503 | end; 504 | 505 | end. 506 | -------------------------------------------------------------------------------- /Part3/17 SystemNet/NetClient.dpr: -------------------------------------------------------------------------------- 1 | program NetClient; 2 | 3 | uses 4 | Vcl.Forms, 5 | NetClientMainF in 'NetClientMainF.pas' {MainForm}, 6 | NX.Log in '..\..\Part6\33 Logging\NX.Log.pas'; 7 | 8 | {$R *.res} 9 | 10 | begin 11 | ReportMemoryLeaksOnShutdown := True; 12 | Application.Initialize; 13 | Application.MainFormOnTaskbar := True; 14 | Application.CreateForm(TMainForm, MainForm); 15 | Application.Run; 16 | end. 17 | 18 | -------------------------------------------------------------------------------- /Part3/17 SystemNet/NetClientMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 338 6 | ClientWidth = 538 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 526 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | ExplicitWidth = 903 27 | object Button1: TButton 28 | Left = 0 29 | Top = 4 30 | Width = 100 31 | Height = 25 32 | Caption = 'Thread GET 1' 33 | TabOrder = 0 34 | OnClick = Button1Click 35 | end 36 | object Button2: TButton 37 | Left = 106 38 | Top = 4 39 | Width = 100 40 | Height = 25 41 | Caption = 'Thread GET 2' 42 | TabOrder = 1 43 | OnClick = Button2Click 44 | end 45 | object Button3: TButton 46 | Left = 212 47 | Top = 4 48 | Width = 130 49 | Height = 25 50 | Caption = 'Asynchronous GET' 51 | TabOrder = 2 52 | OnClick = Button3Click 53 | end 54 | end 55 | object Memo: TMemo 56 | Left = 6 57 | Top = 41 58 | Width = 526 59 | Height = 291 60 | Align = alClient 61 | TabOrder = 1 62 | ExplicitWidth = 903 63 | ExplicitHeight = 234 64 | end 65 | object HTTPClient: TNetHTTPClient 66 | Asynchronous = True 67 | SynchronizeEvents = False 68 | UserAgent = 'Embarcadero URI Client/1.0' 69 | OnRequestCompleted = HTTPRequestRequestCompleted 70 | OnRequestError = HTTPRequestRequestError 71 | OnRequestException = HTTPRequestRequestException 72 | OnSendData = HTTPRequestSendData 73 | OnReceiveData = HTTPRequestReceiveData 74 | Left = 36 75 | Top = 72 76 | end 77 | end 78 | -------------------------------------------------------------------------------- /Part3/17 SystemNet/NetClientMainF.pas: -------------------------------------------------------------------------------- 1 | unit NetClientMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | Vcl.Graphics, 12 | Vcl.Controls, 13 | Vcl.Forms, 14 | Vcl.Dialogs, 15 | Vcl.StdCtrls, 16 | Vcl.ExtCtrls, 17 | System.Threading, 18 | System.Types, 19 | NX.Log, 20 | System.Net.FileClient, 21 | System.Net.URLClient, 22 | System.Net.HttpClient, 23 | System.Net.HttpClientComponent; 24 | 25 | type 26 | TMainForm = class(TForm) 27 | Panel1: TPanel; 28 | Memo: TMemo; 29 | HttpClient: TNetHTTPClient; 30 | Button1: TButton; 31 | Button2: TButton; 32 | Button3: TButton; 33 | procedure HTTPRequestRequestCompleted(const Sender: TObject; const AResponse: IHTTPResponse); 34 | procedure HTTPRequestSendData(const Sender: TObject; AContentLength, AWriteCount: Int64; var AAbort: Boolean); 35 | procedure HTTPRequestReceiveData(const Sender: TObject; AContentLength, AReadCount: Int64; var AAbort: Boolean); 36 | procedure HTTPRequestRequestError(const Sender: TObject; const AError: string); 37 | procedure HTTPRequestRequestException(const Sender: TObject; const AError: Exception); 38 | procedure Button1Click(Sender: TObject); 39 | procedure Button2Click(Sender: TObject); 40 | procedure Button3Click(Sender: TObject); 41 | private 42 | public 43 | end; 44 | 45 | var 46 | MainForm: TMainForm; 47 | 48 | implementation 49 | 50 | {$R *.dfm} 51 | 52 | procedure TMainForm.Button1Click(Sender: TObject); 53 | begin 54 | Memo.Lines.Clear; 55 | 56 | TThread.CreateAnonymousThread( 57 | procedure 58 | var 59 | Client: THTTPClient; 60 | Response: IHTTPResponse; 61 | begin 62 | Client := THTTPClient.Create; 63 | try 64 | Client.OnReceiveData := HTTPRequestReceiveData; 65 | Client.OnSendData := HTTPRequestSendData; 66 | Response := Client.Get('http://httpbin.org/get'); 67 | NxLog.D('HTTP Request Completed'); 68 | finally 69 | Client.Free; 70 | end; 71 | TThread.Queue(nil, 72 | procedure 73 | begin 74 | Memo.Lines.Add(Response.ContentAsString); 75 | end); 76 | end).Start; 77 | end; 78 | 79 | procedure TMainForm.Button2Click(Sender: TObject); 80 | begin 81 | Memo.Lines.Clear; 82 | 83 | TThread.CreateAnonymousThread( 84 | procedure 85 | var 86 | Client: TNetHTTPClient; 87 | Response: IHTTPResponse; 88 | begin 89 | Client := TNetHTTPClient.Create(nil); 90 | try 91 | Client.OnReceiveData := HTTPRequestReceiveData; 92 | Client.OnSendData := HTTPRequestSendData; 93 | Client.OnRequestCompleted := HTTPRequestRequestCompleted; 94 | Client.Asynchronous := False; 95 | Client.SynchronizeEvents := False; 96 | Response := Client.Get('http://httpbin.org/get'); 97 | finally 98 | Client.Free; 99 | end; 100 | TThread.Queue(nil, 101 | procedure 102 | begin 103 | Memo.Lines.Add(Response.ContentAsString); 104 | end); 105 | end).Start; 106 | end; 107 | 108 | procedure TMainForm.Button3Click(Sender: TObject); 109 | var 110 | Client: TNetHTTPClient; 111 | begin 112 | Memo.Lines.Clear; 113 | 114 | Client := TNetHTTPClient.Create(nil); 115 | Client.Asynchronous := True; 116 | Client.OnRequestCompleted := HTTPRequestRequestCompleted; 117 | Client.OnRequestError := HTTPRequestRequestError; 118 | Client.OnRequestException := HTTPRequestRequestException; 119 | Client.Get('http://httpbin.org/get'); 120 | end; 121 | 122 | procedure TMainForm.HTTPRequestReceiveData(const Sender: TObject; AContentLength, AReadCount: Int64; var AAbort: Boolean); 123 | begin 124 | NxLog.D('HTTP Receive Data'); 125 | TThread.Queue(nil, 126 | procedure 127 | begin 128 | Memo.Lines.Add(Format('Received: %d of %d', [AReadCount, AContentLength])); 129 | end); 130 | end; 131 | 132 | procedure TMainForm.HTTPRequestRequestCompleted(const Sender: TObject; const AResponse: IHTTPResponse); 133 | begin 134 | NxLog.D('HTTP Request Completed'); 135 | TThread.Synchronize(nil, 136 | procedure 137 | begin 138 | Memo.Lines.Add(AResponse.ContentAsString); 139 | Sender.Free; 140 | end); 141 | end; 142 | 143 | procedure TMainForm.HTTPRequestRequestError(const Sender: TObject; const AError: string); 144 | begin 145 | NxLog.D('HTTP Request Error'); 146 | end; 147 | 148 | procedure TMainForm.HTTPRequestRequestException(const Sender: TObject; const AError: Exception); 149 | begin 150 | NxLog.D('HTTP Request Exception'); 151 | end; 152 | 153 | procedure TMainForm.HTTPRequestSendData(const Sender: TObject; AContentLength, AWriteCount: Int64; var AAbort: Boolean); 154 | begin 155 | NxLog.D('HTTP Send Data'); 156 | TThread.Queue(nil, 157 | procedure 158 | begin 159 | Memo.Lines.Add('Sent: ' + AWriteCount.ToString + ' of ' + AContentLength.ToString); 160 | end); 161 | end; 162 | 163 | initialization 164 | 165 | NxLog.SetThreadInfo(TNxLogThread.LogThreadID); 166 | 167 | end. 168 | 169 | -------------------------------------------------------------------------------- /Part3/19 Indy/Indy.dpr: -------------------------------------------------------------------------------- 1 | program Indy; 2 | 3 | uses 4 | Vcl.Forms, 5 | IndyMainF in 'IndyMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part3/19 Indy/IndyMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 281 6 | ClientWidth = 464 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 452 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 0 28 | Top = 4 29 | Width = 100 30 | Height = 25 31 | Caption = 'Synchonous HTTP' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | object Button2: TButton 36 | Left = 106 37 | Top = 4 38 | Width = 111 39 | Height = 25 40 | Caption = 'Asynchronous HTTP' 41 | TabOrder = 1 42 | OnClick = Button2Click 43 | end 44 | end 45 | object Memo: TMemo 46 | Left = 6 47 | Top = 41 48 | Width = 452 49 | Height = 234 50 | Align = alClient 51 | TabOrder = 1 52 | end 53 | object HTTP: TIdHTTP 54 | OnWork = HTTPWork 55 | OnWorkBegin = HTTPWorkBegin 56 | OnWorkEnd = HTTPWorkEnd 57 | ProxyParams.BasicAuthentication = False 58 | ProxyParams.ProxyPort = 0 59 | Request.ContentLength = -1 60 | Request.ContentRangeEnd = -1 61 | Request.ContentRangeStart = -1 62 | Request.ContentRangeInstanceLength = -1 63 | Request.Accept = 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8' 64 | Request.BasicAuthentication = False 65 | Request.UserAgent = 'Mozilla/3.0 (compatible; Indy Library)' 66 | Request.Ranges.Units = 'bytes' 67 | Request.Ranges = <> 68 | HTTPOptions = [hoForceEncodeParams] 69 | Left = 396 70 | Top = 20 71 | end 72 | end 73 | -------------------------------------------------------------------------------- /Part3/19 Indy/IndyMainF.pas: -------------------------------------------------------------------------------- 1 | unit IndyMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | Vcl.Graphics, 12 | Vcl.Controls, 13 | Vcl.Forms, 14 | Vcl.Dialogs, 15 | Vcl.StdCtrls, 16 | Vcl.ExtCtrls, 17 | IdBaseComponent, 18 | IdComponent, 19 | IdTCPConnection, 20 | IdTCPClient, 21 | IdHTTP; 22 | 23 | type 24 | TMainForm = class(TForm) 25 | Panel1: TPanel; 26 | Button1: TButton; 27 | Memo: TMemo; 28 | Button2: TButton; 29 | HTTP: TIdHTTP; 30 | procedure Button1Click(Sender: TObject); 31 | procedure Button2Click(Sender: TObject); 32 | procedure HTTPWorkEnd(ASender: TObject; AWorkMode: TWorkMode); 33 | procedure HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64); 34 | procedure HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64); 35 | private 36 | public 37 | end; 38 | 39 | var 40 | MainForm: TMainForm; 41 | 42 | implementation 43 | 44 | {$R *.dfm} 45 | 46 | procedure TMainForm.Button1Click(Sender: TObject); 47 | var 48 | Response: string; 49 | begin 50 | Memo.Lines.Clear; 51 | Response := HTTP.Get('http://httpbin.org/get'); 52 | Memo.Lines.Add(Response); 53 | end; 54 | 55 | procedure TMainForm.Button2Click(Sender: TObject); 56 | begin 57 | Memo.Lines.Clear; 58 | TThread.CreateAnonymousThread( 59 | procedure 60 | var 61 | Client: TIdHTTP; 62 | Response: string; 63 | begin 64 | Client := TIdHTTP.Create(nil); 65 | try 66 | Client.OnWorkBegin := HTTPWorkBegin; 67 | Client.OnWork := HTTPWork; 68 | Client.OnWorkEnd := HTTPWorkEnd; 69 | Response := Client.Get('http://httpbin.org/get'); 70 | TThread.Synchronize(nil, 71 | procedure 72 | begin 73 | Memo.Lines.Add(Response); 74 | end); 75 | finally 76 | Client.Free; 77 | end; 78 | end).Start; 79 | end; 80 | 81 | procedure TMainForm.HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64); 82 | begin 83 | TThread.Queue(nil, 84 | procedure 85 | begin 86 | Memo.Lines.Add('HTTP Work Begin ' + AWorkCountMax.ToString); 87 | end); 88 | end; 89 | 90 | procedure TMainForm.HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64); 91 | begin 92 | TThread.Queue(nil, 93 | procedure 94 | begin 95 | Memo.Lines.Add('HTTP Work ' + AWorkCount.ToString); 96 | end); 97 | end; 98 | 99 | procedure TMainForm.HTTPWorkEnd(ASender: TObject; AWorkMode: TWorkMode); 100 | begin 101 | TThread.Queue(nil, 102 | procedure 103 | begin 104 | Memo.Lines.Add('HTTP Work End'); 105 | end); 106 | end; 107 | 108 | end. 109 | -------------------------------------------------------------------------------- /Part3/20 REST/RESTDemo.dpr: -------------------------------------------------------------------------------- 1 | program RESTDemo; 2 | 3 | uses 4 | Vcl.Forms, 5 | RESTMainF in 'RESTMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part3/20 REST/RESTMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 281 6 | ClientWidth = 464 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 452 22 | Height = 35 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 8 28 | Top = 6 29 | Width = 100 30 | Height = 25 31 | Caption = 'REST Thread' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | object Button2: TButton 36 | Left = 114 37 | Top = 6 38 | Width = 100 39 | Height = 25 40 | Caption = 'REST Async Auto' 41 | TabOrder = 1 42 | OnClick = Button2Click 43 | end 44 | object Button3: TButton 45 | Left = 220 46 | Top = 6 47 | Width = 100 48 | Height = 25 49 | Caption = 'Rest Async' 50 | TabOrder = 2 51 | OnClick = Button3Click 52 | end 53 | end 54 | object Memo: TMemo 55 | Left = 6 56 | Top = 41 57 | Width = 452 58 | Height = 234 59 | Align = alClient 60 | TabOrder = 1 61 | end 62 | object Client: TRESTClient 63 | Authenticator = BasicAuth 64 | BaseURL = 'https://reqres.in/api' 65 | ContentType = 'application/json' 66 | Params = <> 67 | Left = 32 68 | Top = 88 69 | end 70 | object Request: TRESTRequest 71 | Client = Client 72 | Params = <> 73 | Resource = 'users' 74 | Response = Response 75 | Left = 32 76 | Top = 160 77 | end 78 | object Response: TRESTResponse 79 | Left = 32 80 | Top = 224 81 | end 82 | object BasicAuth: THTTPBasicAuthenticator 83 | Username = 'test' 84 | Password = 'test' 85 | Left = 136 86 | Top = 88 87 | end 88 | end 89 | -------------------------------------------------------------------------------- /Part3/20 REST/RESTMainF.pas: -------------------------------------------------------------------------------- 1 | unit RESTMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | Vcl.Graphics, 12 | Vcl.Controls, 13 | Vcl.Forms, 14 | Vcl.Dialogs, 15 | Vcl.StdCtrls, 16 | Vcl.ExtCtrls, 17 | REST.Types, 18 | REST.Client, 19 | REST.Authenticator.Basic, 20 | Data.Bind.Components, 21 | Data.Bind.ObjectScope; 22 | 23 | type 24 | TMainForm = class(TForm) 25 | Panel1: TPanel; 26 | Button1: TButton; 27 | Memo: TMemo; 28 | Button2: TButton; 29 | Client: TRESTClient; 30 | Request: TRESTRequest; 31 | Response: TRESTResponse; 32 | BasicAuth: THTTPBasicAuthenticator; 33 | Button3: TButton; 34 | procedure Button1Click(Sender: TObject); 35 | procedure Button3Click(Sender: TObject); 36 | procedure Button2Click(Sender: TObject); 37 | private 38 | public 39 | FThread: TThread; 40 | end; 41 | 42 | var 43 | MainForm: TMainForm; 44 | 45 | implementation 46 | 47 | {$R *.dfm} 48 | 49 | procedure TMainForm.Button1Click(Sender: TObject); 50 | begin 51 | Memo.Lines.Clear; 52 | TThread.CreateAnonymousThread( 53 | procedure 54 | var 55 | Client: TRESTClient; 56 | Request: TRESTRequest; 57 | Response: TRESTResponse; 58 | Auth: THTTPBasicAuthenticator; 59 | begin 60 | Client := TRESTClient.Create(nil); 61 | try 62 | Auth := THTTPBasicAuthenticator.Create(Client); 63 | Request := TRESTRequest.Create(Client); 64 | Response := TRESTResponse.Create(Client); 65 | Auth.Username := 'test'; 66 | Auth.Password := 'test'; 67 | Client.Accept := 'application/json'; 68 | Client.BaseURL := 'https://reqres.in/api/'; 69 | Request.Client := Client; 70 | Request.Resource := 'users'; 71 | Request.Response := Response; 72 | Request.Execute; 73 | TThread.Synchronize(nil, 74 | procedure 75 | begin 76 | Memo.Lines.Add(Response.Content); 77 | end); 78 | finally 79 | Client.Free; 80 | end; 81 | end).Start; 82 | end; 83 | 84 | procedure TMainForm.Button2Click(Sender: TObject); 85 | begin 86 | Memo.Lines.Clear; 87 | Request.ExecuteAsync( 88 | procedure 89 | begin 90 | Memo.Lines.Add(Response.Content); 91 | end, True, True, 92 | procedure(Error: TObject) 93 | begin 94 | Memo.Lines.Add(Exception(Error).Message); 95 | end); 96 | end; 97 | 98 | procedure TMainForm.Button3Click(Sender: TObject); 99 | begin 100 | if Assigned(FThread) then 101 | Exit; 102 | 103 | Memo.Lines.Clear; 104 | FThread := Request.ExecuteAsync( 105 | procedure 106 | begin 107 | Memo.Lines.Add(Response.Content); 108 | TThread.ForceQueue(nil, 109 | procedure 110 | begin 111 | FreeAndNil(FThread); 112 | end); 113 | end, 114 | True, False, 115 | procedure(Error: TObject) 116 | begin 117 | Memo.Lines.Add(Exception(Error).Message); 118 | TThread.ForceQueue(nil, 119 | procedure 120 | begin 121 | FreeAndNil(FThread); 122 | end); 123 | end); 124 | end; 125 | 126 | end. 127 | -------------------------------------------------------------------------------- /Part3/21 Regular expressions/RegEx.dpr: -------------------------------------------------------------------------------- 1 | program RegEx; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | {$R *.res} 6 | 7 | uses 8 | System.SysUtils, 9 | System.Classes, 10 | System.Threading, 11 | System.RegularExpressions; 12 | 13 | var 14 | OK: Boolean; 15 | 16 | procedure SafeSplit; 17 | var 18 | a: TArray; 19 | s: string; 20 | begin 21 | a := TRegEx.Split('abcfoo 123 abac458', 'ab*c'); 22 | for s in a do 23 | Writeln(s); 24 | end; 25 | 26 | procedure ThreadUnsafe; 27 | var 28 | Reg: TRegEx; 29 | t1, t2: ITask; 30 | begin 31 | // THREAD UNSAFE - INCORRECT CODE 32 | Reg := TRegEx.Create('ab*c'); 33 | t1 := TTask.Run( 34 | procedure 35 | var 36 | Found: Boolean; 37 | begin 38 | Found := Reg.IsMatch('abcfoo 123 abac458'); 39 | if not Found then 40 | begin 41 | OK := False; 42 | Writeln('WRONG MATCH'); 43 | end; 44 | end); 45 | 46 | t2 := TTask.Run( 47 | procedure 48 | var 49 | Found: Boolean; 50 | begin 51 | Found := Reg.IsMatch('foo'); 52 | if Found then 53 | begin 54 | OK := False; 55 | Writeln('WRONG MATCH'); 56 | end; 57 | end); 58 | end; 59 | 60 | procedure ThreadUnsafeLoop; 61 | begin 62 | OK := True; 63 | while OK do 64 | ThreadUnsafe; 65 | end; 66 | 67 | procedure ThreadSafe; 68 | var 69 | t1, t2: ITask; 70 | begin 71 | // THREAD SAFE CORRECTCODE 72 | t1 := TTask.Run( 73 | procedure 74 | var 75 | Reg: TRegEx; 76 | Found: Boolean; 77 | begin 78 | Reg := TRegEx.Create('ab*c'); 79 | Found := Reg.IsMatch('abcfoo 123 abac458'); 80 | if not Found then 81 | begin 82 | OK := False; 83 | Writeln('WRONG MATCH'); 84 | end; 85 | end); 86 | 87 | t2 := TTask.Run( 88 | procedure 89 | var 90 | Reg: TRegEx; 91 | Found: Boolean; 92 | begin 93 | Reg := TRegEx.Create('ab*c'); 94 | Found := Reg.IsMatch('foo'); 95 | if Found then 96 | begin 97 | OK := False; 98 | Writeln('WRONG MATCH'); 99 | end; 100 | end); 101 | end; 102 | 103 | procedure ThreadSafeLoop; 104 | begin 105 | // This loop will never end because code will always run correctly 106 | OK := True; 107 | while OK do 108 | ThreadSafe; 109 | end; 110 | 111 | begin 112 | try 113 | ThreadUnsafeLoop; 114 | // ThreadSafeLoop; 115 | except 116 | on E: Exception do 117 | Writeln(E.ClassName, ': ', E.Message); 118 | end; 119 | Writeln('DONE'); 120 | Readln; 121 | end. 122 | -------------------------------------------------------------------------------- /Part5/27 Resource consumption/Resources.dpr: -------------------------------------------------------------------------------- 1 | program Resources; 2 | 3 | uses 4 | Vcl.Forms, 5 | ResourcesMainF in 'ResourcesMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part5/27 Resource consumption/ResourcesMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 501 6 | ClientWidth = 751 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 739 22 | Height = 43 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 8 28 | Top = 6 29 | Width = 200 30 | Height = 25 31 | Caption = 'Threads - excessive consumption' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | object Button2: TButton 36 | Left = 214 37 | Top = 6 38 | Width = 120 39 | Height = 25 40 | Caption = 'Single thread' 41 | TabOrder = 1 42 | OnClick = Button2Click 43 | end 44 | object Button3: TButton 45 | Left = 340 46 | Top = 6 47 | Width = 120 48 | Height = 25 49 | Caption = 'Tasks' 50 | TabOrder = 2 51 | OnClick = Button3Click 52 | end 53 | object Button4: TButton 54 | Left = 466 55 | Top = 6 56 | Width = 200 57 | Height = 25 58 | Caption = 'Tasks with dedicated thread pool' 59 | TabOrder = 3 60 | OnClick = Button4Click 61 | end 62 | end 63 | object Memo: TMemo 64 | Left = 6 65 | Top = 49 66 | Width = 739 67 | Height = 446 68 | Align = alClient 69 | TabOrder = 1 70 | ExplicitTop = 89 71 | ExplicitHeight = 403 72 | end 73 | end 74 | -------------------------------------------------------------------------------- /Part5/27 Resource consumption/ResourcesMainF.pas: -------------------------------------------------------------------------------- 1 | unit ResourcesMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | System.Threading, 12 | Vcl.Graphics, 13 | Vcl.Controls, 14 | Vcl.Imaging.jpeg, 15 | Vcl.Imaging.pngimage, 16 | Vcl.Imaging.GIFImg, 17 | Vcl.Forms, 18 | Vcl.Dialogs, 19 | Vcl.StdCtrls, 20 | Vcl.ExtCtrls; 21 | 22 | type 23 | TMainForm = class(TForm) 24 | Panel1: TPanel; 25 | Button1: TButton; 26 | Memo: TMemo; 27 | Button2: TButton; 28 | Button3: TButton; 29 | Button4: TButton; 30 | procedure Button1Click(Sender: TObject); 31 | procedure Button2Click(Sender: TObject); 32 | procedure Button3Click(Sender: TObject); 33 | procedure Button4Click(Sender: TObject); 34 | private 35 | FPool: TThreadPool; 36 | public 37 | constructor Create(AOwner: TComponent); override; 38 | destructor Destroy; override; 39 | end; 40 | 41 | 42 | var 43 | MainForm: TMainForm; 44 | 45 | const 46 | Declare path to some larger (at least 12MP) JPEG image 47 | JpegFile = 'C:\....jpg'; 48 | 49 | implementation 50 | 51 | {$R *.dfm} 52 | 53 | // This code will excessively consume resources and eventually crash. 54 | // Crash is easier to reproduce with larger images (at least 12MP) 55 | procedure TMainForm.Button1Click(Sender: TObject); 56 | var 57 | i: Integer; 58 | begin 59 | Memo.Lines.Add('Running'); 60 | for i := 0 to 100 do 61 | TThread.CreateAnonymousThread( 62 | procedure 63 | var 64 | Pic: TPicture; 65 | Bmp: TBitmap; 66 | begin 67 | try 68 | Bmp := nil; 69 | Pic := TPicture.Create; 70 | try 71 | Bmp := TBitmap.Create; 72 | Bmp.Width := 150; 73 | Bmp.Height := 100; 74 | // path to some image 75 | // for demonstration we can load the same image 76 | Pic.LoadFromFile(JpegFile); 77 | Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), Pic.Graphic); 78 | finally 79 | Pic.Free; 80 | // intentional leak of thumbnail bitmap 81 | // to simulate adding bitmap to some image list 82 | // Bmp.Free; 83 | end; 84 | except 85 | on E: Exception do 86 | TThread.Queue(nil, 87 | procedure 88 | begin 89 | Memo.Lines.Add(E.Message); 90 | end); 91 | end; 92 | end).Start; 93 | end; 94 | 95 | // Single thread with a loop 96 | // This example consumes the least resources, but 97 | // it requires the most time 98 | // Anonymous thread can be replaced with single task 99 | procedure TMainForm.Button2Click(Sender: TObject); 100 | begin 101 | Memo.Lines.Add('Running'); 102 | TThread.CreateAnonymousThread( 103 | procedure 104 | var 105 | Pic: TPicture; 106 | Bmp: TBitmap; 107 | i: Integer; 108 | begin 109 | try 110 | for i := 0 to 100 do 111 | begin 112 | Bmp := nil; 113 | Pic := TPicture.Create; 114 | try 115 | Bmp := TBitmap.Create; 116 | Bmp.Width := 150; 117 | Bmp.Height := 100; 118 | // path to some image 119 | // for demonstration we can load the same image 120 | Pic.LoadFromFile(JpegFile); 121 | Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), Pic.Graphic); 122 | finally 123 | Pic.Free; 124 | // intentional leak of thumbnail bitmap 125 | // to simulate adding bitmap to some image list 126 | // Bmp.Free; 127 | end; 128 | end; 129 | TThread.Queue(nil, 130 | procedure 131 | begin 132 | Memo.Lines.Add('Completed'); 133 | end); 134 | except 135 | on E: Exception do 136 | TThread.Queue(nil, 137 | procedure 138 | begin 139 | Memo.Lines.Add(E.Message); 140 | end); 141 | end; 142 | end).Start; 143 | end; 144 | 145 | // Tasks 146 | // This example significantly reduces memory consumption 147 | // However, resource exhaustion is still possible, as the number of 148 | // running tasks will be determined by number of CPU cores and 149 | // with higher number of tasks running on 32-bit platforms issues 150 | // can happen more often 151 | procedure TMainForm.Button3Click(Sender: TObject); 152 | var 153 | i: Integer; 154 | begin 155 | Memo.Lines.Add('Running'); 156 | for i := 0 to 100 do 157 | TTask.Run( 158 | procedure 159 | var 160 | Pic: TPicture; 161 | Bmp: TBitmap; 162 | begin 163 | try 164 | Bmp := nil; 165 | Pic := TPicture.Create; 166 | try 167 | Bmp := TBitmap.Create; 168 | Bmp.Width := 150; 169 | Bmp.Height := 100; 170 | // path to some image 171 | // for demonstration we can load the same image 172 | Pic.LoadFromFile(JpegFile); 173 | Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), Pic.Graphic); 174 | finally 175 | Pic.Free; 176 | // intentional leak of thumbnail bitmap 177 | // to simulate adding bitmap to some image list 178 | // Bmp.Free; 179 | end; 180 | except 181 | on E: Exception do 182 | TThread.Queue(nil, 183 | procedure 184 | begin 185 | Memo.Lines.Add(E.Message); 186 | end); 187 | end; 188 | end); 189 | end; 190 | 191 | // Tasks with dedicated thread pool 192 | // This example significantly reduces memory consumption 193 | procedure TMainForm.Button4Click(Sender: TObject); 194 | var 195 | i: Integer; 196 | begin 197 | Memo.Lines.Add('Running'); 198 | for i := 0 to 100 do 199 | TTask.Run( 200 | procedure 201 | var 202 | Pic: TPicture; 203 | Bmp: TBitmap; 204 | begin 205 | try 206 | Bmp := nil; 207 | Pic := TPicture.Create; 208 | try 209 | Bmp := TBitmap.Create; 210 | Bmp.Width := 150; 211 | Bmp.Height := 100; 212 | // path to some image 213 | // for demonstration we can load the same image 214 | Pic.LoadFromFile(JpegFile); 215 | Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), Pic.Graphic); 216 | finally 217 | Pic.Free; 218 | // intentional leak of thumbnail bitmap 219 | // to simulate adding bitmap to some image list 220 | // Bmp.Free; 221 | end; 222 | except 223 | on E: Exception do 224 | TThread.Queue(nil, 225 | procedure 226 | begin 227 | Memo.Lines.Add(E.Message); 228 | end); 229 | end; 230 | end, FPool); 231 | end; 232 | 233 | constructor TMainForm.Create(AOwner: TComponent); 234 | begin 235 | inherited; 236 | FPool := TThreadPool.Create; 237 | FPool.SetMinWorkerThreads(2); 238 | FPool.SetMaxWorkerThreads(4); 239 | end; 240 | 241 | destructor TMainForm.Destroy; 242 | begin 243 | FPool.Free; 244 | inherited; 245 | end; 246 | 247 | end. 248 | -------------------------------------------------------------------------------- /Part5/30 VCL/Images.dpr: -------------------------------------------------------------------------------- 1 | program Images; 2 | 3 | uses 4 | Vcl.Forms, 5 | ImagesMainF in 'ImagesMainF.pas' {MainForm}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TMainForm, MainForm); 13 | Application.Run; 14 | end. 15 | 16 | -------------------------------------------------------------------------------- /Part5/30 VCL/ImagesMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 501 6 | ClientWidth = 751 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | TextHeight = 13 18 | object Panel1: TPanel 19 | Left = 6 20 | Top = 6 21 | Width = 739 22 | Height = 45 23 | Align = alTop 24 | BevelOuter = bvNone 25 | TabOrder = 0 26 | object Button1: TButton 27 | Left = 8 28 | Top = 8 29 | Width = 200 30 | Height = 25 31 | Caption = 'Generate Jpeg thumbnails' 32 | TabOrder = 0 33 | OnClick = Button1Click 34 | end 35 | object Button2: TButton 36 | Left = 214 37 | Top = 8 38 | Width = 220 39 | Height = 25 40 | Caption = 'Generate image thumbnails - Synchronize' 41 | TabOrder = 1 42 | OnClick = Button2Click 43 | end 44 | object Button3: TButton 45 | Left = 440 46 | Top = 8 47 | Width = 220 48 | Height = 25 49 | Caption = 'Generate image thumbnails - Queue' 50 | TabOrder = 2 51 | OnClick = Button3Click 52 | end 53 | end 54 | object ListView1: TListView 55 | Left = 6 56 | Top = 51 57 | Width = 739 58 | Height = 444 59 | Align = alClient 60 | Columns = <> 61 | LargeImages = ThnList 62 | TabOrder = 1 63 | ExplicitTop = 258 64 | ExplicitHeight = 237 65 | end 66 | object ThnList: TImageList 67 | Height = 100 68 | Width = 150 69 | Left = 678 70 | Top = 22 71 | end 72 | end 73 | -------------------------------------------------------------------------------- /Part5/30 VCL/ImagesMainF.pas: -------------------------------------------------------------------------------- 1 | unit ImagesMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | System.Threading, 12 | System.IOUtils, 13 | Winapi.GDIPOBJ, 14 | ActiveX, 15 | Vcl.Graphics, 16 | Vcl.Controls, 17 | Vcl.Imaging.jpeg, 18 | Vcl.Imaging.pngimage, 19 | Vcl.Imaging.GIFImg, 20 | Vcl.Forms, 21 | Vcl.Dialogs, 22 | Vcl.StdCtrls, 23 | Vcl.ExtCtrls, 24 | System.ImageList, 25 | Vcl.ImgList, 26 | Vcl.ComCtrls; 27 | 28 | type 29 | TMainForm = class(TForm) 30 | Panel1: TPanel; 31 | ListView1: TListView; 32 | ThnList: TImageList; 33 | Button1: TButton; 34 | Button2: TButton; 35 | Button3: TButton; 36 | procedure Button1Click(Sender: TObject); 37 | procedure Button2Click(Sender: TObject); 38 | procedure Button3Click(Sender: TObject); 39 | private 40 | public 41 | procedure AddThumbnail(const FileName: string; Bmp: TBitmap); 42 | end; 43 | 44 | var 45 | MainForm: TMainForm; 46 | 47 | const 48 | Declare path to folder with some image files 49 | DataFolder = 'C:\...\'; 50 | 51 | implementation 52 | 53 | {$R *.dfm} 54 | 55 | // Generate Jpeg thumbnails 56 | procedure TMainForm.Button1Click(Sender: TObject); 57 | var 58 | Folder: string; 59 | begin 60 | Folder := DataFolder; 61 | TTask.Run( 62 | procedure 63 | var 64 | Files: TArray; 65 | jpeg: TJpegImage; 66 | Bmp: TBitmap; 67 | i: Integer; 68 | begin 69 | Files := TDirectory.GetFiles(Folder, '*.jpg'); 70 | Bmp := nil; 71 | jpeg := TJpegImage.Create; 72 | try 73 | jpeg.Scale := jsEighth; 74 | Bmp := TBitmap.Create; 75 | Bmp.Width := 150; 76 | Bmp.Height := 100; 77 | for i := 0 to high(Files) do 78 | begin 79 | jpeg.LoadFromFile(Files[i]); 80 | jpeg.Canvas.Lock; 81 | try 82 | Bmp.Canvas.Lock; 83 | try 84 | Bmp.Canvas.StretchDraw(Rect(0, 0, 150, 100), jpeg); 85 | finally 86 | Bmp.Canvas.Unlock; 87 | end; 88 | finally 89 | jpeg.Canvas.Unlock; 90 | end; 91 | TThread.Synchronize(nil, 92 | procedure 93 | var 94 | Item: TListItem; 95 | Index: Integer; 96 | begin 97 | index := ThnList.Add(Bmp, nil); 98 | Item := ListView1.Items.Add; 99 | Item.Caption := Files[i]; 100 | Item.ImageIndex := index; 101 | end); 102 | end; 103 | finally 104 | jpeg.Free; 105 | Bmp.Free; 106 | end; 107 | end); 108 | end; 109 | 110 | // Generate image thumbnails with Synchronize method 111 | procedure TMainForm.Button2Click(Sender: TObject); 112 | var 113 | Folder: string; 114 | begin 115 | Folder := DataFolder; 116 | TTask.Run( 117 | procedure 118 | var 119 | Files: TArray; 120 | Bmp: TBitmap; 121 | i: Integer; 122 | Image: TGPBitmap; 123 | Dest: TGPGraphics; 124 | ImgStream: IStream; 125 | begin 126 | Files := TDirectory.GetFiles(Folder, '*.*'); 127 | Bmp := TBitmap.Create; 128 | try 129 | Bmp.Width := 150; 130 | Bmp.Height := 100; 131 | for i := 0 to high(Files) do 132 | begin 133 | ImgStream := TStreamAdapter.Create(TFileStream.Create(Files[i], fmOpenRead or fmShareDenyWrite), soOwned); 134 | Image := nil; 135 | Dest := nil; 136 | Bmp.Canvas.Lock; 137 | try 138 | Bmp.Canvas.FillRect(Rect(0, 0, 150, 100)); 139 | Image := TGPBitmap.Create(ImgStream); 140 | Dest := TGPGraphics.Create(Bmp.Canvas.Handle); 141 | Dest.DrawImage(Image, 0, 0, 150, 100); 142 | finally 143 | Dest.Free; 144 | Image.Free; 145 | Bmp.Canvas.Unlock; 146 | end; 147 | TThread.Synchronize(nil, 148 | procedure 149 | var 150 | Item: TListItem; 151 | Index: Integer; 152 | begin 153 | index := ThnList.Add(Bmp, nil); 154 | Item := ListView1.Items.Add; 155 | Item.Caption := Files[i]; 156 | Item.ImageIndex := index; 157 | end); 158 | end; 159 | finally 160 | Bmp.Free; 161 | end; 162 | end); 163 | end; 164 | 165 | procedure TMainForm.AddThumbnail(const FileName: string; Bmp: TBitmap); 166 | begin 167 | TThread.Queue(nil, 168 | procedure 169 | var 170 | Item: TListItem; 171 | Index: Integer; 172 | begin 173 | try 174 | index := ThnList.Add(Bmp, nil); 175 | Item := ListView1.Items.Add; 176 | Item.Caption := FileName; 177 | Item.ImageIndex := index; 178 | finally 179 | Bmp.Free; 180 | end; 181 | end); 182 | end; 183 | 184 | // Generate image thumbnails with Queue method 185 | procedure TMainForm.Button3Click(Sender: TObject); 186 | var 187 | Folder: string; 188 | begin 189 | Folder := DataFolder; 190 | TTask.Run( 191 | procedure 192 | var 193 | Files: TArray; 194 | Bmp: TBitmap; 195 | i: Integer; 196 | Image: TGPBitmap; 197 | Dest: TGPGraphics; 198 | ImgStream: IStream; 199 | begin 200 | Files := TDirectory.GetFiles(Folder, '*.*'); 201 | for i := 0 to high(Files) do 202 | begin 203 | ImgStream := TStreamAdapter.Create(TFileStream.Create(Files[i], fmOpenRead or fmShareDenyWrite), soOwned); 204 | Image := nil; 205 | Dest := nil; 206 | Bmp := TBitmap.Create; 207 | try 208 | Bmp.Width := 150; 209 | Bmp.Height := 100; 210 | Bmp.Canvas.Lock; 211 | try 212 | Bmp.Canvas.FillRect(Rect(0, 0, 150, 100)); 213 | Image := TGPBitmap.Create(ImgStream); 214 | Dest := TGPGraphics.Create(Bmp.Canvas.Handle); 215 | Dest.DrawImage(Image, 0, 0, 150, 100); 216 | finally 217 | Dest.Free; 218 | Image.Free; 219 | Bmp.Canvas.Unlock; 220 | end; 221 | AddThumbnail(Files[i], Bmp); 222 | except 223 | Bmp.Free; 224 | raise; 225 | end; 226 | end; 227 | end); 228 | end; 229 | 230 | end. 231 | -------------------------------------------------------------------------------- /Part6/33 Logging/Logging.dpr: -------------------------------------------------------------------------------- 1 | program Logging; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | {$R *.res} 6 | 7 | uses 8 | NX.Log in 'NX.Log.pas', 9 | System.SysUtils, 10 | System.Threading; 11 | 12 | procedure Test; 13 | var 14 | t1, t2, t3, t4: ITask; 15 | begin 16 | t1 := TTask.Run( 17 | procedure 18 | begin 19 | for var i := 0 to 100 do 20 | NxLog.D('TASK 1'); 21 | end); 22 | 23 | t2 := TTask.Run( 24 | procedure 25 | begin 26 | for var i := 0 to 100 do 27 | NxLog.D('TASK 2'); 28 | end); 29 | 30 | t3 := TTask.Run( 31 | procedure 32 | begin 33 | for var i := 0 to 100 do 34 | NxLog.D('TASK 3'); 35 | end); 36 | 37 | t4 := TTask.Run( 38 | procedure 39 | begin 40 | for var i := 0 to 100 do 41 | NxLog.D('TASK 4'); 42 | end); 43 | 44 | TTask.WaitForAll([t1, t2, t3, t4]); 45 | end; 46 | 47 | begin 48 | try 49 | Test; 50 | NxLog.D('Done'); 51 | except 52 | on E: Exception do 53 | Writeln(E.ClassName, ': ', E.Message); 54 | end; 55 | Readln; 56 | end. 57 | -------------------------------------------------------------------------------- /Part6/33 Logging/NX.Log.pas: -------------------------------------------------------------------------------- 1 | (******************************************************************************* 2 | 3 | Licensed under MIT License 4 | 5 | Code examples from Delphi Thread Safety Patterns book 6 | Copyright (c) 2022 Dalija Prasnikar, Neven Prasnikar Jr. 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software (the "Software"), to deal in the Software without restriction, 10 | including without limitation the rights to use, copy, modify, merge, publish, 11 | distribute, sublicense, and/or sell copies of the Software, and to permit 12 | persons to whom the Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in all 16 | copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | SOFTWARE. 25 | ******************************************************************************) 26 | 27 | 28 | unit NX.Log; 29 | 30 | interface 31 | 32 | uses 33 | {$IFDEF MSWINDOWS} 34 | Winapi.Windows, 35 | {$ENDIF} 36 | {$IFDEF ANDROID} 37 | Androidapi.JNI.JavaTypes, 38 | Androidapi.Helpers, 39 | Androidapi.Log, 40 | {$ENDIF} 41 | {$IFDEF IOS} 42 | Macapi.Helpers, 43 | Macapi.ObjectiveC, 44 | iOSapi.Foundation, 45 | {$ENDIF} 46 | {$IFDEF OSX} 47 | Macapi.Helpers, 48 | Macapi.ObjectiveC, 49 | Macapi.Foundation, 50 | {$ENDIF} 51 | {$IFDEF POSIX} 52 | Posix.Base, 53 | Posix.SysTypes, 54 | Posix.Pthread, 55 | {$ENDIF} 56 | System.SysUtils, 57 | System.Classes, 58 | System.DateUtils; 59 | 60 | type 61 | INxLogger = interface 62 | procedure Output(const aMsg: string); 63 | end; 64 | 65 | TNxLogLevel = (LogOff, LogFatal, LogError, LogWarning, LogInfo, LogDebug); 66 | 67 | TNxLogThread = (LogThreadOff, LogThreadID, LogThreadName); 68 | 69 | NxLog = class 70 | protected 71 | protected 72 | class var Logger: INxLogger; 73 | class var Level: TNxLogLevel; 74 | class var ThreadInfo: TNxLogThread; 75 | class var TimeStamp: Boolean; 76 | class constructor ClassCreate; 77 | class destructor ClassDestroy; 78 | class function GetThreadID: string; static; 79 | class function GetThreadName: string; static; 80 | class procedure SetThreadName(const aValue: string); static; 81 | class function PrepareOutput(aLevel: TNxLogLevel; const aMsg: string): string; static; inline; 82 | public 83 | class procedure SetLogger(const aValue: INxLogger); static; 84 | class procedure SetLevel(aValue: TNxLogLevel); static; 85 | class procedure SetThreadInfo(aValue: TNxLogThread); static; 86 | class procedure SetTimeStamp(aValue: Boolean); static; 87 | 88 | class procedure D(const aMsg: string); overload; static; 89 | class procedure I(const aMsg: string); static; 90 | class procedure W(const aMsg: string); static; 91 | class procedure E(const aMsg: string); static; 92 | class procedure F(const aMsg: string); static; 93 | 94 | class property ThreadID: string read GetThreadID; 95 | class property ThreadName: string read GetThreadName write SetThreadName; 96 | end; 97 | 98 | TNxSystemLogger = class(TInterfacedObject, INxLogger) 99 | public 100 | procedure Output(const aMsg: string); 101 | class function New: INxLogger; 102 | end; 103 | 104 | TNxFileLogger = class(TInterfacedObject, INxLogger) 105 | protected 106 | f: TFileStream; 107 | public 108 | constructor Create(const aFileName: string); 109 | destructor Destroy; override; 110 | procedure Output(const aMsg: string); 111 | class function New(const aFileName: string): INxLogger; 112 | end; 113 | 114 | const 115 | LogDelimiter = ' - '; 116 | TNxLogLevelText: array[TNxLogLevel] of string = 117 | ('OFF' + LogDelimiter, 118 | 'NXFATAL ' + LogDelimiter, 119 | 'NXERROR ' + LogDelimiter, 120 | 'NXWARNING' + LogDelimiter, 121 | 'NXINFO ' + LogDelimiter, 122 | 'NXDEBUG ' + LogDelimiter); 123 | 124 | implementation 125 | 126 | {$IFDEF LINUX} 127 | function pthread_setname_np(Thread: pthread_t; Name: MarshaledAString): Integer; cdecl; 128 | external libpthread name _PU + 'pthread_setname_np'; 129 | {$EXTERNALSYM pthread_setname_np} 130 | {$ENDIF} 131 | 132 | 133 | { NxLog } 134 | 135 | class constructor NxLog.ClassCreate; 136 | begin 137 | {$IFDEF DEBUG} 138 | Logger := TNxSystemLogger.New; 139 | Level := LogDebug; 140 | {$ENDIF} 141 | end; 142 | 143 | class destructor NxLog.ClassDestroy; 144 | begin 145 | SetLevel(LogOff); 146 | end; 147 | 148 | class procedure NxLog.SetLogger(const aValue: INxLogger); 149 | begin 150 | if not Assigned(aValue) then 151 | Level := LogOff; 152 | Logger := aValue; 153 | end; 154 | 155 | class procedure NxLog.SetLevel(aValue: TNxLogLevel); 156 | begin 157 | Level := aValue; 158 | end; 159 | 160 | class procedure NxLog.SetThreadInfo(aValue: TNxLogThread); 161 | begin 162 | ThreadInfo := aValue; 163 | end; 164 | 165 | class procedure NxLog.SetTimeStamp(aValue: Boolean); 166 | begin 167 | TimeStamp := aValue; 168 | end; 169 | 170 | class function NxLog.GetThreadID: string; 171 | begin 172 | if TThread.CurrentThread.ThreadID = MainThreadID then 173 | Result := 'MT ' + UIntToStr(TThread.CurrentThread.ThreadID) 174 | else 175 | Result := 'BT ' + UIntToStr(TThread.CurrentThread.ThreadID); 176 | end; 177 | 178 | class function NxLog.GetThreadName: string; 179 | {$IFDEF POSIX} 180 | var 181 | Buf: array[0..16] of AnsiChar; 182 | {$ENDIF} 183 | begin 184 | {$IF defined(ANDROID)} 185 | Result := JStringToString(TJThread.JavaClass.currentThread.getName); 186 | {$ELSEIF defined(POSIX)} 187 | pthread_getname_np(pthread_self, @Buf, SizeOf(Buf)); 188 | Result := string(Utf8String(buf)); 189 | {$ELSE} 190 | Result := UIntToStr(TThread.CurrentThread.ThreadID); 191 | {$ENDIF} 192 | if TThread.CurrentThread.ThreadID = MainThreadID then 193 | Result := 'MT ' + Result 194 | else 195 | Result := 'BT ' + Result; 196 | end; 197 | 198 | class procedure NxLog.SetThreadName(const aValue: string); 199 | begin 200 | {$IF defined(ANDROID)} 201 | TJThread.JavaClass.currentThread.setName(StringToJString(aValue)); 202 | {$ELSEIF defined(LINUX)} 203 | pthread_setname_np(pthread_self, PUtf8Char(Utf8String(aValue))); 204 | {$ELSEIF defined(MACOS)} 205 | pthread_setname_np(PUtf8Char(Utf8String(aValue))); 206 | {$ELSE} 207 | // not implemented 208 | {$ENDIF} 209 | end; 210 | 211 | class function NxLog.PrepareOutput(aLevel: TNxLogLevel; const aMsg: string): string; 212 | begin 213 | Result := TNxLogLevelText[aLevel]; 214 | if TimeStamp then 215 | Result := Result + DateToISO8601(Now) + LogDelimiter; 216 | case ThreadInfo of 217 | LogThreadID : Result := Result + ThreadID + LogDelimiter; 218 | LogThreadName : Result := Result + ThreadName + LogDelimiter; 219 | end; 220 | Result := Result + aMsg; 221 | end; 222 | 223 | class procedure NxLog.D(const aMsg: string); 224 | var 225 | Result: string; 226 | begin 227 | if Ord(Level) >= Ord(LogDebug) then 228 | begin 229 | Result := PrepareOutput(LogDebug, aMsg); 230 | Logger.Output(Result); 231 | end; 232 | end; 233 | 234 | class procedure NxLog.I(const aMsg: string); 235 | var 236 | Result: string; 237 | begin 238 | if Ord(Level) >= Ord(LogInfo) then 239 | begin 240 | Result := PrepareOutput(LogInfo, aMsg); 241 | Logger.Output(Result); 242 | end; 243 | end; 244 | 245 | class procedure NxLog.W(const aMsg: string); 246 | var 247 | Result: string; 248 | begin 249 | if Ord(Level) >= Ord(LogWarning) then 250 | begin 251 | Result := PrepareOutput(LogWarning, aMsg); 252 | Logger.Output(Result); 253 | end 254 | end; 255 | 256 | class procedure NxLog.E(const aMsg: string); 257 | var 258 | Result: string; 259 | begin 260 | if Ord(Level) >= Ord(LogError) then 261 | begin 262 | Result := PrepareOutput(LogError, aMsg); 263 | Logger.Output(Result); 264 | end 265 | end; 266 | 267 | class procedure NxLog.F(const aMsg: string); 268 | var 269 | Result: string; 270 | begin 271 | if Ord(Level) >= Ord(LogFatal) then 272 | begin 273 | Result := PrepareOutput(LogFatal, aMsg); 274 | Logger.Output(Result); 275 | end 276 | end; 277 | 278 | { TNxSystemLogger } 279 | 280 | {$IF defined(MSWINDOWS)} 281 | procedure TNxSystemLogger.Output(const aMsg: string); 282 | begin 283 | OutputDebugString(PChar(aMsg)); 284 | if IsConsole then 285 | begin 286 | TMonitor.Enter(Self); 287 | try 288 | Writeln(aMsg); 289 | finally 290 | TMonitor.Exit(Self); 291 | end; 292 | end; 293 | end; 294 | {$ELSEIF defined(ANDROID)} 295 | procedure TNxSystemLogger.Output(const aMsg: string); 296 | begin 297 | LOGI(PUtf8Char(Utf8String(aMsg))); 298 | end; 299 | {$ELSEIF defined(MACOS)} 300 | procedure TNxSystemLogger.Output(const aMsg: string); 301 | begin 302 | NSLog(StringToID(aMsg)); 303 | end; 304 | {$ELSEIF defined(LINUX)} 305 | procedure TNxSystemLogger.Output(const aMsg: string); 306 | begin 307 | if IsConsole then 308 | begin 309 | TMonitor.Enter(Self); 310 | try 311 | Writeln(aMsg); 312 | finally 313 | TMonitor.Exit(Self); 314 | end; 315 | end; 316 | end; 317 | {$ELSE} 318 | procedure TNxSystemLogger.Output(const aMsg: string); 319 | begin 320 | end; 321 | {$ENDIF} 322 | 323 | class function TNxSystemLogger.New: INxLogger; 324 | begin 325 | Result := TNxSystemLogger.Create; 326 | end; 327 | 328 | { TNxFileLogger } 329 | 330 | constructor TNxFileLogger.Create(const aFileName: string); 331 | begin 332 | inherited Create; 333 | f := TFileStream.Create(aFileName, fmCreate or fmShareExclusive); 334 | end; 335 | 336 | destructor TNxFileLogger.Destroy; 337 | begin 338 | f.Free; 339 | inherited; 340 | end; 341 | 342 | procedure TNxFileLogger.Output(const aMsg: string); 343 | var 344 | Buf: TBytes; 345 | begin 346 | Buf := TEncoding.UTF8.GetBytes(aMsg + #13#10); 347 | TMonitor.Enter(f); 348 | try 349 | f.WriteData(Buf, Length(Buf)); 350 | finally 351 | TMonitor.Exit(f); 352 | end; 353 | end; 354 | 355 | class function TNxFileLogger.New(const aFileName: string): INxLogger; 356 | begin 357 | Result := TNxFileLogger.Create(aFileName); 358 | end; 359 | 360 | end. 361 | 362 | 363 | -------------------------------------------------------------------------------- /Part6/34 Cancellation tokens/NX.Tokens.pas: -------------------------------------------------------------------------------- 1 | (******************************************************************************* 2 | 3 | Licensed under MIT License 4 | 5 | Code examples from Delphi Thread Safety Patterns book 6 | Copyright (c) 2022 Dalija Prasnikar, Neven Prasnikar Jr. 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software (the "Software"), to deal in the Software without restriction, 10 | including without limitation the rights to use, copy, modify, merge, publish, 11 | distribute, sublicense, and/or sell copies of the Software, and to permit 12 | persons to whom the Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in all 16 | copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | SOFTWARE. 25 | ******************************************************************************) 26 | 27 | 28 | unit NX.Tokens; 29 | 30 | interface 31 | 32 | uses 33 | System.SysUtils, 34 | System.Classes, 35 | System.Generics.Collections; 36 | 37 | type 38 | INxCancellationToken = interface 39 | function GetIsCanceled: Boolean; 40 | procedure Cancel; 41 | procedure RaiseIfCanceled; 42 | property IsCanceled: Boolean read GetIsCanceled; 43 | end; 44 | 45 | TNxCancellationToken = class(TInterfacedObject, INxCancellationToken) 46 | protected 47 | fIsCanceled: Boolean; 48 | function GetIsCanceled: Boolean; 49 | public 50 | procedure Cancel; 51 | procedure RaiseIfCanceled; 52 | property IsCanceled: Boolean read GetIsCanceled; 53 | end; 54 | 55 | TNxEmptyCancellationToken = class(TInterfacedObject, INxCancellationToken) 56 | protected 57 | function GetIsCanceled: Boolean; 58 | public 59 | procedure Cancel; 60 | procedure RaiseIfCanceled; 61 | property IsCanceled: Boolean read GetIsCanceled; 62 | end; 63 | 64 | implementation 65 | 66 | { TNxCancellationToken } 67 | 68 | function TNxCancellationToken.GetIsCanceled: Boolean; 69 | begin 70 | Result := fIsCanceled; 71 | end; 72 | 73 | procedure TNxCancellationToken.Cancel; 74 | begin 75 | fIsCanceled := True; 76 | end; 77 | 78 | procedure TNxCancellationToken.RaiseIfCanceled; 79 | begin 80 | if fIsCanceled then 81 | raise EOperationCancelled.Create('Operation canceled'); 82 | end; 83 | 84 | { TNxEmptyCancellationToken } 85 | 86 | function TNxEmptyCancellationToken.GetIsCanceled: Boolean; 87 | begin 88 | Result := False; 89 | end; 90 | 91 | procedure TNxEmptyCancellationToken.Cancel; 92 | begin 93 | // do nothing 94 | end; 95 | 96 | procedure TNxEmptyCancellationToken.RaiseIfCanceled; 97 | begin 98 | // do nothing 99 | end; 100 | 101 | end. 102 | -------------------------------------------------------------------------------- /Part6/34 Cancellation tokens/Tokens.dpr: -------------------------------------------------------------------------------- 1 | program Tokens; 2 | 3 | uses 4 | NX.Log in '..\33 Logging\NX.Log.pas', 5 | Vcl.Forms, 6 | NX.Tokens in 'NX.Tokens.pas', 7 | TokensMainF in 'TokensMainF.pas' {MainForm}; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | Application.Initialize; 13 | Application.MainFormOnTaskbar := True; 14 | Application.CreateForm(TMainForm, MainForm); 15 | Application.Run; 16 | end. 17 | 18 | -------------------------------------------------------------------------------- /Part6/34 Cancellation tokens/TokensMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 281 6 | ClientWidth = 464 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | OnCreate = FormCreate 18 | OnDestroy = FormDestroy 19 | TextHeight = 13 20 | object Panel1: TPanel 21 | Left = 6 22 | Top = 6 23 | Width = 452 24 | Height = 35 25 | Align = alTop 26 | BevelOuter = bvNone 27 | TabOrder = 0 28 | object Button1: TButton 29 | Left = 0 30 | Top = 4 31 | Width = 75 32 | Height = 25 33 | Caption = 'Start Task' 34 | TabOrder = 0 35 | OnClick = Button1Click 36 | end 37 | object CancelBtn: TButton 38 | Left = 243 39 | Top = 4 40 | Width = 75 41 | Height = 25 42 | Caption = 'Cancel' 43 | TabOrder = 1 44 | OnClick = CancelBtnClick 45 | end 46 | object Button2: TButton 47 | Left = 81 48 | Top = 4 49 | Width = 75 50 | Height = 25 51 | Caption = 'Start Thread' 52 | TabOrder = 2 53 | OnClick = Button2Click 54 | end 55 | object Button3: TButton 56 | Left = 162 57 | Top = 4 58 | Width = 75 59 | Height = 25 60 | Caption = 'Start Foo' 61 | TabOrder = 3 62 | OnClick = Button3Click 63 | end 64 | end 65 | object Memo: TMemo 66 | Left = 6 67 | Top = 41 68 | Width = 452 69 | Height = 234 70 | Align = alClient 71 | TabOrder = 1 72 | end 73 | end 74 | -------------------------------------------------------------------------------- /Part6/34 Cancellation tokens/TokensMainF.pas: -------------------------------------------------------------------------------- 1 | unit TokensMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | System.Threading, 12 | System.Types, 13 | Vcl.Graphics, 14 | Vcl.Controls, 15 | Vcl.Forms, 16 | Vcl.Dialogs, 17 | Vcl.StdCtrls, 18 | Vcl.ExtCtrls, 19 | NX.Log, 20 | NX.Tokens; 21 | 22 | type 23 | TFooOperation = class 24 | public 25 | procedure Foo(const Token: INxCancellationToken); 26 | end; 27 | 28 | TMainForm = class(TForm) 29 | Panel1: TPanel; 30 | Button1: TButton; 31 | Memo: TMemo; 32 | CancelBtn: TButton; 33 | Button2: TButton; 34 | Button3: TButton; 35 | procedure Button1Click(Sender: TObject); 36 | procedure FormCreate(Sender: TObject); 37 | procedure FormDestroy(Sender: TObject); 38 | procedure CancelBtnClick(Sender: TObject); 39 | procedure Button3Click(Sender: TObject); 40 | procedure Button2Click(Sender: TObject); 41 | private 42 | public 43 | Foo: TFooOperation; 44 | fToken: INxCancellationToken; 45 | end; 46 | 47 | var 48 | MainForm: TMainForm; 49 | 50 | implementation 51 | 52 | {$R *.dfm} 53 | 54 | procedure TFooOperation.Foo(const Token: INxCancellationToken); 55 | begin 56 | NxLog.D('Foo step 1'); 57 | Sleep(1000); 58 | NxLog.D('Foo step 2'); 59 | Token.RaiseIfCanceled; 60 | NxLog.D('Foo step 3'); 61 | Sleep(1000); 62 | NxLog.D('Foo step 4'); 63 | Token.RaiseIfCanceled; 64 | NxLog.D('Foo step 5'); 65 | Sleep(1000); 66 | NxLog.D('Foo step 6'); 67 | Token.RaiseIfCanceled; 68 | NxLog.D('Foo step 7'); 69 | end; 70 | 71 | procedure TMainForm.FormCreate(Sender: TObject); 72 | begin 73 | Foo := TFooOperation.Create; 74 | end; 75 | 76 | procedure TMainForm.FormDestroy(Sender: TObject); 77 | begin 78 | Foo.Free; 79 | end; 80 | 81 | procedure TMainForm.Button1Click(Sender: TObject); 82 | begin 83 | Memo.Lines.Add('Task Started'); 84 | fToken := TNxCancellationToken.Create; 85 | TTask.Run( 86 | procedure 87 | begin 88 | NxLog.D('Task step 1'); 89 | Sleep(1000); 90 | NxLog.D('Task step 2'); 91 | fToken.RaiseIfCanceled; 92 | NxLog.D('Task step 3'); 93 | Sleep(1000); 94 | NxLog.D('Task step 4'); 95 | fToken.RaiseIfCanceled; 96 | NxLog.D('Task step 5'); 97 | Sleep(1000); 98 | NxLog.D('Task step 6'); 99 | fToken.RaiseIfCanceled; 100 | NxLog.D('Task step 7'); 101 | TThread.Queue(nil, 102 | procedure 103 | begin 104 | Memo.Lines.Add('Task Completed'); 105 | end); 106 | end); 107 | end; 108 | 109 | procedure TMainForm.Button2Click(Sender: TObject); 110 | begin 111 | Memo.Lines.Add('Thread Started'); 112 | fToken := TNxCancellationToken.Create; 113 | TThread.CreateAnonymousThread( 114 | procedure 115 | begin 116 | NxLog.D('Thread step 1'); 117 | Sleep(1000); 118 | NxLog.D('Thread step 2'); 119 | fToken.RaiseIfCanceled; 120 | NxLog.D('Thread step 3'); 121 | Sleep(1000); 122 | NxLog.D('Thread step 4'); 123 | fToken.RaiseIfCanceled; 124 | NxLog.D('Thread step 5'); 125 | Sleep(1000); 126 | NxLog.D('Thread step 6'); 127 | fToken.RaiseIfCanceled; 128 | NxLog.D('Thread step 7'); 129 | TThread.Queue(nil, 130 | procedure 131 | begin 132 | Memo.Lines.Add('Thread Completed'); 133 | end); 134 | end).Start; 135 | end; 136 | 137 | procedure TMainForm.Button3Click(Sender: TObject); 138 | begin 139 | Memo.Lines.Add('Foo Started'); 140 | fToken := TNxCancellationToken.Create; 141 | TTask.Run( 142 | procedure 143 | begin 144 | NxLog.D('Foo start'); 145 | Foo.Foo(fToken); 146 | NxLog.D('Foo completed'); 147 | TThread.Queue(nil, 148 | procedure 149 | begin 150 | Memo.Lines.Add('Foo Completed'); 151 | end); 152 | end); 153 | end; 154 | 155 | procedure TMainForm.CancelBtnClick(Sender: TObject); 156 | begin 157 | if Assigned(fToken) then 158 | begin 159 | NxLog.D('Canceling'); 160 | fToken.Cancel; 161 | NxLog.D('Canceled'); 162 | Memo.Lines.Add('Canceled'); 163 | end; 164 | end; 165 | 166 | end. 167 | -------------------------------------------------------------------------------- /Part6/35 Event bus/Horizon.dpr: -------------------------------------------------------------------------------- 1 | program Horizon; 2 | 3 | uses 4 | Vcl.Forms, 5 | HorizonMainF in 'HorizonMainF.pas' {MainForm}, 6 | NX.Horizon in 'NX.Horizon.pas'; 7 | 8 | {$R *.res} 9 | 10 | begin 11 | Application.Initialize; 12 | Application.MainFormOnTaskbar := True; 13 | Application.CreateForm(TMainForm, MainForm); 14 | Application.Run; 15 | end. 16 | 17 | -------------------------------------------------------------------------------- /Part6/35 Event bus/HorizonMainF.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'MainForm' 5 | ClientHeight = 281 6 | ClientWidth = 464 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Padding.Left = 6 14 | Padding.Top = 6 15 | Padding.Right = 6 16 | Padding.Bottom = 6 17 | OnClose = FormClose 18 | OnCreate = FormCreate 19 | TextHeight = 13 20 | object Panel1: TPanel 21 | Left = 6 22 | Top = 6 23 | Width = 452 24 | Height = 35 25 | Align = alTop 26 | BevelOuter = bvNone 27 | TabOrder = 0 28 | object Button1: TButton 29 | Left = 8 30 | Top = 6 31 | Width = 100 32 | Height = 25 33 | Caption = 'Send String' 34 | TabOrder = 0 35 | OnClick = Button1Click 36 | end 37 | object Button2: TButton 38 | Left = 114 39 | Top = 6 40 | Width = 100 41 | Height = 25 42 | Caption = 'Send Foo' 43 | TabOrder = 1 44 | OnClick = Button2Click 45 | end 46 | object Button3: TButton 47 | Left = 220 48 | Top = 6 49 | Width = 100 50 | Height = 25 51 | Caption = 'Subscribe Int' 52 | TabOrder = 2 53 | OnClick = Button3Click 54 | end 55 | end 56 | object Memo: TMemo 57 | Left = 6 58 | Top = 41 59 | Width = 452 60 | Height = 234 61 | Align = alClient 62 | TabOrder = 1 63 | end 64 | object Timer1: TTimer 65 | OnTimer = Timer1Timer 66 | Left = 398 67 | Top = 22 68 | end 69 | end 70 | -------------------------------------------------------------------------------- /Part6/35 Event bus/HorizonMainF.pas: -------------------------------------------------------------------------------- 1 | unit HorizonMainF; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | Winapi.Messages, 8 | System.SysUtils, 9 | System.Variants, 10 | System.Classes, 11 | System.Threading, 12 | System.SyncObjs, 13 | System.Generics.Collections, 14 | Vcl.Graphics, 15 | Vcl.Controls, 16 | Vcl.Forms, 17 | Vcl.Dialogs, 18 | Vcl.StdCtrls, 19 | Vcl.ExtCtrls, 20 | NX.Horizon; 21 | 22 | type 23 | TFooEvent = type string; 24 | 25 | TMainForm = class(TForm) 26 | Panel1: TPanel; 27 | Button1: TButton; 28 | Memo: TMemo; 29 | Button2: TButton; 30 | Timer1: TTimer; 31 | Button3: TButton; 32 | procedure Button1Click(Sender: TObject); 33 | procedure Timer1Timer(Sender: TObject); 34 | procedure FormClose(Sender: TObject; var Action: TCloseAction); 35 | procedure FormCreate(Sender: TObject); 36 | procedure Button2Click(Sender: TObject); 37 | procedure Button3Click(Sender: TObject); 38 | public 39 | fIntSubscription: INxEventSubscription; 40 | fFooSubscripton: INxEventSubscription; 41 | fStringSubscription: INxEventSubscription; 42 | procedure OnIntData(const aEvent: Integer); 43 | procedure OnStringData(const aEvent: string); 44 | procedure OnFooData(const aEvent: TFooEvent); 45 | end; 46 | 47 | var 48 | MainForm: TMainForm; 49 | Count: Integer; 50 | 51 | implementation 52 | 53 | {$R *.dfm} 54 | 55 | procedure TMainForm.FormCreate(Sender: TObject); 56 | begin 57 | fFooSubscripton := NxHorizon.Instance.Subscribe(Sync, OnFooData); 58 | fStringSubscription := NxHorizon.Instance.Subscribe(MainAsync, OnStringData); 59 | end; 60 | 61 | procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); 62 | begin 63 | if Assigned(fIntSubscription) then 64 | fIntSubscription.WaitFor; 65 | fFooSubscripton.WaitFor; 66 | fStringSubscription.WaitFor; 67 | end; 68 | 69 | procedure TMainForm.Button1Click(Sender: TObject); 70 | begin 71 | NxHorizon.Instance.Post('abcd'); 72 | end; 73 | 74 | procedure TMainForm.Button2Click(Sender: TObject); 75 | begin 76 | TTask.Run( 77 | procedure 78 | begin 79 | NxHorizon.Instance.Post('Foo'); 80 | end); 81 | end; 82 | 83 | procedure TMainForm.Button3Click(Sender: TObject); 84 | begin 85 | fIntSubscription := NxHorizon.Instance.Subscribe(Sync, OnIntData); 86 | end; 87 | 88 | procedure TMainForm.OnFooData(const aEvent: TFooEvent); 89 | begin 90 | TThread.Queue(nil, 91 | procedure 92 | begin 93 | Memo.Lines.Add(aEvent); 94 | end); 95 | end; 96 | 97 | procedure TMainForm.OnIntData(const aEvent: Integer); 98 | begin 99 | Memo.Lines.Add(aEvent.ToString); 100 | NxHorizon.Instance.UnsubscribeAsync(fIntSubscription); 101 | end; 102 | 103 | procedure TMainForm.OnStringData(const aEvent: string); 104 | begin 105 | Memo.Lines.Add(aEvent); 106 | end; 107 | 108 | procedure TMainForm.Timer1Timer(Sender: TObject); 109 | begin 110 | Inc(Count); 111 | NxHorizon.Instance.Send(Count, Sync); 112 | end; 113 | 114 | end. 115 | -------------------------------------------------------------------------------- /Part6/35 Event bus/NX.Horizon.pas: -------------------------------------------------------------------------------- 1 | (******************************************************************************* 2 | 3 | Licensed under MIT License 4 | 5 | Code examples from Delphi Thread Safety Patterns book 6 | Copyright (c) 2022 Dalija Prasnikar, Neven Prasnikar Jr. 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software (the "Software"), to deal in the Software without restriction, 10 | including without limitation the rights to use, copy, modify, merge, publish, 11 | distribute, sublicense, and/or sell copies of the Software, and to permit 12 | persons to whom the Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in all 16 | copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | SOFTWARE. 25 | ******************************************************************************) 26 | 27 | unit NX.Horizon; 28 | 29 | interface 30 | 31 | uses 32 | System.SysUtils, 33 | System.Classes, 34 | System.Generics.Collections, 35 | System.TypInfo, 36 | System.SyncObjs, 37 | System.Threading; 38 | 39 | type 40 | INxEvent = interface 41 | function GetValue: T; 42 | property Value: T read GetValue; 43 | end; 44 | 45 | TNxEventMethod = procedure(const aEvent: T) of object; 46 | TNxEventMethod = TNxEventMethod; 47 | 48 | TNxHorizonDelivery = ( 49 | Sync, // Run synchronously on current thread - BLOCKING 50 | Async, // Run asynchronously in a random background thread 51 | MainSync, // Run synchronously on main thread - BLOCKING 52 | MainAsync // Run asynchronously on main thread 53 | ); 54 | 55 | INxEventSubscription = interface 56 | ['{15BE488F-CFE3-4EFB-A3DA-910D0C443D50}'] 57 | function BeginWork: Boolean; 58 | procedure EndWork; 59 | procedure WaitFor; 60 | procedure Cancel; 61 | function GetIsActive: Boolean; 62 | function GetIsCanceled: Boolean; 63 | property IsActive: Boolean read GetIsActive; 64 | property IsCanceled: Boolean read GetIsCanceled; 65 | end; 66 | 67 | TNxEventObject = class(TInterfacedObject, INxEvent) 68 | protected 69 | fValue: T; 70 | function GetValue: T; 71 | public 72 | constructor Create(const aValue: T); 73 | destructor Destroy; override; 74 | property Value: T read GetValue; 75 | class function New(const aValue: T): INxEvent; 76 | end; 77 | 78 | TNxEvent = record 79 | private 80 | fValue: T; 81 | function GetValue: T; 82 | public 83 | constructor New(const aValue: T); 84 | property Value: T read GetValue; 85 | end; 86 | 87 | TNxEventSubscription = class(TInterfacedObject, INxEventSubscription) 88 | protected 89 | fCountdown: TCountdownEvent; 90 | fEventMethod: TNxEventMethod; 91 | fEventInfo: PTypeInfo; 92 | fDelivery: TNxHorizonDelivery; 93 | fIsCanceled: Boolean; 94 | function GetIsActive: Boolean; 95 | function GetIsCanceled: Boolean; 96 | public 97 | constructor Create(aEventInfo: PTypeInfo; aDelivery: TNxHorizonDelivery; aObserver: TNxEventMethod); 98 | destructor Destroy; override; 99 | function BeginWork: Boolean; 100 | procedure EndWork; 101 | procedure WaitFor; 102 | procedure Cancel; 103 | property IsActive: Boolean read GetIsActive; 104 | property IsCanceled: Boolean read GetIsCanceled; 105 | end; 106 | 107 | TNxHorizon = class 108 | protected 109 | fLock: IReadWriteSync; 110 | fSubscriptions: TDictionary>; 111 | procedure DispatchEvent(const aEvent: T; const aSubscription: INxEventSubscription; aDelivery: TNxHorizonDelivery; aObserver: TNxEventMethod); 112 | public 113 | constructor Create; 114 | destructor Destroy; override; 115 | function Subscribe(aDelivery: TNxHorizonDelivery; aObserver: TNxEventMethod): INxEventSubscription; 116 | procedure Unsubscribe(const aSubscription: INxEventSubscription); 117 | procedure UnsubscribeAsync(const aSubscription: INxEventSubscription); 118 | procedure Post(const aEvent: T); 119 | procedure Send(const aEvent: T; aDelivery: TNxHorizonDelivery); 120 | end; 121 | 122 | NxHorizon = class 123 | protected 124 | class var 125 | fInstance: TNxHorizon; 126 | class constructor ClassCreate; 127 | class destructor ClassDestroy; 128 | public 129 | class property Instance: TNxHorizon read fInstance; 130 | end; 131 | 132 | implementation 133 | 134 | { TNxEventObject } 135 | 136 | constructor TNxEventObject.Create(const aValue: T); 137 | begin 138 | fValue := aValue; 139 | end; 140 | 141 | destructor TNxEventObject.Destroy; 142 | var 143 | Obj: TObject; 144 | begin 145 | if PTypeInfo(TypeInfo(T)).Kind = tkClass then 146 | begin 147 | PObject(@Obj)^ := PPointer(@fValue)^; 148 | Obj.Free; 149 | end; 150 | inherited; 151 | end; 152 | 153 | function TNxEventObject.GetValue: T; 154 | begin 155 | Result := fValue; 156 | end; 157 | 158 | class function TNxEventObject.New(const aValue: T): INxEvent; 159 | begin 160 | Result := TNxEventObject.Create(aValue); 161 | end; 162 | 163 | { TNxEvent } 164 | 165 | constructor TNxEvent.New(const aValue: T); 166 | begin 167 | fValue := aValue; 168 | end; 169 | 170 | function TNxEvent.GetValue: T; 171 | begin 172 | Result := fValue; 173 | end; 174 | 175 | { TNxEventSubscription } 176 | 177 | constructor TNxEventSubscription.Create(aEventInfo: PTypeInfo; aDelivery: TNxHorizonDelivery; aObserver: TNxEventMethod); 178 | begin 179 | fEventInfo := aEventInfo; 180 | fDelivery := aDelivery; 181 | fEventMethod := aObserver; 182 | fCountdown := TCountdownEvent.Create(1); 183 | end; 184 | 185 | destructor TNxEventSubscription.Destroy; 186 | begin 187 | fCountdown.Free; 188 | inherited; 189 | end; 190 | 191 | function TNxEventSubscription.BeginWork: Boolean; 192 | begin 193 | Result := (not fIsCanceled) and fCountdown.TryAddCount; 194 | end; 195 | 196 | procedure TNxEventSubscription.EndWork; 197 | begin 198 | fCountdown.Signal; 199 | end; 200 | 201 | procedure TNxEventSubscription.WaitFor; 202 | begin 203 | fIsCanceled := True; 204 | fCountdown.Signal; 205 | fCountdown.WaitFor; 206 | end; 207 | 208 | function TNxEventSubscription.GetIsActive: Boolean; 209 | begin 210 | Result := not fIsCanceled; 211 | end; 212 | 213 | function TNxEventSubscription.GetIsCanceled: Boolean; 214 | begin 215 | Result := fIsCanceled; 216 | end; 217 | 218 | procedure TNxEventSubscription.Cancel; 219 | begin 220 | fIsCanceled := True; 221 | end; 222 | 223 | { TNxHorizon } 224 | 225 | constructor TNxHorizon.Create; 226 | begin 227 | fLock := TMultiReadExclusiveWriteSynchronizer.Create; 228 | fSubscriptions := TObjectDictionary>.Create([doOwnsValues]); 229 | end; 230 | 231 | destructor TNxHorizon.Destroy; 232 | begin 233 | fSubscriptions.Free; 234 | inherited; 235 | end; 236 | 237 | function TNxHorizon.Subscribe(aDelivery: TNxHorizonDelivery; aObserver: TNxEventMethod): INxEventSubscription; 238 | var 239 | SubList: TList; 240 | begin 241 | Result := TNxEventSubscription.Create(PTypeInfo(TypeInfo(T)), aDelivery, TNxEventMethod(aObserver)); 242 | fLock.BeginWrite; 243 | try 244 | if not fSubscriptions.TryGetValue(PTypeInfo(TypeInfo(T)), SubList) then 245 | begin 246 | SubList := TList.Create; 247 | fSubscriptions.Add(PTypeInfo(TypeInfo(T)), SubList); 248 | end; 249 | SubList.Add(Result); 250 | finally 251 | fLock.EndWrite; 252 | end; 253 | end; 254 | 255 | procedure TNxHorizon.Unsubscribe(const aSubscription: INxEventSubscription); 256 | var 257 | SubList: TList; 258 | begin 259 | aSubscription.Cancel; 260 | fLock.BeginWrite; 261 | try 262 | if fSubscriptions.TryGetValue(TNxEventSubscription(aSubscription).fEventInfo, SubList) then 263 | SubList.Remove(aSubscription); 264 | finally 265 | fLock.EndWrite; 266 | end; 267 | end; 268 | 269 | procedure TNxHorizon.UnsubscribeAsync(const aSubscription: INxEventSubscription); 270 | var 271 | [unsafe] lProc: TProc; 272 | begin 273 | aSubscription.Cancel; 274 | lProc := 275 | procedure 276 | begin 277 | Unsubscribe(aSubscription); 278 | end; 279 | TTask.Run(lProc); 280 | end; 281 | 282 | procedure TNxHorizon.DispatchEvent(const aEvent: T; const aSubscription: INxEventSubscription; aDelivery: TNxHorizonDelivery; aObserver: TNxEventMethod); 283 | var 284 | [unsafe] lProc: TProc; 285 | begin 286 | lProc := 287 | procedure 288 | begin 289 | if aSubscription.BeginWork then 290 | try 291 | TNxEventMethod(aObserver)(aEvent); 292 | finally; 293 | aSubscription.EndWork; 294 | end; 295 | end; 296 | 297 | case aDelivery of 298 | // Synchronous dispatching is done directly in Send and Post methods 299 | // Sync : 300 | // begin 301 | // // IsActive was already checked before entering dispatch 302 | // // in synchronous execution IsActive could not be changed in the meantime 303 | // TNxEventMethod(aObserver)(aEvent); 304 | // end; 305 | Async : 306 | begin 307 | TTask.Run(lProc); 308 | end; 309 | MainSync : 310 | begin 311 | if TThread.CurrentThread.ThreadID = MainThreadID then 312 | lProc 313 | else 314 | TThread.Synchronize(nil, TThreadProcedure(lProc)); 315 | end; 316 | MainAsync : 317 | begin 318 | TThread.ForceQueue(nil, TThreadProcedure(lProc)); 319 | end; 320 | end; 321 | end; 322 | 323 | procedure TNxHorizon.Post(const aEvent: T); 324 | var 325 | SubList: TList; 326 | Sub: TNxEventSubscription; 327 | i: Integer; 328 | begin 329 | fLock.BeginRead; 330 | try 331 | if fSubscriptions.TryGetValue(PTypeInfo(TypeInfo(T)), SubList) then 332 | for i := 0 to SubList.Count - 1 do 333 | begin 334 | Sub := TNxEventSubscription(SubList.List[i]); 335 | if Sub.IsActive and (Sub.fEventInfo = PTypeInfo(TypeInfo(T))) then 336 | begin 337 | // check if delivery is Sync because 338 | // DispatchEvent has anonymous methods setup 339 | // that is unnecessary for synchronous execution path 340 | if Sub.fDelivery = Sync then 341 | begin 342 | if Sub.BeginWork then 343 | try 344 | TNxEventMethod(Sub.fEventMethod)(aEvent); 345 | finally 346 | Sub.EndWork; 347 | end; 348 | end 349 | else 350 | DispatchEvent(aEvent, Sub, Sub.fDelivery, Sub.fEventMethod); 351 | end; 352 | end; 353 | finally 354 | fLock.EndRead; 355 | end; 356 | end; 357 | 358 | procedure TNxHorizon.Send(const aEvent: T; aDelivery: TNxHorizonDelivery); 359 | var 360 | SubList: TList; 361 | Sub: TNxEventSubscription; 362 | i: Integer; 363 | begin 364 | fLock.BeginRead; 365 | try 366 | if fSubscriptions.TryGetValue(PTypeInfo(TypeInfo(T)), SubList) then 367 | for i := 0 to SubList.Count - 1 do 368 | begin 369 | Sub := TNxEventSubscription(SubList.List[i]); 370 | if Sub.IsActive and (Sub.fEventInfo = PTypeInfo(TypeInfo(T))) then 371 | begin 372 | // check if delivery is Sync because 373 | // DispatchEvent has anonymous methods setup 374 | // that is unnecessary for synchronous execution path 375 | if aDelivery = Sync then 376 | begin 377 | if Sub.BeginWork then 378 | try 379 | TNxEventMethod(Sub.fEventMethod)(aEvent); 380 | finally 381 | Sub.EndWork; 382 | end; 383 | end 384 | else 385 | DispatchEvent(aEvent, Sub, aDelivery, Sub.fEventMethod); 386 | end; 387 | end; 388 | finally 389 | fLock.EndRead; 390 | end; 391 | end; 392 | 393 | { NxHorizon } 394 | 395 | class constructor NxHorizon.ClassCreate; 396 | begin 397 | fInstance := TNxHorizon.Create; 398 | end; 399 | 400 | class destructor NxHorizon.ClassDestroy; 401 | begin 402 | fInstance.Free; 403 | end; 404 | 405 | end. -------------------------------------------------------------------------------- /Part6/36 Measuring performance/NX.Chronos.pas: -------------------------------------------------------------------------------- 1 | (******************************************************************************* 2 | 3 | Licensed under MIT License 4 | 5 | Code examples from Delphi Thread Safety Patterns book 6 | Copyright (c) 2022 Dalija Prasnikar, Neven Prasnikar Jr. 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software (the "Software"), to deal in the Software without restriction, 10 | including without limitation the rights to use, copy, modify, merge, publish, 11 | distribute, sublicense, and/or sell copies of the Software, and to permit 12 | persons to whom the Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in all 16 | copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | SOFTWARE. 25 | ******************************************************************************) 26 | 27 | 28 | unit NX.Chronos; 29 | 30 | interface 31 | 32 | uses 33 | {$IFDEF MSWINDOWS} 34 | Winapi.Windows, 35 | {$ELSE} 36 | Posix.Base, 37 | Posix.Time, 38 | {$IFDEF ANDROID} 39 | Androidapi.JNI.JavaTypes, 40 | Androidapi.Helpers, 41 | Androidapi.Log, 42 | {$ENDIF} 43 | {$IFDEF IOS} 44 | Macapi.Mach, 45 | Macapi.Helpers, 46 | Macapi.ObjectiveC, 47 | iOSapi.Foundation, 48 | {$ENDIF} 49 | {$IFDEF OSX} 50 | Macapi.Mach, 51 | Macapi.Helpers, 52 | Macapi.ObjectiveC, 53 | Macapi.Foundation, 54 | {$ENDIF} 55 | {$ENDIF} 56 | System.SysUtils, 57 | System.Classes; 58 | 59 | type 60 | TNxChronoMode = 61 | (CalendarTime, ProcessTime, ThreadTime, ProcessCycles, ThreadCycles); 62 | 63 | TNxChronometer = record 64 | private 65 | fMode: TNxChronoMode; 66 | // accumulated time 67 | fElapsed: UInt64; 68 | // current time stamp - if 0 nothing is being measured 69 | fStartTimeStamp: UInt64; 70 | function CurrentTimeStamp: UInt64; 71 | function GetElapsedMs: UInt64; 72 | function GetElapsedNs: UInt64; 73 | public 74 | constructor Create(aMode: TNxChronoMode); 75 | constructor Start(aMode: TNxChronoMode); overload; 76 | procedure Start; overload; 77 | procedure Stop; 78 | procedure Clear; 79 | property Elapsed: UInt64 read fElapsed; 80 | property ElapsedNs: UInt64 read GetElapsedNs; 81 | property ElapsedMs: UInt64 read GetElapsedMs; 82 | end; 83 | 84 | implementation 85 | 86 | // ***** Time measuring APIs ***** 87 | 88 | {$IFDEF MACOS} 89 | type 90 | clockid_t = clock_res_t; 91 | 92 | function clock_gettime_nsec_np(clock_id: clockid_t): uint64_t; cdecl; 93 | external libc name _PU + 'clock_gettime_nsec_np'; 94 | {$EXTERNALSYM clock_gettime_nsec_np} 95 | 96 | function clock_gettime(clk_id: clockid_t; ts: Ptimespec): Integer; cdecl; 97 | external libc name _PU + 'clock_gettime'; 98 | {$EXTERNALSYM clock_gettime} 99 | 100 | const 101 | CLOCK_REALTIME = 0; 102 | CLOCK_MONOTONIC_RAW = 4; 103 | CLOCK_MONOTONIC_RAW_APPROX = 5; 104 | CLOCK_MONOTONIC = 6; 105 | CLOCK_UPTIME_RAW = 8; 106 | CLOCK_UPTIME_RAW_APPROX = 9; 107 | CLOCK_PROCESS_CPUTIME_ID = 12; 108 | CLOCK_THREAD_CPUTIME_ID = 16; 109 | 110 | NSEC_PER_USEC = 1000; // nanoseconds per microsecond 111 | USEC_PER_SEC = 1000000; // microseconds per second 112 | NSEC_PER_SEC = 1000000000; // nanoseconds per second 113 | NSEC_PER_MSEC = 1000000; // nanoseconds per millisecond 114 | {$ENDIF} 115 | 116 | {$IFDEF MSWINDOWS} 117 | function GetCalendarTimeStamp: UInt64; 118 | begin 119 | Result := GetTickCount * UInt64(10000); 120 | end; 121 | 122 | function GetProcessTimeStamp: UInt64; 123 | var 124 | lpCreationTime, lpExitTime, lpKernelTime, lpUserTime: TFileTime; 125 | ts: ULARGE_INTEGER; 126 | begin 127 | Result := 0; 128 | if GetProcessTimes(GetCurrentProcess, lpCreationTime, lpExitTime, 129 | lpKernelTime, lpUserTime) then 130 | begin 131 | ts.HighPart := lpKernelTime.dwHighDateTime; 132 | ts.LowPart := lpKernelTime.dwLowDateTime; 133 | Result := ts.QuadPart; 134 | ts.HighPart := lpUserTime.dwHighDateTime; 135 | ts.LowPart := lpUserTime.dwLowDateTime; 136 | Result := Result + ts.QuadPart; 137 | end; 138 | end; 139 | 140 | function GetThreadTimeStamp: UInt64; 141 | var 142 | lpCreationTime, lpExitTime, lpKernelTime, lpUserTime: TFileTime; 143 | ts: ULARGE_INTEGER; 144 | begin 145 | Result := 0; 146 | if GetThreadTimes(TThread.CurrentThread.Handle, lpCreationTime, lpExitTime, 147 | lpKernelTime, lpUserTime) then 148 | begin 149 | ts.HighPart := lpKernelTime.dwHighDateTime; 150 | ts.LowPart := lpKernelTime.dwLowDateTime; 151 | Result := ts.QuadPart; 152 | ts.HighPart := lpUserTime.dwHighDateTime; 153 | ts.LowPart := lpUserTime.dwLowDateTime; 154 | Result := Result + ts.QuadPart; 155 | end; 156 | end; 157 | 158 | function GetProcessCycles: UInt64; 159 | begin 160 | if not QueryProcessCycleTime(GetCurrentProcess, Result) then 161 | Result := 0; 162 | end; 163 | 164 | function GetThreadCycles: UInt64; 165 | begin 166 | if not QueryThreadCycleTime(TThread.CurrentThread.Handle, Result) then 167 | Result := 0; 168 | end; 169 | 170 | {$ELSE} 171 | function GetCalendarTimeStamp: UInt64; 172 | var 173 | ts: timespec; 174 | begin 175 | Result := 0; 176 | if clock_gettime(CLOCK_MONOTONIC, @ts) = 0 then 177 | Result := (Int64(1000000000) * ts.tv_sec + ts.tv_nsec) div 100; 178 | end; 179 | 180 | function GetProcessTimeStamp: UInt64; 181 | var 182 | ts: timespec; 183 | begin 184 | Result := 0; 185 | if clock_gettime(CLOCK_PROCESS_CPUTIME_ID, @ts) = 0 then 186 | Result := (Int64(1000000000) * ts.tv_sec + ts.tv_nsec) div 100; 187 | end; 188 | 189 | function GetThreadTimeStamp: UInt64; 190 | var 191 | ts: timespec; 192 | begin 193 | Result := 0; 194 | if clock_gettime(CLOCK_THREAD_CPUTIME_ID, @ts) = 0 then 195 | Result := (Int64(1000000000) * ts.tv_sec + ts.tv_nsec) div 100; 196 | end; 197 | 198 | function GetProcessCycles: UInt64; 199 | var 200 | ts: timespec; 201 | begin 202 | Result := 0; 203 | if clock_gettime(CLOCK_PROCESS_CPUTIME_ID, @ts) = 0 then 204 | Result := (Int64(1000000000) * ts.tv_sec + ts.tv_nsec) div 100; 205 | end; 206 | 207 | function GetThreadCycles: UInt64; 208 | var 209 | ts: timespec; 210 | begin 211 | Result := 0; 212 | if clock_gettime(CLOCK_THREAD_CPUTIME_ID, @ts) = 0 then 213 | Result := (Int64(1000000000) * ts.tv_sec + ts.tv_nsec) div 100; 214 | end; 215 | {$ENDIF} 216 | 217 | // ***** TNxChronometer ***** 218 | 219 | constructor TNxChronometer.Create(aMode: TNxChronoMode); 220 | begin 221 | fMode := aMode; 222 | fElapsed := 0; 223 | fStartTimeStamp := 0; 224 | end; 225 | 226 | constructor TNxChronometer.Start(aMode: TNxChronoMode); 227 | begin 228 | fMode := aMode; 229 | fElapsed := 0; 230 | fStartTimeStamp := CurrentTimeStamp; 231 | end; 232 | 233 | procedure TNxChronometer.Start; 234 | begin 235 | fStartTimeStamp := CurrentTimeStamp; 236 | end; 237 | 238 | procedure TNxChronometer.Stop; 239 | var 240 | Current: UInt64; 241 | begin 242 | if fStartTimeStamp = 0 then 243 | Exit; 244 | Current := CurrentTimeStamp - fStartTimeStamp; 245 | fStartTimeStamp := 0; 246 | if Current > 0 then 247 | fElapsed := fElapsed + Current; 248 | end; 249 | 250 | procedure TNxChronometer.Clear; 251 | begin 252 | fStartTimeStamp := 0; 253 | fElapsed := 0; 254 | end; 255 | 256 | function TNxChronometer.CurrentTimeStamp: UInt64; 257 | begin 258 | case fMode of 259 | CalendarTime : Result := GetCalendarTimeStamp; 260 | ProcessTime : Result := GetProcessTimeStamp; 261 | ThreadTime : Result := GetThreadTimeStamp; 262 | ProcessCycles : Result := GetProcessCycles; 263 | ThreadCycles : Result := GetThreadCycles; 264 | else Result := 0; 265 | end; 266 | end; 267 | 268 | function TNxChronometer.GetElapsedNs: UInt64; 269 | begin 270 | Result := fElapsed * 100; 271 | end; 272 | 273 | function TNxChronometer.GetElapsedMs: UInt64; 274 | begin 275 | Result := fElapsed div 10000; 276 | end; 277 | 278 | end. 279 | 280 | -------------------------------------------------------------------------------- /Part6/36 Measuring performance/ZeroThread.dpr: -------------------------------------------------------------------------------- 1 | program ZeroThread; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | {$R *.res} 6 | 7 | uses 8 | System.SysUtils, 9 | System.Classes, 10 | System.SyncObjs, 11 | NX.Chronos in 'NX.Chronos.pas'; 12 | 13 | procedure Measure; 14 | var 15 | Thread: TThread; 16 | begin 17 | Thread := TThread.CreateAnonymousThread( 18 | procedure 19 | var 20 | tsr, tsc, ts: TNxChronometer; 21 | i: Integer; 22 | begin 23 | tsr := TNxChronometer.Start(CalendarTime); 24 | tsc := TNxChronometer.Start(ThreadCycles); 25 | ts := TNxChronometer.Start(ThreadTime); 26 | for i := 0 to 1000 do 27 | begin 28 | Sleep(1); 29 | end; 30 | ts.Stop; 31 | tsc.Stop; 32 | tsr.Stop; 33 | Writeln('Real time: ', tsr.ElapsedMs); 34 | Writeln('Thread time: ', ts.Elapsed); 35 | Writeln('Cycles: ', tsc.Elapsed); 36 | end); 37 | Thread.FreeOnTerminate := False; 38 | Thread.Start; 39 | Thread.WaitFor; 40 | Thread.Free; 41 | end; 42 | 43 | begin 44 | try 45 | Measure; 46 | except 47 | on E: Exception do 48 | Writeln(E.ClassName, ': ', E.Message); 49 | end; 50 | Readln; 51 | end. 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Code examples from Delphi Thread Safety Patterns Book 2 | 3 | [https://dalija.prasnikar.info/delphitspatt/](https://dalija.prasnikar.info/delphitspatt/) 4 | 5 | [https://dalija.prasnikar.info](https://dalija.prasnikar.info) 6 | 7 | 8 | ## Part 2. The Core Run-Time Library 9 | 10 | ### Chapter 5. Floating-point control register 11 | 12 | + BrokenMath.dpr 13 | + BrokenMath.dproj 14 | + SafeMath.dpr 15 | + SafeMath.dproj 16 | 17 | ### Chapter 7.1. Parameters 18 | 19 | + Parameters.dpr 20 | + Parameters.dproj 21 | + ParametersMainF.pas 22 | + ParametersMainF.dfm 23 | 24 | ### Chapter 8. Class fields, singletons, and default instances 25 | 26 | + Singletons.dpr 27 | + Singletons.dproj 28 | + SingletonsMainF.pas 29 | + SingletonsMainF.dfm 30 | + SingletonClasses.pas 31 | + SingletonLocal.pas 32 | + SingletonClassProp.pas 33 | + SingletonLazy.pas 34 | 35 | ### Chapter 12. Collections 36 | 37 | + CollectionsTest.dpr 38 | + CollectionsTest.dproj 39 | + CollectionsMainF.pas 40 | + CollectionsMainF.dfm 41 | 42 | ### Chapter 13. Parallel collection processing 43 | 44 | + 13.1 Independent processing of individual collection items 45 | 46 | - ParallelCollections.dpr 47 | - ParallelCollections.dproj 48 | - ParallelCollectionsMainF.pas 49 | - ParallelCollectionsMainF.dfm 50 | 51 | + 13.2 Dependent processing of individual collection items 52 | 53 | - DependentParallelCollections.dpr 54 | - DependentParallelCollections.dproj 55 | - DependentParallelCollectionsMainF.pas 56 | - DependentParallelCollectionsMainF.dfm 57 | 58 | 59 | ## Part 3. Core Frameworks 60 | 61 | ### Chapter 16. Serialization 62 | 63 | + Serialization.dpr 64 | + Serialization.dproj 65 | + SerializationMainF.pas 66 | + SerializationMainF.dfm 67 | 68 | ### Chapter 17. System.Net 69 | 70 | + NetClient.dpr 71 | + NetClient.dproj 72 | + NetClientMainF.pas 73 | + NetClientMainF.dfm 74 | 75 | ### Chapter 19. Indy 76 | 77 | + Indy.dpr 78 | + Indy.dproj 79 | + IndyMainF.pas 80 | + IndyMainF.dfm 81 | 82 | ### Chapter 20. REST 83 | 84 | + RESTDemo.dpr 85 | + RESTDemo.dproj 86 | + RESTMainF.pas 87 | + RESTMainF.dfm 88 | 89 | ### Chapter 21. Regular expressions 90 | 91 | + RegEx.dpr 92 | 93 | 94 | ## Part 5. Graphics and Image Processing 95 | 96 | ### Chapter 27. Resource consumption 97 | 98 | + Resources.dpr 99 | + Resources.dproj 100 | + ResourcesMainF.pas 101 | + ResourcesMainF.dfm 102 | 103 | ### Chapter 30. VCL graphics example 104 | 105 | + Images.dpr 106 | + Images.dproj 107 | + ImagesMainF.pas 108 | + ImagesMainF.dfm 109 | 110 | 111 | ## Part 6. Custom Frameworks 112 | 113 | ### Chapter 33. Logging 114 | 115 | + NX.Log.pas 116 | + Logging.dpr 117 | + Logging.dproj 118 | 119 | ### Chapter 34. Cancellation tokens 120 | 121 | + NX.Tokens.pas 122 | + Tokens.dpr 123 | + Tokens.dproj 124 | + TokensMainF.pas 125 | + TokensMainF.dfm 126 | 127 | ### Chapter 35. Event bus 128 | 129 | + NX.Horizon.pas 130 | + Horizon.dpr 131 | + Horizon.dproj 132 | + HorizonMainF.pas 133 | + HorizonMainF.dfm 134 | 135 | ### Chapter 36. Measuring performance 136 | 137 | + NX.Chronos.pas 138 | + ZeroThread.dpr 139 | + ZeroThread.dproj 140 | 141 | --- 142 | 143 | Note: Purpose of the presented examples is to either show thread-unsafe code and 144 | issues that may arise in such code, or to show general coding patterns for 145 | achieving thread-safe code while multiple threads are running. As such many of 146 | them don't implement proper cleanup on application shutdown, and if you close the 147 | application before started background tasks or threads completed their job, 148 | application may crash. 149 | 150 | In order to perform clean shutdown, you either need to wait for task or thread 151 | completion or use some other mechanism that will prevent accessing GUI or 152 | other shared data during application shutdown. 153 | 154 | You can find examples on how to shutdown application in https://github.com/dalijap/code-delphi-async Chapter 35.2 Cleanup on GUI destruction 155 | --------------------------------------------------------------------------------