├── .gitignore ├── LICENSE ├── README.md ├── docs ├── AsyncCommand.md └── resources │ ├── gof-command.png │ ├── moderniz-process.png │ └── tcommand-vcl.png ├── samples ├── 01-BasicDemo │ ├── Command.Button1.pas │ ├── Command.Button2.pas │ ├── CommandDemo.dpr │ ├── Form.Main.dfm │ ├── Form.Main.pas │ ├── Helper.TWinControl.pas │ └── clear_project.bat └── 02-AsyncDemo │ ├── AsyncCommandDemo.dpr │ ├── Command.AsyncDiceRoll.pas │ ├── Command.AsyncDiceRollExtra.pas │ ├── Command.DiceRoll.pas │ ├── Form.Main.dfm │ └── Form.Main.pas ├── src ├── Pattern.AsyncCommand.pas ├── Pattern.Command.pas └── Pattern.CommandAction.pas ├── tests ├── TestCommandPattern.dpr ├── Tests.Injection.pas ├── Tests.TCommand.pas ├── Tests.TCommandAction.pas ├── Tests.TPropertyList.pas └── clear_project.bat └── tools ├── app-config.json └── bumper_source ├── AppConfiguration.pas ├── Main.pas ├── Processor.PascalUnit.pas ├── Processor.ReadmeMarkdown.pas ├── Processor.Utils.pas ├── clear_project.bat ├── out └── app-config.json ├── test ├── README.md ├── sample │ ├── demo01 │ │ ├── UnitForm1.dfm │ │ └── UnitForm1.pas │ └── demo02 │ │ ├── UnitForm1.dfm │ │ └── UnitForm1.pas └── src │ ├── Unit1_WithVersion.pas │ ├── Unit2_NoVersion.pas │ ├── Unit3_WithPublicVersion.pas │ └── subfolder │ └── Unit4_Subfolder_WithVersion.pas └── version_bumper.dpr /.gitignore: -------------------------------------------------------------------------------- 1 | # ########## OS X hidden file index data 2 | 3 | .DS_Store 4 | 5 | # ########## Delphi project file 6 | # (*.dproj) Delphi Project file 7 | # (*.cbproj) C++Builder Project file 8 | 9 | *.dproj 10 | 11 | # ########## Resource file 12 | # (*.rc, *.res) Compiled and uncompiled resource files 13 | # *.rc 14 | 15 | *.res 16 | 17 | # ########## Delphi binary files 18 | # (*.dll) A dynamically linked library file 19 | # (*.exe) Windows executable file 20 | # (*.bpl) Package shared library file 21 | # (*.bpi) Package import library file 22 | # (*.dcp) Delphi Compiled Package file 23 | # (*.drc) Delphi resource string file 24 | # (*.map) Map debug file 25 | # (*.dres) Delphi compiled resource file. (Used when you add to a project RESOURCE such as an icon or image.) 26 | # (*.dcu) Delphi Compiled Unit file 27 | # (*.lib) static library file OR import library for the Win32/Win64 28 | # (*.ocx) OLE Control eXtension 29 | # (*.rsm) Used for remote debugging. (Include remote debug symbols option.) 30 | # (*.dylib) Dynamic library (.dll) or package (.bpl) compiled for the OS X 31 | # (*.tds) Remote debugger TDS debug file. 32 | # (*.tlb) Type library 33 | 34 | *.exe 35 | *.dll 36 | *.bpl 37 | *.bpi 38 | *.dcp 39 | *.drc 40 | *.map 41 | *.dres 42 | *.tds 43 | *.dcu 44 | *.lib 45 | *.ocx 46 | *.rsm 47 | *.tds 48 | *.tlb 49 | 50 | # ########## Android / iOS / OS X binary files 51 | # (*.apk) Android application package file. 52 | # (*.so) Unix-like systems shared libraries (OS X and Linux) 53 | # (*.a) Static library file (ELF-format) produced by Clang 54 | 55 | *.so 56 | *.apk 57 | *.a 58 | 59 | # ########## IDE files 60 | # (*.cfg) Project configuration file used for command-line compiles 61 | # (*.ddp): Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 62 | # (*.vlb): Visual LiveBindings file. Added in Delphi XE2. 63 | # (*.deployproj): Deployment Manager configuration file for your project. Added in Delphi XE2. 64 | 65 | *.cfg 66 | *.ddp 67 | *.vlb 68 | *.deployproj 69 | 70 | 71 | # ########## Other IDE files 72 | # Delphi local files (user-specific info) 73 | 74 | *.local 75 | *.identcache 76 | *.projdata 77 | *.tvsconfig 78 | *.dsk 79 | *.otares 80 | 81 | # ########## Delphi history and backups 82 | # (__history) History folder 83 | # (__recovery) Recovery folder 84 | # (*.~*) Local versions history file 85 | 86 | __history/ 87 | __recovery/ 88 | *.~* 89 | 90 | # ########## Castalia statistics file. Castalia add in Delphi XE7 91 | 92 | *.stat 93 | 94 | # ########## C++Builder 95 | # (*.obj) C++ Object File 96 | # (*.pch) C++ Precompiled Header File 97 | # (*.o) C++ object file or compiled translation unit. 98 | # (*.pch) C++ precompiled header file. 99 | 100 | # ########## Other files 101 | # (.vscode/**) Visual Studio Code configuration files 102 | # (**/Win32/Debug/**) for DUnitX projects - ignore XML file with test results 103 | 104 | **/Win32/Debug/** 105 | .vscode/** 106 | dunitx-results.xml 107 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Bogdan Polak 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Command Pattern for Delphi 2 | 3 | ![ Delphi Support ](https://img.shields.io/badge/Delphi%20Support-%20XE8%20..%2010.4-blue.svg) 4 | ![ version ](https://img.shields.io/badge/version-%201.0-yellow.svg) 5 | 6 | ## Overview 7 | 8 | Simplified version of the GoF Command Pattern, created for the purposes of modernization of VCL projects. Also added action factory to this project, which is wrapping a command into VCL action. 9 | 10 | ## The Command Pattern 11 | 12 | ![](docs/resources/gof-command.png) 13 | 14 | ## Implementation 15 | 16 | The project contains two versions of the pattern implementation: 17 | 1) classic Gang of Four `ICommand` interface 18 | 1) VCL `TCommand` class based on TComponent 19 | 20 | ## Modernization process 21 | 22 | The `TCommand` component was created to help the **modernization of the legacy VCL code**. It assists the extraction of tangled code, which after securing it with unit tests, can be refactored into cleaner and cheaper to maintain object-oriented code. 23 | 24 | `TCommand` component is a transition object that should be refactored after clearing extracted code and after removing UI dependencies 25 | 26 | ![](/docs/resources/moderniz-process.png) 27 | 28 | ## TCommand component 29 | 30 | The easiest way to use the `TCommand` component is to create a new class, paste long method into Execute method and add all dependencies as published properties. See sample bellow. 31 | 32 | Diagram of TCommand usage in the VCL application: 33 | 34 | ![](./docs/resources/tcommand-vcl.png) 35 | 36 | ## Creating / implementing new command 37 | 38 | Developer to build new command needs to define new class derived from `TCommand` (unit: `Pattern.Command.pas`) and implements a protected method `DoExecute`, which contains a main command logic. 39 | 40 | Developer can implement a method `DoGuard` also, which is called before `DoExecute` and allow to verify all mandatory injections (injection system is explained bellow). Usually all injections are checked with Assert call. 41 | 42 | Sample command without injection (empty guard): 43 | ```pas 44 | type 45 | TDiceRollCommand = class (TCommand) 46 | protected 47 | procedure DoExecute; override; 48 | end; 49 | 50 | procedure TDiceRollCommand.DoExecute; 51 | begin 52 | ShowMessage('Dice roll: '+RandomRange(1,6).ToString); 53 | end; 54 | ``` 55 | 56 | To execute command you should create object and call `Execute` public method, which call `DoGuard` and then `DoExecute`: 57 | 58 | ```pas 59 | cmd := TDiceRollCommand.Ceate(Self); 60 | cmd.Execute; 61 | ``` 62 | 63 | ## TCommand injection system 64 | 65 | `TCommand` component has built in automated injection system based on classic `RTTI` mechanism used by IDE Form Designer (Object Inspector). Properties exposed to be injectable have to be defined in `published` section of the component (command). All component based classes have switched on run-time type information generation during compilation process (compiler option `{$TYPEINFO ON}`). Thanks of that during creation of new command all dependencies can be easily provided and assigned to published properties automatically. More information about classic RTTI engine can be find in Delphi documentation: [Run-Time Type Information](http://docwiki.embarcadero.com/RADStudio/Rio/en/Run-Time_Type_Information_\(Delphi\)) 66 | 67 | Sample command with two dependencies (one required and one optional): 68 | ```pas 69 | type 70 | TDiceRollCommand = class (TCommand) 71 | const 72 | RollCount = 100; 73 | private 74 | fOutput: TStrings; 75 | fProgressBar: TProgressBar; 76 | procedure ShowProgress(aRoll: integer); 77 | protected 78 | procedure DoGuard; override; 79 | procedure DoExecute; override; 80 | published 81 | property OutputRolls: TStrings read fOutput 82 | write fOutput; 83 | property ProgressBar: TProgressBar read fProgressBar 84 | write fProgressBar; 85 | end; 86 | 87 | procedure TDiceRollCommand.DoGuard; 88 | begin 89 | System.Assert(fOutput<>nil); 90 | end; 91 | 92 | procedure TDiceRollCommand.ShowProgress(aRoll: integer); 93 | begin 94 | if Assigned(fProgressBar) then begin 95 | if aRoll=0 then 96 | fProgressBar.Max := RollCount; 97 | fProgressBar.Position := aRoll; 98 | end; 99 | end 100 | 101 | procedure TDiceRollCommand.DoExecute; 102 | begin 103 | ShowProgress(0); 104 | for var i := 0 to RollCount-1 do 105 | begin 106 | fOutput.Add(RandomRange(1,7).ToString); 107 | ShowProgress(i+1); 108 | end; 109 | end; 110 | ``` 111 | 112 | Available published properties of TCommand are matched against types of parameters passed in parameters (open array). Following rules are used by matching algorithm: 113 | 114 | 1. The same object types are matched 115 | 1. If there is two or more object of the same class passed and more matching properties then parameter are assigned to properties according to order first with first, second with second, etc. 116 | 1. More specific object passed as parameter is matching to more general object in properties list 117 | 1. Numeric integer parameters are assigned to numeric properties 118 | 1. Strings to strings 119 | 1. Supported are also decimals, enumerable and boolean types. 120 | 121 | **Warning!** Injected object are accessed by address in memory (pointer), thanks of that any changes made to object are visible inside and outside of the TCommand. Simple types and strings are accessed via value and properties have to updated manually to be updated. 122 | 123 | Sample code injecting objects to properties of TDiceRollCommand: 124 | ```pas 125 | cmd := TDiceRollCommand.Create(Self) 126 | .Inject([Memo1.Lines,ProgressBar1]); 127 | ``` 128 | 129 | Most popular and usually advised method of injecting dependencies is a constructor injection. This solution introduced here (TCommand pattern) is more component based approach. This pattern is more like a transition stage which allow quickly extract and execute important parts of big application. Final target point in that process is the best architectural solution, means injection through the constructor and use interfaces instead of objects. 130 | 131 | ## TCommand execution 132 | 133 | 1) Instant (ad-hoc) command execution 134 | * `TCommand.AdhocExecute` - executes a command (creates a command, injects dependencies executes it and removes) 135 | 1) Full command construction and execution 136 | * Create command with standard (component) constructor 137 | * Call method `Inject` 138 | * Execute command with `Execute` 139 | 1) Build command invoker `TCommandAction` which executes the command when the action is invoked 140 | * `TCommandAction` class is classic VCL action 141 | * This class has special methods to allow rapid construction and initialization 142 | 143 | ## Asynchronous Command 144 | 145 | Business logic, extracted into the command, can be easily converted into asynchronous command, processed in a separate background thread. Replacing `TCommand` class with `TAsyncCommand` is first steep in such transformation: 146 | 147 | ```pas 148 | uses 149 | Pattern.AsyncCommand; 150 | type 151 | TAsyncDiceRollCommand = class (TAsyncCommand) 152 | ... 153 | end; 154 | ``` 155 | 156 | Although the change is very simple, but in general, multi-threaded processing is a much more serious subject and requires deeper knowledge of this area. In this example (`TDiceRollCommand`) two topics are problematic: 157 | 158 | 1. Access to UI control `fProgressBar: TProgressBar` 159 | 1. Access to shared memory `fOutputRolls: TStrings` 160 | 161 | You can easily deal with them, but this requires more general multithread processing knowledge. More info you can find in dedicated documentation: [Asynchronous Command](docs/AsyncCommand.md) 162 | 163 | ## TCommandAction - VCL command invoker 164 | 165 | `TCommandAction` is a wrapper class based on `TAction` and is able to execute commands based on `TCommand` class. Developer, when building VCL application, can easily bind this action to many controls (visual components which are driven by actions or are action-aware). For example `TCheckBox` has `Action` property which is executed when used is changing checkbox state (checked). Actions have some other advantages like build in notification system, precisely two such engines: one for updating visual state and another, more internal, for notifying about creation of new and deletion of existing components. Both engines are too complex to be described in this section, more information can be found in the Delphi online documentation. 166 | 167 | Looking form architectural perspective `TCommandAction` can be used as an Invoker object and after migration can be replaced by more elastic custom solution. 168 | 169 | Sample construction on `TCommandAction` invoker: 170 | 171 | ```pas 172 | Button1.Action := TCommandAction.Create(Button1) 173 | .WithCaption('Run sample command') 174 | .WithCommand(TSampleCommand.Create(Button1)) 175 | .WithInjections([Memo1, Edit1]); 176 | ``` 177 | 178 | ### TCommandAction methods 179 | 180 | | Utility method | Description | 181 | | --- | --- | 182 | | `WithCaption(aCaption)` | Sets an action caption which is displayed in a control | 183 | | `WithShortCut(aShortcut)` | Sets a shortcut which is activating an action | 184 | | `WithCommand(aCommand)` | Sets a command to execute | 185 | | `WithInjections(aInjections)` | Injects values into the command's properties | 186 | | `WithEventOnUpdate(aProc)` | Event triggered after action onUpdate event | 187 | | `WithEventAfterExecution(aProc)` | Event triggered when command will be finished | 188 | 189 | Sample setup OnUpdate event in `TCommandAction`: 190 | 191 | ```pas 192 | Button2.Action := TCommandAction.Create(Self) 193 | .WithCaption('Run sample command') 194 | .WithCommand(MySampleCommand) 195 | .WithEventOnUpdate( 196 | procedure(cmd: TCommandAction) 197 | begin 198 | cmd.Enabled := CheckBox1.Checked; 199 | end); 200 | ``` 201 | 202 | ## Command Evolution 203 | 204 | TCommand Pattern allow developers to extract the valuable business code and make applications less coupled. Simultaneously developers can still use well known component practices and compose more complex code using command components. Developers can even expand Command Pattern with their own properties and events. However this approach is a temporary solution and should be evolved into more object oriented design. 205 | 206 | TCommand Pattern is compatible to GoF Command Pattern (see diagrams above) and can be modernized. This moderation should be started when the refactoring phase will be finished and logic will be covered by unit tests. During refactoring all the visual dependencies should be removed, also all irrelevant dependencies and the code should be breaking down into smaller more logical methods or classes. 207 | 208 | After modernization all dependencies should be inject through constructor, the command should be accessed through the interface, access to command internal items should be through getter and setter methods. Composed objects should be created using DI container, like Spring4D `GlobalContainer` method. 209 | 210 | ## Samples 211 | 212 | Ad-hoc command execution (create, inject, execute, remove) 213 | ```pas 214 | TCommand.AdhocExecute([Memo1, Edit1]); 215 | ``` 216 | 217 | Creates command and inject dependencies: 218 | ```pas 219 | cmdSampleCommand := TSampleCommand.Create(AOwner); 220 | cmdSampleCommand.Inject([Memo1, Edit1]); 221 | ``` 222 | 223 | Sample `TCommand` component: 224 | ```pas 225 | type 226 | TSampleCommand = class (TCommand) 227 | private 228 | FMemo: TMemo; 229 | FEdit: TEdit; 230 | protected 231 | procedure DoGuard; override; 232 | procedure DoExecute; override; 233 | published 234 | property Memo: TMemo read FMemo write FMemo; 235 | property Edit: TEdit read FEdit write FEdit; 236 | end; 237 | 238 | procedure TSampleCommand.DoGuard; 239 | begin 240 | System.Assert(Memo<>nil); 241 | System.Assert(Edit<>nil); 242 | end; 243 | 244 | procedure TSampleCommand.DoExecute; 245 | begin 246 | Memo.Lines.Add('Getting Edit text and put it here ...'); 247 | Memo.Lines.Add(' * Edit.Text: '+Edit.Text); 248 | end; 249 | ``` 250 | -------------------------------------------------------------------------------- /docs/AsyncCommand.md: -------------------------------------------------------------------------------- 1 | # Asynchronous command 2 | 3 | ## Introduction 4 | 5 | Command component (`TCommand`) can be converted into asynchronous one using `TAsyncCommand` class. Asynchronous means that all code implemented in `DoExecute` method will be processed in a separate background thread. Today when each machine has access multiple CPU cores this functionality will allow to execute domain code in background, even in parallel, without any negative influence on displayed UI. 6 | 7 | Introducing parallel programing into your project is not very simple in general, usually developers are struggling with many issues coming from that area, but in this days there is no other alternative and `TAsyncCommand` pattern can make this transition much easier. 8 | 9 | One of the simplest async commands can look like this code: 10 | ```pas 11 | type 12 | TSimpleAsyncCommand = class(TAsyncCommand) 13 | protected 14 | procedure DoExecute; override; 15 | end; 16 | 17 | procedure TSimpleAsyncCommand.DoExecute; 18 | begin 19 | DoSampleJobInBackgroundThread; 20 | end; 21 | ``` 22 | 23 | The only difference between command executed in main thread and this one executed in background thread is base class `TAsyncCommand`. This command launching looks the same like any other command: 24 | 25 | ```pas 26 | TSimpleAsyncCommand.Create(aOwner).Execute; 27 | ``` 28 | 29 | ## Main and background thread 30 | 31 | This is very important to be sure which code on the async command is executed in background thread and which in main thread. Writing code working in background developer has very restricted access to outside "world". To force some portion of code to be executed in main thread you can use Synchronize method: 32 | 33 | ```pas 34 | procedure TSimpleAsyncCommand.DoExecute; 35 | begin 36 | for i:=0 to fDataNames.Count-1 do 37 | begin 38 | LoadData (fDataNames[i]); 39 | Synchronize(procedure begin 40 | fReportMemo.Lines.Add('Step '+i.ToString 41 | +', Data: '+fDataNames[i]); 42 | end); 43 | end; 44 | end; 45 | ``` 46 | 47 | In this sample adding report line into TMemo component has to be done in main thread and data can be loaded in background thread. 48 | 49 | > **Warning!** Whereas using Synchronize looks like very simple solution it not recommended one. This should be used with full understanding that switching to main thread is very costly and during this time working thread (DoExecute code) is blocked, till the end of the Synchronize method. 50 | 51 | ### Debugging background thread 52 | 53 | Delphi gives developers a very easy method of testing background thread processing. Usually it's enough to set a breakpoint inside DoExecute method and verify processing flow and inspect a variable values. In more complex situations there could be needed to define thread name, by default TAsyncCommand background thread is named using following formula: `'TAsyncCommand - '+ClassName`, where ClassName is a name of this particular command class. 54 | 55 | ## TAsyncCommand methods and properties 56 | 57 | | Method | Description | 58 | | --- | --- | 59 | | `Execute` | Starts a new background thread and run DoExecute | 60 | | `WithEventBeforeStart( aProc )` | Provided method is called before DoExecute | 61 | | `WithEventAfterFinish( aProc )` | Provided method is called when DoExecute will finish | 62 | | `WithEventOnProgress( aProc )` | Provided method is called during command executing once a defined time (`ProgressInterval`) | 63 | | `Terminate` | Allows to break execution of background thread | 64 | | `IsBusy: boolean` | Returns true when command was started and being processed | 65 | | `IsTerminated: boolean` | Returns whether command processing should be terminated | 66 | | `GetElapsedTime` | Returns time consumed by commands | 67 | 68 | Events defined in methods: `WithEventBeforeStart`, `WithEventAfterFinish` and `WithEventOnProgress` are processed in the main thread and can access all the VCL resources, but not directly background threads data and structures (this requires thread safe, critical section solution). 69 | 70 | Event defined in `WithEventOnProgress` method is called every defined interval (in milliseconds). The AsyncCommand is using an internal timer which is triggered with that interval. Then OnProgress event is executed in the main thread and if developer wants to access thread (command internal) data structures he has to use proper thread safe mechanism. 71 | 72 | | Property | Description | 73 | | --- | --- | 74 | | `ProgressInterval: integer` | Defined interval of internal command timer (in milliseconds) which is calling OnProgress event. Default value = 100 ms | 75 | 76 | 77 | Sample execution of TAsyncCommand: 78 | 79 | ```pas 80 | cmdGenerateSampelCSV 81 | .WithInjections([fCustomerID,fOrdersProxy]) 82 | .WithEventBeforeStart( 83 | procedure 84 | begin 85 | aProgressBar.Position := 0; 86 | end) 87 | .WithEventOnUpdate( 88 | procedure 89 | begin 90 | aProgressBar.Position := fMyAsyncCommand.GetProgressPercent; 91 | end) 92 | .WithEventAfterFinish( 93 | procedure 94 | begin 95 | aProgressBar.Position := 100; 96 | fCSVExporter.SaveToFile(aFileName, fMyAsyncCommand.ReportData); 97 | aSeconds := cmdGenerateSampelCSV.GetElapsedTime.TotalSeconds; 98 | LogAppPerformance(aReportName, aSeconds); 99 | end) 100 | .Execute; 101 | ``` 102 | 103 | ## Async Command Rules 104 | 105 | 1) Remove code manipulating UI controls 106 | - Remove as much of that code as it is possible 107 | - The best approach is to remove all such code from `DoExecute` method 108 | - `TAsyncCommand` has a dedicated support for updating UI controls 109 | 1) Use synchronize method if UI assess is required 110 | - if assess to UI elements is required from background thread (`DoExecute` code) wrap such code accessing UI elements into `Synchronize` method - example bellow 111 | - Synchronize reduce a lot parallel processing capabilities and reduce a thread performance, therefore it is not the recommended solution 112 | 1) Do not share memory structures with main thread 113 | - Use memory structures only internally (inside `DoExecute`) 114 | - for example if you want to access SQL server and fetch data it's better to create a new SQL connection component dedicated only for the async command 115 | - Suggested solution is to: crate a structure colones before async execution, process everything using internal structures and get the results after processing 116 | 1) Access shared memory structures inside critical section 117 | - Use proper concurrency control structures like `TMonitor` to prevent parallel access to the same memory area by many threads 118 | 1) Avoid memory sharing between multiple background threads 119 | - Try to avoid such memory sharing because this is the most challenging scenario of parallel computing 120 | - Proper solutions and patterns covering that scenario are far beyond the scope of this documentation 121 | -------------------------------------------------------------------------------- /docs/resources/gof-command.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bogdanpolak/command-delphi/593d8992c9ad56e736686f01cc33cd4dca248c04/docs/resources/gof-command.png -------------------------------------------------------------------------------- /docs/resources/moderniz-process.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bogdanpolak/command-delphi/593d8992c9ad56e736686f01cc33cd4dca248c04/docs/resources/moderniz-process.png -------------------------------------------------------------------------------- /docs/resources/tcommand-vcl.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bogdanpolak/command-delphi/593d8992c9ad56e736686f01cc33cd4dca248c04/docs/resources/tcommand-vcl.png -------------------------------------------------------------------------------- /samples/01-BasicDemo/Command.Button1.pas: -------------------------------------------------------------------------------- 1 | unit Command.Button1; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | System.SysUtils, 8 | Vcl.StdCtrls, 9 | Pattern.Command; 10 | 11 | type 12 | TButon1Command = class (TCommand) 13 | private 14 | FMemo: TMemo; 15 | protected 16 | procedure DoGuard; override; 17 | procedure DoExecute; override; 18 | published 19 | property Memo: Vcl.StdCtrls.TMemo read FMemo write FMemo; 20 | end; 21 | 22 | implementation 23 | 24 | procedure TButon1Command.DoGuard; 25 | begin 26 | Assert(Memo<>nil); 27 | end; 28 | 29 | procedure TButon1Command.DoExecute; 30 | begin 31 | Memo.Lines.Add('[1] Simple message from command 1'); 32 | Memo.Lines.Add('--- ---'); 33 | end; 34 | 35 | end. 36 | -------------------------------------------------------------------------------- /samples/01-BasicDemo/Command.Button2.pas: -------------------------------------------------------------------------------- 1 | unit Command.Button2; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | System.SysUtils, 8 | Vcl.StdCtrls, 9 | Pattern.Command; 10 | 11 | type 12 | TButon2Command = class (TCommand) 13 | private 14 | FMemo: TMemo; 15 | FEdit: TEdit; 16 | protected 17 | procedure DoGuard; override; 18 | procedure DoExecute; override; 19 | published 20 | property Memo: TMemo read FMemo write FMemo; 21 | property Edit: TEdit read FEdit write FEdit; 22 | end; 23 | 24 | implementation 25 | 26 | procedure TButon2Command.DoGuard; 27 | begin 28 | Assert(Memo<>nil); 29 | Assert(Edit<>nil); 30 | end; 31 | 32 | procedure TButon2Command.DoExecute; 33 | begin 34 | Memo.Lines.Add('[2] Getting info from Edit and put it here ...'); 35 | Memo.Lines.Add('[2] Edit.Text = "'+Edit.Text+'"'); 36 | Memo.Lines.Add('--- ---'); 37 | end; 38 | 39 | end. 40 | 41 | -------------------------------------------------------------------------------- /samples/01-BasicDemo/CommandDemo.dpr: -------------------------------------------------------------------------------- 1 | program CommandDemo; 2 | 3 | uses 4 | Vcl.Forms, 5 | Pattern.Command in '..\..\src\Pattern.Command.pas', 6 | Pattern.CommandAction in '..\..\src\Pattern.CommandAction.pas', 7 | Command.Button1 in 'Command.Button1.pas', 8 | Command.Button2 in 'Command.Button2.pas', 9 | Form.Main in 'Form.Main.pas' {Form1}; 10 | 11 | {$R *.res} 12 | 13 | begin 14 | Application.Initialize; 15 | Application.MainFormOnTaskbar := True; 16 | Application.CreateForm(TForm1, Form1); 17 | Application.Run; 18 | end. 19 | -------------------------------------------------------------------------------- /samples/01-BasicDemo/Form.Main.dfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form1' 5 | ClientHeight = 397 6 | ClientWidth = 678 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | OnCreate = FormCreate 15 | PixelsPerInch = 96 16 | TextHeight = 13 17 | object Memo1: TMemo 18 | AlignWithMargins = True 19 | Left = 246 20 | Top = 3 21 | Width = 429 22 | Height = 391 23 | Align = alClient 24 | Font.Charset = DEFAULT_CHARSET 25 | Font.Color = clWindowText 26 | Font.Height = -12 27 | Font.Name = 'Consolas' 28 | Font.Style = [] 29 | Lines.Strings = ( 30 | 'Memo1') 31 | ParentFont = False 32 | ScrollBars = ssVertical 33 | TabOrder = 1 34 | ExplicitLeft = 207 35 | ExplicitWidth = 416 36 | ExplicitHeight = 511 37 | end 38 | object GroupBoxSimpleDemo: TGroupBox 39 | AlignWithMargins = True 40 | Left = 3 41 | Top = 3 42 | Width = 237 43 | Height = 391 44 | Align = alLeft 45 | Caption = 'GroupBoxSimpleDemo' 46 | TabOrder = 0 47 | ExplicitHeight = 511 48 | object btnAdhocExecute: TButton 49 | AlignWithMargins = True 50 | Left = 5 51 | Top = 18 52 | Width = 227 53 | Height = 31 54 | Align = alTop 55 | Caption = 'btnAdhocExecute' 56 | TabOrder = 0 57 | OnClick = btnAdhocExecuteClick 58 | ExplicitLeft = 7 59 | end 60 | object Button1: TButton 61 | AlignWithMargins = True 62 | Left = 5 63 | Top = 77 64 | Width = 227 65 | Height = 34 66 | Margins.Top = 25 67 | Align = alTop 68 | Caption = 'Button1' 69 | TabOrder = 1 70 | OnClick = Button1Click 71 | ExplicitWidth = 180 72 | end 73 | object Button2: TButton 74 | AlignWithMargins = True 75 | Left = 5 76 | Top = 117 77 | Width = 227 78 | Height = 34 79 | Align = alTop 80 | Caption = 'Button2' 81 | TabOrder = 2 82 | OnClick = Button2Click 83 | ExplicitWidth = 180 84 | end 85 | object Edit1: TEdit 86 | AlignWithMargins = True 87 | Left = 7 88 | Top = 162 89 | Width = 223 90 | Height = 27 91 | Margins.Left = 5 92 | Margins.Top = 8 93 | Margins.Right = 5 94 | Margins.Bottom = 8 95 | Align = alTop 96 | Font.Charset = DEFAULT_CHARSET 97 | Font.Color = clWindowText 98 | Font.Height = -16 99 | Font.Name = 'Tahoma' 100 | Font.Style = [] 101 | ParentFont = False 102 | TabOrder = 3 103 | Text = 'Edit1' 104 | ExplicitWidth = 176 105 | end 106 | end 107 | end 108 | -------------------------------------------------------------------------------- /samples/01-BasicDemo/Form.Main.pas: -------------------------------------------------------------------------------- 1 | unit Form.Main; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Variants, 8 | System.Classes, 9 | System.Actions, 10 | Winapi.Windows, Winapi.Messages, 11 | Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, 12 | Vcl.ActnList, Vcl.ExtCtrls, Vcl.PlatformDefaultStyleActnCtrls, 13 | Vcl.ActnMan, Vcl.ComCtrls, Vcl.Menus, 14 | Pattern.Command, 15 | Pattern.CommandAction, 16 | Command.Button1, 17 | Command.Button2; 18 | 19 | type 20 | TForm1 = class(TForm) 21 | Memo1: TMemo; 22 | GroupBoxSimpleDemo: TGroupBox; 23 | btnAdhocExecute: TButton; 24 | Button1: TButton; 25 | Button2: TButton; 26 | Edit1: TEdit; 27 | procedure FormCreate(Sender: TObject); 28 | procedure btnAdhocExecuteClick(Sender: TObject); 29 | procedure Button1Click(Sender: TObject); 30 | procedure Button2Click(Sender: TObject); 31 | public 32 | private 33 | actCommandButon1: TCommandAction; 34 | actCommandButon2: TCommandAction; 35 | procedure BuildCommandsOnStart; 36 | end; 37 | 38 | var 39 | Form1: TForm1; 40 | 41 | implementation 42 | 43 | {$R *.dfm} 44 | 45 | procedure TForm1.BuildCommandsOnStart; 46 | begin 47 | // --------------------------------------------------------- 48 | // --------------------------------------------------------- 49 | actCommandButon1 := TCommandAction.Create(Self) 50 | .WithCommand(TButon1Command.Create(Self)) 51 | .WithShortCut(TextToShortCut('Ctrl+1')) 52 | .WithCaption('Run command: Button1') //--+ 53 | .WithInjections([Memo1]); 54 | // --------------------------------------------------------- 55 | // --------------------------------------------------------- 56 | actCommandButon2 := TCommandAction.Create(Self) 57 | .WithCommand(TButon2Command.Create(Self)) 58 | .WithShortCut(TextToShortCut('Ctrl+2')) 59 | .WithCaption('Run command: Button2') //--+ 60 | .WithInjections([Memo1, Edit1]); 61 | // --------------------------------------------------------- 62 | // --------------------------------------------------------- 63 | Button1.Action := actCommandButon1; 64 | Button2.Action := actCommandButon2; 65 | end; 66 | 67 | procedure TForm1.FormCreate(Sender: TObject); 68 | begin 69 | BuildCommandsOnStart; 70 | Memo1.Clear; 71 | ReportMemoryLeaksOnShutdown := True; 72 | end; 73 | 74 | procedure TForm1.Button1Click(Sender: TObject); 75 | begin 76 | // this event is not called. Action actCommandButon1 is triggered 77 | end; 78 | 79 | procedure TForm1.Button2Click(Sender: TObject); 80 | begin 81 | // this event is not called. Action actCommandButon2 is triggered 82 | end; 83 | 84 | procedure TForm1.btnAdhocExecuteClick(Sender: TObject); 85 | begin 86 | TCommand.AdhocExecute([Memo1]); 87 | end; 88 | 89 | end. 90 | -------------------------------------------------------------------------------- /samples/01-BasicDemo/Helper.TWinControl.pas: -------------------------------------------------------------------------------- 1 | unit Helper.TWinControl; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes, 8 | Vcl.Controls; 9 | 10 | type 11 | TWinControlHelper = class helper for TWinControl 12 | private const 13 | Version = '1.3'; 14 | private 15 | public 16 | function FindChildControlByType(aClass: TClass): TControl; 17 | function FindChildControlRecursiveByType(aClass: TClass): TControl; 18 | function FindChildControlRecursive(const aName: string): TControl; 19 | // function GetChildControlsByType(aClass: TClass): TArray; 20 | end; 21 | 22 | implementation 23 | 24 | function TWinControlHelper.FindChildControlByType(aClass: TClass): TControl; 25 | var 26 | i: Integer; 27 | begin 28 | for i := 0 to Self.ControlCount - 1 do 29 | if Self.Controls[i].ClassType = aClass then 30 | Exit(Self.Controls[i]); 31 | Result := nil; 32 | end; 33 | 34 | function TWinControlHelper.FindChildControlRecursiveByType(aClass: TClass) 35 | : TControl; 36 | var 37 | i: Integer; 38 | begin 39 | Result := Self.FindChildControlByType(aClass); 40 | if Result = nil then 41 | for i := 0 to Self.ControlCount - 1 do 42 | if Self.Controls[i] is TWinControl then 43 | begin 44 | Result := (Self.Controls[i] as TWinControl) 45 | .FindChildControlRecursiveByType(aClass); 46 | if Result<>nil then 47 | exit; 48 | end; 49 | end; 50 | 51 | function TWinControlHelper.FindChildControlRecursive(const aName: string) 52 | : TControl; 53 | begin 54 | // TODO: implement - simmilar to FindChildControlRecursiveByType but by name 55 | Result := nil; 56 | end; 57 | 58 | end. 59 | -------------------------------------------------------------------------------- /samples/01-BasicDemo/clear_project.bat: -------------------------------------------------------------------------------- 1 | rmdir /Q /S __history 2 | rmdir /Q /S Win32 3 | rmdir /Q /S .svn 4 | rmdir /Q /S __recovery 5 | 6 | del *.identcache 7 | del *.dproj.local 8 | del desktop.ini 9 | del *.stat 10 | 11 | del *.dcu 12 | del *.exe 13 | del *.dll 14 | -------------------------------------------------------------------------------- /samples/02-AsyncDemo/AsyncCommandDemo.dpr: -------------------------------------------------------------------------------- 1 | program AsyncCommandDemo; 2 | 3 | uses 4 | Vcl.Forms, 5 | Pattern.AsyncCommand in '..\..\src\Pattern.AsyncCommand.pas', 6 | Pattern.Command in '..\..\src\Pattern.Command.pas', 7 | Command.AsyncDiceRoll in 'Command.AsyncDiceRoll.pas', 8 | Command.DiceRoll in 'Command.DiceRoll.pas', 9 | Form.Main in 'Form.Main.pas' {Form1}, 10 | Command.AsyncDiceRollExtra in 'Command.AsyncDiceRollExtra.pas'; 11 | 12 | {$R *.res} 13 | 14 | begin 15 | Application.Initialize; 16 | Application.MainFormOnTaskbar := True; 17 | Application.CreateForm(TForm1, Form1); 18 | Application.Run; 19 | end. 20 | -------------------------------------------------------------------------------- /samples/02-AsyncDemo/Command.AsyncDiceRoll.pas: -------------------------------------------------------------------------------- 1 | unit Command.AsyncDiceRoll; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes, 8 | System.Math, 9 | System.Diagnostics, 10 | Vcl.ComCtrls, // for TProgressBar class (needs refactoring) 11 | Vcl.StdCtrls, // for TMemo class (needs refactoring) 12 | Pattern.AsyncCommand; 13 | 14 | type 15 | TAsyncDiceRollCommand = class(TAsyncCommand) 16 | const 17 | MaxDiceValue = 6; 18 | private 19 | fRolls: TArray; 20 | fResultDistribution: TArray; 21 | fReportMemo: TMemo; 22 | fProgressBar: TProgressBar; 23 | fProgressLabel: TLabel; 24 | fStep: Integer; 25 | fRollsCount: Integer; 26 | procedure DoDisplayStepInfo; 27 | procedure DoDisplaySummaryInfo; 28 | procedure DoSomeOtherWork(aSpendMiliseconds: double); 29 | protected 30 | procedure DoGuard; override; 31 | procedure DoExecute; override; 32 | published 33 | property ReportMemo: TMemo read fReportMemo write fReportMemo; 34 | property ProgressBar: TProgressBar read fProgressBar write fProgressBar; 35 | property ProgressLabel: TLabel read fProgressLabel write fProgressLabel; 36 | property RollsCount: Integer read fRollsCount write fRollsCount; 37 | end; 38 | 39 | implementation 40 | 41 | procedure TAsyncDiceRollCommand.DoGuard; 42 | begin 43 | System.Assert(fReportMemo <> nil); 44 | System.Assert(fProgressBar <> nil); 45 | end; 46 | 47 | procedure TAsyncDiceRollCommand.DoDisplayStepInfo; 48 | begin 49 | fProgressBar.Position := fStep; 50 | if fProgressLabel <> nil then 51 | fProgressLabel.Caption := Format('calculating %d/%d', [fStep, fRollsCount]); 52 | end; 53 | 54 | procedure TAsyncDiceRollCommand.DoDisplaySummaryInfo; 55 | var 56 | i: Integer; 57 | begin 58 | ReportMemo.Lines.Add(Format('Elapsed time: %.1f seconds', 59 | [GetElapsedTime.TotalSeconds])); 60 | ReportMemo.Lines.Add 61 | (Format('Dice results (%d-sided dice) (number of rolls: %d)', 62 | [MaxDiceValue, fRollsCount])); 63 | for i := 1 to MaxDiceValue do 64 | ReportMemo.Lines.Add(Format(' [%d] : %d', [i, fResultDistribution[i]])); 65 | end; 66 | 67 | procedure TAsyncDiceRollCommand.DoSomeOtherWork (aSpendMiliseconds: double); 68 | var 69 | sw: TStopwatch; 70 | begin 71 | sw := TStopWatch.Create; 72 | sw.Start; 73 | while sw.Elapsed.Milliseconds; 18 | fResultDistribution: TArray; 19 | fStep: Integer; 20 | fRollsCount: Integer; 21 | function GetStep: Integer; 22 | procedure SetStep(aStep: Integer); 23 | procedure DoSomeOtherWork(aSpendMiliseconds: double); 24 | protected 25 | procedure DoGuard; override; 26 | procedure DoExecute; override; 27 | public 28 | function GetDistribution: TArray; 29 | property Step: Integer read GetStep write SetStep; 30 | published 31 | property RollsCount: Integer read fRollsCount write fRollsCount; 32 | end; 33 | 34 | implementation 35 | 36 | procedure TAsyncDiceRollCommandEx.DoGuard; 37 | begin 38 | end; 39 | 40 | function TAsyncDiceRollCommandEx.GetDistribution: TArray; 41 | begin 42 | Result := fResultDistribution; 43 | end; 44 | 45 | function TAsyncDiceRollCommandEx.GetStep: Integer; 46 | begin 47 | TMonitor.Enter(Self); 48 | try 49 | Result := fStep; 50 | finally 51 | TMonitor.Exit(Self); 52 | end; 53 | end; 54 | 55 | procedure TAsyncDiceRollCommandEx.SetStep(aStep: Integer); 56 | begin 57 | TMonitor.Enter(Self); 58 | try 59 | fStep := aStep; 60 | finally 61 | TMonitor.Exit(Self); 62 | end; 63 | end; 64 | 65 | procedure TAsyncDiceRollCommandEx.DoSomeOtherWork (aSpendMiliseconds: double); 66 | var 67 | sw: TStopwatch; 68 | begin 69 | sw := TStopWatch.Create; 70 | sw.Start; 71 | while sw.Elapsed.Milliseconds; 21 | fResultDistribution: TArray; 22 | fReportMemo: TMemo; 23 | fProgressBar: TProgressBar; 24 | fProgressLabel: TLabel; 25 | fRollsCount: Integer; 26 | fStep: Integer; 27 | fIsTerminated: boolean; 28 | procedure DoDisplayStepInfo; 29 | procedure DoDisplaySummaryInfo; 30 | procedure DoSomeOtherWork(aSpendMiliseconds: double); 31 | protected 32 | procedure DoGuard; override; 33 | procedure DoExecute; override; 34 | public 35 | procedure Terminate; 36 | published 37 | property ReportMemo: TMemo read fReportMemo write fReportMemo; 38 | property ProgressBar: TProgressBar read fProgressBar write fProgressBar; 39 | property ProgressLabel: TLabel read fProgressLabel write fProgressLabel; 40 | property RollsCount: Integer read fRollsCount write fRollsCount; 41 | end; 42 | 43 | implementation 44 | 45 | procedure TDiceRollCommand.DoGuard; 46 | begin 47 | System.Assert(fReportMemo <> nil); 48 | System.Assert(fProgressBar <> nil); 49 | end; 50 | 51 | procedure TDiceRollCommand.Terminate; 52 | begin 53 | fIsTerminated := True; 54 | end; 55 | 56 | procedure TDiceRollCommand.DoDisplayStepInfo; 57 | begin 58 | fProgressBar.Position := fStep; 59 | if fProgressLabel <> nil then 60 | fProgressLabel.Caption := Format('calculating %d/%d', [fStep, fRollsCount]); 61 | end; 62 | 63 | procedure TDiceRollCommand.DoDisplaySummaryInfo; 64 | var 65 | i: Integer; 66 | begin 67 | ReportMemo.Lines.Add(Format('Elapsed time: %.1f seconds', 68 | [GetElapsedTime.TotalSeconds])); 69 | ReportMemo.Lines.Add 70 | (Format('Dice results (%d-sided dice) (number of rolls: %d)', 71 | [MaxDiceValue, fRollsCount])); 72 | for i := 1 to MaxDiceValue do 73 | ReportMemo.Lines.Add(Format(' [%d] : %d', [i, fResultDistribution[i]])); 74 | end; 75 | 76 | procedure TDiceRollCommand.DoSomeOtherWork (aSpendMiliseconds: double); 77 | var 78 | sw: TStopwatch; 79 | begin 80 | sw := TStopWatch.Create; 81 | sw.Start; 82 | while sw.Elapsed.Milliseconds; 122 | i: integer; 123 | begin 124 | aDistribution := fAsyncCommandEx.GetDistribution; 125 | Memo1.Lines.Add(Format('Elapsed time: %.1f seconds', 126 | [fAsyncCommandEx.GetElapsedTime.TotalSeconds])); 127 | Memo1.Lines.Add(Format('Dice results (%d-sided dice) (number of rolls: %d)', 128 | [fAsyncCommandEx.MaxDiceValue, fAsyncCommandEx.Step])); 129 | for i := 1 to High(aDistribution) do 130 | Memo1.Lines.Add(Format(' [%d] : %d', [i, aDistribution[i]])); 131 | end; 132 | 133 | procedure TForm1.btnAsycDiceRollCmdTwoClick(Sender: TObject); 134 | begin 135 | with fAsyncCommandEx do 136 | begin 137 | WithInjections([NumberOfRolls]); 138 | WithEventBeforeStart( 139 | procedure 140 | begin 141 | ProgressBar3.Position := 0; 142 | ProgressBar3.Max := fAsyncCommandEx.RollsCount; 143 | lblProgress3.Caption := ''; 144 | end); 145 | WithEventOnUpdate(DiceRoll_DoDisplayStepInfo); 146 | WithEventAfterFinish( 147 | procedure 148 | begin 149 | DiceRoll_DoDisplayStepInfo; 150 | DiceRoll_DoDisplaySummaryInfo; 151 | end); 152 | Execute; 153 | end; 154 | end; 155 | 156 | end. 157 | -------------------------------------------------------------------------------- /src/Pattern.AsyncCommand.pas: -------------------------------------------------------------------------------- 1 | {* ------------------------------------------------------------------------ * 2 | * Command Parttern ♥ TAsyncCommand 3 | * ------------------------------------------------------------------------ *} 4 | unit Pattern.AsyncCommand; 5 | 6 | interface 7 | 8 | uses 9 | System.Classes, 10 | System.SysUtils, 11 | System.TypInfo, 12 | System.Diagnostics, 13 | System.TimeSpan, 14 | 15 | Vcl.ExtCtrls, // TTimer (VCL) 16 | 17 | Pattern.Command; 18 | 19 | type 20 | TAsyncCommand = class(TCommand) 21 | private const 22 | Version = '1.0'; 23 | private 24 | fUpdateInterval: integer; 25 | fOnUpdateProc: TProc; 26 | procedure OnUpdateTimer(Sender: TObject); 27 | protected 28 | fBeforeStartEvent: TProc; 29 | fAfterFinishEvent: TProc; 30 | fThread: TThread; 31 | fIsCommandDone: boolean; 32 | fTimer: TTimer; 33 | procedure Synchronize(aProc: TThreadProcedure); 34 | function GetIsCommandDone: boolean; 35 | procedure SetIsCommandDone(aIsTermianted: boolean); 36 | public 37 | constructor Create(AOwner: TComponent); override; 38 | destructor Destroy; override; 39 | function WithInjections(const Injections: array of const): TAsyncCommand; 40 | function WithEventBeforeStart(aBeforeStart: TProc): TAsyncCommand; 41 | function WithEventAfterFinish(aAfterFinish: TProc): TAsyncCommand; 42 | function WithEventOnUpdate(aOnUpdateProc: TProc): TAsyncCommand; 43 | procedure Execute; override; 44 | procedure Terminate; 45 | function IsBusy: boolean; override; 46 | function IsTerminated: boolean; 47 | property UpdateInterval: integer read fUpdateInterval 48 | write fUpdateInterval; 49 | end; 50 | 51 | implementation 52 | 53 | // ------------------------------------------------------------------------ 54 | // TAsyncCommand 55 | // ------------------------------------------------------------------------ 56 | 57 | constructor TAsyncCommand.Create(AOwner: TComponent); 58 | begin 59 | inherited; 60 | fThread := nil; 61 | fBeforeStartEvent := nil; 62 | fAfterFinishEvent := nil; 63 | fIsCommandDone := true; 64 | fUpdateInterval := 100; 65 | // --- Timer --- 66 | fTimer := TTimer.Create(nil); 67 | fTimer.Enabled := false; 68 | fTimer.Interval := fUpdateInterval; 69 | fTimer.OnTimer := OnUpdateTimer; 70 | end; 71 | 72 | destructor TAsyncCommand.Destroy; 73 | begin 74 | Self.IsBusy; // call to tear down all internal structures 75 | fTimer.Free; 76 | inherited; 77 | end; 78 | 79 | procedure TAsyncCommand.Execute; 80 | begin 81 | SetIsCommandDone(false); 82 | DoGuard; 83 | fThread := TThread.CreateAnonymousThread( 84 | procedure 85 | begin 86 | TThread.NameThreadForDebugging('Command: ' + Self.ClassName); 87 | try 88 | SetIsCommandDone(false); 89 | DoExecute; 90 | finally 91 | SetIsCommandDone(true); 92 | end; 93 | end); 94 | fThread.FreeOnTerminate := false; 95 | fTimer.Enabled := True; 96 | if Assigned(fBeforeStartEvent) then 97 | fBeforeStartEvent(); 98 | fStopwatch := TStopwatch.StartNew; 99 | fThread.Start; 100 | end; 101 | 102 | function TAsyncCommand.GetIsCommandDone: boolean; 103 | begin 104 | TMonitor.Enter(Self); 105 | try 106 | Result := fIsCommandDone; 107 | finally 108 | TMonitor.Exit(Self); 109 | end; 110 | end; 111 | 112 | procedure TAsyncCommand.SetIsCommandDone(aIsTermianted: boolean); 113 | begin 114 | TMonitor.Enter(Self); 115 | try 116 | fIsCommandDone := aIsTermianted; 117 | finally 118 | TMonitor.Exit(Self); 119 | end; 120 | end; 121 | 122 | function TAsyncCommand.IsBusy: boolean; 123 | var 124 | IsCommandDone: boolean; 125 | begin 126 | IsCommandDone := GetIsCommandDone; 127 | if IsCommandDone and (fThread <> nil) then 128 | begin 129 | fTimer.Enabled := False; 130 | FreeAndNil (fThread); 131 | fStopwatch.Stop; 132 | if Assigned(fAfterFinishEvent) then 133 | fAfterFinishEvent(); 134 | end; 135 | Result := not IsCommandDone; 136 | end; 137 | 138 | function TAsyncCommand.IsTerminated: boolean; 139 | begin 140 | Result := TThread.CheckTerminated; 141 | end; 142 | 143 | procedure TAsyncCommand.OnUpdateTimer(Sender: TObject); 144 | begin 145 | fTimer.Enabled := Self.IsBusy; 146 | if fTimer.Enabled and Assigned(fOnUpdateProc) then 147 | fOnUpdateProc; 148 | end; 149 | 150 | procedure TAsyncCommand.Synchronize(aProc: TThreadProcedure); 151 | begin 152 | if (fThread <> nil) and Assigned(aProc) then 153 | TThread.Synchronize(fThread, aProc); 154 | end; 155 | 156 | procedure TAsyncCommand.Terminate; 157 | begin 158 | if (fThread<>nil) and not GetIsCommandDone then 159 | fThread.Terminate; 160 | end; 161 | 162 | function TAsyncCommand.WithInjections(const Injections: array of const): TAsyncCommand; 163 | begin 164 | TComponentInjector.InjectProperties(Self, Injections); 165 | Result := Self; 166 | end; 167 | 168 | function TAsyncCommand.WithEventAfterFinish(aAfterFinish: TProc): TAsyncCommand; 169 | begin 170 | fAfterFinishEvent := aAfterFinish; 171 | Result := Self; 172 | end; 173 | 174 | function TAsyncCommand.WithEventBeforeStart(aBeforeStart: TProc): TAsyncCommand; 175 | begin 176 | fBeforeStartEvent := aBeforeStart; 177 | Result := Self; 178 | end; 179 | 180 | function TAsyncCommand.WithEventOnUpdate(aOnUpdateProc: TProc): TAsyncCommand; 181 | begin 182 | fOnUpdateProc := aOnUpdateProc; 183 | Result := Self; 184 | end; 185 | 186 | end. 187 | -------------------------------------------------------------------------------- /src/Pattern.Command.pas: -------------------------------------------------------------------------------- 1 | {* ------------------------------------------------------------------------ * 2 | * Command Parttern ♥ TCommand 3 | * ------------------------------------------------------------------------ *} 4 | unit Pattern.Command; 5 | 6 | interface 7 | 8 | uses 9 | System.Classes, 10 | System.SysUtils, 11 | System.TypInfo, 12 | System.Diagnostics, 13 | System.TimeSpan; 14 | 15 | type 16 | ICommand = interface 17 | procedure Execute(); 18 | end; 19 | 20 | TCommand = class(TComponent, ICommand) 21 | private const 22 | Version = '1.0'; 23 | protected 24 | fStopwatch: TStopwatch; 25 | fBusy: boolean; 26 | procedure DoGuard; virtual; 27 | procedure DoExecute; virtual; abstract; 28 | public 29 | class procedure AdhocExecute(const Injections 30 | : array of const); static; 31 | function WithInjections(const Injections: array of const): TCommand; 32 | procedure Execute; virtual; 33 | function GetElapsedTime: TTimeSpan; 34 | function GetElapsedTimeMs: integer; 35 | function IsBusy: boolean; virtual; 36 | end; 37 | 38 | 39 | TPropertyInfo = record 40 | Kind: TTypeKind; 41 | PropertyName: string; 42 | ClassName: string; 43 | function isAvaliableForInjection(const aInjection: TVarRec): boolean; 44 | end; 45 | 46 | TPropertyArray = array of TPropertyInfo; 47 | 48 | TComponentMetadata = class 49 | public 50 | class function GetPublishedPropetries(aComponent: TComponent) 51 | : TPropertyArray; 52 | end; 53 | 54 | TComponentInjector = class 55 | class procedure InjectProperties(aComponent: TComponent; 56 | const Injections: array of const); 57 | private 58 | class procedure AssertParameters(const Injections: array of const); static; 59 | end; 60 | 61 | type 62 | TCommandClass = class of TCommand; 63 | 64 | implementation 65 | 66 | uses 67 | System.RTTI; 68 | 69 | // ------------------------------------------------------------------------ 70 | // TCommand 71 | // ------------------------------------------------------------------------ 72 | 73 | const 74 | ERRMSG_NotSupportedParameter = 'Not supported parameter type to inject!' + 75 | 'Parameter index (zaro-based): %d. Paramter type: %s'; 76 | 77 | procedure TCommand.Execute; 78 | begin 79 | DoGuard; 80 | fStopwatch := TStopwatch.StartNew; 81 | fBusy := True; 82 | try 83 | DoExecute; 84 | finally 85 | fBusy := False; 86 | fStopwatch.Stop; 87 | end; 88 | end; 89 | 90 | function TCommand.GetElapsedTime: TTimeSpan; 91 | begin 92 | Result := fStopwatch.Elapsed; 93 | end; 94 | 95 | function TCommand.GetElapsedTimeMs: integer; 96 | begin 97 | Result := fStopwatch.ElapsedMilliseconds; 98 | end; 99 | 100 | function TCommand.IsBusy: boolean; 101 | begin 102 | Result := fBusy; 103 | end; 104 | 105 | procedure TCommand.DoGuard; 106 | begin 107 | end; 108 | 109 | function TCommand.WithInjections(const Injections: array of const): TCommand; 110 | begin 111 | TComponentInjector.InjectProperties(Self, Injections); 112 | Result := Self; 113 | end; 114 | 115 | class procedure TCommand.AdhocExecute(const Injections: array of const); 116 | var 117 | AClass: TCommandClass; 118 | Command: T; 119 | begin 120 | try 121 | // ----------------------------------------- 122 | AClass := T; 123 | Command := T(AClass.Create(nil)); 124 | // 10.3 Rio: Command := T.Create(nil); 125 | // ----------------------------------------- 126 | TComponentInjector.InjectProperties(Command, Injections); 127 | Command.Execute; 128 | finally 129 | Command.Free; 130 | end; 131 | end; 132 | 133 | 134 | // ------------------------------------------------------------------------ 135 | // TComponentInjector 136 | // ------------------------------------------------------------------------ 137 | 138 | { TPropertyInfo } 139 | 140 | procedure SetInterfaceProperty(aComponent: TComponent; 141 | const aPropertyName: string; const aInjection: TVarRec); 142 | var 143 | ctx: TRttiContext; 144 | typ: TRttiType; 145 | prop: TRttiProperty; 146 | val: TValue; 147 | begin 148 | typ := ctx.GetType(aComponent.ClassType); 149 | val := TValue.From(IInterface(aInjection.VInterface) as TObject); 150 | for prop in typ.GetProperties do 151 | if prop.Name = aPropertyName then 152 | prop.SetValue(aComponent, val); 153 | end; 154 | 155 | function IsInterfaceInjectionImplementsInterface(const aInjection: TVarRec; 156 | const aInterfaceName: string): boolean; 157 | var 158 | obj: TObject; 159 | implementedList: TArray; 160 | IntfType: TRttiInterfaceType; 161 | ctx: TRttiContext; 162 | begin 163 | System.Assert(aInjection.VType = vtInterface); 164 | obj := IInterface(aInjection.VInterface) as TObject; 165 | implementedList := (ctx.GetType(obj.ClassType) as TRttiInstanceType) 166 | .GetImplementedInterfaces; 167 | for IntfType in implementedList do 168 | if IntfType.Name = aInterfaceName then 169 | Exit(true); 170 | Result := False; 171 | end; 172 | 173 | function TPropertyInfo.isAvaliableForInjection(const aInjection 174 | : TVarRec): boolean; 175 | var 176 | ClassType: TClass; 177 | begin 178 | if (Self.Kind = tkInterface) and (aInjection.VType = vtInterface) then 179 | Result := IsInterfaceInjectionImplementsInterface(aInjection, 180 | Self.ClassName) 181 | else if (Self.Kind = tkClass) and (aInjection.VType = vtObject) then 182 | begin 183 | Result := (aInjection.VObject.ClassName = Self.ClassName); 184 | ClassType := aInjection.VObject.ClassType; 185 | while not(Result) and (ClassType.ClassParent <> nil) do 186 | begin 187 | Result := (ClassType.ClassParent.ClassName = Self.ClassName); 188 | ClassType := ClassType.ClassParent; 189 | end; 190 | end 191 | else 192 | Result := (Self.Kind = tkInteger) and (aInjection.VType = vtInteger) or 193 | (Self.Kind = tkEnumeration) and (aInjection.VType = vtBoolean) or 194 | (Self.Kind = tkFloat) and (aInjection.VType = vtExtended); 195 | end; 196 | 197 | function TypeKindToStr(value: TTypeKind): string; 198 | begin 199 | Result := System.TypInfo.GetEnumName(TypeInfo(TTypeKind), Integer(value)); 200 | end; 201 | 202 | function VTypeToStr(value: byte): string; 203 | begin 204 | case value of 205 | {$REGION 'case VType values 0 .. 17, vtInteger = 0, vtBoolean = 1, ...'} 206 | 0: 207 | Result := 'vtInteger'; 208 | 1: 209 | Result := 'vtBoolean'; 210 | 2: 211 | Result := 'vtChar'; 212 | 3: 213 | Result := 'vtExtended'; 214 | 4: 215 | Result := 'vtString'; 216 | 5: 217 | Result := 'vtPointer'; 218 | 6: 219 | Result := 'vtPChar'; 220 | 7: 221 | Result := 'vtObject'; 222 | 8: 223 | Result := 'vtClass'; 224 | 9: 225 | Result := 'vtWideChar'; 226 | 10: 227 | Result := 'vtPWideChar'; 228 | 11: 229 | Result := 'vtAnsiString'; 230 | 12: 231 | Result := 'vtCurrency'; 232 | 13: 233 | Result := 'vtVariant'; 234 | 14: 235 | Result := 'vtInterface'; 236 | 15: 237 | Result := 'vtWideString'; 238 | 16: 239 | Result := 'vtInt64'; 240 | 17: 241 | Result := 'vtUnicodeString'; 242 | {$ENDREGION} 243 | end; 244 | end; 245 | 246 | class procedure TComponentInjector.AssertParameters(const Injections 247 | : array of const); 248 | var 249 | j: Integer; 250 | begin 251 | for j := 0 to High(Injections) do 252 | if not(Injections[j].VType in [vtObject, vtInterface, vtInteger, vtBoolean, 253 | vtExtended]) then 254 | Assert(False, Format(ERRMSG_NotSupportedParameter, 255 | [j, VTypeToStr(Injections[j].VType)])); 256 | end; 257 | 258 | // - - - - - - - - - - - - - - - - - - - - - - - - - 259 | // TPropertyInfo.Kind: tkInteger, tkChar, tkEnumeration, tkFloat, tkString, 260 | // tkSet, tkWChar, tkLString, tkWString, tkVariant, tkArray, tkRecord, 261 | // tkInterface, tkInt64, tkDynArray, tkUString 262 | // - - - - - - - - - - - - - - - - - - - - - - - - - 263 | class procedure TComponentInjector.InjectProperties(aComponent: TComponent; 264 | const Injections: array of const); 265 | var 266 | i: Integer; 267 | j: Integer; 268 | PropertyList: TPropertyArray; 269 | propInfo: TPropertyInfo; 270 | UsedInjection: TArray; 271 | begin 272 | AssertParameters(Injections); 273 | PropertyList := TComponentMetadata.GetPublishedPropetries(aComponent); 274 | SetLength(UsedInjection, Length(Injections)); 275 | for i := 0 to High(PropertyList) do 276 | begin 277 | propInfo := PropertyList[i]; 278 | for j := 0 to High(Injections) do 279 | begin 280 | if not(UsedInjection[j]) and propInfo.isAvaliableForInjection 281 | (Injections[j]) then 282 | begin 283 | UsedInjection[j] := true; 284 | case propInfo.Kind of 285 | tkInterface: 286 | SetInterfaceProperty(aComponent, propInfo.PropertyName, 287 | Injections[j]); 288 | tkClass: 289 | SetObjectProp(aComponent, propInfo.PropertyName, 290 | Injections[j].VObject); 291 | tkInteger, tkEnumeration: 292 | SetOrdProp(aComponent, propInfo.PropertyName, 293 | Injections[j].VInteger); 294 | tkFloat: 295 | SetFloatProp(aComponent, propInfo.PropertyName, 296 | Injections[j].VExtended^); 297 | end; 298 | Break; 299 | end; 300 | end 301 | end; 302 | end; 303 | 304 | 305 | // ------------------------------------------------------------------------ 306 | // ------------------------------------------------------------------------ 307 | { TClassPropertyList } 308 | 309 | class function TComponentMetadata.GetPublishedPropetries(aComponent: TComponent) 310 | : TPropertyArray; 311 | var 312 | aStandardComponent: TComponent; 313 | FPropList: PPropList; 314 | FStandardPropList: PPropList; 315 | aStandardCount: Integer; 316 | aCount: Integer; 317 | i: Integer; 318 | begin 319 | aCount := System.TypInfo.GetPropList(aComponent, FPropList); 320 | aStandardComponent := TComponent.Create(nil); 321 | aStandardCount := System.TypInfo.GetPropList(aStandardComponent, 322 | FStandardPropList); 323 | try 324 | SetLength(Result, aCount - aStandardCount); 325 | for i := 0 to aCount - aStandardCount - 1 do 326 | begin 327 | Result[i].Kind := FPropList^[aStandardCount + i].PropType^.Kind; 328 | Result[i].PropertyName := string(FPropList^[aStandardCount + i].Name); 329 | Result[i].ClassName := 330 | string(FPropList^[aStandardCount + i].PropType^.Name); 331 | end; 332 | finally 333 | FreeMem(FPropList); 334 | aStandardComponent.Free; 335 | FreeMem(FStandardPropList); 336 | end; 337 | end; 338 | 339 | end. 340 | -------------------------------------------------------------------------------- /src/Pattern.CommandAction.pas: -------------------------------------------------------------------------------- 1 | {* ------------------------------------------------------------------------ * 2 | * Command Parttern ♥ TCommandAction = command invoker 3 | * ------------------------------------------------------------------------ *} 4 | unit Pattern.CommandAction; 5 | 6 | interface 7 | 8 | uses 9 | System.Classes, 10 | System.SysUtils, 11 | System.Actions, 12 | Vcl.ActnList, 13 | Pattern.Command; 14 | 15 | type 16 | TCommandAction = class(TAction) 17 | private const 18 | Version = '1.0'; 19 | private 20 | fCommand: TCommand; 21 | fOnUpdateProc: TProc; 22 | fOnAfterProc: TProc; 23 | fDisableDuringExecution: boolean; 24 | fActionList: TActionList; 25 | procedure OnExecuteEvent(Sender: TObject); 26 | procedure OnUpdateEvent(Sender: TObject); 27 | procedure DoExecuteAction(Sender: TObject); 28 | public 29 | constructor Create(aOwner: TComponent); override; 30 | destructor Destroy; override; 31 | function WithCaption(const aCaption: string): TCommandAction; 32 | function WithCommand(aCommand: TCommand): TCommandAction; 33 | function WithShortCut(aShorcut: TShortCut): TCommandAction; 34 | function WithEventOnUpdate(AUpdateProc: TProc) 35 | : TCommandAction; 36 | function WitEventAfterExecution(aAfterProc: TProc) 37 | : TCommandAction; 38 | function WithInjections(const Injections: array of const): TCommandAction; 39 | property Command: TCommand read fCommand write fCommand; 40 | property DisableDuringExecution: boolean read fDisableDuringExecution 41 | write fDisableDuringExecution; 42 | end; 43 | 44 | implementation 45 | 46 | constructor TCommandAction.Create(aOwner: TComponent); 47 | begin 48 | inherited; 49 | DisableDuringExecution := False; 50 | fActionList := nil; 51 | fCommand := nil; 52 | fOnUpdateProc := nil; 53 | fOnAfterProc := nil; 54 | Self.OnExecute := OnExecuteEvent; 55 | end; 56 | 57 | destructor TCommandAction.Destroy; 58 | begin 59 | inherited; 60 | end; 61 | 62 | procedure TCommandAction.DoExecuteAction(Sender: TObject); 63 | begin 64 | fCommand.Execute; 65 | if Assigned(fOnAfterProc) then 66 | fOnAfterProc(Self) 67 | end; 68 | 69 | function TCommandAction.WithInjections(const Injections: array of const) 70 | : TCommandAction; 71 | begin 72 | System.Assert(fCommand <> nil, 73 | 'Command have to be created and provided before injection'); 74 | fCommand.WithInjections(Injections); 75 | Result := Self; 76 | end; 77 | 78 | procedure TCommandAction.OnExecuteEvent(Sender: TObject); 79 | begin 80 | System.Assert(fCommand <> nil); 81 | if DisableDuringExecution then 82 | begin 83 | try 84 | Self.Enabled := False; 85 | DoExecuteAction(Sender); 86 | finally 87 | Self.Enabled := True; 88 | end; 89 | end 90 | else 91 | DoExecuteAction(Sender); 92 | end; 93 | 94 | procedure TCommandAction.OnUpdateEvent(Sender: TObject); 95 | begin 96 | if Assigned(fOnUpdateProc) then 97 | fOnUpdateProc(Self); 98 | end; 99 | 100 | function TCommandAction.WithCaption(const aCaption: string): TCommandAction; 101 | begin 102 | Caption := aCaption; 103 | Result := Self; 104 | end; 105 | 106 | function TCommandAction.WithCommand(aCommand: TCommand): TCommandAction; 107 | begin 108 | fCommand := aCommand; 109 | Result := Self; 110 | end; 111 | 112 | function TCommandAction.WitEventAfterExecution 113 | (aAfterProc: TProc): TCommandAction; 114 | begin 115 | fOnAfterProc := aAfterProc; 116 | Result := Self; 117 | end; 118 | 119 | function TCommandAction.WithEventOnUpdate(AUpdateProc: TProc) 120 | : TCommandAction; 121 | begin 122 | fOnUpdateProc := AUpdateProc; 123 | Self.OnUpdate := OnUpdateEvent; 124 | Result := Self; 125 | end; 126 | 127 | function TCommandAction.WithShortCut(aShorcut: TShortCut): TCommandAction; 128 | begin 129 | // ------------------------------------------------------------------ 130 | // Too support shortcuts action requires TActionList assigned 131 | // --- 132 | // this code is constructing a new ActionList only once when a new 133 | // shortcut is assigned to this action (deleyed construction) 134 | // --- 135 | // Memory of fActionList is not released by Free but managed by Owner 136 | // ------------------------------------------------------------------ 137 | if (Owner <> nil) and (Self.ActionList = nil) and (fActionList = nil) then 138 | begin 139 | fActionList := TActionList.Create(Owner); 140 | Self.ActionList := fActionList; 141 | end; 142 | Self.ShortCut := aShorcut; 143 | Result := Self; 144 | end; 145 | 146 | end. 147 | -------------------------------------------------------------------------------- /tests/TestCommandPattern.dpr: -------------------------------------------------------------------------------- 1 | program TestCommandPattern; 2 | 3 | {$IFNDEF TESTINSIGHT} 4 | {$APPTYPE CONSOLE} 5 | {$ENDIF}{$STRONGLINKTYPES ON} 6 | uses 7 | SysUtils, 8 | {$IFDEF TESTINSIGHT} 9 | TestInsight.DUnitX, 10 | {$ENDIF } 11 | DUnitX.Loggers.Console, 12 | DUnitX.Loggers.Xml.NUnit, 13 | DUnitX.TestFramework, 14 | Pattern.Command in '..\src\Pattern.Command.pas', 15 | Tests.TPropertyList in 'Tests.TPropertyList.pas', 16 | Tests.TCommand in 'Tests.TCommand.pas', 17 | Tests.Injection in 'Tests.Injection.pas', 18 | Pattern.CommandAction in '..\src\Pattern.CommandAction.pas', 19 | Tests.TCommandAction in 'Tests.TCommandAction.pas'; 20 | 21 | var 22 | runner : ITestRunner; 23 | results : IRunResults; 24 | logger : ITestLogger; 25 | nunitLogger : ITestLogger; 26 | begin 27 | {$IFDEF TESTINSIGHT} 28 | TestInsight.DUnitX.RunRegisteredTests; 29 | exit; 30 | {$ENDIF} 31 | try 32 | //Check command line options, will exit if invalid 33 | TDUnitX.CheckCommandLine; 34 | //Create the test runner 35 | runner := TDUnitX.CreateRunner; 36 | //Tell the runner to use RTTI to find Fixtures 37 | runner.UseRTTI := True; 38 | //tell the runner how we will log things 39 | //Log to the console window 40 | logger := TDUnitXConsoleLogger.Create(true); 41 | runner.AddLogger(logger); 42 | //Generate an NUnit compatible XML File 43 | nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile); 44 | runner.AddLogger(nunitLogger); 45 | runner.FailsOnNoAsserts := False; //When true, Assertions must be made during tests; 46 | 47 | //Run tests 48 | results := runner.Execute; 49 | if not results.AllPassed then 50 | System.ExitCode := EXIT_ERRORS; 51 | 52 | {$IFNDEF CI} 53 | //We don't want this happening when running under CI. 54 | if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then 55 | begin 56 | System.Write('Done.. press key to quit.'); 57 | System.Readln; 58 | end; 59 | {$ENDIF} 60 | except 61 | on E: Exception do 62 | System.Writeln(E.ClassName, ': ', E.Message); 63 | end; 64 | end. 65 | -------------------------------------------------------------------------------- /tests/Tests.Injection.pas: -------------------------------------------------------------------------------- 1 | unit Tests.Injection; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, 7 | System.Classes, System.SysUtils, 8 | Pattern.Command; 9 | 10 | {$M+} 11 | 12 | type 13 | 14 | [TestFixture] 15 | TestInjection_SingleParam = class(TObject) 16 | private 17 | FInteger101: integer; 18 | FStrings: TStringList; 19 | FOwnerComponent: TComponent; 20 | public 21 | [Setup] 22 | procedure Setup; 23 | [TearDown] 24 | procedure TearDown; 25 | published 26 | procedure ParameterStringList; 27 | procedure ParameterStringList_ToStringsProperty; 28 | procedure ParameterStringList_ToObjectProperty; 29 | procedure ParameterInteger; 30 | procedure ParameterBoolean; 31 | procedure ParameterDouble; 32 | procedure ParameterDateTime; 33 | procedure ParameterWord; 34 | procedure ParameterValueBoolean; 35 | procedure ParameterValueFloat; 36 | procedure ParameterValueInt; 37 | procedure ParameterInterface; 38 | procedure UnsupportedProperty_Exception; 39 | end; 40 | 41 | [TestFixture] 42 | TestInjection_MultipleParams = class(TObject) 43 | private 44 | FStrings1: TStringList; 45 | FStrings2: TStringList; 46 | FOwnerComponent: TComponent; 47 | public 48 | [Setup] 49 | procedure Setup; 50 | [TearDown] 51 | procedure TearDown; 52 | published 53 | procedure TwoStringLists; 54 | procedure InjectAll; 55 | end; 56 | 57 | implementation 58 | 59 | // ------------------------------------------------------------------------ 60 | // sample interfaces injected into components 61 | // ------------------------------------------------------------------------ 62 | 63 | type 64 | ISample1 = interface (IInvokable) 65 | ['{AB5F0562-A0E6-4E93-910C-DD592FF02ADE}'] 66 | function GetValue: integer; 67 | end; 68 | 69 | ISample2 = interface (IInvokable) 70 | ['{D0562FD6-5393-4CA8-8285-46308C21B532}'] 71 | function GetValue(aValue: integer): integer; 72 | end; 73 | 74 | TSampleClass = class (TInterfacedObject,ISample1) 75 | function GetValue: integer; 76 | end; 77 | 78 | TAnotherClass = class (TInterfacedObject,ISample2) 79 | function GetValue(aValue: integer): integer; 80 | end; 81 | 82 | function TSampleClass.GetValue: integer; 83 | begin 84 | Exit(0); 85 | end; 86 | 87 | function TAnotherClass.GetValue(aValue: integer): integer; 88 | begin 89 | Result := aValue; 90 | end; 91 | 92 | 93 | 94 | // ------------------------------------------------------------------------ 95 | // sample components used in the tests 96 | // ------------------------------------------------------------------------ 97 | 98 | type 99 | TStringsComponent = class(TComponent) 100 | strict private 101 | FStringList: TStringList; 102 | FStrings: TStrings; 103 | FSameObject: TObject; 104 | published 105 | property StringList: TStringList read FStringList write FStringList; 106 | property Strings: TStrings read FStrings write FStrings; 107 | property SameObject: TObject read FSameObject write FSameObject; 108 | end; 109 | 110 | TIntegerComponent = class(TComponent) 111 | strict private 112 | FNumber: integer; 113 | published 114 | property Number: integer read FNumber write FNumber; 115 | end; 116 | 117 | TSimpleComponent = class(TComponent) 118 | strict private 119 | FNumber: integer; 120 | FIsTrue: boolean; 121 | FFloatNumber: Double; 122 | FStartDate: TDateTime; 123 | FSample1: ISample1; 124 | published 125 | property Number: integer read FNumber write FNumber; 126 | property IsTrue: boolean read FIsTrue write FIsTrue; 127 | property FloatNumber: Double read FFloatNumber write FFloatNumber; 128 | property StartDate: TDateTime read FStartDate write FStartDate; 129 | property Sample1: ISample1 read FSample1 write FSample1; 130 | end; 131 | 132 | // ------------------------------------------------------------------------ 133 | // tests: inject single parameter 134 | // ------------------------------------------------------------------------ 135 | 136 | procedure TestInjection_SingleParam.Setup; 137 | begin 138 | FOwnerComponent := TComponent.Create(nil); // used as Owner for TCommand-s 139 | FStrings := TStringList.Create(); 140 | FInteger101 := 101; 141 | end; 142 | 143 | procedure TestInjection_SingleParam.TearDown; 144 | begin 145 | FOwnerComponent.Free; 146 | FreeAndNil(FStrings); 147 | end; 148 | 149 | procedure TestInjection_SingleParam.ParameterStringList; 150 | var 151 | StringsComponent: TStringsComponent; 152 | begin 153 | StringsComponent := TStringsComponent.Create(FOwnerComponent); 154 | TComponentInjector.InjectProperties(StringsComponent, [FStrings]); 155 | Assert.IsNotNull(StringsComponent.StringList); 156 | Assert.AreSame(FStrings, StringsComponent.StringList); 157 | end; 158 | 159 | procedure TestInjection_SingleParam.ParameterStringList_ToStringsProperty; 160 | var 161 | StringsComponent: TStringsComponent; 162 | FStrings2: TStringList; 163 | begin 164 | StringsComponent := TStringsComponent.Create(FOwnerComponent); 165 | FStrings2 := TStringList.Create; 166 | try 167 | TComponentInjector.InjectProperties(StringsComponent, [FStrings,FStrings2]); 168 | Assert.IsNotNull(StringsComponent.Strings); 169 | Assert.AreSame(FStrings2, StringsComponent.Strings); 170 | finally 171 | FStrings2.Free; 172 | end; 173 | end; 174 | 175 | procedure TestInjection_SingleParam.ParameterStringList_ToObjectProperty; 176 | var 177 | StringsComponent: TStringsComponent; 178 | FStrings2: TStringList; 179 | FStrings3: TStringList; 180 | begin 181 | StringsComponent := TStringsComponent.Create(FOwnerComponent); 182 | FStrings2 := TStringList.Create; 183 | FStrings3 := TStringList.Create; 184 | try 185 | TComponentInjector.InjectProperties(StringsComponent, [FStrings,FStrings2,FStrings3]); 186 | Assert.IsNotNull(StringsComponent.SameObject); 187 | Assert.AreSame(FStrings3, StringsComponent.SameObject); 188 | finally 189 | FStrings2.Free; 190 | FStrings3.Free; 191 | end; 192 | end; 193 | 194 | procedure TestInjection_SingleParam.ParameterInteger; 195 | var 196 | IntegerComponent: TIntegerComponent; 197 | begin 198 | IntegerComponent := TIntegerComponent.Create(FOwnerComponent); 199 | TComponentInjector.InjectProperties(IntegerComponent, [FInteger101]); 200 | Assert.AreEqual(FInteger101, IntegerComponent.Number); 201 | end; 202 | 203 | procedure TestInjection_SingleParam.ParameterBoolean; 204 | var 205 | SimpleComponent: TSimpleComponent; 206 | b: boolean; 207 | begin 208 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 209 | b := True; 210 | TComponentInjector.InjectProperties(SimpleComponent, [b]); 211 | Assert.AreEqual(b, SimpleComponent.IsTrue); 212 | end; 213 | 214 | procedure TestInjection_SingleParam.ParameterDouble; 215 | var 216 | SimpleComponent: TSimpleComponent; 217 | val: Double; 218 | begin 219 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 220 | val := Pi; 221 | TComponentInjector.InjectProperties(SimpleComponent, [val]); 222 | Assert.AreEqual(val, SimpleComponent.FloatNumber); 223 | end; 224 | 225 | procedure TestInjection_SingleParam.ParameterDateTime; 226 | var 227 | SimpleComponent: TSimpleComponent; 228 | FloatVal: Single; 229 | Date: TDateTime; 230 | begin 231 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 232 | FloatVal := 2.1; 233 | Date := EncodeDate(2019, 02, 01) + EncodeTime(18, 50, 0, 0); 234 | TComponentInjector.InjectProperties(SimpleComponent, [FloatVal, Date]); 235 | Assert.AreEqual(Double(FloatVal), SimpleComponent.FloatNumber); 236 | Assert.AreEqual(Date, SimpleComponent.StartDate); 237 | end; 238 | 239 | procedure TestInjection_SingleParam.ParameterWord; 240 | var 241 | SimpleComponent: TSimpleComponent; 242 | Value: word; 243 | begin 244 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 245 | Value := 999; 246 | TComponentInjector.InjectProperties(SimpleComponent, [Value]); 247 | Assert.AreEqual(999, SimpleComponent.Number); 248 | end; 249 | 250 | procedure TestInjection_SingleParam.ParameterValueBoolean; 251 | var 252 | SimpleComponent: TSimpleComponent; 253 | begin 254 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 255 | TComponentInjector.InjectProperties(SimpleComponent, [True]); 256 | Assert.AreEqual(True, SimpleComponent.IsTrue); 257 | end; 258 | 259 | procedure TestInjection_SingleParam.ParameterValueInt; 260 | var 261 | SimpleComponent: TSimpleComponent; 262 | begin 263 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 264 | TComponentInjector.InjectProperties(SimpleComponent, [55]); 265 | Assert.AreEqual(55, SimpleComponent.Number); 266 | end; 267 | 268 | procedure TestInjection_SingleParam.ParameterValueFloat; 269 | var 270 | SimpleComponent: TSimpleComponent; 271 | begin 272 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 273 | TComponentInjector.InjectProperties(SimpleComponent, [99.99]); 274 | Assert.AreEqual(99.99, Extended(SimpleComponent.FloatNumber)); 275 | end; 276 | 277 | procedure TestInjection_SingleParam.ParameterInterface; 278 | var 279 | SimpleComponent: TSimpleComponent; 280 | sample1: ISample1; 281 | begin 282 | SimpleComponent := TSimpleComponent.Create(FOwnerComponent); 283 | sample1 := TSampleClass.Create; 284 | TComponentInjector.InjectProperties(SimpleComponent, [sample1]); 285 | Assert.IsTrue(SimpleComponent.Sample1 = sample1); 286 | end; 287 | 288 | procedure TestInjection_SingleParam.UnsupportedProperty_Exception; 289 | type 290 | TMyRec = record 291 | a: integer; 292 | b: boolean; 293 | end; 294 | var 295 | aRec1: TMyRec; 296 | StringsComponent: TStringsComponent; 297 | begin 298 | StringsComponent := TStringsComponent.Create(FOwnerComponent); 299 | Assert.WillRaise( 300 | procedure 301 | begin 302 | TComponentInjector.InjectProperties(StringsComponent, [@aRec1]); 303 | end); 304 | end; 305 | 306 | // ------------------------------------------------------------------------ 307 | // Test_MoreInjections - tests component with many injected properties 308 | // * 2x TStringList, 1x TComponent 309 | // ------------------------------------------------------------------------ 310 | 311 | type 312 | TManyPropComponent = class(TComponent) 313 | strict private 314 | FCount: integer; 315 | FEvenLines: TStringList; 316 | FOddLines: TStringList; 317 | FComponent: TComponent; 318 | FStream: TStream; 319 | FSample1: ISample1; 320 | FSample2: ISample2; 321 | public 322 | property Count: integer read FCount write FCount; 323 | property Stream: TStream read FStream write FStream; 324 | published 325 | property OddLines: TStringList read FOddLines write FOddLines; 326 | property Component: TComponent read FComponent write FComponent; 327 | property Sample1: ISample1 read FSample1 write FSample1; 328 | property EvenLines: TStringList read FEvenLines write FEvenLines; 329 | property Sample2: ISample2 read FSample2 write FSample2; 330 | end; 331 | 332 | procedure TestInjection_MultipleParams.Setup; 333 | begin 334 | FStrings1 := TStringList.Create; 335 | FStrings2 := TStringList.Create; 336 | FOwnerComponent := TComponent.Create(nil); 337 | end; 338 | 339 | procedure TestInjection_MultipleParams.TearDown; 340 | begin 341 | FreeAndNil(FStrings1); 342 | FreeAndNil(FStrings2); 343 | FreeAndNil(FOwnerComponent); 344 | end; 345 | 346 | procedure TestInjection_MultipleParams.TwoStringLists; 347 | var 348 | ManyPropComponent: TManyPropComponent; 349 | begin 350 | // -- 351 | ManyPropComponent := TManyPropComponent.Create(FOwnerComponent); 352 | // -- 353 | TComponentInjector.InjectProperties(ManyPropComponent, 354 | [FStrings1, FStrings2]); 355 | // -- 356 | Assert.AreSame(FStrings1, ManyPropComponent.OddLines); 357 | Assert.AreSame(FStrings2, ManyPropComponent.EvenLines); 358 | end; 359 | 360 | procedure TestInjection_MultipleParams.InjectAll; 361 | var 362 | ManyPropComponent: TManyPropComponent; 363 | sample1: ISample1; 364 | sample2: ISample2; 365 | begin 366 | // Arrange: 367 | ManyPropComponent := TManyPropComponent.Create(FOwnerComponent); 368 | sample1 := TSampleClass.Create; 369 | sample2 := TAnotherClass.Create; 370 | // Act: 371 | TComponentInjector.InjectProperties(ManyPropComponent, 372 | [FStrings1, FStrings2, FOwnerComponent, sample2, sample1]); 373 | // Assert 374 | Assert.AreSame(FStrings1, ManyPropComponent.OddLines); 375 | Assert.AreSame(FStrings2, ManyPropComponent.EvenLines); 376 | Assert.AreSame(FOwnerComponent, ManyPropComponent.Component); 377 | Assert.AreSame(sample1, ManyPropComponent.Sample1); 378 | Assert.AreSame(sample2, ManyPropComponent.Sample2); 379 | Assert.AreEqual(99, ManyPropComponent.Sample2.GetValue(99)); 380 | end; 381 | 382 | // ------------------------------------------------------------------------ 383 | // ------------------------------------------------------------------------ 384 | 385 | initialization 386 | 387 | TDUnitX.RegisterTestFixture(TestInjection_SingleParam); 388 | TDUnitX.RegisterTestFixture(TestInjection_MultipleParams); 389 | 390 | end. 391 | -------------------------------------------------------------------------------- /tests/Tests.TCommand.pas: -------------------------------------------------------------------------------- 1 | unit Tests.TCommand; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, 7 | System.Classes, 8 | System.SysUtils, 9 | System.Generics.Collections, 10 | Pattern.Command; 11 | 12 | {$M+} 13 | 14 | type 15 | 16 | [TestFixture] 17 | TestCommnd_Basic = class(TObject) 18 | strict private 19 | FOwnerComponent: TComponent; 20 | public 21 | [Setup] 22 | procedure Setup; 23 | [TearDown] 24 | procedure TearDown; 25 | published 26 | procedure Test_ExecuteCommandAndCheckActive; 27 | procedure Test_NotExecuteCommand_CounterZero; 28 | procedure Test_ExecuteCommand2x; 29 | end; 30 | 31 | [TestFixture] 32 | TestCommnd_StrigsCommand = class(TObject) 33 | private 34 | FOwnerComponent: TComponent; 35 | FStrings: TStringList; 36 | public 37 | [Setup] 38 | procedure Setup; 39 | [TearDown] 40 | procedure TearDown; 41 | published 42 | procedure NoGuardAssert_WithProperInjection; 43 | procedure ChangeStringList_AfterExecute; 44 | procedure GuardException_NoInjection; 45 | end; 46 | 47 | [TestFixture] 48 | TestCommnd_Advanced = class(TObject) 49 | private 50 | FComponent: TComponent; 51 | FStringPrime: TStringList; 52 | FStringNonPrime: TStringList; 53 | FMemStream: TMemoryStream; 54 | FList: TList; 55 | public 56 | [Setup] 57 | procedure Setup; 58 | [TearDown] 59 | procedure TearDown; 60 | published 61 | procedure Execute_TestPrimes; 62 | procedure Execute_TestNonPrimes; 63 | procedure Execute_TestStream; 64 | procedure Execute_ProcessOnlyPrimes; 65 | end; 66 | 67 | implementation 68 | 69 | // ------------------------------------------------------------------------ 70 | // Test Basic Command - TCommandA 71 | // ------------------------------------------------------------------------ 72 | 73 | type 74 | TCommandA = class(TCommand) 75 | strict private 76 | FActive: boolean; 77 | FCount: Integer; 78 | strict protected 79 | procedure DoExecute; override; 80 | public 81 | property Active: boolean read FActive write FActive; 82 | property Count: Integer read FCount write FCount; 83 | end; 84 | 85 | procedure TCommandA.DoExecute; 86 | begin 87 | Active := True; 88 | Count := Count + 1; 89 | end; 90 | 91 | // ------------------------------------------------------------------------ 92 | 93 | procedure TestCommnd_Basic.Setup; 94 | begin 95 | FOwnerComponent := TComponent.Create(nil); 96 | end; 97 | 98 | procedure TestCommnd_Basic.TearDown; 99 | begin 100 | FOwnerComponent.Free; 101 | end; 102 | 103 | procedure TestCommnd_Basic.Test_ExecuteCommandAndCheckActive; 104 | var 105 | CommandA: TCommandA; 106 | begin 107 | CommandA := TCommandA.Create(FOwnerComponent); 108 | CommandA.Execute; 109 | Assert.IsTrue(CommandA.Active, 'TCommanndA.Active property expected True'); 110 | Assert.AreEqual(1, CommandA.Count); 111 | end; 112 | 113 | procedure TestCommnd_Basic.Test_NotExecuteCommand_CounterZero; 114 | var 115 | CommandA: TCommandA; 116 | begin 117 | CommandA := TCommandA.Create(FOwnerComponent); 118 | Assert.AreEqual(0, CommandA.Count); 119 | end; 120 | 121 | procedure TestCommnd_Basic.Test_ExecuteCommand2x; 122 | var 123 | CommandA: TCommandA; 124 | begin 125 | CommandA := TCommandA.Create(FOwnerComponent); 126 | CommandA.Execute; 127 | CommandA.Execute; 128 | Assert.AreEqual(2, CommandA.Count); 129 | end; 130 | 131 | 132 | // ------------------------------------------------------------------------ 133 | // TestCommndFactory_StrigListCommand 134 | // ------------------------------------------------------------------------ 135 | 136 | type 137 | TCommandStringList = class(TCommand) 138 | strict private 139 | FCount: Integer; 140 | FLines: TStringList; 141 | strict protected 142 | procedure DoGuard; override; 143 | procedure DoExecute; override; 144 | public 145 | property Count: Integer read FCount write FCount; 146 | published 147 | property Lines: TStringList read FLines write FLines; 148 | end; 149 | 150 | {$REGION 'implementation TCommandStringList'} 151 | 152 | procedure TCommandStringList.DoGuard; 153 | begin 154 | System.Assert(Lines <> nil); 155 | end; 156 | 157 | procedure TCommandStringList.DoExecute; 158 | begin 159 | inherited; 160 | Count := Count + 1; 161 | Lines.Add(Format('%.3d', [Count])); 162 | end; 163 | 164 | {$ENDREGION} 165 | 166 | procedure TestCommnd_StrigsCommand.Setup; 167 | begin 168 | FOwnerComponent := TComponent.Create(nil); 169 | FStrings := TStringList.Create; 170 | end; 171 | 172 | procedure TestCommnd_StrigsCommand.TearDown; 173 | begin 174 | FStrings.Free; 175 | FOwnerComponent.Free; 176 | end; 177 | 178 | procedure TestCommnd_StrigsCommand.NoGuardAssert_WithProperInjection; 179 | begin 180 | TCommand.AdhocExecute([FStrings]); 181 | // Check if there was any exception above 182 | Assert.Pass; 183 | end; 184 | 185 | procedure TestCommnd_StrigsCommand.ChangeStringList_AfterExecute; 186 | var 187 | CommandStrings: TCommandStringList; 188 | begin 189 | CommandStrings := TCommandStringList.Create(FOwnerComponent); 190 | CommandStrings.WithInjections([FStrings]); 191 | CommandStrings.Execute; 192 | CommandStrings.Execute; 193 | FStrings.Delete(0); 194 | Assert.AreEqual(1, FStrings.Count); 195 | Assert.AreEqual(1, CommandStrings.Lines.Count); 196 | end; 197 | 198 | procedure TestCommnd_StrigsCommand.GuardException_NoInjection; 199 | begin 200 | Assert.WillRaiseDescendant( 201 | procedure 202 | begin 203 | TCommand.AdhocExecute([]); 204 | end, EAssertionFailed); 205 | end; 206 | 207 | // ------------------------------------------------------------------------ 208 | // TestCommndFactory_StrigListCommand 209 | // ------------------------------------------------------------------------ 210 | 211 | type 212 | TAdvancedCommand = class(TCommand) 213 | private 214 | FCount: Integer; 215 | FNonPrimeLines: TStrings; 216 | FPrimeLines: TStrings; 217 | FComponent: TComponent; 218 | FStream: TStream; 219 | FListInt: TList; 220 | FProcessNonPrimeNumbers: boolean; 221 | procedure WriteIntegerToStream(aValue: Integer); 222 | class function isPrime(num: Integer): boolean; 223 | strict protected 224 | procedure DoGuard; override; 225 | procedure DoExecute; override; 226 | public 227 | constructor Create(AOwner: TComponent); override; 228 | property Count: Integer read FCount write FCount; 229 | published 230 | property Stream: TStream read FStream write FStream; 231 | property PrimeLines: TStrings read FPrimeLines write FPrimeLines; 232 | property Component: TComponent read FComponent write FComponent; 233 | property ProcessNonPrimeNumbers: boolean read FProcessNonPrimeNumbers 234 | write FProcessNonPrimeNumbers; 235 | property NonPrimeLines: TStrings read FNonPrimeLines write FNonPrimeLines; 236 | property ListInt: TList read FListInt write FListInt; 237 | end; 238 | 239 | {$REGION 'implementation TAdvancedCommand'} 240 | 241 | procedure TAdvancedCommand.DoGuard; 242 | begin 243 | System.Assert(Stream <> nil); 244 | System.Assert(PrimeLines <> nil); 245 | System.Assert(Component <> nil); 246 | System.Assert(NonPrimeLines <> nil); 247 | System.Assert(ListInt <> nil); 248 | end; 249 | 250 | class function TAdvancedCommand.isPrime(num: Integer): boolean; 251 | var 252 | M: Integer; 253 | begin 254 | if num <= 1 then 255 | exit(false); 256 | for M := 2 to (num div 2) do 257 | if num mod M = 0 then 258 | exit(false); 259 | exit(True); 260 | end; 261 | 262 | procedure TAdvancedCommand.WriteIntegerToStream(aValue: Integer); 263 | begin 264 | Stream.Write(aValue, SizeOf(aValue)); 265 | end; 266 | 267 | constructor TAdvancedCommand.Create(AOwner: TComponent); 268 | begin 269 | inherited; 270 | ProcessNonPrimeNumbers := True; 271 | end; 272 | 273 | procedure TAdvancedCommand.DoExecute; 274 | var 275 | i: Integer; 276 | begin 277 | inherited; 278 | PrimeLines.Clear; 279 | NonPrimeLines.Clear; 280 | WriteIntegerToStream(ListInt.Count); 281 | for i := 0 to ListInt.Count - 1 do 282 | begin 283 | WriteIntegerToStream(ListInt[i]); 284 | if isPrime(ListInt[i]) then 285 | PrimeLines.Add(Format('%d is prime', [ListInt[i]])) 286 | else if ProcessNonPrimeNumbers then 287 | NonPrimeLines.Add(ListInt[i].ToString); 288 | end; 289 | with Component do 290 | begin 291 | Name := 'A' + Component.Name; 292 | Tag := ListInt.Count; 293 | end; 294 | Count := ListInt.Count; 295 | end; 296 | 297 | {$ENDREGION} 298 | 299 | procedure TestCommnd_Advanced.Setup; 300 | begin 301 | FComponent := TComponent.Create(nil); 302 | FStringPrime := TStringList.Create; 303 | FStringNonPrime := TStringList.Create; 304 | FMemStream := TMemoryStream.Create; 305 | FList := TList.Create; 306 | end; 307 | 308 | procedure TestCommnd_Advanced.TearDown; 309 | begin 310 | FStringPrime.Free; 311 | FStringNonPrime.Free; 312 | FMemStream.Free; 313 | FList.Free; 314 | FComponent.Free; 315 | end; 316 | 317 | procedure TestCommnd_Advanced.Execute_TestPrimes; 318 | begin 319 | with FList do 320 | begin 321 | Clear; 322 | AddRange([10, 13, 20, 17, 100, 101, 105]); 323 | end; 324 | TCommand.AdhocExecute([FComponent, FStringPrime, 325 | FStringNonPrime, FMemStream, FList]); 326 | Assert.AreEqual(3, FStringPrime.Count); 327 | Assert.AreEqual('13 is prime', FStringPrime[0]); 328 | Assert.AreEqual('17 is prime', FStringPrime[1]); 329 | Assert.AreEqual('101 is prime', FStringPrime[2]); 330 | end; 331 | 332 | procedure TestCommnd_Advanced.Execute_TestNonPrimes; 333 | begin 334 | with FList do 335 | begin 336 | Clear; 337 | AddRange([10, 13, 20, 17, 100, 101, 105]); 338 | end; 339 | TCommand.AdhocExecute([FComponent, FStringPrime, 340 | FStringNonPrime, FMemStream, FList]); 341 | Assert.AreEqual(4, FStringNonPrime.Count); 342 | Assert.AreEqual('10', FStringNonPrime[0]); 343 | Assert.AreEqual('20', FStringNonPrime[1]); 344 | Assert.AreEqual('100', FStringNonPrime[2]); 345 | Assert.AreEqual('105', FStringNonPrime[3]); 346 | end; 347 | 348 | procedure TestCommnd_Advanced.Execute_TestStream; 349 | begin 350 | with FList do 351 | begin 352 | Clear; 353 | AddRange([10, 13, 20, 17, 100, 101, 105]); 354 | end; 355 | TCommand.AdhocExecute([FComponent, FStringPrime, 356 | FStringNonPrime, FMemStream, FList]); 357 | Assert.AreEqual(32, Integer(FMemStream.Size)); 358 | end; 359 | 360 | procedure TestCommnd_Advanced.Execute_ProcessOnlyPrimes; 361 | begin 362 | with FList do 363 | begin 364 | Clear; 365 | AddRange([10, 13, 20, 17, 100, 101, 105]); 366 | end; 367 | TCommand.AdhocExecute([FComponent, FStringPrime, 368 | FStringNonPrime, FMemStream, FList, false]); 369 | Assert.AreEqual(3, FStringPrime.Count); 370 | Assert.AreEqual(0, FStringNonPrime.Count); 371 | end; 372 | 373 | // ------------------------------------------------------------------------ 374 | // ------------------------------------------------------------------------ 375 | 376 | initialization 377 | 378 | end. 379 | -------------------------------------------------------------------------------- /tests/Tests.TCommandAction.pas: -------------------------------------------------------------------------------- 1 | unit Tests.TCommandAction; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, 7 | System.Classes, 8 | System.SysUtils, 9 | Pattern.Command, 10 | Pattern.CommandAction, 11 | Vcl.StdCtrls, 12 | Vcl.Forms; 13 | 14 | {$M+} 15 | 16 | type 17 | 18 | [TestFixture] 19 | TestCommandAction = class(TObject) 20 | private 21 | fOwnerComponent: TComponent; 22 | fStringList: TStringList; 23 | fAction: TCommandAction; 24 | public 25 | [Setup] 26 | procedure Setup; 27 | [TearDown] 28 | procedure TearDown; 29 | published 30 | procedure ActionWithCaption; 31 | procedure ActionWithCommand; 32 | procedure ActionWithShotcut; 33 | procedure ActionWitnEventOnUpdate; 34 | procedure ActionWitEventAfterExecution; 35 | procedure ActionWithInjections; 36 | procedure ActionCaption_WillChangeButtonCaption; 37 | end; 38 | 39 | implementation 40 | 41 | uses 42 | Vcl.Menus; 43 | 44 | type 45 | TTestCommand = class(TCommand) 46 | const 47 | DefaultRange = 10; 48 | private 49 | FRandomNumbers: TStringList; 50 | FRange: integer; 51 | protected 52 | procedure DoGuard; override; 53 | procedure DoExecute; override; 54 | public 55 | constructor Create(AOwner: TComponent); override; 56 | published 57 | property Range: integer read FRange write FRange; 58 | property RandomNumbers: TStringList read FRandomNumbers 59 | write FRandomNumbers; 60 | end; 61 | 62 | {$REGION 'implementation TTestCommand -----------------'} 63 | 64 | constructor TTestCommand.Create(AOwner: TComponent); 65 | begin 66 | inherited; 67 | Randomize; 68 | Range := DefaultRange; 69 | end; 70 | 71 | procedure TTestCommand.DoGuard; 72 | begin 73 | System.Assert(RandomNumbers <> nil); 74 | end; 75 | 76 | procedure TTestCommand.DoExecute; 77 | begin 78 | RandomNumbers.Add((1 + Random(Range)).ToString); 79 | end; 80 | 81 | {$ENDREGION --------------------------------------------} 82 | 83 | procedure TestCommandAction.Setup; 84 | begin 85 | fOwnerComponent := TComponent.Create(nil); 86 | fAction := TCommandAction.Create(fOwnerComponent); 87 | fStringList := TStringList.Create; 88 | end; 89 | 90 | procedure TestCommandAction.TearDown; 91 | begin 92 | fOwnerComponent.Free; 93 | fStringList.Free; 94 | end; 95 | 96 | procedure TestCommandAction.ActionWithCaption; 97 | begin 98 | // Arrage & Act: 99 | fAction.WithCaption('Execute test command'); 100 | // Assert 101 | Assert.AreEqual('Execute test command', fAction.Caption); 102 | end; 103 | 104 | procedure TestCommandAction.ActionWithCommand; 105 | var 106 | cmd: TTestCommand; 107 | begin 108 | // Arrage: 109 | cmd := TTestCommand.Create(fOwnerComponent); 110 | cmd.WithInjections([fStringList]); 111 | // Act: 112 | fAction.WithCommand(cmd); 113 | fAction.Execute; 114 | fAction.Execute; 115 | // Assert 116 | Assert.AreEqual(2, cmd.RandomNumbers.Count); 117 | end; 118 | 119 | procedure TestCommandAction.ActionWithShotcut; 120 | var 121 | aShortCut: TShortCut; 122 | begin 123 | aShortCut := TextToShortCut('CTRL+K'); 124 | fAction.WithShortCut(aShortCut); 125 | Assert.AreEqual(ShortCutToText(aShortCut), ShortCutToText(fAction.ShortCut)); 126 | end; 127 | 128 | procedure TestCommandAction.ActionWitnEventOnUpdate; 129 | begin 130 | fAction.WithEventOnUpdate( 131 | procedure(act: TCommandAction) 132 | begin 133 | act.Tag := act.Tag + 1; 134 | end); 135 | fAction.Update; 136 | Assert.AreEqual(1, fAction.Tag); 137 | end; 138 | 139 | procedure TestCommandAction.ActionWitEventAfterExecution; 140 | begin 141 | fAction.Tag := -1; 142 | fAction.Command := TTestCommand.Create(fOwnerComponent); 143 | fAction.Command.WithInjections([fStringList]); 144 | fAction.WitEventAfterExecution( 145 | procedure(act: TCommandAction) 146 | begin 147 | act.Tag := 99; 148 | end); 149 | 150 | fAction.Execute; 151 | 152 | Assert.AreEqual(99, fAction.Tag); 153 | end; 154 | 155 | procedure TestCommandAction.ActionWithInjections; 156 | var 157 | actualNumbers: integer; 158 | begin 159 | fAction // --+ 160 | .WithCommand(TTestCommand.Create(fOwnerComponent)) //--+ 161 | .WithInjections([fStringList]); 162 | fAction.Execute; 163 | fAction.Execute; 164 | fAction.Execute; 165 | actualNumbers := (fAction.Command as TTestCommand).RandomNumbers.Count; 166 | Assert.AreEqual(3, actualNumbers); 167 | end; 168 | 169 | procedure TestCommandAction.ActionCaption_WillChangeButtonCaption; 170 | var 171 | aButton: TButton; 172 | begin 173 | aButton := TButton.Create(fOwnerComponent); 174 | fAction.WithCaption('Sample caption'); 175 | aButton.Action := fAction; 176 | Assert.AreEqual('Sample caption', aButton.Caption); 177 | end; 178 | 179 | end. 180 | -------------------------------------------------------------------------------- /tests/Tests.TPropertyList.pas: -------------------------------------------------------------------------------- 1 | unit Tests.TPropertyList; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, 7 | System.Classes, 8 | System.SysUtils, 9 | System.TypInfo, 10 | Pattern.Command; 11 | 12 | {$M+} 13 | 14 | type 15 | 16 | [TestFixture] 17 | TestPropertyList = class(TObject) 18 | private 19 | fComponent: TComponent; 20 | procedure AssertMetadataItem(const expectedPropertyName 21 | : string; const expectedClassName: string; expectedKind: TTypeKind; 22 | const metadataItem: TPropertyInfo); 23 | function AssertMetadataSize(const expectedSize: integer; 24 | const metadataArray: TPropertyArray): boolean; 25 | public 26 | [Setup] 27 | procedure Setup; 28 | [TearDown] 29 | procedure TearDown; 30 | published 31 | procedure ComponentWithoutProperties; 32 | procedure OneProperty; 33 | procedure ManyProperties_StrListTStringList; 34 | procedure ManyProperties_IsDoneBoolean; 35 | procedure ManyProperties_TCollection; 36 | procedure ManyProperties_ValueIntInteger; 37 | procedure ManyProperties_AnyDateTDateTime; 38 | procedure ManyProperties_MemStreamTMemoryStream; 39 | procedure ManyProperties_TextString; 40 | end; 41 | 42 | implementation 43 | 44 | // ---------------------------------------------------------------------- 45 | // Tested samples (components) 46 | // ---------------------------------------------------------------------- 47 | 48 | type 49 | TComponentWithTList = class(TComponent) 50 | private 51 | FList: TList; 52 | published 53 | property List: TList read FList write FList; 54 | end; 55 | 56 | TComponentManyProps = class(TComponent) 57 | private 58 | FStrList: TStringList; 59 | FIsDone: boolean; 60 | FCollection: TCollection; 61 | FValueInt: integer; 62 | FAnyDate: TDateTime; 63 | FMemStream: TMemoryStream; 64 | FText: string; 65 | published 66 | property StrList: TStringList read FStrList write FStrList; 67 | property IsDone: boolean read FIsDone write FIsDone; 68 | property Collection: TCollection read FCollection write FCollection; 69 | property ValueInt: integer read FValueInt write FValueInt; 70 | property AnyDate: TDateTime read FAnyDate write FAnyDate; 71 | property MemStream: TMemoryStream read FMemStream write FMemStream; 72 | property Text: String read FText write FText; 73 | end; 74 | 75 | type 76 | TTypeKindHelper = record helper for TTypeKind 77 | function ToString: string; 78 | end; 79 | 80 | function TTypeKindHelper.ToString: string; 81 | begin 82 | Result := GetEnumName(TypeInfo(TTypeKind), integer(Self)); 83 | end; 84 | 85 | // ---------------------------------------------------------------------- 86 | // Setup / TearDown 87 | // ---------------------------------------------------------------------- 88 | 89 | procedure TestPropertyList.Setup; 90 | begin 91 | fComponent := TComponent.Create(nil); 92 | end; 93 | 94 | procedure TestPropertyList.TearDown; 95 | begin 96 | fComponent.Free; 97 | end; 98 | 99 | function TestPropertyList.AssertMetadataSize(const expectedSize: integer; 100 | const metadataArray: TPropertyArray): boolean; 101 | begin 102 | Result := (expectedSize <= Length(metadataArray)); 103 | if not Result then 104 | Assert.Fail 105 | (Format('Expected %d items but got %d items (metadata TPropertyArray has not enough items)', 106 | [expectedSize,Length(metadataArray)])); 107 | end; 108 | 109 | procedure TestPropertyList.AssertMetadataItem(const expectedPropertyName 110 | : string; const expectedClassName: string; expectedKind: TTypeKind; 111 | const metadataItem: TPropertyInfo); 112 | begin 113 | if (expectedPropertyName <> metadataItem.PropertyName) or 114 | (expectedClassName <> metadataItem.ClassName) then 115 | Assert.Fail(Format('Expected item %s:%s but got %s:%s', 116 | [expectedPropertyName, expectedClassName, metadataItem.PropertyName, 117 | metadataItem.ClassName])) 118 | else if (expectedKind<>metadataItem.Kind) then 119 | Assert.Fail(Format('Expected item kind %s but got %s', 120 | [expectedKind.ToString, metadataItem.Kind.ToString])) 121 | else 122 | Assert.Pass; 123 | 124 | end; 125 | 126 | // ---------------------------------------------------------------------- 127 | // Tests 128 | // ---------------------------------------------------------------------- 129 | 130 | procedure TestPropertyList.ComponentWithoutProperties; 131 | var 132 | metadata: TPropertyArray; 133 | begin 134 | metadata := TComponentMetadata.GetPublishedPropetries(fComponent); 135 | if AssertMetadataSize(0,metadata) then 136 | Assert.Pass; 137 | end; 138 | 139 | procedure TestPropertyList.OneProperty; 140 | var 141 | metadata: TPropertyArray; 142 | begin 143 | metadata := TComponentMetadata.GetPublishedPropetries 144 | (TComponentWithTList.Create(fComponent)); 145 | AssertMetadataSize(1,metadata); 146 | AssertMetadataItem('List','TList',tkClass, metadata[0]); 147 | end; 148 | 149 | procedure TestPropertyList.ManyProperties_StrListTStringList; 150 | var 151 | metadata: TPropertyArray; 152 | begin 153 | metadata := TComponentMetadata.GetPublishedPropetries 154 | (TComponentManyProps.Create(fComponent)); 155 | AssertMetadataSize(7,metadata); 156 | AssertMetadataItem('StrList','TStringList',tkClass, metadata[0]); 157 | end; 158 | 159 | procedure TestPropertyList.ManyProperties_IsDoneBoolean; 160 | var 161 | metadata: TPropertyArray; 162 | begin 163 | metadata := TComponentMetadata.GetPublishedPropetries 164 | (TComponentManyProps.Create(fComponent)); 165 | AssertMetadataSize(7,metadata); 166 | AssertMetadataItem('IsDone', 'Boolean', tkEnumeration, metadata[1]); 167 | end; 168 | 169 | procedure TestPropertyList.ManyProperties_TCollection; 170 | var 171 | metadata: TPropertyArray; 172 | begin 173 | metadata := TComponentMetadata.GetPublishedPropetries 174 | (TComponentManyProps.Create(fComponent)); 175 | AssertMetadataSize(7,metadata); 176 | AssertMetadataItem('Collection','TCollection',tkClass, metadata[2]); 177 | end; 178 | 179 | procedure TestPropertyList.ManyProperties_ValueIntInteger; 180 | var 181 | metadata: TPropertyArray; 182 | begin 183 | metadata := TComponentMetadata.GetPublishedPropetries 184 | (TComponentManyProps.Create(fComponent)); 185 | AssertMetadataSize(7,metadata); 186 | AssertMetadataItem('ValueInt', 'Integer', tkInteger, metadata[3]); 187 | end; 188 | 189 | procedure TestPropertyList.ManyProperties_AnyDateTDateTime; 190 | var 191 | metadata: TPropertyArray; 192 | begin 193 | metadata := TComponentMetadata.GetPublishedPropetries 194 | (TComponentManyProps.Create(fComponent)); 195 | AssertMetadataSize(7,metadata); 196 | AssertMetadataItem('AnyDate', 'TDateTime', tkFloat, metadata[4]); 197 | end; 198 | 199 | procedure TestPropertyList.ManyProperties_MemStreamTMemoryStream; 200 | var 201 | metadata: TPropertyArray; 202 | begin 203 | metadata := TComponentMetadata.GetPublishedPropetries 204 | (TComponentManyProps.Create(fComponent)); 205 | AssertMetadataSize(7,metadata); 206 | AssertMetadataItem('MemStream', 'TMemoryStream', tkClass, metadata[5]); 207 | end; 208 | 209 | procedure TestPropertyList.ManyProperties_TextString; 210 | var 211 | metadata: TPropertyArray; 212 | begin 213 | metadata := TComponentMetadata.GetPublishedPropetries 214 | (TComponentManyProps.Create(fComponent)); 215 | AssertMetadataSize(7,metadata); 216 | AssertMetadataItem('Text', 'string', tkUString, metadata[6]); 217 | end; 218 | 219 | end. 220 | -------------------------------------------------------------------------------- /tests/clear_project.bat: -------------------------------------------------------------------------------- 1 | rmdir /Q /S __history 2 | rmdir /Q /S Win32 3 | rmdir /Q /S .svn 4 | rmdir /Q /S __recovery 5 | 6 | del *.identcache 7 | del *.dproj.local 8 | del desktop.ini 9 | del *.stat 10 | 11 | del *.dcu 12 | del *.exe 13 | del *.dll 14 | -------------------------------------------------------------------------------- /tools/app-config.json: -------------------------------------------------------------------------------- 1 | { 2 | "sourceUnits": [ 3 | "..\\src\\Pattern.*.pas"], 4 | "bumpReadme": { 5 | "fileName": "..\\README.md", 6 | "versionPrefix": "https://img.shields.io/badge/version" 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /tools/bumper_source/AppConfiguration.pas: -------------------------------------------------------------------------------- 1 | unit AppConfiguration; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes, 8 | System.JSON, 9 | System.IOUtils, 10 | System.Generics.Collections; 11 | 12 | type 13 | TAppConfiguration = class 14 | private const 15 | KeySourceUnits = 'sourceUnits'; 16 | KeyReadmeSection = 'bumpReadme'; 17 | KeyReadmeFilePath = 'fileName'; 18 | KeyReadmeSearchPattern = 'versionPrefix'; 19 | private 20 | FSourceUnits: TList; 21 | FDoReadmeBump: boolean; 22 | FReadmeFilePath: string; 23 | FReadmeSearchPattern: string; 24 | public 25 | constructor Create; 26 | destructor Destroy; override; 27 | procedure LoadFromFile; 28 | property SourceUnits: TList read FSourceUnits write FSourceUnits; 29 | property DoReadmeBump: boolean read FDoReadmeBump write FDoReadmeBump; 30 | property ReadmeFilePath: string read FReadmeFilePath write FReadmeFilePath; 31 | property ReadmeSearchPattern: string read FReadmeSearchPattern 32 | write FReadmeSearchPattern; 33 | end; 34 | 35 | implementation 36 | 37 | constructor TAppConfiguration.Create; 38 | begin 39 | FSourceUnits := TList.Create; 40 | end; 41 | 42 | destructor TAppConfiguration.Destroy; 43 | begin 44 | FSourceUnits.Free; 45 | inherited; 46 | end; 47 | 48 | procedure TAppConfiguration.LoadFromFile; 49 | var 50 | aJsonData: string; 51 | jsObject: TJSONObject; 52 | jsTrue: TJSONTrue; 53 | jsValueSourceUnits: TJSONValue; 54 | jsSourceUnitsArray: TJSONArray; 55 | aSourcePath: string; 56 | i: integer; 57 | jsReadmeBump: TJSONObject; 58 | begin 59 | aJsonData := TFile.ReadAllText('app-config.json'); 60 | jsObject := TJSONObject.ParseJSONValue(aJsonData) as TJSONObject; 61 | jsTrue := TJSONTrue.Create; 62 | try 63 | // --- PAS Source ---- 64 | jsValueSourceUnits := jsObject.GetValue(KeySourceUnits); 65 | if jsValueSourceUnits=nil then 66 | begin 67 | writeln(Format('Error! Mandatory configuration item: "%s" does not exist.', 68 | [KeySourceUnits])); 69 | Halt(2); 70 | end; 71 | if not(jsValueSourceUnits is TJSONArray) then 72 | begin 73 | writeln(Format('Error! Configuration item: "%s" is not array of strings', 74 | [KeySourceUnits])); 75 | Halt(2); 76 | end; 77 | jsSourceUnitsArray := jsValueSourceUnits as TJSONArray; 78 | FSourceUnits.Clear; 79 | for i := 0 to jsSourceUnitsArray.Count - 1 do 80 | begin 81 | aSourcePath := jsSourceUnitsArray.Items[i].Value; 82 | FSourceUnits.Add(aSourcePath); 83 | end; 84 | // --- README ---- 85 | 86 | DoReadmeBump := (jsObject.GetValue(KeyReadmeSection) <> nil); 87 | if DoReadmeBump then 88 | begin 89 | jsReadmeBump := jsObject.GetValue(KeyReadmeSection) as TJSONObject; 90 | ReadmeFilePath := jsReadmeBump.GetValue(KeyReadmeFilePath).Value; 91 | ReadmeSearchPattern := jsReadmeBump.GetValue(KeyReadmeSearchPattern).Value; 92 | end; 93 | finally 94 | jsObject.Free; 95 | jsTrue.Free; 96 | end; 97 | end; 98 | 99 | end. 100 | -------------------------------------------------------------------------------- /tools/bumper_source/Main.pas: -------------------------------------------------------------------------------- 1 | unit Main; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes, 8 | System.IOUtils, 9 | 10 | AppConfiguration; 11 | 12 | type 13 | TMainApplication = class 14 | private 15 | fAppConfig: TAppConfiguration; 16 | fSilentMode: boolean; 17 | procedure ValidateSourceConfiguration(); 18 | function ExtractInputParameters(): string; 19 | procedure ProcessReadmeMarkdown(const aNewVersion: string); 20 | procedure ProcessSourcePasFiles(const aNewVersion: string); 21 | procedure ProcessOnePasFile(const aPath: string; const aNewVersion: string); 22 | procedure WriteProcessErrorAndHalt(const AErrorMsg: string); 23 | public 24 | constructor Create(); 25 | destructor Destroy; override; 26 | procedure ExecuteApplication(); 27 | class procedure Run; 28 | end; 29 | 30 | implementation 31 | 32 | uses 33 | Processor.Utils, 34 | Processor.PascalUnit, 35 | Processor.ReadmeMarkdown; 36 | 37 | constructor TMainApplication.Create(); 38 | begin 39 | fAppConfig := TAppConfiguration.Create; 40 | fAppConfig.LoadFromFile; 41 | fSilentMode := true; 42 | end; 43 | 44 | destructor TMainApplication.Destroy; 45 | begin 46 | fAppConfig.Free; 47 | inherited; 48 | end; 49 | 50 | procedure TMainApplication.ValidateSourceConfiguration(); 51 | var 52 | aIsError: boolean; 53 | aSourceDir: string; 54 | aSourceUnit: string; 55 | begin 56 | aIsError := False; 57 | for aSourceUnit in fAppConfig.SourceUnits do 58 | begin 59 | aSourceDir := ExtractFileDir(aSourceUnit); 60 | if not DirectoryExists(aSourceDir) then 61 | begin 62 | writeln(Format 63 | ('Configured source directory [%s] didnt exists. Please update configuration!', 64 | [aSourceDir])); 65 | aIsError := true; 66 | end; 67 | end; 68 | if aIsError then 69 | Halt(1); 70 | end; 71 | 72 | procedure TMainApplication.WriteProcessErrorAndHalt(const AErrorMsg: string); 73 | begin 74 | writeln(' [Error] Processing error!'); 75 | writeln(' ' + AErrorMsg); 76 | Halt(3); 77 | end; 78 | 79 | procedure TMainApplication.ProcessReadmeMarkdown(const aNewVersion: string); 80 | var 81 | aFilePath: string; 82 | aSourceText: string; 83 | aNewSource: string; 84 | begin 85 | aFilePath := fAppConfig.ReadmeFilePath; 86 | if not FileExists(aFilePath) then 87 | raise EProcessError.CreateFmt('Error! Readme file not found %s',[aFilePath]); 88 | aSourceText := TFile.ReadAllText(aFilePath, TEncoding.UTF8); 89 | try 90 | aNewSource := TReadmeMarkdownProcessor.ProcessReadme(aSourceText, aNewVersion, 91 | fAppConfig.ReadmeSearchPattern); 92 | except 93 | on E: Processor.Utils.EProcessError do 94 | WriteProcessErrorAndHalt(E.Message); 95 | end; 96 | TFile.WriteAllText(aFilePath, aNewSource, TEncoding.UTF8); 97 | writeln(' - bumped readme version to: '+aNewVersion); 98 | end; 99 | 100 | procedure TMainApplication.ProcessSourcePasFiles(const aNewVersion: string); 101 | var 102 | aSourcePath: string; 103 | aSourceDir: string; 104 | aSourcePattern: string; 105 | aFiles: TArray; 106 | aPath: string; 107 | begin 108 | for aSourcePath in fAppConfig.SourceUnits do 109 | begin 110 | if FileExists(aSourcePath) then 111 | begin 112 | ProcessOnePasFile(aSourcePath, aNewVersion) 113 | end 114 | else 115 | begin 116 | aSourceDir := ExtractFileDir(aSourcePath); 117 | aSourcePattern := ExtractFileName(aSourcePath); 118 | aFiles := TDirectory.GetFiles(aSourceDir, aSourcePattern); 119 | for aPath in aFiles do 120 | begin 121 | ProcessOnePasFile(aPath, aNewVersion); 122 | end; 123 | end; 124 | end; 125 | end; 126 | 127 | procedure TMainApplication.ProcessOnePasFile(const aPath: string; const aNewVersion: string); 128 | var 129 | aSourceText: string; 130 | aOldVersion: string; 131 | aNewSource: string; 132 | begin 133 | aSourceText := TFile.ReadAllText(aPath, TEncoding.UTF8); 134 | try 135 | aNewSource := TPascalUnitProcessor.ProcessUnit(aSourceText, aNewVersion); 136 | aOldVersion := TPascalUnitProcessor.OldVersion; 137 | except 138 | on E: Processor.Utils.EProcessError do 139 | WriteProcessErrorAndHalt(E.Message); 140 | end; 141 | if aSourceText <> aNewSource then 142 | begin 143 | TFile.WriteAllText(aPath, aNewSource, TEncoding.UTF8); 144 | writeln(Format(' - %s - %s => %s', [aPath, aOldVersion, aNewVersion])); 145 | end; 146 | end; 147 | 148 | procedure TMainApplication.ExecuteApplication(); 149 | var 150 | aNewVersion: string; 151 | begin 152 | ValidateSourceConfiguration; 153 | aNewVersion := ExtractInputParameters; 154 | if fAppConfig.DoReadmeBump then 155 | ProcessReadmeMarkdown(aNewVersion); 156 | ProcessSourcePasFiles(aNewVersion); 157 | if fSilentMode = False then 158 | begin 159 | writeln(''); 160 | write('All files was updated. Press [Enter] to close application ...'); 161 | readln; 162 | end; 163 | end; 164 | 165 | function TMainApplication.ExtractInputParameters: string; 166 | var 167 | version: string; 168 | begin 169 | if ParamCount = 0 then 170 | begin 171 | fSilentMode := False; 172 | Write('New version: '); 173 | readln(version); 174 | if Trim(version) = '' then 175 | Halt(2); 176 | writeln(''); 177 | end 178 | else 179 | version := ParamStr(1); 180 | Result := version; 181 | end; 182 | 183 | class procedure TMainApplication.Run; 184 | var 185 | App: TMainApplication; 186 | begin 187 | App := TMainApplication.Create; 188 | try 189 | App.ExecuteApplication; 190 | finally 191 | App.Free; 192 | end; 193 | end; 194 | 195 | end. 196 | -------------------------------------------------------------------------------- /tools/bumper_source/Processor.PascalUnit.pas: -------------------------------------------------------------------------------- 1 | unit Processor.PascalUnit; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.StrUtils; 8 | 9 | type 10 | TPascalUnitProcessor = class 11 | const 12 | Aphostrophe = ''''; 13 | private 14 | class function FindSignature(const aSource, FieldName: string) 15 | : integer; static; 16 | class function TextLength(const aSource: string; aTextStartIdx: integer) 17 | : integer; static; 18 | public 19 | class var OldVersion: string; 20 | class function ProcessUnit(const aSource: string; const aNewVersion: string) 21 | : string; static; 22 | end; 23 | 24 | implementation 25 | 26 | uses 27 | Processor.Utils; 28 | 29 | class function TPascalUnitProcessor.FindSignature(const aSource, 30 | FieldName: string): integer; 31 | var 32 | idx1: integer; 33 | i: integer; 34 | begin 35 | idx1 := aSource.IndexOf(FieldName); 36 | if idx1 >= 0 then 37 | begin 38 | i := aSource.IndexOf(Aphostrophe, idx1); 39 | if i >= 0 then 40 | Exit(i + 1); 41 | end; 42 | Result := -1; 43 | end; 44 | 45 | class function TPascalUnitProcessor.TextLength(const aSource: string; 46 | aTextStartIdx: integer): integer; 47 | var 48 | j: integer; 49 | begin 50 | if aTextStartIdx > 0 then 51 | begin 52 | j := aSource.IndexOf(Aphostrophe, aTextStartIdx); 53 | if j > aTextStartIdx then 54 | Exit(j - aTextStartIdx); 55 | end; 56 | Result := 0; 57 | end; 58 | 59 | class function TPascalUnitProcessor.ProcessUnit(const aSource: string; 60 | const aNewVersion: string): string; 61 | var 62 | idx2: integer; 63 | len2: integer; 64 | aReleaseVersion: string; 65 | aNewSource: string; 66 | begin 67 | idx2 := FindSignature(aSource, 'Version'); 68 | len2 := TextLength(aSource, idx2); 69 | aReleaseVersion := aSource.Substring(idx2, len2); 70 | if len2 > 0 then 71 | begin 72 | OldVersion := aReleaseVersion; 73 | aNewSource := aSource.Substring(0, idx2) + aNewVersion + 74 | aSource.Substring(idx2 + len2, 99999); 75 | if aSource <> aNewSource then 76 | Result := aNewSource; 77 | end 78 | else 79 | Result := aSource; 80 | end; 81 | 82 | end. 83 | -------------------------------------------------------------------------------- /tools/bumper_source/Processor.ReadmeMarkdown.pas: -------------------------------------------------------------------------------- 1 | unit Processor.ReadmeMarkdown; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.StrUtils; 8 | 9 | type 10 | TReadmeMarkdownProcessor = class 11 | private 12 | public 13 | class function ProcessReadme(const aSource: string; 14 | const aNewVersion: string; const aSearchPattern: string): string; static; 15 | end; 16 | 17 | implementation 18 | 19 | uses 20 | Processor.Utils; 21 | 22 | class function TReadmeMarkdownProcessor.ProcessReadme(const aSource: string; 23 | const aNewVersion: string; const aSearchPattern: string): string; 24 | var 25 | idx1: Integer; 26 | len: Integer; 27 | idx2: Integer; 28 | idx3: Integer; 29 | begin 30 | // --------------------------------------------------------------------- 31 | // ![ version ](https://img.shields.io/badge/version-%201.2-yellow.svg) 32 | // ^----------- search pattern -------^ 33 | // --------------------------------------------------------------------- 34 | idx1 := aSource.IndexOf(aSearchPattern); 35 | len := length(aSearchPattern); 36 | if idx1 = -1 then 37 | raise Processor.Utils.EProcessError.Create 38 | ('No version pattern found in main README file. Please update configuration file.'); 39 | idx2 := aSource.IndexOf('-', idx1 + len); 40 | idx3 := aSource.IndexOf('-', idx2+1); 41 | if (idx2 = -1) or (idx3 = -1) then 42 | raise Processor.Utils.EProcessError.Create 43 | ('Invalid format of version stored in main README'); 44 | Result := aSource.Substring(0, idx2+1) + '%20'+aNewVersion + 45 | aSource.Substring(idx3, 9999999); 46 | end; 47 | 48 | end. 49 | -------------------------------------------------------------------------------- /tools/bumper_source/Processor.Utils.pas: -------------------------------------------------------------------------------- 1 | unit Processor.Utils; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | EProcessError = class(Exception); 10 | 11 | 12 | implementation 13 | 14 | end. 15 | -------------------------------------------------------------------------------- /tools/bumper_source/clear_project.bat: -------------------------------------------------------------------------------- 1 | rmdir /Q /S __history 2 | rmdir /Q /S Win32 3 | rmdir /Q /S .svn 4 | rmdir /Q /S __recovery 5 | 6 | del *.identcache 7 | del *.dproj.local 8 | del desktop.ini 9 | del *.stat 10 | 11 | del *.dcu 12 | del *.exe 13 | del *.dll 14 | -------------------------------------------------------------------------------- /tools/bumper_source/out/app-config.json: -------------------------------------------------------------------------------- 1 | { 2 | "sourceUnits": [ 3 | "..\\test\\src\\*.pas", 4 | "..\\test\\sample\\demo01\\UnitForm1.pas", 5 | "..\\test\\sample\\demo02\\*.pas"], 6 | "bumpReadme": { 7 | "fileName": "..\\test\\README.md", 8 | "versionPrefix": "https://img.shields.io/badge/version" 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /tools/bumper_source/test/README.md: -------------------------------------------------------------------------------- 1 | # Version Bumper 2 | 3 | ![ Delphi Support ](https://img.shields.io/badge/Delphi%20Support-%20XE8%20..%2010.3%20Rio-blue.svg) 4 | ![ version ](https://img.shields.io/badge/version-%202.1-yellow.svg) 5 | 6 | ## Overview 7 | 8 | Lorem Ipsum 9 | -------------------------------------------------------------------------------- /tools/bumper_source/test/sample/demo01/UnitForm1.dfm: -------------------------------------------------------------------------------- 1 | object Form2: TForm2 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form2' 5 | ClientHeight = 289 6 | ClientWidth = 554 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | PixelsPerInch = 96 15 | TextHeight = 13 16 | end 17 | -------------------------------------------------------------------------------- /tools/bumper_source/test/sample/demo01/UnitForm1.pas: -------------------------------------------------------------------------------- 1 | unit UnitForm1; 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; 8 | 9 | type 10 | TForm2 = class(TForm) 11 | strict private const 12 | Version = '2.1'; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | Form2: TForm2; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /tools/bumper_source/test/sample/demo02/UnitForm1.dfm: -------------------------------------------------------------------------------- 1 | object Form2: TForm2 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form2' 5 | ClientHeight = 289 6 | ClientWidth = 554 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | PixelsPerInch = 96 15 | TextHeight = 13 16 | end 17 | -------------------------------------------------------------------------------- /tools/bumper_source/test/sample/demo02/UnitForm1.pas: -------------------------------------------------------------------------------- 1 | unit UnitForm1; 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; 8 | 9 | type 10 | TForm2 = class(TForm) 11 | strict private const 12 | Version = '2.1'; 13 | private 14 | { Private declarations } 15 | public 16 | { Public declarations } 17 | end; 18 | 19 | var 20 | Form2: TForm2; 21 | 22 | implementation 23 | 24 | {$R *.dfm} 25 | 26 | end. 27 | -------------------------------------------------------------------------------- /tools/bumper_source/test/src/Unit1_WithVersion.pas: -------------------------------------------------------------------------------- 1 | unit Unit1_WithVersion; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | System.SysUtils; 8 | 9 | type 10 | TClass1 = class 11 | private 12 | fUpdateInterval: integer; 13 | fOnUpdateProc: TProc; 14 | procedure OnUpdateTimer(Sender: TObject); 15 | protected 16 | fBeforeStartEvent: TProc; 17 | fAfterFinishEvent: TProc; 18 | fThread: TThread; 19 | fIsCommandDone: boolean; 20 | fTimer: TTimer; 21 | procedure SetIsCommandDone(aIsTermianted: boolean); 22 | strict private const 23 | Version = '2.1'; 24 | public 25 | constructor Create(AOwner: TComponent); override; 26 | destructor Destroy; override; 27 | end; 28 | 29 | implementation 30 | 31 | constructor TClass1.Create(AOwner: TComponent); 32 | begin 33 | inherited; 34 | end; 35 | 36 | destructor TClass1.Destroy; 37 | begin 38 | inherited; 39 | end; 40 | 41 | procedure TClass1.OnUpdateTimer(Sender: TObject); 42 | begin 43 | end; 44 | 45 | procedure TClass1.SetIsCommandDone(aIsTermianted: boolean); 46 | begin 47 | end; 48 | 49 | end. 50 | -------------------------------------------------------------------------------- /tools/bumper_source/test/src/Unit2_NoVersion.pas: -------------------------------------------------------------------------------- 1 | unit Unit2_NoVersion; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | System.SysUtils; 8 | 9 | type 10 | TFoo = class(TComponent) 11 | public 12 | function GetElapsedTimeMs: integer; 13 | function IsBusy: boolean; virtual; 14 | end; 15 | 16 | implementation 17 | 18 | function TFoo.GetElapsedTimeMs: integer; 19 | begin 20 | Result := 0; 21 | end; 22 | 23 | function TCommand.IsBusy: TTimeSpan; 24 | begin 25 | Result := False; 26 | end; 27 | 28 | end. 29 | -------------------------------------------------------------------------------- /tools/bumper_source/test/src/Unit3_WithPublicVersion.pas: -------------------------------------------------------------------------------- 1 | unit Unit3_WithPublicVersion; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | System.SysUtils; 8 | 9 | type 10 | ICommand = interface 11 | procedure Execute(); 12 | end; 13 | 14 | TFooInfo = record 15 | Kind: TTypeKind; 16 | PropertyName: string; 17 | ClassName: string; 18 | function isAvaliableForInjection(const aInjection: TVarRec): boolean; 19 | end; 20 | 21 | type 22 | TFoo3 = class(TComponent) 23 | public 24 | function GetElapsedTimeMs: integer; 25 | function IsBusy: boolean; virtual; 26 | public const 27 | Version = '1.0'; 28 | end; 29 | 30 | implementation 31 | 32 | uses 33 | System.RTTI; 34 | 35 | const 36 | ERRMSG_NotSupportedParameter = 'Not supported parameter type to inject!' + 37 | 'Parameter index (zaro-based): %d. Paramter type: %s'; 38 | 39 | function TFoo3.GetElapsedTimeMs: integer; 40 | begin 41 | Result := 0; 42 | end; 43 | 44 | function TFoo3.IsBusy: TTimeSpan; 45 | begin 46 | Result := False; 47 | end; 48 | 49 | end. 50 | -------------------------------------------------------------------------------- /tools/bumper_source/test/src/subfolder/Unit4_Subfolder_WithVersion.pas: -------------------------------------------------------------------------------- 1 | unit Unit4_Subfolder_WithVersion; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | System.SysUtils; 8 | 9 | type 10 | TClass1 = class 11 | strict private const 12 | Version = '2.1'; 13 | private 14 | fUpdateInterval: integer; 15 | fOnUpdateProc: TProc; 16 | procedure OnUpdateTimer(Sender: TObject); 17 | protected 18 | fBeforeStartEvent: TProc; 19 | fAfterFinishEvent: TProc; 20 | fThread: TThread; 21 | fIsCommandDone: boolean; 22 | fTimer: TTimer; 23 | procedure SetIsCommandDone(aIsTermianted: boolean); 24 | public 25 | constructor Create(AOwner: TComponent); override; 26 | destructor Destroy; override; 27 | end; 28 | 29 | implementation 30 | 31 | constructor TClass1.Create(AOwner: TComponent); 32 | begin 33 | inherited; 34 | end; 35 | 36 | destructor TClass1.Destroy; 37 | begin 38 | inherited; 39 | end; 40 | 41 | procedure TClass1.OnUpdateTimer(Sender: TObject); 42 | begin 43 | end; 44 | 45 | procedure TClass1.SetIsCommandDone(aIsTermianted: boolean); 46 | begin 47 | end; 48 | 49 | end. 50 | -------------------------------------------------------------------------------- /tools/bumper_source/version_bumper.dpr: -------------------------------------------------------------------------------- 1 | program version_bumper; 2 | 3 | {$APPTYPE CONSOLE} 4 | {$R *.res} 5 | 6 | uses 7 | System.SysUtils, 8 | Main in 'Main.pas', 9 | AppConfiguration in 'AppConfiguration.pas', 10 | Processor.PascalUnit in 'Processor.PascalUnit.pas', 11 | Processor.ReadmeMarkdown in 'Processor.ReadmeMarkdown.pas', 12 | Processor.Utils in 'Processor.Utils.pas'; 13 | 14 | function ExpandStringWidth(s: String; len: Integer): string; 15 | begin 16 | while Length(s) < len do 17 | s := s + ' '; 18 | Result := s; 19 | end; 20 | 21 | const 22 | APP_Version = '1.2'; 23 | APP_Date = '2020-09-26'; 24 | 25 | var 26 | aTitle: String; 27 | 28 | begin 29 | aTitle := ExpandStringWidth(Format('version_bumper.exe - %s (%s)', 30 | [APP_Version, APP_Date]), 50); 31 | writeln('+--------------------------------------------------------+'); 32 | writeln('| ' + aTitle + ' |'); 33 | writeln('+--------------------------------------------------------+'); 34 | writeln('| Can''t execute - required version string as parameter |'); 35 | writeln('| Syntax: version_bumper.exe version |'); 36 | writeln('| Sample: version_bumper.exe "1.3" |'); 37 | writeln('+--------------------------------------------------------+'); 38 | writeln(''); 39 | writeln('New version number is required to update files!'); 40 | writeln(' Type new version ([Enter] exits application):'); 41 | try 42 | TMainApplication.Run(); 43 | except 44 | on E: Exception do 45 | writeln(E.ClassName, ': ', E.Message); 46 | end; 47 | 48 | end. 49 | --------------------------------------------------------------------------------