├── .gitignore ├── LICENSE ├── README.md ├── docs ├── Built_for_Delphi.png ├── DEB_Logo.png ├── DEB_logo_square.png ├── DelphiEventBusArchitecture.png └── star_project.png ├── samples ├── AccessRemoteData │ ├── AccessRemoteData.dpr │ ├── AccessRemoteData.dproj │ ├── AccessRemoteData.res │ ├── BOsU.pas │ ├── MainFMX.fmx │ ├── MainFMX.pas │ └── ServicesU.pas ├── Analytics │ ├── Analytics.dpr │ ├── Analytics.dproj │ ├── Analytics.res │ ├── BOU.pas │ ├── LogginFormU.dfm │ ├── LogginFormU.pas │ ├── MainFormU.dfm │ └── MainFormU.pas ├── SamplesProjectGroup.groupproj ├── WeatherStation │ ├── HumidityFMX.fmx │ ├── HumidityFMX.pas │ ├── InterfacedForm.fmx │ ├── InterfacedForm.pas │ ├── ModelU.pas │ ├── PaintedFMX.fmx │ ├── PaintedFMX.pas │ ├── PressureFMX.fmx │ ├── PressureFMX.pas │ ├── TemperatureFMX.fmx │ ├── TemperatureFMX.pas │ ├── WeatherStation.dpr │ ├── WeatherStation.dproj │ ├── WeatherStation.res │ └── data │ │ ├── cloudy.jpg │ │ ├── rainy.png │ │ └── sunny.jpeg └── vclmessaging │ ├── EventU.pas │ ├── MainFormU.dfm │ ├── MainFormU.pas │ ├── SecondFormU.dfm │ ├── SecondFormU.pas │ ├── ThirdFormU.dfm │ ├── ThirdFormU.pas │ ├── VCLMessaging.dpr │ ├── VCLMessaging.dproj │ └── VCLMessaging.res ├── source ├── EventBus.Core.pas ├── EventBus.Helpers.pas ├── EventBus.Subscribers.pas └── EventBus.pas └── tests ├── BOs.pas ├── BaseTestU.pas ├── DEBDUnitXTests.dpr ├── DEBDUnitXTests.dproj ├── DEBDunitXTests.res ├── DEBTestsPG.groupproj └── EventBusTestU.pas /.gitignore: -------------------------------------------------------------------------------- 1 | *.stat 2 | Win32 3 | __history 4 | __recovery 5 | Android 6 | *.local 7 | *.identcache 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright 2016 Daniele Spinetti 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![alt text](/docs/DEB_Logo.png "DEB Logo") 2 | 3 | # DEB an Event Bus framework for Delphi 4 | Delphi Event Bus (for short DEB) is a publish/subscribe Event Bus framework for the Delphi platform. 5 | 6 | DEB is designed to decouple different parts/layers of your application while still allowing them to communicate efficiently. 7 | It was inspired by EventBus framework for the Android platform. 8 | 9 | ![alt text](/docs/DelphiEventBusArchitecture.png "Delphi Event Bus Architecture") 10 | 11 | ## Give it a star 12 | Please "star" this project in GitHub! It costs nothing but helps to reference the code 13 | 14 | ![alt text](/docs/star_project.png "Give it a star") 15 | 16 | ## Features 17 | * __Easy and clean:__ DelphiEventBus is super easy to learn and use because it respects KISS and "Convention over configuration" design principles. By using default TEventBus instance, you can start immediately to delivery and receive events 18 | * __Designed to decouple different parts/layers of your application__ 19 | * __Event Driven__ 20 | * __Attributes based API:__ Simply put the Subscribe attribute on your subscriber method you are able to receive a specific event 21 | * __Support different delivery mode:__ Specifying the TThreadMode in Subscribe attribute, you can choose to delivery the event in the Main Thread or in a Background ones, regardless where an event was posted. The EventBus will manage Thread synchronization 22 | * __Unit Tested__ 23 | * __Thread Safe__ 24 | 25 | ## Show me the code 26 | 27 | ### Events 28 | 29 | 1.Define events: 30 | 31 | ```delphi 32 | IEvent = interface(IInterface) 33 | ['{3522E1C5-547F-4AB6-A799-5B3D3574D2FA}'] 34 | // additional information here 35 | end; 36 | ``` 37 | 38 | 2.Prepare subscribers: 39 | 40 | * Declare your subscribing method: 41 | ```delphi 42 | [Subscribe] 43 | procedure OnEvent(AEvent: IAnyTypeOfEvent); 44 | begin 45 | // manage the event 46 | end; 47 | ``` 48 | 49 | * Register your subscriber: 50 | ```delphi 51 | GlobalEventBus.RegisterSubscriberForEvents(Self); 52 | ``` 53 | 54 | 3.Post events: 55 | ```delphi 56 | GlobalEventBus.post(LEvent); 57 | ``` 58 | 59 | ### Channels 60 | 61 | 1.Define channel: 62 | 63 | ```delphi 64 | const MY_CHANNEL = 'MYCHANNEL' 65 | ``` 66 | 67 | 2.Prepare subscribers: 68 | 69 | * Declare your subscribing method: 70 | ```delphi 71 | [Channel(MY_CHANNEL)] 72 | procedure OnMessage(AMsg: string); 73 | begin 74 | // manage the message 75 | end; 76 | ``` 77 | 78 | * Register your subscriber: 79 | ```delphi 80 | GlobalEventBus.RegisterSubscriberForChannels(Self); 81 | ``` 82 | 83 | 3.Post event on channel: 84 | ```delphi 85 | GlobalEventBus.post(MY_CHANNEL, 'My Message'); 86 | ``` 87 | 88 | 89 | 90 | --- 91 | 92 | ## Support 93 | * DEB is a 100% ObjectPascal framework so it works on VCL and Firemonkey 94 | * It works with Delphi2010 and major 95 | * It works with latest version Alexandria 96 | 97 | ## Release Notes 98 | 99 | ### DEB 2.1 100 | 101 | * NEW! Introduced dedicated thread pool for DEB threading 102 | 103 | ### DEB 2.0 104 | 105 | * NEW! Added new Interface based mechanism to declare and handle events! 106 | * NEW! Added channels for simple string-based events 107 | * NEW! Removed internal CloneEvent because now events are interface based! 108 | 109 | #### Breaking Changes 110 | 111 | * A subscriber method can only have 1 parameter that is an IInterface or descendants 112 | * EventBus.Post method can accept only an interface as parameter now 113 | 114 | 115 | ## License 116 | Copyright 2016-2022 Daniele Spinetti 117 | 118 | Licensed under the Apache License, Version 2.0 (the "License"); 119 | you may not use this file except in compliance with the License. 120 | You may obtain a copy of the License at 121 | 122 | http://www.apache.org/licenses/LICENSE-2.0 123 | 124 | Unless required by applicable law or agreed to in writing, software 125 | distributed under the License is distributed on an "AS IS" BASIS, 126 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 127 | See the License for the specific language governing permissions and 128 | limitations under the License. 129 | -------------------------------------------------------------------------------- /docs/Built_for_Delphi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/docs/Built_for_Delphi.png -------------------------------------------------------------------------------- /docs/DEB_Logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/docs/DEB_Logo.png -------------------------------------------------------------------------------- /docs/DEB_logo_square.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/docs/DEB_logo_square.png -------------------------------------------------------------------------------- /docs/DelphiEventBusArchitecture.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/docs/DelphiEventBusArchitecture.png -------------------------------------------------------------------------------- /docs/star_project.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/docs/star_project.png -------------------------------------------------------------------------------- /samples/AccessRemoteData/AccessRemoteData.dpr: -------------------------------------------------------------------------------- 1 | program AccessRemoteData; 2 | 3 | uses 4 | System.StartUpCopy, 5 | FMX.Forms, 6 | MainFMX in 'MainFMX.pas' {HeaderFooterForm} , 7 | BOsU in 'BOsU.pas', 8 | ServicesU in 'ServicesU.pas'; 9 | 10 | {$R *.res} 11 | 12 | begin 13 | ReportMemoryLeaksOnShutdown := true; 14 | Application.Initialize; 15 | Application.CreateForm(THeaderFooterForm, HeaderFooterForm); 16 | Application.Run; 17 | end. 18 | -------------------------------------------------------------------------------- /samples/AccessRemoteData/AccessRemoteData.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/AccessRemoteData/AccessRemoteData.res -------------------------------------------------------------------------------- /samples/AccessRemoteData/BOsU.pas: -------------------------------------------------------------------------------- 1 | unit BOsU; 2 | 3 | interface 4 | 5 | uses 6 | EventBus; 7 | 8 | type 9 | TLoginDTO = class(TObject) 10 | private 11 | FPassword: string; 12 | FUsername: string; 13 | procedure SetPassword(const AValue: string); 14 | procedure SetUsername(const AValue: string); 15 | public 16 | constructor Create(AUsername: string; APwd: string); 17 | property Username: string read FUsername write SetUsername; 18 | property Password: string read FPassword write SetPassword; 19 | end; 20 | 21 | IOnLoginEvent = interface 22 | ['{E3C9633D-86CA-488F-A452-29DAB206C92A}'] 23 | procedure SetMsg(const AValue: string); 24 | procedure SetSuccess(const AValue: Boolean); 25 | function GetMsg: string; 26 | function GetSuccess: Boolean; 27 | property Success: Boolean read GetSuccess write SetSuccess; 28 | property Msg: string read GetMsg write SetMsg; 29 | end; 30 | 31 | function CreateOnLoginEvent(ASuccess: Boolean; AMsg: string): IOnLoginEvent; 32 | 33 | implementation 34 | 35 | uses 36 | System.Classes; 37 | 38 | type 39 | TOnLoginEvent = class(TInterfacedObject, IOnLoginEvent) 40 | private 41 | FSuccess: Boolean; 42 | FMsg: string; 43 | procedure SetMsg(const AValue: string); 44 | procedure SetSuccess(const AValue: Boolean); 45 | function GetMsg: string; 46 | function GetSuccess: Boolean; 47 | public 48 | constructor Create(ASuccess: Boolean; AMsg: string); 49 | property Success: Boolean read GetSuccess write SetSuccess; 50 | property Msg: string read GetMsg write SetMsg; 51 | end; 52 | 53 | { TLoginDTO } 54 | 55 | constructor TLoginDTO.Create(AUsername, APwd: string); 56 | begin 57 | FPassword := APwd; 58 | FUsername := AUsername; 59 | end; 60 | 61 | procedure TLoginDTO.SetPassword(const AValue: string); 62 | begin 63 | FPassword := AValue; 64 | end; 65 | 66 | procedure TLoginDTO.SetUsername(const AValue: string); 67 | begin 68 | FUsername := AValue; 69 | end; 70 | 71 | { TOnLoginEvent } 72 | 73 | constructor TOnLoginEvent.Create(ASuccess: Boolean; AMsg: string); 74 | begin 75 | inherited Create; 76 | FSuccess := ASuccess; 77 | FMsg := AMsg; 78 | end; 79 | 80 | function TOnLoginEvent.GetMsg: string; 81 | begin 82 | Result:= FMsg; 83 | end; 84 | 85 | function TOnLoginEvent.GetSuccess: Boolean; 86 | begin 87 | Result:= FSuccess; 88 | end; 89 | 90 | procedure TOnLoginEvent.SetMsg(const AValue: string); 91 | begin 92 | FMsg := AValue; 93 | end; 94 | 95 | procedure TOnLoginEvent.SetSuccess(const AValue: Boolean); 96 | begin 97 | FSuccess := AValue; 98 | end; 99 | 100 | function CreateOnLoginEvent(ASuccess: Boolean; AMsg: string): IOnLoginEvent; 101 | begin 102 | Result:= TOnLoginEvent.Create(ASuccess, AMsg); 103 | end; 104 | 105 | end. 106 | -------------------------------------------------------------------------------- /samples/AccessRemoteData/MainFMX.fmx: -------------------------------------------------------------------------------- 1 | object HeaderFooterForm: THeaderFooterForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'Header Footer Form' 5 | ClientHeight = 567 6 | ClientWidth = 384 7 | FormFactor.Width = 1440 8 | FormFactor.Height = 900 9 | FormFactor.Devices = [Desktop] 10 | OnCreate = FormCreate 11 | DesignerMasterStyle = 0 12 | object Header: TToolBar 13 | Size.Width = 384.000000000000000000 14 | Size.Height = 48.000000000000000000 15 | Size.PlatformDefault = False 16 | TabOrder = 0 17 | object HeaderLabel: TLabel 18 | Align = Contents 19 | Size.Width = 384.000000000000000000 20 | Size.Height = 48.000000000000000000 21 | Size.PlatformDefault = False 22 | StyleLookup = 'toollabel' 23 | TextSettings.HorzAlign = Center 24 | Text = 'DEB - Delphi Event Bus' 25 | end 26 | end 27 | object TabControl1: TTabControl 28 | Align = Client 29 | Size.Width = 384.000000000000000000 30 | Size.Height = 519.000000000000000000 31 | Size.PlatformDefault = False 32 | TabHeight = 49.000000000000000000 33 | TabIndex = 0 34 | TabOrder = 2 35 | TabPosition = None 36 | Sizes = ( 37 | 384s 38 | 519s 39 | 384s 40 | 519s) 41 | object TabItem1: TTabItem 42 | CustomIcon = < 43 | item 44 | end> 45 | IsSelected = True 46 | Size.Width = 8.000000000000000000 47 | Size.Height = 8.000000000000000000 48 | Size.PlatformDefault = False 49 | StyleLookup = '' 50 | TabOrder = 0 51 | Text = 'TabItem1' 52 | ExplicitSize.cx = 8.000000000000000000 53 | ExplicitSize.cy = 8.000000000000000000 54 | object GridPanelLayout1: TGridPanelLayout 55 | Align = Client 56 | Size.Width = 384.000000000000000000 57 | Size.Height = 519.000000000000000000 58 | Size.PlatformDefault = False 59 | TabOrder = 0 60 | ColumnCollection = < 61 | item 62 | Value = 9.785596288102472000 63 | end 64 | item 65 | Value = 80.211974132343560000 66 | end 67 | item 68 | Value = 10.002429579553980000 69 | end> 70 | ControlCollection = < 71 | item 72 | Column = 1 73 | Control = Edit1 74 | Row = 2 75 | end 76 | item 77 | Column = 1 78 | Control = Edit2 79 | Row = 4 80 | end 81 | item 82 | Column = 1 83 | Control = Button1 84 | Row = 6 85 | end 86 | item 87 | Column = 1 88 | Control = AniIndicator1 89 | Row = 8 90 | end 91 | item 92 | Column = 1 93 | Control = Text1 94 | Row = 0 95 | end> 96 | RowCollection = < 97 | item 98 | Value = 49.736522464674410000 99 | end 100 | item 101 | Value = 6.282934691915696000 102 | end 103 | item 104 | Value = 6.282934691915696000 105 | end 106 | item 107 | Value = 6.282934691915696000 108 | end 109 | item 110 | Value = 6.282934691915696000 111 | end 112 | item 113 | Value = 6.282934691915696000 114 | end 115 | item 116 | Value = 6.282934691915696000 117 | end 118 | item 119 | Value = 6.282934691915696000 120 | end 121 | item 122 | Value = 6.282934691915696000 123 | end> 124 | object Edit1: TEdit 125 | Touch.InteractiveGestures = [LongTap, DoubleTap] 126 | Align = Client 127 | TabOrder = 0 128 | Hint = 'Username' 129 | Size.Width = 308.013977050781300000 130 | Size.Height = 32.608428955078130000 131 | Size.PlatformDefault = False 132 | TextPrompt = 'Username...' 133 | end 134 | object Edit2: TEdit 135 | Touch.InteractiveGestures = [LongTap, DoubleTap] 136 | Align = Client 137 | TabOrder = 1 138 | Password = True 139 | Size.Width = 308.013977050781300000 140 | Size.Height = 32.608428955078130000 141 | Size.PlatformDefault = False 142 | TextPrompt = 'Password...' 143 | end 144 | object Button1: TButton 145 | Align = Client 146 | Size.Width = 308.013977050781300000 147 | Size.Height = 32.608428955078130000 148 | Size.PlatformDefault = False 149 | TabOrder = 2 150 | Text = 'Login' 151 | OnClick = Button1Click 152 | end 153 | object AniIndicator1: TAniIndicator 154 | Align = Client 155 | Size.Width = 308.013977050781300000 156 | Size.Height = 32.608459472656250000 157 | Size.PlatformDefault = False 158 | end 159 | object Text1: TText 160 | Align = Client 161 | Size.Width = 308.013977050781300000 162 | Size.Height = 258.132537841796900000 163 | Size.PlatformDefault = False 164 | Stretch = True 165 | Text = 'D.E.B.' 166 | TextSettings.Trimming = Word 167 | end 168 | end 169 | end 170 | object TabItem2: TTabItem 171 | CustomIcon = < 172 | item 173 | end> 174 | IsSelected = False 175 | Size.Width = 8.000000000000000000 176 | Size.Height = 8.000000000000000000 177 | Size.PlatformDefault = False 178 | StyleLookup = '' 179 | TabOrder = 0 180 | Text = 'TabItem2' 181 | ExplicitSize.cx = 8.000000000000000000 182 | ExplicitSize.cy = 8.000000000000000000 183 | object GridPanelLayout2: TGridPanelLayout 184 | Align = Client 185 | Size.Width = 384.000000000000000000 186 | Size.Height = 519.000000000000000000 187 | Size.PlatformDefault = False 188 | TabOrder = 0 189 | ColumnCollection = < 190 | item 191 | Value = 9.785596288102472000 192 | end 193 | item 194 | Value = 80.211974132343560000 195 | end 196 | item 197 | Value = 10.002429579553980000 198 | end> 199 | ControlCollection = < 200 | item 201 | Column = 1 202 | Control = Button2 203 | Row = 6 204 | end 205 | item 206 | Column = 1 207 | Control = Text2 208 | Row = 0 209 | end> 210 | RowCollection = < 211 | item 212 | Value = 49.736522464674410000 213 | end 214 | item 215 | Value = 6.282934691915696000 216 | end 217 | item 218 | Value = 6.282934691915696000 219 | end 220 | item 221 | Value = 6.282934691915696000 222 | end 223 | item 224 | Value = 6.282934691915696000 225 | end 226 | item 227 | Value = 6.282934691915696000 228 | end 229 | item 230 | Value = 6.282934691915696000 231 | end 232 | item 233 | Value = 6.282934691915696000 234 | end 235 | item 236 | Value = 6.282934691915696000 237 | end> 238 | object Button2: TButton 239 | Align = Client 240 | Size.Width = 308.013977050781300000 241 | Size.Height = 32.608428955078130000 242 | Size.PlatformDefault = False 243 | TabOrder = 0 244 | Text = 'Logout' 245 | OnClick = Button2Click 246 | end 247 | object Text2: TText 248 | Align = Client 249 | Size.Width = 308.013977050781300000 250 | Size.Height = 258.132537841796900000 251 | Size.PlatformDefault = False 252 | Stretch = True 253 | Text = 'Welcome' 254 | TextSettings.Trimming = Word 255 | end 256 | end 257 | end 258 | end 259 | end 260 | -------------------------------------------------------------------------------- /samples/AccessRemoteData/MainFMX.pas: -------------------------------------------------------------------------------- 1 | unit MainFMX; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, System.Types, System.UITypes, System.Classes, 7 | System.Variants, FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, 8 | FMX.Dialogs, FMX.StdCtrls, FMX.Controls.Presentation, FMX.Layouts, 9 | FMX.Objects, FMX.Edit, FMX.TabControl, BOsU, EventBus, ServicesU; 10 | 11 | type 12 | THeaderFooterForm = class(TForm) 13 | AniIndicator1: TAniIndicator; 14 | Button1: TButton; 15 | Button2: TButton; 16 | Edit1: TEdit; 17 | Edit2: TEdit; 18 | GridPanelLayout1: TGridPanelLayout; 19 | GridPanelLayout2: TGridPanelLayout; 20 | Header: TToolBar; 21 | HeaderLabel: TLabel; 22 | TabControl1: TTabControl; 23 | TabItem1: TTabItem; 24 | TabItem2: TTabItem; 25 | Text1: TText; 26 | Text2: TText; 27 | procedure Button1Click(Sender: TObject); 28 | procedure Button2Click(Sender: TObject); 29 | procedure FormCreate(Sender: TObject); 30 | private 31 | { Private declarations } 32 | FRemoteDataContext: IRemoteDataContext; 33 | public 34 | { Public declarations } 35 | [Subscribe(TThreadMode.Main)] 36 | procedure OnAfterLogin(AEvent: IOnLoginEvent); 37 | end; 38 | 39 | var 40 | HeaderFooterForm: THeaderFooterForm; 41 | 42 | implementation 43 | 44 | {$R *.fmx} 45 | 46 | procedure THeaderFooterForm.Button1Click(Sender: TObject); 47 | var 48 | LLoginDTO: TLoginDTO; 49 | begin 50 | AniIndicator1.Enabled := true; 51 | Button1.Enabled := false; 52 | LLoginDTO := TLoginDTO.Create(Edit1.Text, Edit2.Text); 53 | FRemoteDataContext.Login(LLoginDTO); 54 | end; 55 | 56 | procedure THeaderFooterForm.Button2Click(Sender: TObject); 57 | begin 58 | TabControl1.SetActiveTabWithTransition(TabItem1, TTabTransition.None); 59 | end; 60 | 61 | procedure THeaderFooterForm.FormCreate(Sender: TObject); 62 | begin 63 | TabControl1.ActiveTab := TabItem1; 64 | FRemoteDataContext:= CreateRemoteDataContext; 65 | // register subscribers 66 | GlobalEventBus.RegisterSubscriberForEvents(Self); 67 | end; 68 | 69 | procedure THeaderFooterForm.OnAfterLogin(AEvent: IOnLoginEvent); 70 | begin 71 | AniIndicator1.Enabled := false; 72 | Button1.Enabled := true; 73 | Text2.Text := 'Welcome' + sLineBreak + Edit1.Text; 74 | TabControl1.SetActiveTabWithTransition(TabItem2, TTabTransition.Slide); 75 | end; 76 | 77 | end. 78 | -------------------------------------------------------------------------------- /samples/AccessRemoteData/ServicesU.pas: -------------------------------------------------------------------------------- 1 | unit ServicesU; 2 | 3 | interface 4 | 5 | uses 6 | BOsU; 7 | 8 | type 9 | IRemoteDataContext = interface(IInterface) 10 | ['{05EC9B06-C552-4718-ACF4-AA584F5F65DB}'] 11 | procedure Login(aLoginDTO: TLoginDTO); 12 | end; 13 | 14 | IAccessRemoteDataProxy = interface(IInterface) 15 | ['{A9C0DE85-8FE7-43E0-B9FB-82D1BFE35E4D}'] 16 | procedure DoLogin(aLoginDTO: TLoginDTO); 17 | end; 18 | 19 | function GetAccessRemoteDataProxyInstance: IAccessRemoteDataProxy; 20 | function CreateRemoteDataContext: IRemoteDataContext; 21 | 22 | implementation 23 | 24 | uses 25 | EventBus, System.Threading, System.Classes; 26 | 27 | var 28 | FDefaultInstance: IAccessRemoteDataProxy; 29 | 30 | type 31 | TRemoteDataContext = class(TInterfacedObject, IRemoteDataContext) 32 | public 33 | procedure Login(ALoginDTO: TLoginDTO); 34 | end; 35 | 36 | TAccessRemoteDataProxy = class(TInterfacedObject, IAccessRemoteDataProxy) 37 | public 38 | procedure DoLogin(ALoginDTO: TLoginDTO); 39 | end; 40 | 41 | procedure TAccessRemoteDataProxy.DoLogin(ALoginDTO: TLoginDTO); 42 | begin 43 | TTask.Run( 44 | procedure 45 | begin 46 | TThread.Sleep(3000); // simulate an http request for 3 seconds 47 | GlobalEventBus.Post(CreateOnLoginEvent(true, 'Login ok')); 48 | ALoginDTO.Free; 49 | end 50 | ); 51 | end; 52 | 53 | { TRemoteDataContext } 54 | 55 | procedure TRemoteDataContext.Login(ALoginDTO: TLoginDTO); 56 | begin 57 | GetAccessRemoteDataProxyInstance.DoLogin(ALoginDTO); 58 | end; 59 | 60 | function GetAccessRemoteDataProxyInstance: IAccessRemoteDataProxy; 61 | begin 62 | if (not Assigned(FDefaultInstance)) then 63 | FDefaultInstance := TAccessRemoteDataProxy.Create; 64 | Result := FDefaultInstance; 65 | end; 66 | 67 | function CreateRemoteDataContext: IRemoteDataContext; 68 | begin 69 | Result:= TRemoteDataContext.Create; 70 | end; 71 | 72 | end. 73 | -------------------------------------------------------------------------------- /samples/Analytics/Analytics.dpr: -------------------------------------------------------------------------------- 1 | program Analytics; 2 | 3 | uses 4 | Vcl.Forms, 5 | MainFormU in 'MainFormU.pas' {Form6} , 6 | BOU in 'BOU.pas', 7 | LogginFormU in 'LogginFormU.pas' {FormLogger}; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | ReportMemoryLeaksOnShutdown := True; 13 | Application.Initialize; 14 | Application.MainFormOnTaskbar := True; 15 | Application.CreateForm(TForm6, Form6); 16 | Application.CreateForm(TFormLogger, FormLogger); 17 | Application.Run; 18 | 19 | end. 20 | -------------------------------------------------------------------------------- /samples/Analytics/Analytics.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/Analytics/Analytics.res -------------------------------------------------------------------------------- /samples/Analytics/BOU.pas: -------------------------------------------------------------------------------- 1 | unit BOU; 2 | 3 | interface 4 | 5 | type 6 | IAnalyticsEvent = interface(IInvokable) 7 | ['{50DABFB6-62D3-42C9-91BC-4D6357D75DF3}'] 8 | procedure SetWhat(const AValue: string); 9 | procedure SetWhen(const AValue: TDateTime); 10 | procedure SetWho(const AValue: string); 11 | 12 | function GetWhat: String; 13 | function GetWhen: TDateTime; 14 | function GetWho: String; 15 | 16 | property What: string read GetWhat write SetWhat; 17 | property When: TDateTime read GetWhen write SetWhen; 18 | property Who: string read GetWho write SetWho; 19 | end; 20 | 21 | TAnalyticsEvent = class(TInterfacedObject, IAnalyticsEvent) 22 | private 23 | FWho: string; 24 | FWhat: string; 25 | FWhen: TDateTime; 26 | procedure SetWhat(const AValue: string); 27 | procedure SetWhen(const AValue: TDateTime); 28 | procedure SetWho(const AValue: string); 29 | function GetWhat: String; 30 | function GetWhen: TDateTime; 31 | function GetWho: String; 32 | public 33 | constructor Create(const What, Who: string; const When: TDateTime); 34 | property What: string read FWhat write SetWhat; 35 | property When: TDateTime read FWhen write SetWhen; 36 | property Who: string read FWho write SetWho; 37 | end; 38 | 39 | implementation 40 | 41 | { TAnalyticsEvent } 42 | 43 | constructor TAnalyticsEvent.Create(const What, Who: string; const When: TDateTime); 44 | begin 45 | FWhat := What; 46 | FWho := Who; 47 | FWhen := When; 48 | end; 49 | 50 | function TAnalyticsEvent.GetWhat: String; 51 | begin 52 | Result:= FWhat; 53 | end; 54 | 55 | function TAnalyticsEvent.GetWhen: TDateTime; 56 | begin 57 | Result:= FWhen; 58 | end; 59 | 60 | function TAnalyticsEvent.GetWho: String; 61 | begin 62 | Result:= FWho; 63 | end; 64 | 65 | procedure TAnalyticsEvent.SetWhat(const AValue: string); 66 | begin 67 | FWhat := AValue; 68 | end; 69 | 70 | procedure TAnalyticsEvent.SetWhen(const AValue: TDateTime); 71 | begin 72 | FWhen := AValue; 73 | end; 74 | 75 | procedure TAnalyticsEvent.SetWho(const AValue: string); 76 | begin 77 | FWho := AValue; 78 | end; 79 | 80 | end. 81 | -------------------------------------------------------------------------------- /samples/Analytics/LogginFormU.dfm: -------------------------------------------------------------------------------- 1 | object FormLogger: TFormLogger 2 | Left = 0 3 | Top = 0 4 | Caption = 'Logger Form' 5 | ClientHeight = 277 6 | ClientWidth = 510 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 | Left = 0 19 | Top = 0 20 | Width = 510 21 | Height = 277 22 | Align = alClient 23 | Lines.Strings = ( 24 | 'Memo1') 25 | TabOrder = 0 26 | end 27 | end 28 | -------------------------------------------------------------------------------- /samples/Analytics/LogginFormU.pas: -------------------------------------------------------------------------------- 1 | unit LogginFormU; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 7 | System.Classes, Vcl.Graphics, EventBus, 8 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, BOU; 9 | 10 | type 11 | TFormLogger = class(TForm) 12 | Memo1: TMemo; 13 | procedure FormCreate(Sender: TObject); 14 | private 15 | { Private declarations } 16 | function GetFormattedAnalyticsEvent(AAnalyticsEvent: IAnalyticsEvent): string; 17 | public 18 | { Public declarations } 19 | [Subscribe] 20 | procedure OnAnalyticsEvent(AAnalyticsEvent: IAnalyticsEvent); 21 | end; 22 | 23 | var 24 | FormLogger: TFormLogger; 25 | 26 | implementation 27 | 28 | {$R *.dfm} 29 | 30 | procedure TFormLogger.FormCreate(Sender: TObject); 31 | begin 32 | Memo1.Lines.Clear; 33 | GlobalEventBus.RegisterSubscriberForEvents(Self); 34 | end; 35 | 36 | function TFormLogger.GetFormattedAnalyticsEvent(AAnalyticsEvent: IAnalyticsEvent): string; 37 | begin 38 | Result := Format('User %s - %s - at %s ', [AAnalyticsEvent.Who, AAnalyticsEvent.What, DateTimeToStr(AAnalyticsEvent.When)]); 39 | end; 40 | 41 | procedure TFormLogger.OnAnalyticsEvent(AAnalyticsEvent: IAnalyticsEvent); 42 | begin 43 | Memo1.Lines.Add(GetFormattedAnalyticsEvent(AAnalyticsEvent)); 44 | end; 45 | 46 | end. 47 | -------------------------------------------------------------------------------- /samples/Analytics/MainFormU.dfm: -------------------------------------------------------------------------------- 1 | object Form6: TForm6 2 | Left = 0 3 | Top = 0 4 | Caption = 'Analytics Form' 5 | ClientHeight = 337 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 | OnResize = FormResize 15 | OnShow = FormShow 16 | PixelsPerInch = 96 17 | TextHeight = 13 18 | object Memo1: TMemo 19 | Left = 8 20 | Top = 128 21 | Width = 273 22 | Height = 201 23 | Lines.Strings = ( 24 | 'Memo1') 25 | TabOrder = 0 26 | OnChange = Memo1Change 27 | end 28 | object Button1: TButton 29 | Left = 8 30 | Top = 97 31 | Width = 273 32 | Height = 25 33 | Caption = 'Click Me!' 34 | TabOrder = 1 35 | OnClick = Button1Click 36 | end 37 | object LabeledEdit1: TLabeledEdit 38 | Left = 8 39 | Top = 24 40 | Width = 121 41 | Height = 21 42 | EditLabel.Width = 22 43 | EditLabel.Height = 13 44 | EditLabel.Caption = 'User' 45 | ReadOnly = True 46 | TabOrder = 2 47 | Text = 'ironman' 48 | end 49 | object RadioGroup1: TRadioGroup 50 | Left = 304 51 | Top = 97 52 | Width = 242 53 | Height = 232 54 | Caption = 'Favorite Food' 55 | Items.Strings = ( 56 | 'Pasta' 57 | 'Pizza' 58 | 'Hamburger' 59 | 'Lasagna') 60 | TabOrder = 3 61 | OnClick = RadioGroup1Click 62 | end 63 | object PrototypeBindSource1: TPrototypeBindSource 64 | AutoActivate = True 65 | AutoPost = False 66 | FieldDefs = < 67 | item 68 | Name = 'ContactName1' 69 | Generator = 'ContactNames' 70 | ReadOnly = False 71 | end 72 | item 73 | Name = 'ContactTitle1' 74 | Generator = 'ContactTitles' 75 | ReadOnly = False 76 | end> 77 | ScopeMappings = <> 78 | Left = 392 79 | Top = 8 80 | end 81 | object BindingsList1: TBindingsList 82 | Methods = <> 83 | OutputConverters = <> 84 | Left = 308 85 | Top = 13 86 | object LinkFillControlToField1: TLinkFillControlToField 87 | Category = 'Quick Bindings' 88 | Track = True 89 | FillDataSource = PrototypeBindSource1 90 | FillDisplayFieldName = 'ContactName1' 91 | AutoFill = True 92 | FillExpressions = <> 93 | FillHeaderExpressions = <> 94 | FillBreakGroups = <> 95 | end 96 | object LinkFillControlToField2: TLinkFillControlToField 97 | Category = 'Quick Bindings' 98 | Track = True 99 | FillDataSource = PrototypeBindSource1 100 | FillDisplayFieldName = 'ContactName1' 101 | AutoFill = True 102 | FillExpressions = <> 103 | FillHeaderExpressions = <> 104 | FillBreakGroups = <> 105 | end 106 | end 107 | end 108 | -------------------------------------------------------------------------------- /samples/Analytics/MainFormU.pas: -------------------------------------------------------------------------------- 1 | unit MainFormU; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 7 | System.Classes, Vcl.Graphics, 8 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, 9 | LogginFormU, Data.Bind.GenData, System.Rtti, System.Bindings.Outputs, 10 | Data.Bind.EngExt, Vcl.Bind.DBEngExt, Data.Bind.Components, 11 | Data.Bind.ObjectScope; 12 | 13 | type 14 | TForm6 = class(TForm) 15 | Memo1: TMemo; 16 | Button1: TButton; 17 | LabeledEdit1: TLabeledEdit; 18 | PrototypeBindSource1: TPrototypeBindSource; 19 | BindingsList1: TBindingsList; 20 | LinkFillControlToField1: TLinkFillControlToField; 21 | LinkFillControlToField2: TLinkFillControlToField; 22 | RadioGroup1: TRadioGroup; 23 | procedure Button1Click(Sender: TObject); 24 | procedure FormShow(Sender: TObject); 25 | procedure Memo1Change(Sender: TObject); 26 | procedure FormResize(Sender: TObject); 27 | procedure RadioGroup1Click(Sender: TObject); 28 | private 29 | { Private declarations } 30 | public 31 | { Public declarations } 32 | end; 33 | 34 | var 35 | Form6: TForm6; 36 | 37 | implementation 38 | 39 | uses 40 | BOU, EventBus, EventBus.Helpers, System.TypInfo; 41 | 42 | {$R *.dfm} 43 | 44 | function BuildAnalyticsEvent(const What: string): IAnalyticsEvent; 45 | begin 46 | Result := TAnalyticsEvent.Create(What, Form6.LabeledEdit1.Text, Now); 47 | end; 48 | 49 | procedure TForm6.Button1Click(Sender: TObject); 50 | begin 51 | GlobalEventBus.Post(BuildAnalyticsEvent('Button1 Clicked'), ''); 52 | ShowMessage('You clicked ' + Button1.Name); 53 | end; 54 | 55 | procedure TForm6.FormResize(Sender: TObject); 56 | begin 57 | GlobalEventBus.Post(BuildAnalyticsEvent('Analytics form changed size'), ''); 58 | end; 59 | 60 | procedure TForm6.FormShow(Sender: TObject); 61 | begin 62 | FormLogger.Show; 63 | end; 64 | 65 | procedure TForm6.Memo1Change(Sender: TObject); 66 | begin 67 | GlobalEventBus.Post(BuildAnalyticsEvent('Memo1 Changed'), ''); 68 | end; 69 | 70 | procedure TForm6.RadioGroup1Click(Sender: TObject); 71 | var 72 | LChoice: string; 73 | begin 74 | LChoice := RadioGroup1.Items[RadioGroup1.ItemIndex]; 75 | GlobalEventBus.Post(BuildAnalyticsEvent(LChoice + ' is actual favorite food '), ''); 76 | end; 77 | 78 | end. 79 | -------------------------------------------------------------------------------- /samples/SamplesProjectGroup.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {06B0EBCF-260A-4992-A219-B700B373FA10} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | Default.Personality.12 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /samples/WeatherStation/HumidityFMX.fmx: -------------------------------------------------------------------------------- 1 | object HumidityForm: THumidityForm 2 | Left = 0 3 | Top = 0 4 | BorderStyle = ToolWindow 5 | Caption = 'Weather Station' 6 | ClientHeight = 180 7 | ClientWidth = 250 8 | Visible = True 9 | FormFactor.Width = 320 10 | FormFactor.Height = 480 11 | FormFactor.Devices = [Desktop] 12 | OnCreate = FormCreate 13 | DesignerMasterStyle = 0 14 | object Label2: TLabel 15 | Align = Bottom 16 | AutoSize = True 17 | StyledSettings = [Family, Style] 18 | Margins.Left = 10.000000000000000000 19 | Margins.Top = 10.000000000000000000 20 | Margins.Right = 10.000000000000000000 21 | Margins.Bottom = 10.000000000000000000 22 | Position.X = 10.000000000000000000 23 | Position.Y = 103.000000000000000000 24 | Size.Width = 230.000000000000000000 25 | Size.Height = 67.000000000000000000 26 | Size.PlatformDefault = False 27 | TextSettings.Font.Size = 50.000000000000000000 28 | TextSettings.FontColor = claBlue 29 | TextSettings.HorzAlign = Center 30 | Text = '13 '#176'C' 31 | end 32 | object Label1: TLabel 33 | Align = Top 34 | AutoSize = True 35 | StyledSettings = [Family, Style, FontColor] 36 | Margins.Left = 10.000000000000000000 37 | Margins.Top = 10.000000000000000000 38 | Margins.Right = 10.000000000000000000 39 | Margins.Bottom = 10.000000000000000000 40 | Position.X = 10.000000000000000000 41 | Position.Y = 10.000000000000000000 42 | Size.Width = 230.000000000000000000 43 | Size.Height = 54.000000000000000000 44 | Size.PlatformDefault = False 45 | TextSettings.Font.Size = 40.000000000000000000 46 | TextSettings.HorzAlign = Center 47 | Text = 'Humidity' 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /samples/WeatherStation/HumidityFMX.pas: -------------------------------------------------------------------------------- 1 | unit HumidityFMX; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, System.Types, System.UITypes, System.Classes, 7 | System.Variants, 8 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, 9 | FMX.Controls.Presentation, FMX.StdCtrls, ModelU, EventBus; 10 | 11 | type 12 | THumidityForm = class(TForm) 13 | Label2: TLabel; 14 | Label1: TLabel; 15 | procedure FormCreate(Sender: TObject); 16 | private 17 | { Private declarations } 18 | public 19 | { Public declarations } 20 | [Subscribe(TThreadMode.Main)] 21 | procedure OnWeatherInfoEvent(AWeatherInfo: IWeatherInformation); 22 | end; 23 | 24 | var 25 | HumidityForm: THumidityForm; 26 | 27 | implementation 28 | 29 | {$R *.fmx} 30 | { THumidityForm } 31 | 32 | procedure THumidityForm.FormCreate(Sender: TObject); 33 | begin 34 | GlobalEventBus.RegisterSubscriberForEvents(Self); 35 | end; 36 | 37 | procedure THumidityForm.OnWeatherInfoEvent(AWeatherInfo: IWeatherInformation); 38 | begin 39 | Label2.Text := Format('%d %', [AWeatherInfo.Humidity]); 40 | end; 41 | 42 | end. 43 | -------------------------------------------------------------------------------- /samples/WeatherStation/InterfacedForm.fmx: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form1' 5 | ClientHeight = 480 6 | ClientWidth = 640 7 | FormFactor.Width = 320 8 | FormFactor.Height = 480 9 | FormFactor.Devices = [Desktop] 10 | DesignerMasterStyle = 0 11 | end 12 | -------------------------------------------------------------------------------- /samples/WeatherStation/InterfacedForm.pas: -------------------------------------------------------------------------------- 1 | unit InterfacedForm; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, 7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs; 8 | 9 | type 10 | TForm1 = class(TForm) 11 | private 12 | { Private declarations } 13 | public 14 | { Public declarations } 15 | end; 16 | 17 | var 18 | Form1: TForm1; 19 | 20 | implementation 21 | 22 | {$R *.fmx} 23 | 24 | end. 25 | -------------------------------------------------------------------------------- /samples/WeatherStation/ModelU.pas: -------------------------------------------------------------------------------- 1 | unit ModelU; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils; 7 | 8 | type 9 | TWeatherType = (Sunny = 0, Cloudy = 1, Rainy = 2); 10 | 11 | IWeatherInformation = interface 12 | ['{669F0E41-DE90-470E-A90D-94FE537CB735}'] 13 | procedure SetHumidity(const Value: Integer); 14 | procedure SetPressure(const Value: Double); 15 | procedure SetTemperature(const Value: Integer); 16 | procedure SetWeatherType(const Value: TWeatherType); 17 | function GetHumidity: Integer; 18 | function GetPressure: Double; 19 | function GetTemperature: Integer; 20 | function GetType: TWeatherType; 21 | property WeatherType: TWeatherType read GetType write SetWeatherType; 22 | property Temperature: Integer read GetTemperature write SetTemperature; 23 | property Humidity: Integer read GetHumidity write SetHumidity; 24 | property Pressure: Double read GetPressure write SetPressure; 25 | end; 26 | 27 | TWeatherModel = class(TObject) 28 | private 29 | class var FStopped: Boolean; 30 | public 31 | class procedure StartPolling; 32 | class procedure StopPolling; 33 | end; 34 | 35 | implementation 36 | 37 | uses 38 | System.Threading, EventBus, System.Classes; 39 | 40 | type 41 | TWeatherInformation = class(TInterfacedObject, IWeatherInformation) 42 | private 43 | FHumidity: Integer; 44 | FWeatherType: TWeatherType; 45 | FPressure: Double; 46 | FTemperature: Integer; 47 | procedure SetHumidity(const Value: Integer); 48 | procedure SetPressure(const Value: Double); 49 | procedure SetTemperature(const Value: Integer); 50 | procedure SetWeatherType(const Value: TWeatherType); 51 | function GetHumidity: Integer; 52 | function GetPressure: Double; 53 | function GetTemperature: Integer; 54 | function GetType: TWeatherType; 55 | public 56 | property WeatherType: TWeatherType read GetType write SetWeatherType; 57 | property Temperature: Integer read GetTemperature write SetTemperature; 58 | property Humidity: Integer read GetHumidity write SetHumidity; 59 | property Pressure: Double read GetPressure write SetPressure; 60 | end; 61 | 62 | function GetRandomWeatherInfo: IWeatherInformation; 63 | begin 64 | Result := TWeatherInformation.Create; 65 | Result.Temperature := -10 + Random(41); 66 | Result.WeatherType := TWeatherType(Random(3)); 67 | Result.Humidity := 30 + Random(41); 68 | Result.Pressure := 20 + Random(11); 69 | end; 70 | 71 | { TWeatherModel } 72 | 73 | class procedure TWeatherModel.StartPolling; 74 | begin 75 | FStopped:= False; 76 | TTask.Create( 77 | procedure 78 | begin 79 | while not FStopped do begin 80 | // simulate a sensor 81 | GlobalEventBus.Post(GetRandomWeatherInfo, ''); 82 | TThread.Sleep(3000); 83 | end 84 | end 85 | ).Start; 86 | end; 87 | 88 | class procedure TWeatherModel.StopPolling; 89 | begin 90 | FStopped:= True; 91 | end; 92 | 93 | { TWeatherInformation } 94 | 95 | function TWeatherInformation.GetHumidity: Integer; 96 | begin 97 | Result:= FHumidity; 98 | end; 99 | 100 | function TWeatherInformation.GetPressure: Double; 101 | begin 102 | Result:= FPressure; 103 | end; 104 | 105 | function TWeatherInformation.GetTemperature: Integer; 106 | begin 107 | Result:= FTemperature; 108 | end; 109 | 110 | function TWeatherInformation.GetType: TWeatherType; 111 | begin 112 | Result:= FWeatherType; 113 | end; 114 | 115 | procedure TWeatherInformation.SetHumidity(const Value: Integer); 116 | begin 117 | FHumidity := Value; 118 | end; 119 | 120 | procedure TWeatherInformation.SetPressure(const Value: Double); 121 | begin 122 | FPressure := Value; 123 | end; 124 | 125 | procedure TWeatherInformation.SetTemperature(const Value: Integer); 126 | begin 127 | FTemperature := Value; 128 | end; 129 | 130 | procedure TWeatherInformation.SetWeatherType(const Value: TWeatherType); 131 | begin 132 | FWeatherType := Value; 133 | end; 134 | 135 | end. 136 | -------------------------------------------------------------------------------- /samples/WeatherStation/PaintedFMX.pas: -------------------------------------------------------------------------------- 1 | unit PaintedFMX; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, System.Types, System.UITypes, System.Classes, 7 | System.Variants, 8 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Objects, 9 | System.ImageList, FMX.ImgList, ModelU, EventBus; 10 | 11 | type 12 | TPaintedForm = class(TForm) 13 | Image1: TImage; 14 | ImageList1: TImageList; 15 | procedure FormCreate(Sender: TObject); 16 | private 17 | { Private declarations } 18 | public 19 | { Public declarations } 20 | [Subscribe(TThreadMode.Main)] 21 | procedure OnWeatherInfoEvent(AWeatherInfo: IWeatherInformation); 22 | end; 23 | 24 | var 25 | PaintedForm: TPaintedForm; 26 | 27 | implementation 28 | 29 | {$R *.fmx} 30 | { TPaintedForm } 31 | 32 | procedure TPaintedForm.FormCreate(Sender: TObject); 33 | begin 34 | GlobalEventBus.RegisterSubscriberForEvents(Self); 35 | end; 36 | 37 | procedure TPaintedForm.OnWeatherInfoEvent(AWeatherInfo: IWeatherInformation); 38 | begin 39 | Image1.Bitmap := ImageList1.Bitmap(Image1.Size.Size, Integer(AWeatherInfo.WeatherType)); 40 | end; 41 | 42 | end. 43 | -------------------------------------------------------------------------------- /samples/WeatherStation/PressureFMX.fmx: -------------------------------------------------------------------------------- 1 | object PressureForm: TPressureForm 2 | Left = 0 3 | Top = 0 4 | BorderStyle = ToolWindow 5 | Caption = 'Weather Station' 6 | ClientHeight = 180 7 | ClientWidth = 250 8 | Visible = True 9 | FormFactor.Width = 320 10 | FormFactor.Height = 480 11 | FormFactor.Devices = [Desktop] 12 | OnCreate = FormCreate 13 | DesignerMasterStyle = 0 14 | object Label2: TLabel 15 | Align = Bottom 16 | AutoSize = True 17 | StyledSettings = [Family, Style] 18 | Margins.Left = 10.000000000000000000 19 | Margins.Top = 10.000000000000000000 20 | Margins.Right = 10.000000000000000000 21 | Margins.Bottom = 10.000000000000000000 22 | Position.X = 10.000000000000000000 23 | Position.Y = 103.000000000000000000 24 | Size.Width = 230.000000000000000000 25 | Size.Height = 67.000000000000000000 26 | Size.PlatformDefault = False 27 | TextSettings.Font.Size = 50.000000000000000000 28 | TextSettings.FontColor = claBlue 29 | TextSettings.HorzAlign = Center 30 | Text = '13 '#176'C' 31 | end 32 | object Label1: TLabel 33 | Align = Top 34 | AutoSize = True 35 | StyledSettings = [Family, Style, FontColor] 36 | Margins.Left = 10.000000000000000000 37 | Margins.Top = 10.000000000000000000 38 | Margins.Right = 10.000000000000000000 39 | Margins.Bottom = 10.000000000000000000 40 | Position.X = 10.000000000000000000 41 | Position.Y = 10.000000000000000000 42 | Size.Width = 230.000000000000000000 43 | Size.Height = 54.000000000000000000 44 | Size.PlatformDefault = False 45 | TextSettings.Font.Size = 40.000000000000000000 46 | TextSettings.HorzAlign = Center 47 | Text = 'Pressure' 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /samples/WeatherStation/PressureFMX.pas: -------------------------------------------------------------------------------- 1 | unit PressureFMX; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, System.Types, System.UITypes, System.Classes, 7 | System.Variants, 8 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, 9 | FMX.Controls.Presentation, FMX.StdCtrls, ModelU, EventBus; 10 | 11 | type 12 | TPressureForm = class(TForm) 13 | Label2: TLabel; 14 | Label1: TLabel; 15 | procedure FormCreate(Sender: TObject); 16 | private 17 | { Private declarations } 18 | public 19 | { Public declarations } 20 | [Subscribe(TThreadMode.Main)] 21 | procedure OnWeatherInfoEvent(aWeatherInfo: IWeatherInformation); 22 | end; 23 | 24 | var 25 | PressureForm: TPressureForm; 26 | 27 | implementation 28 | 29 | {$R *.fmx} 30 | { TPressureForm } 31 | 32 | procedure TPressureForm.FormCreate(Sender: TObject); 33 | begin 34 | GlobalEventBus.RegisterSubscriberForEvents(Self); 35 | end; 36 | 37 | procedure TPressureForm.OnWeatherInfoEvent(aWeatherInfo: IWeatherInformation); 38 | begin 39 | Label2.Text := Format(' %d ', [Trunc(aWeatherInfo.Pressure)]); 40 | end; 41 | 42 | end. 43 | -------------------------------------------------------------------------------- /samples/WeatherStation/TemperatureFMX.fmx: -------------------------------------------------------------------------------- 1 | object TemperatureForm: TTemperatureForm 2 | Left = 0 3 | Top = 0 4 | BorderStyle = ToolWindow 5 | Caption = 'Weather Station' 6 | ClientHeight = 180 7 | ClientWidth = 250 8 | Visible = True 9 | FormFactor.Width = 320 10 | FormFactor.Height = 480 11 | FormFactor.Devices = [Desktop] 12 | OnCreate = FormCreate 13 | OnDestroy = FormDestroy 14 | DesignerMasterStyle = 0 15 | object Label1: TLabel 16 | Align = Top 17 | AutoSize = True 18 | StyledSettings = [Family, Style, FontColor] 19 | Margins.Left = 10.000000000000000000 20 | Margins.Top = 10.000000000000000000 21 | Margins.Right = 10.000000000000000000 22 | Margins.Bottom = 10.000000000000000000 23 | Position.X = 10.000000000000000000 24 | Position.Y = 10.000000000000000000 25 | Size.Width = 230.000000000000000000 26 | Size.Height = 54.000000000000000000 27 | Size.PlatformDefault = False 28 | TextSettings.Font.Size = 40.000000000000000000 29 | TextSettings.HorzAlign = Center 30 | Text = 'Temperature' 31 | end 32 | object Label2: TLabel 33 | Align = Bottom 34 | AutoSize = True 35 | StyledSettings = [Family, Style] 36 | Margins.Left = 10.000000000000000000 37 | Margins.Top = 10.000000000000000000 38 | Margins.Right = 10.000000000000000000 39 | Margins.Bottom = 10.000000000000000000 40 | Position.X = 10.000000000000000000 41 | Position.Y = 103.000000000000000000 42 | Size.Width = 230.000000000000000000 43 | Size.Height = 67.000000000000000000 44 | Size.PlatformDefault = False 45 | TextSettings.Font.Size = 50.000000000000000000 46 | TextSettings.FontColor = claBlue 47 | TextSettings.HorzAlign = Center 48 | Text = '13 '#176'C' 49 | end 50 | end 51 | -------------------------------------------------------------------------------- /samples/WeatherStation/TemperatureFMX.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/WeatherStation/TemperatureFMX.pas -------------------------------------------------------------------------------- /samples/WeatherStation/WeatherStation.dpr: -------------------------------------------------------------------------------- 1 | program WeatherStation; 2 | 3 | uses 4 | System.StartUpCopy, 5 | FMX.Forms, 6 | TemperatureFMX in 'TemperatureFMX.pas' {TemperatureForm} , 7 | PressureFMX in 'PressureFMX.pas' {PressureForm} , 8 | HumidityFMX in 'HumidityFMX.pas' {HumidityForm} , 9 | PaintedFMX in 'PaintedFMX.pas' {PaintedForm} , 10 | ModelU in 'ModelU.pas'; 11 | 12 | {$R *.res} 13 | 14 | begin 15 | ReportMemoryLeaksOnShutdown:= True; 16 | Application.Initialize; 17 | Application.CreateForm(TTemperatureForm, TemperatureForm); 18 | Application.CreateForm(TPressureForm, PressureForm); 19 | Application.CreateForm(THumidityForm, HumidityForm); 20 | Application.CreateForm(TPaintedForm, PaintedForm); 21 | Application.Run; 22 | 23 | end. 24 | -------------------------------------------------------------------------------- /samples/WeatherStation/WeatherStation.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/WeatherStation/WeatherStation.res -------------------------------------------------------------------------------- /samples/WeatherStation/data/cloudy.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/WeatherStation/data/cloudy.jpg -------------------------------------------------------------------------------- /samples/WeatherStation/data/rainy.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/WeatherStation/data/rainy.png -------------------------------------------------------------------------------- /samples/WeatherStation/data/sunny.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/WeatherStation/data/sunny.jpeg -------------------------------------------------------------------------------- /samples/vclmessaging/EventU.pas: -------------------------------------------------------------------------------- 1 | unit EventU; 2 | 3 | interface 4 | 5 | type 6 | IMemoChangeEvent = interface 7 | ['{DCFE64D2-9BA8-4949-9BB1-F5CD672E51A2}'] 8 | procedure SetText(const Value: string); 9 | function GetText: String; 10 | property Text: string read GetText write SetText; 11 | end; 12 | 13 | ICheckBoxEvent = interface 14 | ['{2212C465-BD01-4E0E-8468-12FB5DCCA33A}'] 15 | procedure SetChecked(const Value: boolean); 16 | function GetChecked: Boolean; 17 | property Checked: boolean read GetChecked write SetChecked; 18 | end; 19 | 20 | function GetMemoEvent: IMemoChangeEvent; 21 | function GetCheckBoxEvent: ICheckBoxEvent; 22 | 23 | implementation 24 | 25 | type 26 | TMemoChangeEvent = class(TInterfacedObject, IMemoChangeEvent) 27 | private 28 | FText: string; 29 | procedure SetText(const Value: string); 30 | function GetText: String; 31 | public 32 | property Text: string read GetText write SetText; 33 | end; 34 | 35 | TCheckBoxEvent = class(TInterfacedObject, ICheckBoxEvent) 36 | private 37 | FChecked: boolean; 38 | procedure SetChecked(const Value: boolean); 39 | function GetChecked: Boolean; 40 | public 41 | property Checked: boolean read GetChecked write SetChecked; 42 | end; 43 | 44 | { TMemoChange } 45 | 46 | function TMemoChangeEvent.GetText: String; 47 | begin 48 | Result:= FText; 49 | end; 50 | 51 | procedure TMemoChangeEvent.SetText(const Value: string); 52 | begin 53 | FText := Value; 54 | end; 55 | 56 | { TCheckBoxEvent } 57 | 58 | function TCheckBoxEvent.GetChecked: Boolean; 59 | begin 60 | Result:= FChecked; 61 | end; 62 | 63 | procedure TCheckBoxEvent.SetChecked(const Value: boolean); 64 | begin 65 | FChecked := Value; 66 | end; 67 | 68 | function GetMemoEvent: IMemoChangeEvent; 69 | begin 70 | Result:= TMemoChangeEvent.Create; 71 | end; 72 | 73 | function GetCheckBoxEvent: ICheckBoxEvent; 74 | begin 75 | Result:= TCheckBoxEvent.Create; 76 | end; 77 | 78 | end. 79 | -------------------------------------------------------------------------------- /samples/vclmessaging/MainFormU.dfm: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | Caption = 'frmMain' 5 | ClientHeight = 239 6 | ClientWidth = 444 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -19 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | PixelsPerInch = 96 15 | TextHeight = 23 16 | object Memo1: TMemo 17 | Left = 0 18 | Top = 0 19 | Width = 444 20 | Height = 208 21 | Align = alClient 22 | TabOrder = 0 23 | OnChange = Memo1Change 24 | end 25 | object Panel1: TPanel 26 | Left = 0 27 | Top = 208 28 | Width = 444 29 | Height = 31 30 | Align = alBottom 31 | TabOrder = 1 32 | object CheckBox1: TCheckBox 33 | Left = 8 34 | Top = 6 35 | Width = 121 36 | Height = 17 37 | Caption = 'Click on me!' 38 | TabOrder = 0 39 | OnClick = CheckBox1Click 40 | end 41 | end 42 | end 43 | -------------------------------------------------------------------------------- /samples/vclmessaging/MainFormU.pas: -------------------------------------------------------------------------------- 1 | unit MainFormU; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 7 | System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, 8 | Vcl.StdCtrls, Vcl.ExtCtrls; 9 | 10 | type 11 | TfrmMain = class(TForm) 12 | Memo1: TMemo; 13 | Panel1: TPanel; 14 | CheckBox1: TCheckBox; 15 | procedure Memo1Change(Sender: TObject); 16 | procedure CheckBox1Click(Sender: TObject); 17 | private 18 | { Private declarations } 19 | public 20 | { Public declarations } 21 | end; 22 | 23 | var 24 | FrmMain: TfrmMain; 25 | 26 | implementation 27 | 28 | uses 29 | EventBus, EventU; 30 | 31 | {$R *.dfm} 32 | 33 | procedure TfrmMain.CheckBox1Click(Sender: TObject); 34 | var 35 | LEvent: ICheckBoxEvent; 36 | begin 37 | LEvent := GetCheckBoxEvent; 38 | LEvent.Checked := CheckBox1.Checked; 39 | GlobalEventBus.Post(LEvent); 40 | end; 41 | 42 | procedure TfrmMain.Memo1Change(Sender: TObject); 43 | var 44 | LEvent: IMemoChangeEvent; 45 | begin 46 | LEvent := GetMemoEvent; 47 | LEvent.Text := Memo1.Lines.Text; 48 | GlobalEventBus.Post(LEvent); 49 | GlobalEventBus.Post('MemoChange', Memo1.Lines.Text); 50 | end; 51 | 52 | end. 53 | -------------------------------------------------------------------------------- /samples/vclmessaging/SecondFormU.dfm: -------------------------------------------------------------------------------- 1 | object frmSecond: TfrmSecond 2 | Left = 658 3 | Top = 62 4 | ClientHeight = 208 5 | ClientWidth = 350 6 | Color = clBtnFace 7 | Font.Charset = DEFAULT_CHARSET 8 | Font.Color = clWindowText 9 | Font.Height = -11 10 | Font.Name = 'Tahoma' 11 | Font.Style = [] 12 | OldCreateOrder = False 13 | Position = poDesigned 14 | Visible = True 15 | PixelsPerInch = 96 16 | TextHeight = 13 17 | object MemoObserver: TMemo 18 | Left = 0 19 | Top = 36 20 | Width = 350 21 | Height = 155 22 | Align = alClient 23 | Font.Charset = DEFAULT_CHARSET 24 | Font.Color = clRed 25 | Font.Height = -19 26 | Font.Name = 'Tahoma' 27 | Font.Style = [] 28 | ParentFont = False 29 | ReadOnly = True 30 | TabOrder = 0 31 | end 32 | object Panel1: TPanel 33 | Left = 0 34 | Top = 0 35 | Width = 350 36 | Height = 36 37 | Align = alTop 38 | TabOrder = 1 39 | object Label1: TLabel 40 | AlignWithMargins = True 41 | Left = 4 42 | Top = 4 43 | Width = 225 44 | Height = 28 45 | Align = alClient 46 | Caption = 'Second Form' 47 | Font.Charset = DEFAULT_CHARSET 48 | Font.Color = clWindowText 49 | Font.Height = -19 50 | Font.Name = 'Tahoma' 51 | Font.Style = [] 52 | ParentFont = False 53 | ExplicitWidth = 111 54 | ExplicitHeight = 23 55 | end 56 | object CheckBox1: TCheckBox 57 | Left = 232 58 | Top = 1 59 | Width = 117 60 | Height = 34 61 | Align = alRight 62 | Caption = 'Mirror' 63 | TabOrder = 0 64 | end 65 | end 66 | object CheckBox2: TCheckBox 67 | Left = 0 68 | Top = 191 69 | Width = 350 70 | Height = 17 71 | Align = alBottom 72 | Caption = 'Register/Unregister' 73 | TabOrder = 2 74 | OnClick = CheckBox2Click 75 | end 76 | end 77 | -------------------------------------------------------------------------------- /samples/vclmessaging/SecondFormU.pas: -------------------------------------------------------------------------------- 1 | unit SecondFormU; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 7 | System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, 8 | Vcl.StdCtrls, Vcl.ExtCtrls, EventU, EventBus; 9 | 10 | type 11 | TfrmSecond = class(TForm) 12 | MemoObserver: TMemo; 13 | Panel1: TPanel; 14 | Label1: TLabel; 15 | CheckBox1: TCheckBox; 16 | CheckBox2: TCheckBox; 17 | procedure CheckBox2Click(Sender: TObject); 18 | private 19 | { Private declarations } 20 | public 21 | { Public declarations } 22 | [Subscribe] 23 | procedure OnMemoChange(AEvent: IMemoChangeEvent); 24 | [Subscribe] 25 | procedure OnCheckBoxChange(AEvent: ICheckBoxEvent); 26 | end; 27 | 28 | var 29 | FrmSecond: TfrmSecond; 30 | 31 | implementation 32 | 33 | {$R *.dfm} 34 | 35 | procedure TfrmSecond.CheckBox2Click(Sender: TObject); 36 | begin 37 | if (CheckBox2.Checked) then 38 | GlobalEventBus.RegisterSubscriberForEvents(Self) 39 | else 40 | GlobalEventBus.UnregisterForEvents(Self); 41 | end; 42 | 43 | procedure TfrmSecond.OnCheckBoxChange(AEvent: ICheckBoxEvent); 44 | begin 45 | CheckBox1.Checked := AEvent.Checked; 46 | end; 47 | 48 | procedure TfrmSecond.OnMemoChange(AEvent: IMemoChangeEvent); 49 | begin 50 | MemoObserver.Lines.Text := AEvent.Text; 51 | end; 52 | 53 | end. 54 | -------------------------------------------------------------------------------- /samples/vclmessaging/ThirdFormU.dfm: -------------------------------------------------------------------------------- 1 | object frmThird: TfrmThird 2 | Left = 144 3 | Top = 399 4 | Caption = 'frmThird' 5 | ClientHeight = 308 6 | ClientWidth = 413 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 | Position = poDesigned 15 | Visible = True 16 | OnCreate = FormCreate 17 | PixelsPerInch = 96 18 | TextHeight = 13 19 | object PaintBox1: TPaintBox 20 | Left = 0 21 | Top = 0 22 | Width = 413 23 | Height = 308 24 | Align = alClient 25 | OnPaint = PaintBox1Paint 26 | ExplicitLeft = 168 27 | ExplicitTop = 80 28 | ExplicitWidth = 105 29 | ExplicitHeight = 105 30 | end 31 | end 32 | -------------------------------------------------------------------------------- /samples/vclmessaging/ThirdFormU.pas: -------------------------------------------------------------------------------- 1 | unit ThirdFormU; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 7 | System.Classes, Vcl.Graphics, EventU, EventBus, 8 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls; 9 | 10 | type 11 | TfrmThird = class(TForm) 12 | PaintBox1: TPaintBox; 13 | procedure PaintBox1Paint(Sender: TObject); 14 | procedure FormCreate(Sender: TObject); 15 | private 16 | FMessage: string; 17 | { Private declarations } 18 | public 19 | { Public declarations } 20 | [Channel('MemoChange')] 21 | procedure OnMemoChange(aMsg: String); 22 | end; 23 | 24 | var 25 | FrmThird: TfrmThird; 26 | 27 | implementation 28 | 29 | uses 30 | Vcl.GraphUtil; 31 | 32 | {$R *.dfm} 33 | 34 | procedure TfrmThird.FormCreate(Sender: TObject); 35 | begin 36 | GlobalEventBus.RegisterSubscriberForChannels(self); 37 | end; 38 | 39 | procedure TfrmThird.OnMemoChange(aMsg: String); 40 | begin 41 | FMessage := aMsg; 42 | PaintBox1.Repaint; 43 | end; 44 | 45 | procedure TfrmThird.PaintBox1Paint(Sender: TObject); 46 | var 47 | R: TRect; 48 | begin 49 | R := ClientRect; 50 | GradientFillCanvas(PaintBox1.Canvas, clRed, clWhite, R, TGradientDirection.gdVertical); 51 | InflateRect(R, -5, -5); 52 | PaintBox1.Canvas.Brush.Style := bsClear; 53 | PaintBox1.Canvas.Font.Size := 18; 54 | PaintBox1.Canvas.TextRect(R, FMessage, [TTextFormats.tfWordBreak, TTextFormats.tfCenter]); 55 | end; 56 | 57 | end. 58 | -------------------------------------------------------------------------------- /samples/vclmessaging/VCLMessaging.dpr: -------------------------------------------------------------------------------- 1 | program VCLMessaging; 2 | 3 | uses 4 | Vcl.Forms, 5 | MainFormU in 'MainFormU.pas' {frmMain} , 6 | SecondFormU in 'SecondFormU.pas' {frmSecond} , 7 | ThirdFormU in 'ThirdFormU.pas' {frmThird} , 8 | EventU in 'EventU.pas'; 9 | 10 | {$R *.res} 11 | 12 | begin 13 | 14 | ReportMemoryLeaksOnShutdown := true; 15 | 16 | Application.Initialize; 17 | Application.MainFormOnTaskbar := true; 18 | Application.CreateForm(TfrmMain, FrmMain); 19 | Application.CreateForm(TfrmSecond, FrmSecond); 20 | Application.CreateForm(TfrmThird, FrmThird); 21 | Application.Run; 22 | 23 | end. 24 | -------------------------------------------------------------------------------- /samples/vclmessaging/VCLMessaging.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/samples/vclmessaging/VCLMessaging.res -------------------------------------------------------------------------------- /source/EventBus.Core.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************* 2 | Copyright 2016-2020 Daniele Spinetti 3 | 4 | Licensed under the Apache License, Version 2.0 (the "License"); 5 | you may not use this file except in compliance with the License. 6 | You may obtain a copy of the License at 7 | 8 | http://www.apache.org/licenses/LICENSE-2.0 9 | 10 | Unless required by applicable law or agreed to in writing, software 11 | distributed under the License is distributed on an "AS IS" BASIS, 12 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | See the License for the specific language governing permissions and 14 | limitations under the License. 15 | ********************************************************************************} 16 | 17 | unit EventBus.Core; 18 | 19 | interface 20 | 21 | uses 22 | EventBus; 23 | 24 | type 25 | TEventBusFactory = class 26 | strict private 27 | class var FGlobalEventBus: IEventBus; 28 | class constructor Create; 29 | public 30 | function CreateEventBus: IEventBus; 31 | class property GlobalEventBus: IEventBus read FGlobalEventBus; 32 | end; 33 | 34 | implementation 35 | 36 | uses 37 | System.Classes, 38 | System.Generics.Collections, 39 | System.Rtti, 40 | System.SysUtils, 41 | {$IF CompilerVersion >= 28.0} 42 | System.Threading, 43 | {$ENDIF} 44 | EventBus.Helpers, 45 | EventBus.Subscribers; 46 | 47 | type 48 | {$REGION 'Type aliases to improve readability'} 49 | TSubscriptions = TList; 50 | TMethodCategory = string; 51 | TMethodCategories = TList; 52 | TMethodCategoryToSubscriptionsMap = TObjectDictionary; 53 | TSubscriberToMethodCategoriesMap = TObjectDictionary; 54 | 55 | TAttributeName = string; 56 | TMethodCategoryToSubscriptionsByAttributeName = TObjectDictionary; 57 | TSubscriberToMethodCategoriesByAttributeName = TObjectDictionary; 58 | {$ENDREGION} 59 | 60 | TEventBus = class(TInterfacedObject, IEventBus) 61 | strict private 62 | FDebThreadPool: TThreadPool; 63 | FCategoryToSubscriptionsByAttrName: TMethodCategoryToSubscriptionsByAttributeName; 64 | FMultiReadExclWriteSync: TMultiReadExclusiveWriteSynchronizer; 65 | FSubscriberToCategoriesByAttrName: TSubscriberToMethodCategoriesByAttributeName; 66 | 67 | procedure InvokeSubscriber(ASubscription: IDEBSubscription; const Args: array of TValue); 68 | function IsRegistered(ASubscriber: TObject): Boolean; 69 | procedure RegisterSubscriber(ASubscriber: TObject; ARaiseExcIfEmpty: Boolean); 70 | procedure Subscribe(ASubscriber: TObject; ASubscriberMethod: TSubscriberMethod); 71 | procedure UnregisterSubscriber(ASubscriber: TObject); 72 | procedure Unsubscribe(ASubscriber: TObject; const AMethodCategory: TMethodCategory); 73 | 74 | function RemoveSubscription(ASubscriber: TObject; const ACategory: String): IDEBSubscription; 75 | protected 76 | procedure PostToChannel(ASubscription: IDEBSubscription; const AMessage: string; AIsMainThread: Boolean); virtual; 77 | procedure PostToSubscription(ASubscription: IDEBSubscription; const AEvent: IInterface; AIsMainThread: Boolean); virtual; 78 | public 79 | constructor Create; virtual; 80 | destructor Destroy; override; 81 | 82 | {$REGION'IEventBus interface methods'} 83 | function IsRegisteredForChannels(ASubscriber: TObject): Boolean; 84 | function IsRegisteredForEvents(ASubscriber: TObject): Boolean; 85 | procedure Post(const AChannel: string; const AMessage: string); overload; 86 | procedure Post(const AEvent: IInterface; const AContext: string = ''); overload; 87 | procedure RegisterSubscriberForChannels(ASubscriber: TObject); 88 | procedure SilentRegisterSubscriberForChannels(ASubscriber: TObject); 89 | procedure RegisterSubscriberForEvents(ASubscriber: TObject); 90 | procedure SilentRegisterSubscriberForEvents(ASubscriber: TObject); 91 | procedure RegisterNewContext(ASubscriber: TObject; AEvent: IInterface; const AOldContext: String; const ANewContext: String); 92 | procedure UnregisterForChannels(ASubscriber: TObject); 93 | procedure UnregisterForEvents(ASubscriber: TObject); 94 | {$ENDREGION} 95 | end; 96 | 97 | constructor TEventBus.Create; 98 | begin 99 | inherited Create; 100 | FDebThreadPool := TThreadPool.Create; 101 | FMultiReadExclWriteSync := TMultiReadExclusiveWriteSynchronizer.Create; 102 | FCategoryToSubscriptionsByAttrName := TMethodCategoryToSubscriptionsByAttributeName.Create([doOwnsValues]); 103 | FSubscriberToCategoriesByAttrName := TSubscriberToMethodCategoriesByAttributeName.Create([doOwnsValues]); 104 | end; 105 | 106 | destructor TEventBus.Destroy; 107 | begin 108 | FCategoryToSubscriptionsByAttrName.Free; 109 | FSubscriberToCategoriesByAttrName.Free; 110 | FMultiReadExclWriteSync.Free; 111 | FDebThreadPool.Free; 112 | inherited; 113 | end; 114 | 115 | function TEventBus.RemoveSubscription(ASubscriber: TObject; const ACategory: String): IDEBSubscription; 116 | var 117 | LSubscription: IDEBSubscription; 118 | LExtractedSubscription: IDEBSubscription; 119 | LSubscriptions: TSubscriptions; 120 | LCategoryToSubscriptionsMap: TMethodCategoryToSubscriptionsMap; 121 | LAttrName: TAttributeName; 122 | begin 123 | LAttrName := T.ClassName; 124 | 125 | if (not FCategoryToSubscriptionsByAttrName.TryGetValue(LAttrName, LCategoryToSubscriptionsMap)) then 126 | Exit(Nil); 127 | 128 | if (not LCategoryToSubscriptionsMap.TryGetValue(ACategory, LSubscriptions)) then 129 | Exit(Nil); 130 | 131 | for LSubscription in LSubscriptions do 132 | begin 133 | if LSubscription.Subscriber = ASubscriber then 134 | begin 135 | LExtractedSubscription:= LSubscriptions.Extract( LSubscription); 136 | break; 137 | end 138 | end; 139 | 140 | if LExtractedSubscription = nil then 141 | Exit(Nil); 142 | 143 | Unsubscribe(ASubscriber, ACategory); 144 | 145 | LSubscription.Active:= False; 146 | Result:= LSubscription; 147 | 148 | end; 149 | 150 | procedure TEventBus.InvokeSubscriber(ASubscription: IDEBSubscription; const Args: array of TValue); 151 | begin 152 | try 153 | if not ASubscription.Active then 154 | Exit; 155 | 156 | if not Assigned( ASubscription.Subscriber) then 157 | Exit; 158 | 159 | ASubscription.SubscriberMethod.Method.Invoke(ASubscription.Subscriber, Args); 160 | except 161 | on E: Exception do begin 162 | raise EInvokeSubscriberError.CreateFmt( 163 | 'Error invoking subscriber method. Subscriber class: %s. Event type: %s. Original exception %s: %s.', 164 | [ 165 | ASubscription.Subscriber.ClassName, 166 | ASubscription.SubscriberMethod.EventType, 167 | E.ClassName, 168 | E.Message 169 | ]); 170 | end; 171 | end; 172 | end; 173 | 174 | function TEventBus.IsRegistered(ASubscriber: TObject): Boolean; 175 | var 176 | LSubscriberToCategoriesMap: TSubscriberToMethodCategoriesMap; 177 | LAttrName: TAttributeName; 178 | begin 179 | FMultiReadExclWriteSync.BeginRead; 180 | 181 | try 182 | LAttrName := T.ClassName; 183 | if not FSubscriberToCategoriesByAttrName.TryGetValue(LAttrName, LSubscriberToCategoriesMap) then 184 | Exit(False); 185 | 186 | Result := LSubscriberToCategoriesMap.ContainsKey(ASubscriber); 187 | finally 188 | FMultiReadExclWriteSync.EndRead; 189 | end; 190 | end; 191 | 192 | function TEventBus.IsRegisteredForChannels(ASubscriber: TObject): Boolean; 193 | begin 194 | Result := IsRegistered(ASubscriber); 195 | end; 196 | 197 | function TEventBus.IsRegisteredForEvents(ASubscriber: TObject): Boolean; 198 | begin 199 | Result := IsRegistered(ASubscriber); 200 | end; 201 | 202 | procedure TEventBus.Post(const AChannel, AMessage: string); 203 | var 204 | LSubscriptions: TSubscriptions; 205 | LSubscription: IDEBSubscription; 206 | LIsMainThread: Boolean; 207 | LCategoryToSubscriptionsMap: TMethodCategoryToSubscriptionsMap; 208 | LAttrName: TAttributeName; 209 | begin 210 | FMultiReadExclWriteSync.BeginRead; 211 | 212 | try 213 | LAttrName := ChannelAttribute.ClassName; 214 | if not FCategoryToSubscriptionsByAttrName.TryGetValue(LAttrName, LCategoryToSubscriptionsMap) then 215 | Exit; 216 | 217 | if not LCategoryToSubscriptionsMap.TryGetValue(TSubscriberMethod.EncodeCategory(AChannel), LSubscriptions) then 218 | Exit; 219 | 220 | LIsMainThread := MainThreadID = TThread.CurrentThread.ThreadID; 221 | 222 | for LSubscription in LSubscriptions do begin 223 | if (LSubscription.Context <> AChannel) or (not LSubscription.Active) then Continue; 224 | PostToChannel(LSubscription, AMessage, LIsMainThread); 225 | end; 226 | finally 227 | FMultiReadExclWriteSync.EndRead; 228 | end; 229 | end; 230 | 231 | procedure TEventBus.Post(const AEvent: IInterface; const AContext: string = ''); 232 | var 233 | LIsMainThread: Boolean; 234 | LSubscription: IDEBSubscription; 235 | LSubscriptions: TSubscriptions; 236 | LCategoryToSubscriptionsMap: TMethodCategoryToSubscriptionsMap; 237 | LEventType: string; 238 | LAttrName: TAttributeName; 239 | begin 240 | FMultiReadExclWriteSync.BeginRead; 241 | 242 | try 243 | LAttrName := SubscribeAttribute.ClassName; 244 | if not FCategoryToSubscriptionsByAttrName.TryGetValue(LAttrName, LCategoryToSubscriptionsMap) then 245 | Exit; 246 | 247 | LEventType:= TInterfaceHelper.GetQualifiedName(AEvent); 248 | if not LCategoryToSubscriptionsMap.TryGetValue(TSubscriberMethod.EncodeCategory(AContext, LEventType), LSubscriptions) then 249 | Exit; 250 | 251 | LIsMainThread := MainThreadID = TThread.CurrentThread.ThreadID; 252 | 253 | for LSubscription in LSubscriptions do begin 254 | if not LSubscription.Active then Continue; 255 | PostToSubscription(LSubscription, AEvent, LIsMainThread); 256 | end; 257 | finally 258 | FMultiReadExclWriteSync.EndRead; 259 | end; 260 | end; 261 | 262 | procedure TEventBus.PostToChannel(ASubscription: IDEBSubscription; const AMessage: string; AIsMainThread: Boolean); 263 | var 264 | LProc: TProc; 265 | begin 266 | if not Assigned(ASubscription.Subscriber) then 267 | Exit; 268 | 269 | LProc := procedure begin 270 | InvokeSubscriber(ASubscription, [AMessage]); 271 | end; 272 | 273 | case ASubscription.SubscriberMethod.ThreadMode of 274 | Posting: 275 | LProc(); 276 | Main: 277 | if (AIsMainThread) then 278 | LProc() 279 | else 280 | TThread.Queue(nil, TThreadProcedure(LProc)); 281 | Background: 282 | if (AIsMainThread) then 283 | {$IF CompilerVersion >= 28.0} 284 | TTask.Run(LProc, FDebThreadPool) 285 | {$ELSE} 286 | TThread.CreateAnonymousThread(LProc).Start 287 | {$ENDIF} 288 | else 289 | LProc(); 290 | Async: 291 | {$IF CompilerVersion >= 28.0} 292 | TTask.Run(LProc, FDebThreadPool); 293 | {$ELSE} 294 | TThread.CreateAnonymousThread(LProc).Start; 295 | {$ENDIF} 296 | else 297 | raise EUnknownThreadMode.CreateFmt('Unknown thread mode: %s.', [Ord(ASubscription.SubscriberMethod.ThreadMode)]); 298 | end; 299 | end; 300 | 301 | procedure TEventBus.PostToSubscription(ASubscription: IDEBSubscription; const AEvent: IInterface; AIsMainThread: Boolean); 302 | var 303 | LProc: TProc; 304 | begin 305 | if not Assigned(ASubscription.Subscriber) then 306 | Exit; 307 | 308 | LProc := procedure begin 309 | InvokeSubscriber(ASubscription, [AEvent as TObject]); 310 | end; 311 | 312 | case ASubscription.SubscriberMethod.ThreadMode of 313 | Posting: 314 | LProc(); 315 | Main: 316 | if (AIsMainThread) then 317 | LProc() 318 | else 319 | TThread.Queue(nil, TThreadProcedure(LProc)); 320 | Background: 321 | if (AIsMainThread) then 322 | {$IF CompilerVersion >= 28.0} 323 | TTask.Run(LProc, FDebThreadPool) 324 | {$ELSE} 325 | TThread.CreateAnonymousThread(LProc).Start 326 | {$ENDIF} 327 | else 328 | LProc(); 329 | Async: 330 | {$IF CompilerVersion >= 28.0} 331 | TTask.Run(LProc, FDebThreadPool); 332 | {$ELSE} 333 | TThread.CreateAnonymousThread(LProc)).Start; 334 | {$ENDIF} 335 | else 336 | raise Exception.Create('Unknown thread mode'); 337 | end; 338 | end; 339 | 340 | procedure TEventBus.RegisterNewContext(ASubscriber: TObject; AEvent: IInterface; const AOldContext: String; const ANewContext: String); 341 | var 342 | LMethodCategory: string; 343 | LSubscription: IDEBSubscription; 344 | LOldSubMethod: TSubscriberMethod; 345 | LNewSubMethod: TSubscriberMethod; 346 | begin 347 | FMultiReadExclWriteSync.BeginWrite; 348 | try 349 | LMethodCategory:= TSubscriberMethod.EncodeCategory( AOldContext, TInterfaceHelper.GetQualifiedName( AEvent)); 350 | 351 | LSubscription:= RemoveSubscription( ASubscriber, LMethodCategory); 352 | if LSubscription = nil then 353 | raise Exception.Create('Cannot find the Subscription'); 354 | LOldSubMethod:= LSubscription.SubscriberMethod; 355 | LNewSubMethod:= TSubscriberMethod.Create( LOldSubMethod.Method, LOldSubMethod.EventType, LOldSubMethod.ThreadMode, ANewContext, LOldSubMethod.Priority ); 356 | Subscribe(ASubscriber, LNewSubMethod ); 357 | finally 358 | FMultiReadExclWriteSync.EndWrite; 359 | end; 360 | end; 361 | 362 | procedure TEventBus.RegisterSubscriber(ASubscriber: TObject; ARaiseExcIfEmpty: Boolean); 363 | var 364 | LSubscriberClass: TClass; 365 | LSubscriberMethods: TArray; 366 | LSubscriberMethod: TSubscriberMethod; 367 | begin 368 | FMultiReadExclWriteSync.BeginWrite; 369 | 370 | try 371 | LSubscriberClass := ASubscriber.ClassType; 372 | LSubscriberMethods := TSubscribersFinder.FindSubscriberMethods(LSubscriberClass, ARaiseExcIfEmpty); 373 | for LSubscriberMethod in LSubscriberMethods do Subscribe(ASubscriber, LSubscriberMethod); 374 | finally 375 | FMultiReadExclWriteSync.EndWrite; 376 | end; 377 | end; 378 | 379 | procedure TEventBus.RegisterSubscriberForChannels(ASubscriber: TObject); 380 | begin 381 | RegisterSubscriber(ASubscriber, True); 382 | end; 383 | 384 | procedure TEventBus.RegisterSubscriberForEvents(ASubscriber: TObject); 385 | begin 386 | RegisterSubscriber(ASubscriber, True); 387 | end; 388 | 389 | procedure TEventBus.SilentRegisterSubscriberForChannels(ASubscriber: TObject); 390 | begin 391 | RegisterSubscriber(ASubscriber, False); 392 | end; 393 | 394 | procedure TEventBus.SilentRegisterSubscriberForEvents(ASubscriber: TObject); 395 | begin 396 | RegisterSubscriber(ASubscriber, False); 397 | end; 398 | 399 | procedure TEventBus.Subscribe(ASubscriber: TObject; ASubscriberMethod: TSubscriberMethod); 400 | var 401 | LNewSubscription: IDEBSubscription; 402 | LSubscriptions: TSubscriptions; 403 | LCategories: TMethodCategories; 404 | LCategory: TMethodCategory; 405 | LCategoryToSubscriptionsMap: TMethodCategoryToSubscriptionsMap; 406 | LSubscriberToCategoriesMap: TSubscriberToMethodCategoriesMap; 407 | LAttrName: TAttributeName; 408 | begin 409 | LAttrName := T.ClassName; 410 | if not FCategoryToSubscriptionsByAttrName.ContainsKey(LAttrName) then begin 411 | LCategoryToSubscriptionsMap := TMethodCategoryToSubscriptionsMap.Create([doOwnsValues]); 412 | FCategoryToSubscriptionsByAttrName.Add(LAttrName, LCategoryToSubscriptionsMap); 413 | end else begin 414 | LCategoryToSubscriptionsMap := FCategoryToSubscriptionsByAttrName[LAttrName]; 415 | end; 416 | 417 | LCategory := ASubscriberMethod.Category; 418 | LNewSubscription := NewSubscription(ASubscriber, ASubscriberMethod); 419 | 420 | if (not LCategoryToSubscriptionsMap.ContainsKey(LCategory)) then begin 421 | LSubscriptions := TSubscriptions.Create; 422 | LCategoryToSubscriptionsMap.Add(LCategory, LSubscriptions); 423 | end else begin 424 | LSubscriptions := LCategoryToSubscriptionsMap[LCategory]; 425 | if (LSubscriptions.Contains(LNewSubscription)) then 426 | begin 427 | raise ESubscriberMethodAlreadyRegistered.CreateFmt('Subscriber %s already registered to %s.', [ASubscriber.ClassName, LCategory]); 428 | end; 429 | end; 430 | 431 | LSubscriptions.Add(LNewSubscription); 432 | 433 | if not FSubscriberToCategoriesByAttrName.ContainsKey(LAttrName) then begin 434 | LSubscriberToCategoriesMap := TSubscriberToMethodCategoriesMap.Create([doOwnsValues]); 435 | FSubscriberToCategoriesByAttrName.Add(LAttrName, LSubscriberToCategoriesMap); 436 | end else begin 437 | LSubscriberToCategoriesMap := FSubscriberToCategoriesByAttrName[LAttrName]; 438 | end; 439 | 440 | if (not LSubscriberToCategoriesMap.TryGetValue(ASubscriber, LCategories)) then begin 441 | LCategories := TMethodCategories.Create; 442 | LSubscriberToCategoriesMap.Add(ASubscriber, LCategories); 443 | end; 444 | 445 | LCategories.Add(LCategory); 446 | end; 447 | 448 | procedure TEventBus.UnregisterSubscriber(ASubscriber: TObject); 449 | var 450 | LCategories: TMethodCategories; 451 | LCategory: TMethodCategory; 452 | LSubscriberToCategoriesMap: TSubscriberToMethodCategoriesMap; 453 | LAttrName: TAttributeName; 454 | begin 455 | FMultiReadExclWriteSync.BeginWrite; 456 | 457 | try 458 | LAttrName := T.ClassName; 459 | if not FSubscriberToCategoriesByAttrName.TryGetValue(LAttrName, LSubscriberToCategoriesMap) then 460 | Exit; 461 | 462 | if LSubscriberToCategoriesMap.TryGetValue(ASubscriber, LCategories) then begin 463 | for LCategory in LCategories do Unsubscribe(ASubscriber, LCategory); 464 | LSubscriberToCategoriesMap.Remove(ASubscriber); 465 | end; 466 | finally 467 | FMultiReadExclWriteSync.EndWrite; 468 | end; 469 | end; 470 | 471 | procedure TEventBus.UnregisterForChannels(ASubscriber: TObject); 472 | begin 473 | UnregisterSubscriber(ASubscriber); 474 | end; 475 | 476 | procedure TEventBus.UnregisterForEvents(ASubscriber: TObject); 477 | begin 478 | UnregisterSubscriber(ASubscriber); 479 | end; 480 | 481 | procedure TEventBus.Unsubscribe(ASubscriber: TObject; const AMethodCategory: TMethodCategory); 482 | var 483 | LSubscriptions: TSubscriptions; 484 | LSize, I: Integer; 485 | LSubscription: IDEBSubscription; 486 | LCategoryToSubscriptionsMap: TMethodCategoryToSubscriptionsMap; 487 | LAttrName: TAttributeName; 488 | begin 489 | LAttrName := T.ClassName; 490 | if not FCategoryToSubscriptionsByAttrName.TryGetValue(LAttrName, LCategoryToSubscriptionsMap) then 491 | Exit; 492 | 493 | if not LCategoryToSubscriptionsMap.TryGetValue(AMethodCategory, LSubscriptions) then 494 | Exit; 495 | 496 | if (LSubscriptions.Count < 1) then 497 | Exit; 498 | 499 | LSize := LSubscriptions.Count; 500 | 501 | for I := LSize - 1 downto 0 do begin 502 | LSubscription := LSubscriptions[I]; 503 | // Note - If the subscriber has been freed without unregistering itself, calling 504 | // LSubscription.Subscriber.Equals() will cause Access Violation, hence use '=' instead. 505 | if LSubscription.Subscriber = ASubscriber then begin 506 | LSubscription.Active := False; 507 | LSubscriptions.Delete(I); 508 | end; 509 | end; 510 | end; 511 | 512 | class constructor TEventBusFactory.Create; 513 | begin 514 | FGlobalEventBus := TEventBus.Create; 515 | end; 516 | 517 | function TEventBusFactory.CreateEventBus: IEventBus; 518 | begin 519 | Result := TEventBus.Create; 520 | end; 521 | 522 | end. 523 | -------------------------------------------------------------------------------- /source/EventBus.Helpers.pas: -------------------------------------------------------------------------------- 1 | unit EventBus.Helpers; 2 | 3 | interface 4 | 5 | uses 6 | System.Generics.Collections, 7 | System.Rtti, 8 | System.SysUtils, 9 | System.TypInfo; 10 | 11 | type 12 | TRttiUtils = class sealed 13 | strict private 14 | class var FContext: TRttiContext; 15 | public 16 | /// 17 | /// Examines an RTTI member object to check if it has the required type of attribute specified. 18 | /// 19 | /// 20 | /// The required type of attribute. 21 | /// 22 | /// 23 | /// The RTTI member object to examine. 24 | /// 25 | /// 26 | /// The actual instance of the attribute if the attribute is specified for the RTTI object. 27 | /// 28 | /// 29 | /// True if the required attribute is specified for the RTTI object; False otherwise. 30 | /// 31 | class function HasAttribute(ARttiMember: TRttiMember; out AAttribute: T): Boolean; overload; 32 | 33 | /// 34 | /// Examines an RTTI type object to check if it has the required type of 35 | /// attribute specified. 36 | /// 37 | /// 38 | /// The required type of attribute. 39 | /// 40 | /// 41 | /// The RTTI type object to examine. 42 | /// 43 | /// 44 | /// The actual instance of the attribute if the attribute is specified 45 | /// for the RTTI object. 46 | /// 47 | /// 48 | /// True if the required attribute is specified for the RTTI object; 49 | /// False otherwise. 50 | /// 51 | class function HasAttribute(ARttiType: TRttiType; out AAttribute: T): Boolean; overload; 52 | 53 | /// 54 | /// Rtti context. 55 | /// 56 | class property Context: TRttiContext read FContext; 57 | end; 58 | 59 | /// 60 | /// Provides interface type helper. 61 | /// 62 | /// 63 | /// TInterfaceHelper borrows the code from the answer to this StackOverflow question: 64 | /// 65 | /// 66 | TInterfaceHelper = record 67 | strict private type 68 | TInterfaceTypes = TDictionary; 69 | strict private 70 | class var FInterfaceTypes: TInterfaceTypes; 71 | class var FCached: Boolean; // Boolean in Delphi is atomic 72 | class var FCaching: Boolean; 73 | class constructor Create; 74 | class destructor Destroy; 75 | class procedure CacheIfNotCachedAndWaitFinish; static; 76 | class procedure WaitIfCaching; static; 77 | public 78 | 79 | /// 80 | /// Refreshes the cached RTTI interface types in a background thread (eg. 81 | /// when new package is loaded). 82 | /// 83 | /// 84 | /// RefreshCache is called at program initialization automatically by the 85 | /// class constructor. It may also be called as needed when a package is 86 | /// loaded. The purpose of the cache is to speed up querying a given 87 | /// interface type inside GetType method. 88 | /// 89 | class procedure RefreshCache; static; 90 | 91 | /// 92 | /// Obtains the RTTI interface type object of the specified interface. 93 | /// 94 | class function GetType(const AIntf: IInterface): TRttiInterfaceType; overload; static; 95 | 96 | /// 97 | /// Obtains the RTTI interface type object of the specified interface GUID. 98 | /// 99 | class function GetType(const AGuid: TGUID): TRttiInterfaceType; overload; static; 100 | 101 | /// 102 | /// Obtains the RTTI interface type object of the specified TValue-boxed interface. 103 | /// 104 | class function GetType(const AIntfInTValue: TValue): TRttiInterfaceType; overload; static; 105 | 106 | /// 107 | /// Obtains the name of the interface type. 108 | /// 109 | class function GetTypeName(const AIntf: IInterface): string; overload; static; 110 | 111 | /// 112 | /// Obtains the name of the interface type identified by a GUID. 113 | /// 114 | class function GetTypeName(const AGuid: TGUID): string; overload; static; 115 | 116 | /// 117 | /// Obtains the qualified name of the interface type. A qualified name 118 | /// includes the unit name separated by dot. 119 | /// 120 | class function GetQualifiedName(const AIntf: IInterface): string; overload; static; 121 | 122 | /// 123 | /// Obtains the qualified name of the interface type identified by a 124 | /// GUID. A qualified name includes the unit name separated by dot. 125 | /// 126 | class function GetQualifiedName(const AGuid: TGUID): string; overload; static; 127 | 128 | /// 129 | /// Obtains a list of RTTI objects for all the methods that are members of the specified 130 | /// interface. 131 | /// 132 | class function GetMethods(const AIntf: IInterface): TArray; static; 133 | 134 | /// 135 | /// Returns an RTTI object for the interface method with the 136 | /// specified name. 137 | /// 138 | class function GetMethod(const AIntf: IInterface; const AMethodName: string): TRttiMethod; static; 139 | 140 | /// 141 | /// Performs a call to the described method. 142 | /// 143 | class function InvokeMethod(const AIntf: IInterface; const AMethodName: string; 144 | const Args: array of TValue): TValue; overload; static; 145 | 146 | /// 147 | /// Performs a call to the described method. 148 | /// 149 | class function InvokeMethod(const AIntfInTValue: TValue; const AMethodName: string; 150 | const Args: array of TValue): TValue; overload; static; 151 | end; 152 | 153 | /// 154 | /// Throws when the method with the specified name is not found. 155 | /// 156 | EMethodNotFound = class(Exception) 157 | public 158 | constructor Create(const AMethodName: string); 159 | end; 160 | 161 | implementation 162 | 163 | uses 164 | System.Classes, System.SyncObjs, DUnitX.Utils; 165 | 166 | class function TInterfaceHelper.GetType(const AIntf: IInterface): TRttiInterfaceType; 167 | var 168 | LImplObj: TObject; 169 | LGuid: TGUID; 170 | LIntfType: TRttiInterfaceType; 171 | LTempIntf: IInterface; 172 | begin 173 | Result := nil; 174 | 175 | try 176 | // As far as I know, the cast will fail only when AIntf is obatined from OLE Object 177 | // Is there any other cases? 178 | LImplObj := AIntf as TObject; 179 | except 180 | // For interfaces obtained from OLE Object 181 | Result := TRttiUtils.Context.GetType(TypeInfo(System.IDispatch)) as TRttiInterfaceType; 182 | Exit; 183 | end; 184 | 185 | // For interfaces obtained from TRawVirtualClass (e.g. iOS, Android & Mac intf) 186 | if LImplObj.ClassType.InheritsFrom(TRawVirtualClass) then begin 187 | LGuid := LImplObj.GetField('FIIDs').GetValue(LImplObj).AsType>[0]; 188 | Result := GetType(LGuid); 189 | end else begin 190 | // For interfaces obtained from TVirtualInterface 191 | if LImplObj.ClassType.InheritsFrom(TVirtualInterface) then begin 192 | LGuid := LImplObj.GetField('FIID').GetValue(LImplObj).AsType; 193 | Result := GetType(LGuid); 194 | end else begin 195 | // For interfaces obtained from Delphi object. Code taken from Remy Lebeau's answer 196 | // http://stackoverflow.com/questions/39584234/how-to-obtain-rtti-from-an-interface-reference-in-delphi/ 197 | for LIntfType in (TRttiUtils.Context.GetType(LImplObj.ClassType) as TRttiInstanceType).GetImplementedInterfaces do begin 198 | if LImplObj.GetInterface(LIntfType.GUID, LTempIntf) and (AIntf = LTempIntf) then 199 | Exit(LIntfType); 200 | end; 201 | end; 202 | end; 203 | end; 204 | 205 | class constructor TInterfaceHelper.Create; 206 | begin 207 | FInterfaceTypes := TInterfaceTypes.Create; 208 | FCached := False; 209 | FCaching := False; 210 | RefreshCache; 211 | end; 212 | 213 | class destructor TInterfaceHelper.Destroy; 214 | begin 215 | WaitIfCaching; 216 | FInterfaceTypes.Free; 217 | end; 218 | 219 | class function TInterfaceHelper.GetQualifiedName(const AIntf: IInterface): string; 220 | var 221 | LType: TRttiInterfaceType; 222 | begin 223 | LType := GetType(AIntf); 224 | 225 | if Assigned(LType) then 226 | Result := LType.QualifiedName 227 | else 228 | Result := EmptyStr; 229 | end; 230 | 231 | class function TInterfaceHelper.GetMethod(const AIntf: IInterface; const AMethodName: string): TRttiMethod; 232 | var 233 | LType: TRttiInterfaceType; 234 | begin 235 | LType := GetType(AIntf); 236 | 237 | if Assigned(LType) then 238 | Result := LType.GetMethod(AMethodName) 239 | else 240 | Result := nil; 241 | end; 242 | 243 | class function TInterfaceHelper.GetMethods(const AIntf: IInterface): TArray; 244 | var 245 | LType: TRttiInterfaceType; 246 | begin 247 | LType := GetType(AIntf); 248 | 249 | if Assigned(LType) then 250 | Result := LType.GetMethods 251 | else 252 | Result := nil; 253 | end; 254 | 255 | class function TInterfaceHelper.GetQualifiedName(const AGuid: TGUID): string; 256 | var 257 | LType: TRttiInterfaceType; 258 | begin 259 | LType := GetType(AGuid); 260 | 261 | if Assigned(LType) then 262 | Result := LType.QualifiedName 263 | else 264 | Result := EmptyStr; 265 | end; 266 | 267 | class function TInterfaceHelper.GetType(const AGuid: TGUID): TRttiInterfaceType; 268 | begin 269 | CacheIfNotCachedAndWaitFinish; 270 | Result := FInterfaceTypes.Items[AGuid]; 271 | end; 272 | 273 | class function TInterfaceHelper.GetTypeName(const AGuid: TGUID): string; 274 | var 275 | LType: TRttiInterfaceType; 276 | begin 277 | LType := GetType(AGuid); 278 | 279 | if Assigned(LType) then 280 | Result := LType.Name 281 | else 282 | Result := EmptyStr; 283 | end; 284 | 285 | class function TInterfaceHelper.InvokeMethod(const AIntfInTValue: TValue; const AMethodName: string; const Args: array of TValue): TValue; 286 | var 287 | LMethod: TRttiMethod; 288 | LType: TRttiInterfaceType; 289 | begin 290 | LType := GetType(AIntfInTValue); 291 | 292 | if Assigned(LType) then 293 | LMethod := LType.GetMethod(AMethodName) 294 | else 295 | LMethod := nil; 296 | 297 | if Assigned(LMethod) then 298 | Result := LMethod.Invoke(AIntfInTValue, Args) 299 | else 300 | raise EMethodNotFound.Create(AMethodName); 301 | end; 302 | 303 | class function TInterfaceHelper.InvokeMethod(const AIntf: IInterface; const AMethodName: string; const Args: array of TValue): TValue; 304 | var 305 | LMethod: TRttiMethod; 306 | begin 307 | LMethod := GetMethod(AIntf, AMethodName); 308 | 309 | if not Assigned(LMethod) then 310 | raise EMethodNotFound.Create(AMethodName); 311 | 312 | Result := LMethod.Invoke(AIntf as TObject, Args); 313 | end; 314 | 315 | class function TInterfaceHelper.GetTypeName(const AIntf: IInterface): string; 316 | var 317 | LType: TRttiInterfaceType; 318 | begin 319 | Result := string.Empty; 320 | LType := GetType(AIntf); 321 | 322 | if Assigned(LType) then 323 | Result := LType.Name; 324 | end; 325 | 326 | class procedure TInterfaceHelper.RefreshCache; 327 | begin 328 | WaitIfCaching; 329 | FCaching := True; 330 | FCached := False; 331 | 332 | TThread.CreateAnonymousThread( 333 | procedure 334 | var 335 | LType: TRttiType; 336 | LIntfType: TRttiInterfaceType; 337 | begin 338 | FInterfaceTypes.Clear; 339 | 340 | for LType in TRttiUtils.Context.GetTypes do begin 341 | if LType.IsInterface then begin 342 | LIntfType := (LType as TRttiInterfaceType); 343 | 344 | if TIntfFlag.ifHasGuid in LIntfType.IntfFlags then 345 | FInterfaceTypes.AddOrSetValue(LIntfType.GUID, LIntfType); 346 | end; 347 | end; 348 | 349 | FCaching := False; 350 | FCached := True; 351 | end 352 | ).Start; 353 | end; 354 | 355 | class procedure TInterfaceHelper.WaitIfCaching; 356 | begin 357 | if FCaching then TSpinWait.SpinUntil( 358 | function: Boolean 359 | begin 360 | Result := FCached; 361 | end 362 | ); 363 | end; 364 | 365 | class procedure TInterfaceHelper.CacheIfNotCachedAndWaitFinish; 366 | begin 367 | if FCached then 368 | Exit; 369 | 370 | // Need to be protected because FCaching is changed inside. This will block GetType method. 371 | TMonitor.Enter(FInterfaceTypes); 372 | if not FCaching then RefreshCache; 373 | TMonitor.Exit(FInterfaceTypes); 374 | 375 | WaitIfCaching; 376 | end; 377 | 378 | class function TInterfaceHelper.GetType(const AIntfInTValue: TValue): TRttiInterfaceType; 379 | var 380 | LType: TRttiType; 381 | begin 382 | LType := AIntfInTValue.RttiType; 383 | 384 | if LType is TRttiInterfaceType then 385 | Result := LType as TRttiInterfaceType 386 | else 387 | Result := nil; 388 | end; 389 | 390 | class function TRttiUtils.HasAttribute(ARttiType: TRttiType; out AAttribute: T): Boolean; 391 | var 392 | LAttr: TCustomAttribute; 393 | begin 394 | AAttribute := nil; 395 | Result := False; 396 | 397 | for LAttr in ARttiType.GetAttributes do begin 398 | if LAttr is T then begin 399 | AAttribute := T(LAttr); 400 | Exit(True); 401 | end; 402 | end; 403 | end; 404 | 405 | class function TRttiUtils.HasAttribute(ARttiMember: TRttiMember; out AAttribute: T): Boolean; 406 | var 407 | LAttr: TCustomAttribute; 408 | begin 409 | AAttribute := nil; 410 | Result := False; 411 | 412 | for LAttr in ARttiMember.GetAttributes do begin 413 | if LAttr is T then begin 414 | AAttribute := T(LAttr); 415 | Exit(True); 416 | end; 417 | end; 418 | end; 419 | 420 | constructor EMethodNotFound.Create(const AMethodName: string); 421 | begin 422 | inherited CreateFmt('Method %s not found.', [AMethodName]); 423 | end; 424 | 425 | end. -------------------------------------------------------------------------------- /source/EventBus.Subscribers.pas: -------------------------------------------------------------------------------- 1 | { ******************************************************************************* 2 | Copyright 2016-2020 Daniele Spinetti 3 | 4 | Licensed under the Apache License, Version 2.0 (the "License"); 5 | you may not use this file except in compliance with the License. 6 | You may obtain a copy of the License at 7 | 8 | http://www.apache.org/licenses/LICENSE-2.0 9 | 10 | Unless required by applicable law or agreed to in writing, software 11 | distributed under the License is distributed on an "AS IS" BASIS, 12 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | See the License for the specific language governing permissions and 14 | limitations under the License. 15 | ******************************************************************************** } 16 | 17 | unit EventBus.Subscribers; 18 | 19 | interface 20 | 21 | uses 22 | System.Rtti, EventBus; 23 | 24 | type 25 | /// 26 | /// Encapsulates a subscriber method as an object with relevant properties. 27 | /// 28 | /// 29 | /// TSubscriberMethod.EventType is represented by the qualified name of the method's 30 | /// event argument type. The type of the event argument must be a descendant of 31 | /// interface type. EventType can uniquely identify the type of the event. 32 | /// 33 | TSubscriberMethod = class sealed(TObject) 34 | strict private 35 | FContext: string; 36 | FEventType: string; 37 | FMethod: TRttiMethod; 38 | FPriority: Integer; 39 | FThreadMode: TThreadMode; 40 | function Get_Category: string; 41 | public 42 | /// 43 | /// Rtti information about the subject method. 44 | /// 45 | /// 46 | /// Event type of the method. 47 | /// 48 | /// 49 | /// Designated thread mode. 50 | /// 51 | /// 52 | /// Context of the method. 53 | /// 54 | /// 55 | /// Dispatching priority of the method. 56 | /// 57 | constructor Create(ARttiMethod: TRttiMethod; const AEventType: string; AThreadMode: TThreadMode; 58 | const AContext: string = ''; APriority: Integer = 1); 59 | 60 | /// 61 | /// Encodes Context string and EventType string to a Category string, 62 | /// representing the category a subscriber method belongs to. 63 | /// 64 | /// 65 | /// Named-channel event is a special case of the general event, where the 66 | /// channel name is the Context, and System.string is the event type. 67 | /// 68 | class function EncodeCategory(const AContext: string; const AEventType: string = 'System.string'): string; 69 | 70 | /// 71 | /// Checkes if two subscriber methods are equal. Returns true when 72 | /// both method names and argument types are identical. 73 | /// 74 | /// 75 | /// The object to compare 76 | /// 77 | function Equals(AObject: TObject): Boolean; override; 78 | 79 | /// 80 | /// Category of the subscriber method. Internally it takes value of "Context:EventType". 81 | /// 82 | property Category: string read Get_Category; 83 | 84 | /// 85 | /// Context of the subscriber method. 86 | /// 87 | property Context: string read FContext; 88 | /// 89 | /// Event type of the subscriber method. It is actually the fully 90 | /// qualified name of the event type. 91 | /// 92 | property EventType: string read FEventType; 93 | /// 94 | /// Rtti information of the subscriber method. 95 | /// 96 | property Method: TRttiMethod read FMethod; 97 | /// 98 | /// Dispatching priority of the subscriber method. Currently a placeholder 99 | /// with no impact on actual event dispatching. 100 | /// 101 | property Priority: Integer read FPriority; 102 | /// 103 | /// Thread mode of the subscriber method. 104 | /// 105 | property ThreadMode: TThreadMode read FThreadMode; 106 | end; 107 | 108 | /// 109 | /// Encapsulates the subscriber method and its owner subscriber object. 110 | /// 111 | IDEBSubscription = interface 112 | ['{9D9F9FCF-75B0-4EDA-A882-A16F503687D3}'] 113 | procedure Set_Active(const AValue: Boolean); 114 | function Get_Context: string; 115 | function GetSubscriber: TObject; 116 | function GetSubscriberMethod: TSubscriberMethod; 117 | function GetActive: Boolean; 118 | /// 119 | /// Checks if two subscriptions are equal. Returns True when both 120 | /// having the same subscriber object and the same subscriber method. 121 | /// 122 | function Equals(AObject: TObject): Boolean; 123 | 124 | /// 125 | /// Whether the subject subscription is active. 126 | /// 127 | property Active: Boolean read GetActive write Set_Active; 128 | /// 129 | /// Context of the subscriber method. 130 | /// 131 | property Context: string read Get_Context; 132 | /// 133 | /// The subscriber object. 134 | /// 135 | property Subscriber: TObject read GetSubscriber; 136 | /// 137 | /// The subscriber method. 138 | /// 139 | property SubscriberMethod: TSubscriberMethod read GetSubscriberMethod; 140 | end; 141 | 142 | TSubscribersFinder = class(TObject) 143 | public 144 | /// 145 | /// Collects all subscriber methods from a given subscriber class. Each 146 | /// collected subscriber method must have Subscribe or Channel attribute 147 | /// specified. 148 | /// 149 | /// 150 | /// An attribute class inherited from TEventBusSubscriberMethodAttribute. 151 | /// 152 | /// 153 | /// The subscriber class to collect subscriber methods from. 154 | /// 155 | /// 156 | /// Whether to raise an EObjectHasNoSubscriberMethods exception when the 157 | /// subscriber class does not have any methods with Subscribe or Channel 158 | /// attribute specified. 159 | /// 160 | /// 161 | /// Throws whenever a subscriber method of the subscriber class has 162 | /// invalid number of arguments or invalid argument type. 163 | /// 164 | /// 165 | /// Throws when the subscriber class does not have any methods with 166 | /// Subscribe or Channel attribute specified, and ARaiseExcIfEmpty is 167 | /// True. 168 | /// 169 | class function FindSubscriberMethods(ASubscriberClass: TClass; 170 | ARaiseExcIfEmpty: Boolean = False): TArray; 171 | end; 172 | 173 | function NewSubscription(const ASubscriber: TObject; const ASubscriberMethod: TSubscriberMethod): IDEBSubscription; 174 | 175 | implementation 176 | 177 | uses 178 | System.SysUtils, System.TypInfo, EventBus.Helpers; 179 | 180 | type 181 | 182 | /// 183 | /// Encapsulates the subscriber method and its owner subscriber object. 184 | /// 185 | TSubscription = class sealed(TInterfacedObject, IDEBSubscription) 186 | private 187 | FActive: Boolean; 188 | FSubscriber: TObject; 189 | FSubscriberMethod: TSubscriberMethod; 190 | {$REGION 'Property Gettors and Settors'} 191 | /// 192 | /// Encapsulates the subscriber method and its defining subscriber 193 | /// object. 194 | /// 195 | procedure Set_Active(const AValue: Boolean); 196 | function Get_Context: string; 197 | function GetSubscriber: TObject; 198 | function GetSubscriberMethod: TSubscriberMethod; 199 | function GetActive: Boolean; 200 | {$ENDREGION} 201 | public 202 | constructor Create(const ASubscriber: TObject; const ASubscriberMethod: TSubscriberMethod); 203 | destructor Destroy; override; 204 | 205 | /// 206 | /// Checks if two subscriptions are equal. Returns True when both 207 | /// having the same subscriber object and the same subscriber method. 208 | /// 209 | function Equals(AObject: TObject): Boolean; override; 210 | 211 | /// 212 | /// Whether the subject subscription is active. 213 | /// 214 | property Active: Boolean read GetActive write Set_Active; 215 | /// 216 | /// Context of the subscriber method. 217 | /// 218 | property Context: string read Get_Context; 219 | /// 220 | /// The subscriber object. 221 | /// 222 | property Subscriber: TObject read GetSubscriber; 223 | /// 224 | /// The subscriber method. 225 | /// 226 | property SubscriberMethod: TSubscriberMethod read GetSubscriberMethod; 227 | end; 228 | 229 | constructor TSubscriberMethod.Create(ARttiMethod: TRttiMethod; const AEventType: string; AThreadMode: TThreadMode; 230 | const AContext: string = ''; APriority: Integer = 1); 231 | begin 232 | FMethod := ARttiMethod; 233 | FEventType := AEventType; 234 | FThreadMode := AThreadMode; 235 | FContext := AContext; 236 | FPriority := APriority; 237 | end; 238 | 239 | class function TSubscriberMethod.EncodeCategory(const AContext: string; const AEventType: string = 'System.string'): string; 240 | begin 241 | Result := Format('%s:%s', [AContext, AEventType]); 242 | end; 243 | 244 | function TSubscriberMethod.Equals(AObject: TObject): Boolean; 245 | var 246 | LOtherSubscriberMethod: TSubscriberMethod; 247 | begin 248 | if not (AObject is TSubscriberMethod) then 249 | Exit(False); 250 | 251 | if (inherited Equals(AObject)) then 252 | Exit(True); 253 | 254 | LOtherSubscriberMethod := TSubscriberMethod(AObject); 255 | Result := (LOtherSubscriberMethod.Method.Tostring = Method.Tostring) and (LOtherSubscriberMethod.EventType = EventType); 256 | end; 257 | 258 | function TSubscriberMethod.Get_Category: string; 259 | begin 260 | Result := EncodeCategory(Context, EventType); 261 | end; 262 | 263 | class function TSubscribersFinder.FindSubscriberMethods(ASubscriberClass: TClass; 264 | ARaiseExcIfEmpty: Boolean = False): TArray; 265 | var 266 | LEventType: string; 267 | LMethod: TRttiMethod; 268 | LParamsLength: Integer; 269 | LRttiMethods: TArray; 270 | LRttiType: TRttiType; 271 | LSubMethod: TSubscriberMethod; 272 | LAttribute: T; 273 | begin 274 | {$IF CompilerVersion >= 28.0} 275 | Result := []; 276 | {$ELSE} 277 | SetLength(Result, 0); 278 | {$ENDIF} 279 | 280 | LRttiType := TRttiUtils.Context.GetType(ASubscriberClass); 281 | LRttiMethods := LRttiType.GetMethods; 282 | 283 | for LMethod in LRttiMethods do begin 284 | if TRttiUtils.HasAttribute(LMethod, LAttribute) then begin 285 | LParamsLength := Length(LMethod.GetParameters); 286 | 287 | if (LParamsLength <> 1) or (LMethod.GetParameters[0].ParamType.TypeKind <> LAttribute.ArgTypeKind) then begin 288 | raise EInvalidSubscriberMethod.CreateFmt( 289 | 'Method %s.%s has attribute %s with %d argument(s) and argument[0] is of type %s.' + 290 | 'Only 1 argument allowed and that argument must be of %s type.', 291 | [ 292 | ASubscriberClass.ClassName, 293 | LAttribute.ClassName, 294 | LMethod.Name, 295 | LParamsLength, 296 | LMethod.GetParameters[0].ParamType.Name, 297 | TRttiEnumerationType.GetName(LAttribute.ArgTypeKind) 298 | ]); 299 | end; 300 | 301 | LEventType := LMethod.GetParameters[0].ParamType.QualifiedName; 302 | LSubMethod := TSubscriberMethod.Create(LMethod, LEventType, LAttribute.ThreadMode, LAttribute.Context); 303 | 304 | {$IF CompilerVersion >= 28.0} 305 | Result := Result + [LSubMethod]; 306 | {$ELSE} 307 | SetLength(Result, Length(Result) + 1); 308 | Result[High(Result)] := LSubMethod; 309 | {$ENDIF} 310 | end; 311 | end; 312 | 313 | if (Length(Result) < 1) and ARaiseExcIfEmpty then begin 314 | raise EObjectHasNoSubscriberMethods.CreateFmt( 315 | 'Class %s and its super classes have no public methods with attribute %s defined.', 316 | [ASubscriberClass.QualifiedClassName, T.ClassName]); 317 | end; 318 | end; 319 | 320 | constructor TSubscription.Create(const ASubscriber: TObject; const ASubscriberMethod: TSubscriberMethod); 321 | begin 322 | inherited Create; 323 | FSubscriber := ASubscriber; 324 | FSubscriberMethod := ASubscriberMethod; 325 | FActive := True; 326 | end; 327 | 328 | destructor TSubscription.Destroy; 329 | begin 330 | if Assigned(FSubscriberMethod) then FreeAndNil(FSubscriberMethod); 331 | inherited; 332 | end; 333 | 334 | function TSubscription.Equals(AObject: TObject): Boolean; 335 | var 336 | LOtherSubscription: TSubscription; 337 | begin 338 | if not (AObject is TSubscription) then 339 | Exit(False); 340 | 341 | LOtherSubscription := TSubscription(AObject); 342 | Result := (Subscriber = LOtherSubscription.Subscriber) and (SubscriberMethod.Equals(LOtherSubscription.SubscriberMethod)); 343 | end; 344 | 345 | procedure TSubscription.Set_Active(const AValue: Boolean); 346 | begin 347 | TMonitor.Enter(Self); 348 | try 349 | FActive := AValue; 350 | finally 351 | TMonitor.Exit(Self); 352 | end; 353 | end; 354 | 355 | function TSubscription.GetActive: Boolean; 356 | begin 357 | Result:= FActive; 358 | end; 359 | 360 | function TSubscription.GetSubscriber: TObject; 361 | begin 362 | Result:= FSubscriber; 363 | end; 364 | 365 | function TSubscription.GetSubscriberMethod: TSubscriberMethod; 366 | begin 367 | Result:= FSubscriberMethod; 368 | end; 369 | 370 | function TSubscription.Get_Context: string; 371 | begin 372 | Result := SubscriberMethod.Context; 373 | end; 374 | 375 | 376 | function NewSubscription(const ASubscriber: TObject; const ASubscriberMethod: TSubscriberMethod): IDEBSubscription; 377 | begin 378 | Result:= TSubscription.Create( ASubscriber, ASubscriberMethod); 379 | end; 380 | 381 | end. 382 | -------------------------------------------------------------------------------- /source/EventBus.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************* 2 | Copyright 2016-2020 Daniele Spinetti 3 | 4 | Licensed under the Apache License, Version 2.0 (the "License"); 5 | you may not use this file except in compliance with the License. 6 | You may obtain a copy of the License at 7 | 8 | http://www.apache.org/licenses/LICENSE-2.0 9 | 10 | Unless required by applicable law or agreed to in writing, software 11 | distributed under the License is distributed on an "AS IS" BASIS, 12 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | See the License for the specific language governing permissions and 14 | limitations under the License. 15 | ********************************************************************************} 16 | 17 | /// 18 | /// This unit provides public interfaces and classes for the Delphi Event Bus (DEB) framework. 19 | /// 20 | unit EventBus; 21 | 22 | interface 23 | 24 | uses 25 | System.SysUtils; 26 | 27 | type 28 | /// 29 | /// Provides public interface of event bus implementation. Two types of 30 | /// events are allowed: 31 | /// 32 | /// 33 | /// Interface-typed event, represented by an user-defined interface. 34 | /// An optional Context string can be posted together with the event. 35 | /// The event will be routed to proper subsriber methods based on the 36 | /// event type as well as the Context string. 37 | /// 38 | /// 39 | /// Named-channel message. A string-typed message will be routed to proper 40 | /// subscriber methods based on the name of the channel. 41 | /// 42 | /// 43 | /// Depending on the thread mode of the subscriber method, the 44 | /// subscriber method can be invoked in the main thread, the posting thread, 45 | /// or a newly spawned background thread. 46 | /// 47 | IEventBus = interface 48 | ['{7BDF4536-F2BA-4FBA-B186-09E1EE6C7E35}'] 49 | /// 50 | /// Checks if the subscriber object has been registered with the event 51 | /// bus for receiving named-channel messages. 52 | /// 53 | /// 54 | /// The subscriber object to check, which should have methods with Channel attribute. 55 | /// 56 | function IsRegisteredForChannels(ASubscriber: TObject): Boolean; 57 | 58 | /// 59 | /// Checks if the subscriber object has been registered with the subject 60 | /// event bus for receiving interface-typed events. 61 | /// 62 | /// 63 | /// The subscriber object to check, which should have methods with Subscribe attribute. 64 | /// 65 | function IsRegisteredForEvents(ASubscriber: TObject): Boolean; 66 | 67 | /// 68 | /// Posts a named-channel message to the event bus. 69 | /// 70 | /// 71 | /// The name of the channel 72 | /// 73 | /// 74 | /// The message to be posted 75 | /// 76 | procedure Post(const AChannel: string; const AMessage: string); overload; 77 | 78 | /// 79 | /// Posts an interface-typed event to the event bus. 80 | /// 81 | /// 82 | /// User defined interface-typed event. 83 | /// 84 | /// 85 | /// Context of the event. It will be jointly used by the event bus 86 | /// to route the event to proper subscriber methods. 87 | /// 88 | procedure Post(const AEvent: IInterface; const AContext: string = ''); overload; 89 | 90 | /// 91 | /// Registers a new subscriber for named-channel messages. 92 | /// 93 | /// 94 | /// The subscriber object to register, which should have methods with 95 | /// Channel attribute. 96 | /// 97 | /// 98 | /// Throws whenever a subscriber method of the subscriber object has 99 | /// invalid number of arguments or invalid argument type. 100 | /// 101 | /// 102 | /// Throws when the subscriber object does not have any methods with 103 | /// Channel attribute defined. 104 | /// 105 | procedure RegisterSubscriberForChannels(ASubscriber: TObject); 106 | 107 | /// 108 | /// Registers a new subscriber for named-channel messages. 109 | /// 110 | /// 111 | /// The subscriber object to register, which should have methods with 112 | /// Channel attribute. 113 | /// 114 | /// 115 | /// Throws whenever a subscriber method of the subscriber object has 116 | /// invalid number of arguments or invalid argument type. 117 | /// 118 | /// 119 | /// There won't be any exception thrown if the subscriber object has no 120 | /// subscriber methods defined. 121 | /// 122 | procedure SilentRegisterSubscriberForChannels(ASubscriber: TObject); 123 | 124 | /// 125 | /// Unregisters a subscriber from receiving named-channel messages. 126 | /// 127 | /// 128 | /// The subscriber to unregister. 129 | /// 130 | procedure UnregisterForChannels(ASubscriber: TObject); 131 | 132 | /// 133 | /// Registers a subscriber for interface-typed events. 134 | /// 135 | /// 136 | /// The subscriber object to register, which should have methods with 137 | /// Subscribe attributes. 138 | /// 139 | /// 140 | /// Throws whenever a subscriber method of the subscriber object has 141 | /// invalid number of arguments or invalid argument type. 142 | /// 143 | /// 144 | /// Throws when the subscriber object does not have any methods with 145 | /// Subscribe attribute defined. 146 | /// 147 | procedure RegisterSubscriberForEvents(ASubscriber: TObject); 148 | 149 | /// 150 | /// Registers a subscriber for interface-typed events. 151 | /// 152 | /// 153 | /// The subscriber object to register, which should have methods with 154 | /// Subscribe attributes. 155 | /// 156 | /// 157 | /// Throws whenever a subscriber method of the subscriber object has 158 | /// invalid number of arguments or invalid argument type. 159 | /// 160 | /// 161 | /// There won't be any exception thrown if the subscriber object has no 162 | /// subscriber methods defined. 163 | /// 164 | procedure SilentRegisterSubscriberForEvents(ASubscriber: TObject); 165 | 166 | /// 167 | /// Unregisters a subscriber from receiving interface-typed events. 168 | /// 169 | /// 170 | /// The subscriber object to unregister. 171 | /// 172 | procedure UnregisterForEvents(ASubscriber: TObject); 173 | 174 | /// 175 | /// Register a new context for a given event of a specific subscriber. 176 | /// 177 | /// 178 | /// The subscriber object who holds the event. 179 | /// 180 | /// 181 | /// The event you want to change the context. 182 | /// 183 | /// 184 | /// The old context value to replace. 185 | /// 186 | /// 187 | /// The new context value. 188 | /// 189 | procedure RegisterNewContext(ASubscriber: TObject; AEvent: IInterface; const AOldContext: String; const ANewContext: String); 190 | end; 191 | 192 | type 193 | /// 194 | /// Provides a generic interface for user-defined interface-typed event. 195 | /// It wraps up a generic data object that a user-defined interface can 196 | /// instantiate. 197 | /// 198 | /// 199 | /// A user defined interface-typed event can either inherit from 200 | /// IDEBEvent<T>, or from IInterface directly. If inherited from the latter, 201 | /// the user defined interface-typed event must handle implementation details itself. 202 | /// 203 | IDEBEvent = interface(IInterface) 204 | ['{AFDFF9C9-46D8-4663-9535-2BBB1396587C}'] 205 | {$REGION 'Property Gettors and Settors'} 206 | function Get_Data: T; 207 | procedure Set_Data(const AValue: T); 208 | function Get_OwnsData: Boolean; 209 | procedure Set_OwnsData(const AValue: Boolean); 210 | {$ENDREGION} 211 | /// 212 | /// The wrapped data 213 | /// 214 | property Data: T read Get_Data write Set_Data; 215 | /// 216 | /// Whether the data is owned by the subject event. If so, the data's 217 | /// life will be managed by the event. 218 | /// 219 | property OwnsData: Boolean read Get_OwnsData write Set_OwnsData; 220 | end; 221 | 222 | /// 223 | /// Implements IDEBEvent<T> interface. 224 | /// 225 | TDEBEvent = class(TInterfacedObject, IDEBEvent) 226 | private 227 | FData: T; 228 | FOwnsData: Boolean; 229 | function Get_Data: T; 230 | procedure Set_Data(const AValue: T); 231 | function Get_OwnsData: Boolean; 232 | procedure Set_OwnsData(const AValue: Boolean); 233 | public 234 | constructor Create; overload; 235 | constructor Create(AData: T); overload; 236 | destructor Destroy; override; 237 | 238 | property Data: T read FData write Set_Data; 239 | property OwnsData: Boolean read Get_OwnsData write Set_OwnsData; 240 | end; 241 | 242 | type 243 | /// 244 | /// Thead mode of the subscriber method. 245 | /// 246 | TThreadMode = ( 247 | /// 248 | /// The subscriber method will be invoked in the same posting thread where 249 | /// IEventBus.Post is called. 250 | /// 251 | Posting, 252 | 253 | /// 254 | /// The subscriber method will be invoked in the main thread. 255 | /// 256 | Main, 257 | 258 | /// 259 | /// The subscriber method will be invoked asynchronously in a new thread 260 | /// other than the posting thread. 261 | /// 262 | Async, 263 | 264 | /// 265 | /// If the posting thread is the main thread, the subscriber method will 266 | /// be invoked asynchronously in a new thread other than the posting 267 | /// thread. If the posting thread is NOT the main thread, the subscriber 268 | /// method will be invoked synchronously in the same posting thread. 269 | /// 270 | Background 271 | ); 272 | 273 | type 274 | TSubscriberMethodAttribute = class abstract (TCustomAttribute) 275 | strict private 276 | FContext: string; 277 | FThreadMode: TThreadMode; 278 | strict protected 279 | function Get_ArgTypeKind: TTypeKind; virtual; abstract; 280 | 281 | /// 282 | /// Thread mode of the subscriber method. 283 | /// 284 | /// 285 | /// Context of event. 286 | /// 287 | /// 288 | constructor Create(AThreadMode: TThreadMode; const AContext: string); 289 | public 290 | /// 291 | /// Thread mode of the subscriber method. 292 | /// 293 | property ThreadMode: TThreadMode read FThreadMode; 294 | 295 | /// 296 | /// Context of the subscriber method. 297 | /// 298 | property Context: string read FContext; 299 | 300 | /// 301 | /// Required argment type of the subscriber method. 302 | /// 303 | property ArgTypeKind: TTypeKind read Get_ArgTypeKind; 304 | end; 305 | 306 | /// 307 | /// Subscriber attribute must be specified to subscriber methods in 308 | /// order to receive interface-typed events. 309 | /// 310 | SubscribeAttribute = class(TSubscriberMethodAttribute) 311 | strict protected 312 | function Get_ArgTypeKind: TTypeKind; override; 313 | public 314 | constructor Create(AThreadMode: TThreadMode = TThreadMode.Posting; const AContext: string = ''); 315 | end; 316 | 317 | /// 318 | /// Channel attribute must be specified to subscriber methods in order 319 | /// to receive named-channel messages. 320 | /// 321 | ChannelAttribute = class(TSubscriberMethodAttribute) 322 | strict private 323 | function Get_Channel: string; 324 | strict protected 325 | function Get_ArgTypeKind: TTypeKind; override; 326 | public 327 | /// 328 | /// Name of the channel 329 | /// 330 | /// 331 | /// Thread mode of the subscriber method 332 | /// 333 | constructor Create(const AChannel: string; AThreadMode: TThreadMode = TThreadMode.Posting); 334 | 335 | /// 336 | /// Name of the channel. 337 | /// 338 | property Channel: string read Get_Channel; 339 | end; 340 | 341 | /// 342 | /// Throws whenever a subscriber method has invalid number of arguments or 343 | /// invalid argument type. 344 | /// 345 | EInvalidSubscriberMethod = class(Exception) 346 | end; 347 | 348 | /// 349 | /// Throws when a subscriber object does not have any methods with Channel 350 | /// or Subscribe attribute defined. 351 | /// 352 | EObjectHasNoSubscriberMethods = class(Exception) 353 | end; 354 | 355 | /// 356 | /// Throws when a user trying to register a method of a subscriber object 357 | /// that has been already registered. 358 | /// 359 | ESubscriberMethodAlreadyRegistered = class(Exception) 360 | end; 361 | 362 | /// 363 | /// Throws when an unknown thread mode is specified. 364 | /// 365 | EUnknownThreadMode = class(Exception) 366 | end; 367 | 368 | /// 369 | /// Throws when exception occurs during subscriber method invokation. 370 | /// 371 | EInvokeSubscriberError = class(Exception) 372 | end; 373 | 374 | /// 375 | /// Singleton global event bus. 376 | /// 377 | function GlobalEventBus: IEventBus; 378 | 379 | implementation 380 | 381 | uses 382 | System.Rtti, EventBus.Core; 383 | 384 | function GlobalEventBus: IEventBus; 385 | begin 386 | Result := TEventBusFactory.GlobalEventBus; 387 | end; 388 | 389 | constructor TDEBEvent.Create; 390 | begin 391 | inherited Create; 392 | end; 393 | 394 | constructor TDEBEvent.Create(AData: T); 395 | begin 396 | inherited Create; 397 | OwnsData := True; 398 | Data := AData; 399 | end; 400 | 401 | destructor TDEBEvent.Destroy; 402 | var 403 | LValue: TValue; 404 | begin 405 | LValue := TValue.From(Data); 406 | if (LValue.IsObject) and OwnsData then LValue.AsObject.Free; 407 | inherited; 408 | end; 409 | 410 | function TDEBEvent.Get_Data: T; 411 | begin 412 | Result:= FData; 413 | end; 414 | 415 | procedure TDEBEvent.Set_Data(const AValue: T); 416 | begin 417 | FData := AValue; 418 | end; 419 | 420 | function TDEBEvent.Get_OwnsData: Boolean; 421 | begin 422 | Result:= FOwnsData; 423 | end; 424 | 425 | procedure TDEBEvent.Set_OwnsData(const AValue: Boolean); 426 | begin 427 | FOwnsData := AValue; 428 | end; 429 | 430 | constructor SubscribeAttribute.Create(AThreadMode: TThreadMode = TThreadMode.Posting; const AContext: string = ''); 431 | begin 432 | inherited Create(AThreadMode, AContext); 433 | end; 434 | 435 | function SubscribeAttribute.Get_ArgTypeKind: TTypeKind; 436 | begin 437 | Result := TTypeKind.tkInterface; 438 | end; 439 | 440 | constructor ChannelAttribute.Create(const AChannel: string; AThreadMode: TThreadMode = TThreadMode.Posting); 441 | begin 442 | inherited Create(AThreadMode, AChannel); 443 | end; 444 | 445 | function ChannelAttribute.Get_ArgTypeKind: TTypeKind; 446 | begin 447 | Result := TTypeKind.tkUString; 448 | end; 449 | 450 | function ChannelAttribute.Get_Channel: string; 451 | begin 452 | Result := Context; 453 | end; 454 | 455 | constructor TSubscriberMethodAttribute.Create(AThreadMode: TThreadMode; const AContext: string); 456 | begin 457 | inherited Create; 458 | FContext := AContext; 459 | FThreadMode := AThreadMode; 460 | end; 461 | 462 | end. 463 | 464 | -------------------------------------------------------------------------------- /tests/BOs.pas: -------------------------------------------------------------------------------- 1 | unit BOs; 2 | 3 | interface 4 | 5 | uses 6 | System.Generics.Collections, System.SyncObjs, EventBus; 7 | 8 | type 9 | TPerson = class(TObject) 10 | private 11 | FChild: TPerson; 12 | FFirstname: string; 13 | FLastname: string; 14 | procedure Set_Child(const AValue: TPerson); 15 | procedure Set_Firstname(const AValue: string); 16 | procedure Set_Lastname(const AValue: string); 17 | public 18 | destructor Destroy; override; 19 | property Child: TPerson read FChild write Set_Child; 20 | property Firstname: string read FFirstname write Set_Firstname; 21 | property Lastname: string read FLastname write Set_Lastname; 22 | end; 23 | 24 | IEventBusEvent = IDEBEvent; 25 | 26 | TEventBusEvent = class(TDEBEvent); 27 | 28 | IMainEvent = interface(IEventBusEvent) 29 | ['{68F192C1-1F0F-41CE-85FD-0146C2301A4E}'] 30 | end; 31 | 32 | TMainEvent = class(TDEBEvent, IMainEvent); 33 | 34 | IAsyncEvent = Interface(IEventBusEvent) 35 | ['{68F192C1-1F0F-41CE-85FD-0146C2301A4E}'] 36 | end; 37 | 38 | TAsyncEvent = class(TDEBEvent, IAsyncEvent); 39 | 40 | IBackgroundEvent = Interface(IEventBusEvent) 41 | ['{E70B43F0-7F68-47B9-AFF3-5878A0B1A88D}'] 42 | procedure Set_SequenceID(const AValue: Integer); 43 | function Get_SequenceID: Integer; 44 | property SequenceID: Integer read Get_SequenceID write Set_SequenceID; 45 | end; 46 | 47 | TBackgroundEvent = class(TDEBEvent, IBackgroundEvent) 48 | private 49 | FSequenceID: Integer; 50 | function Get_SequenceID: Integer; 51 | procedure Set_SequenceID(const AValue: Integer); 52 | public 53 | property SequenceID: Integer read Get_SequenceID write Set_SequenceID; 54 | public 55 | end; 56 | 57 | TBaseSubscriber = class(TObject) 58 | private 59 | FChannelMsg: string; 60 | FEvent: TEvent; // Wrapper of Win32 Set_Event with automic Set_/Reset, no need for thread protection. 61 | FCount: Integer; 62 | FEventMsg: string; 63 | FLastEvent: IEventBusEvent; 64 | FLastEventThreadID: Cardinal; 65 | procedure Set_LastChannelMsg(const AValue: string); 66 | procedure Set_LastEvent(const AValue: IEventBusEvent); 67 | procedure Set_LastEventMsg(const AValue: string); 68 | procedure Set_LastEventThreadID(const AValue: Cardinal); 69 | public 70 | constructor Create; 71 | destructor Destroy; override; 72 | 73 | procedure IncrementCount; 74 | 75 | property Event: TEvent read FEvent; // Readonly is good enough 76 | property Count: Integer read FCount; 77 | property LastEvent: IEventBusEvent read FLastEvent write Set_LastEvent; 78 | property LastChannelMsg: string read FChannelMsg write Set_LastChannelMsg; 79 | property LastEventMsg: string read FEventMsg write Set_LastEventMsg; 80 | property LastEventThreadID: Cardinal read FLastEventThreadID write Set_LastEventThreadID; 81 | end; 82 | 83 | TSubscriber = class(TBaseSubscriber) 84 | [Subscribe] 85 | procedure OnSimpleEvent(AEvent: IEventBusEvent); 86 | 87 | [Subscribe(TThreadMode.Async)] 88 | procedure OnSimpleAsyncEvent(AEvent: IAsyncEvent); 89 | 90 | [Subscribe(TThreadMode.Main)] 91 | procedure OnSimpleMainEvent(AEvent: IMainEvent); 92 | 93 | [Subscribe(TThreadMode.Background)] 94 | procedure OnSimpleBackgroundEvent(AEvent: IBackgroundEvent); 95 | 96 | [Subscribe(TThreadMode.Main, 'TestCtx')] 97 | procedure OnSimpleContextEvent(AEvent: IMainEvent); 98 | end; 99 | 100 | TChannelSubscriber = class(TBaseSubscriber) 101 | [Channel('test_channel')] 102 | procedure OnSimpleChannel(AMsg: string); 103 | 104 | [Channel('test_channel_async', TThreadMode.Async)] 105 | procedure OnSimpleAsyncChannel(AMsg: string); 106 | 107 | [Channel('test_channel_main', TThreadMode.Main)] 108 | procedure OnSimpleMainChannel(AMsg: string); 109 | 110 | [Channel('test_channel_bkg', TThreadMode.Background)] 111 | procedure OnSimpleBackgroundChannel(AMsg: string); 112 | end; 113 | 114 | TSubscriberCopy = class(TBaseSubscriber) 115 | [Subscribe] 116 | procedure OnSimpleEvent(AEvent: IEventBusEvent); 117 | end; 118 | 119 | TPersonSubscriber = class(TBaseSubscriber) 120 | private 121 | FPerson: TPerson; 122 | FOwnsObject: Boolean; 123 | procedure Set_OwnsObject(const AValue: Boolean); 124 | procedure Set_Person(const AValue: TPerson); 125 | public 126 | constructor Create; 127 | destructor Destroy; override; 128 | 129 | [Subscribe] 130 | procedure OnPersonEvent(AEvent: IDEBEvent); 131 | 132 | property OwnsObject: Boolean read FOwnsObject write Set_OwnsObject; 133 | property Person: TPerson read FPerson write Set_Person; 134 | end; 135 | 136 | TPersonListSubscriber = class(TBaseSubscriber) 137 | private 138 | FPersonList: TObjectList; 139 | procedure Set_PersonList(const AValue: TObjectList); 140 | public 141 | [Subscribe] 142 | procedure OnPersonListEvent(AEvent: IDEBEvent>); 143 | 144 | property PersonList: TObjectList read FPersonList write Set_PersonList; 145 | end; 146 | 147 | TEmptySubscriber = class 148 | 149 | end; 150 | 151 | 152 | TInvalidArgNumSubscriber = class 153 | public 154 | [Subscribe] 155 | procedure OnEvent(AEvent: IEventBusEvent; AExtraArg: Integer); 156 | 157 | [Channel('Test')] 158 | procedure OnChannelMessage(const AMesage: string; AExtraArg: Integer); 159 | end; 160 | 161 | TInvalidArgTypeSubscriber = class 162 | public 163 | [Subscribe] 164 | procedure OnEvent(AEvent: Integer); 165 | 166 | [Channel('Test')] 167 | procedure OnChannelMessage(const AMesage: Integer); 168 | end; 169 | 170 | implementation 171 | 172 | uses 173 | System.Classes; 174 | 175 | constructor TBaseSubscriber.Create; 176 | begin 177 | inherited Create; 178 | FEvent := TEvent.Create; 179 | FCount := 0; 180 | end; 181 | 182 | destructor TBaseSubscriber.Destroy; 183 | begin 184 | GlobalEventBus.UnregisterForEvents(Self); 185 | GlobalEventBus.UnregisterForChannels(Self); 186 | FEvent.Free; 187 | inherited; 188 | end; 189 | 190 | procedure TBaseSubscriber.IncrementCount; 191 | begin 192 | AtomicIncrement(FCount); 193 | end; 194 | 195 | procedure TBaseSubscriber.Set_LastEvent(const AValue: IEventBusEvent); 196 | begin 197 | TMonitor.Enter(Self); // Need to protect from multithread write (for the Background/Async events testing) 198 | FLastEvent := AValue; 199 | TMonitor.Exit(Self); 200 | end; 201 | 202 | procedure TBaseSubscriber.Set_LastEventThreadID(const AValue: Cardinal); 203 | begin 204 | TMonitor.Enter(Self); // Need to protect from multithread write (for the Background/Async events testing) 205 | FLastEventThreadID := AValue; 206 | TMonitor.Exit(Self); 207 | end; 208 | 209 | procedure TBaseSubscriber.Set_LastChannelMsg(const AValue: string); 210 | begin 211 | TMonitor.Enter(Self); 212 | FChannelMsg := AValue; 213 | TMonitor.Exit(Self); 214 | end; 215 | 216 | procedure TBaseSubscriber.Set_LastEventMsg(const AValue: string); 217 | begin 218 | TMonitor.Enter(Self); 219 | FEventMsg := AValue; 220 | TMonitor.Exit(Self); 221 | end; 222 | 223 | procedure TSubscriber.OnSimpleAsyncEvent(AEvent: IAsyncEvent); 224 | begin 225 | LastEvent := AEvent; 226 | LastEventMsg:= AEvent.Data; 227 | LastEventThreadID := TThread.CurrentThread.ThreadID; 228 | Event.SetEvent; 229 | end; 230 | 231 | procedure TSubscriber.OnSimpleBackgroundEvent(AEvent: IBackgroundEvent); 232 | begin 233 | LastEvent := AEvent; 234 | LastEventThreadID := TThread.CurrentThread.ThreadID; 235 | IncrementCount; 236 | Event.SetEvent; 237 | end; 238 | 239 | procedure TSubscriber.OnSimpleContextEvent(AEvent: IMainEvent); 240 | begin 241 | LastEvent := AEvent; 242 | LastEventThreadID := TThread.CurrentThread.ThreadID; 243 | end; 244 | 245 | procedure TSubscriber.OnSimpleEvent(AEvent: IEventBusEvent); 246 | begin 247 | LastEvent := AEvent; 248 | LastEventMsg:= AEvent.Data; 249 | LastEventThreadID := TThread.CurrentThread.ThreadID; 250 | Event.SetEvent; 251 | end; 252 | 253 | procedure TSubscriber.OnSimpleMainEvent(AEvent: IMainEvent); 254 | begin 255 | LastEvent := AEvent; 256 | LastEventMsg:= AEvent.Data; 257 | LastEventThreadID := TThread.CurrentThread.ThreadID; 258 | end; 259 | 260 | function TBackgroundEvent.Get_SequenceID: Integer; 261 | begin 262 | Result:= FSequenceID; 263 | end; 264 | 265 | procedure TBackgroundEvent.Set_SequenceID(const AValue: Integer); 266 | begin 267 | FSequenceID := AValue; 268 | end; 269 | 270 | procedure TSubscriberCopy.OnSimpleEvent(AEvent: IEventBusEvent); 271 | begin 272 | LastEvent := AEvent; 273 | LastEventThreadID := TThread.CurrentThread.ThreadID; 274 | Event.SetEvent; 275 | end; 276 | 277 | destructor TPerson.Destroy; 278 | begin 279 | if Assigned(Child) then 280 | if Integer(Self) <> Integer(Child) then Child.Free; 281 | inherited; 282 | end; 283 | 284 | procedure TPerson.Set_Child(const AValue: TPerson); 285 | begin 286 | FChild := AValue; 287 | end; 288 | 289 | procedure TPerson.Set_Firstname(const AValue: string); 290 | begin 291 | FFirstname := AValue; 292 | end; 293 | 294 | procedure TPerson.Set_Lastname(const AValue: string); 295 | begin 296 | FLastname := AValue; 297 | end; 298 | 299 | constructor TPersonSubscriber.Create; 300 | begin 301 | inherited Create; 302 | FOwnsObject := True; 303 | end; 304 | 305 | destructor TPersonSubscriber.Destroy; 306 | begin 307 | if OwnsObject and Assigned(Person) then 308 | Person.Free; 309 | 310 | inherited; 311 | end; 312 | 313 | procedure TPersonSubscriber.OnPersonEvent(AEvent: IDEBEvent); 314 | begin 315 | AEvent.OwnsData:= False; 316 | Person := AEvent.Data; 317 | LastEventThreadID := TThread.CurrentThread.ThreadID; 318 | Event.SetEvent; 319 | end; 320 | 321 | procedure TPersonSubscriber.Set_OwnsObject(const AValue: Boolean); 322 | begin 323 | FOwnsObject := AValue; 324 | end; 325 | 326 | procedure TPersonSubscriber.Set_Person(const AValue: TPerson); 327 | begin 328 | FPerson := AValue; 329 | end; 330 | 331 | procedure TPersonListSubscriber.OnPersonListEvent(AEvent: IDEBEvent>); 332 | begin 333 | PersonList := AEvent.Data; 334 | AEvent.OwnsData := False; 335 | LastEventThreadID := TThread.CurrentThread.ThreadID; 336 | Event.SetEvent; 337 | end; 338 | 339 | procedure TPersonListSubscriber.Set_PersonList(const AValue: TObjectList); 340 | begin 341 | FPersonList := AValue; 342 | end; 343 | 344 | procedure TChannelSubscriber.OnSimpleAsyncChannel(AMsg: string); 345 | begin 346 | LastChannelMsg := AMsg; 347 | LastEventThreadID := TThread.CurrentThread.ThreadID; 348 | Event.SetEvent; 349 | end; 350 | 351 | procedure TChannelSubscriber.OnSimpleBackgroundChannel(AMsg: string); 352 | begin 353 | LastChannelMsg := AMsg; 354 | IncrementCount; 355 | LastEventThreadID := TThread.CurrentThread.ThreadID; 356 | Event.SetEvent; 357 | end; 358 | 359 | procedure TChannelSubscriber.OnSimpleChannel(AMsg: string); 360 | begin 361 | LastChannelMsg := AMsg; 362 | LastEventThreadID := TThread.CurrentThread.ThreadID; 363 | Event.SetEvent; 364 | end; 365 | 366 | procedure TChannelSubscriber.OnSimpleMainChannel(AMsg: string); 367 | begin 368 | LastChannelMsg := AMsg; 369 | LastEventThreadID := TThread.CurrentThread.ThreadID; 370 | Event.SetEvent; 371 | end; 372 | 373 | procedure TInvalidArgNumSubscriber.OnChannelMessage(const AMesage: string; AExtraArg: Integer); 374 | begin 375 | // No-Op 376 | end; 377 | 378 | procedure TInvalidArgNumSubscriber.OnEvent(AEvent: IEventBusEvent; AExtraArg: Integer); 379 | begin 380 | // No-Op 381 | end; 382 | 383 | procedure TInvalidArgTypeSubscriber.OnChannelMessage(const AMesage: Integer); 384 | begin 385 | // No-Op 386 | end; 387 | 388 | procedure TInvalidArgTypeSubscriber.OnEvent(AEvent: Integer); 389 | begin 390 | // No-Op 391 | end; 392 | 393 | end. 394 | 395 | -------------------------------------------------------------------------------- /tests/BaseTestU.pas: -------------------------------------------------------------------------------- 1 | unit BaseTestU; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, BOs; 7 | 8 | type 9 | [TestFixture] 10 | TBaseTest = class(TObject) 11 | private 12 | FSubscriber: TSubscriber; 13 | FChannelSubscriber: TChannelSubscriber; 14 | procedure Set_Subscriber(const Value: TSubscriber); 15 | protected 16 | function SimpleCustomClone(const AObject: TObject): TObject; 17 | public 18 | property Subscriber: TSubscriber read FSubscriber write Set_Subscriber; 19 | property ChannelSubscriber: TChannelSubscriber read FChannelSubscriber write FChannelSubscriber; 20 | 21 | [Setup] 22 | procedure Setup; 23 | 24 | [TearDown] 25 | procedure TearDown; 26 | end; 27 | 28 | implementation 29 | 30 | uses 31 | System.SysUtils, EventBus; 32 | 33 | procedure TBaseTest.Set_Subscriber(const Value: TSubscriber); 34 | begin 35 | FSubscriber := Value; 36 | end; 37 | 38 | procedure TBaseTest.Setup; 39 | begin 40 | FSubscriber := TSubscriber.Create; 41 | FChannelSubscriber := TChannelSubscriber.Create; 42 | end; 43 | 44 | function TBaseTest.SimpleCustomClone(const AObject: TObject): TObject; 45 | var 46 | LEvent: TDEBEvent; 47 | begin 48 | LEvent := TDEBEvent.Create; 49 | LEvent.OwnsData := (AObject as TDEBEvent).OwnsData; 50 | LEvent.Data := TPerson.Create; 51 | LEvent.Data.Firstname := (AObject as TDEBEvent).Data.Firstname + 'Custom'; 52 | LEvent.Data.Lastname := (AObject as TDEBEvent).Data.Lastname + 'Custom'; 53 | Result := LEvent; 54 | end; 55 | 56 | procedure TBaseTest.TearDown; 57 | begin 58 | GlobalEventBus.UnregisterForChannels(ChannelSubscriber); 59 | GlobalEventBus.UnregisterForEvents(Subscriber); 60 | 61 | if Assigned(FSubscriber) then 62 | FreeAndNil(FSubscriber); 63 | 64 | if Assigned(FChannelSubscriber) then 65 | FreeAndNil(FChannelSubscriber); 66 | end; 67 | 68 | end. 69 | -------------------------------------------------------------------------------- /tests/DEBDUnitXTests.dpr: -------------------------------------------------------------------------------- 1 | program DEBDUnitXTests; 2 | 3 | {$IFNDEF TESTINSIGHT} 4 | {$IFNDEF GUI_TESTRUNNER} 5 | {$APPTYPE CONSOLE} 6 | {$ENDIF}{$ENDIF}{$STRONGLINKTYPES ON} 7 | 8 | uses 9 | SysUtils, 10 | {$IFDEF GUI_TESTRUNNER} 11 | Vcl.Forms, 12 | DUnitX.Loggers.GUI.Vcl, 13 | {$ENDIF } 14 | {$IFDEF TESTINSIGHT} 15 | TestInsight.DUnitX, 16 | {$ENDIF } 17 | {$IFDEF CONSOLE_TESTRUNNER} 18 | DUnitX.Loggers.Console, 19 | {$ENDIF } 20 | DUnitX.Loggers.Xml.NUnit, 21 | DUnitX.TestFramework, 22 | EventBusTestU in 'EventBusTestU.pas', 23 | BOs in 'BOs.pas', 24 | BaseTestU in 'BaseTestU.pas', 25 | EventBus in '..\source\EventBus.pas', 26 | EventBus.Helpers in '..\source\EventBus.Helpers.pas', 27 | EventBus.Subscribers in '..\source\EventBus.Subscribers.pas', 28 | EventBus.Core in '..\source\EventBus.Core.pas'; 29 | 30 | {$IFDEF TESTINSIGHT} 31 | TestInsight.DUnitX.RunRegisteredTests; 32 | Exit; 33 | {$ENDIF} 34 | 35 | {$IFDEF CONSOLE_TESTRUNNER} 36 | procedure MainConsole(); 37 | var 38 | runner: ITestRunner; 39 | results: IRunResults; 40 | logger: ITestLogger; 41 | nunitLogger: ITestLogger; 42 | try 43 | // Check command line options, will exit if invalid 44 | TDUnitX.CheckCommandLine; 45 | // Create the test runner 46 | runner := TDUnitX.CreateRunner; 47 | // Tell the runner to use RTTI to find Fixtures 48 | runner.UseRTTI := true; 49 | // tell the runner how we will log things 50 | // Log to the console window 51 | logger := TDUnitXConsoleLogger.Create(true); 52 | runner.AddLogger(logger); 53 | // Generate an NUnit compatible XML File 54 | nunitLogger := TDUnitXXMLNUnitFileLogger.Create 55 | (TDUnitX.Options.XMLOutputFile); 56 | runner.AddLogger(nunitLogger); 57 | runner.FailsOnNoAsserts := False; 58 | // When true, Assertions must be made during tests; 59 | 60 | // Run tests 61 | results := runner.Execute; 62 | if not results.AllPassed then 63 | System.ExitCode := EXIT_ERRORS; 64 | 65 | {$IFNDEF CI} 66 | // We don't want this happening when running under CI. 67 | if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then 68 | begin 69 | System.Write('Done.. press key to quit.'); 70 | System.Readln; 71 | end; 72 | {$ENDIF} 73 | except 74 | on E: Exception do 75 | System.Writeln(E.ClassName, ': ', E.Message); 76 | end; 77 | {$ENDIF} 78 | {$IFDEF GUI_TESTRUNNER} 79 | 80 | procedure MainGUI; 81 | begin 82 | Application.Initialize; 83 | Application.CreateForm(TGUIVCLTestRunner, GUIVCLTestRunner); 84 | Application.Run; 85 | end; 86 | {$ENDIF} 87 | 88 | begin 89 | ReportMemoryLeaksOnShutdown := true; 90 | {$IFDEF CONSOLE_TESTRUNNER} 91 | MainConsole(); 92 | {$ENDIF} 93 | {$IFDEF GUI_TESTRUNNER} 94 | MainGUI(); 95 | {$ENDIF} 96 | 97 | end. 98 | -------------------------------------------------------------------------------- /tests/DEBDunitXTests.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spinettaro/delphi-event-bus/233a6b6158bd2579785f997799b9cba276e098aa/tests/DEBDunitXTests.res -------------------------------------------------------------------------------- /tests/DEBTestsPG.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {A1F1F9B4-3D64-4FAE-8910-D712676DFB26} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Default.Personality.12 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /tests/EventBusTestU.pas: -------------------------------------------------------------------------------- 1 | unit EventBusTestU; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, BaseTestU; 7 | 8 | type 9 | 10 | [TestFixture] 11 | TEventBusTest = class(TBaseTest) 12 | public 13 | [Test] 14 | procedure TestRegisterUnregisterEvents; 15 | [Test] 16 | procedure TestIsRegisteredTrueAfterRegisterEvents; 17 | [Test] 18 | procedure TestIsRegisteredFalseAfterUnregisterEvents; 19 | [Test] 20 | procedure TestRegisterUnregisterMultipleSubscriberEvents; 21 | 22 | [Test] 23 | procedure TestRegisterUnregisterChannels; 24 | [Test] 25 | procedure TestIsRegisteredTrueAfterRegisterChannels; 26 | [Test] 27 | procedure TestIsRegisteredFalseAfterUnregisterChannels; 28 | [Test] 29 | procedure TestRegisterUnregisterMultipleSubscriberChannels; 30 | 31 | [Test] 32 | procedure TestSimplePost; 33 | [Test] 34 | procedure TestSimplePostOnBackgroundThread; 35 | [Test] 36 | procedure TestAsyncPost; 37 | [Test] 38 | procedure TestPostOnMainThread; 39 | 40 | [Test] 41 | procedure TestSimplePostChannel; 42 | [Test] 43 | procedure TestSimplePostChannelOnBackgroundThread; 44 | [Test] 45 | procedure TestAsyncPostChannel; 46 | [Test] 47 | procedure TestPostChannelOnMainThread; 48 | [Test] 49 | procedure TestBackgroundPostChannel; 50 | [Test] 51 | procedure TestBackgroundsPostChannel; 52 | 53 | [Test] 54 | procedure TestPostContextOnMainThread; 55 | [Test] 56 | procedure TestPostContextKOOnMainThread; 57 | [Test] 58 | procedure TestRegisterNewContext; 59 | [Test] 60 | procedure TestBackgroundPost; 61 | [Test] 62 | procedure TestBackgroundsPost; 63 | 64 | [Test] 65 | procedure TestPostEntityWithChildObject; 66 | [Test] 67 | procedure TestPostEntityWithItsSelfInChildObject; 68 | [Test] 69 | procedure TestPostEntityWithObjectList; 70 | [Test] 71 | procedure TestRegisterAndFree; 72 | 73 | [Test] 74 | procedure TestEmptySubscriber; 75 | [Test] 76 | procedure TestInvalidArgTypeSubscriber; 77 | [Test] 78 | procedure TestInvalidArgNumberSubscriber; 79 | end; 80 | 81 | implementation 82 | 83 | uses 84 | System.Classes, 85 | System.Generics.Collections, 86 | System.SyncObjs, 87 | System.SysUtils, 88 | System.Threading, 89 | BOs, 90 | EventBus; 91 | 92 | procedure TEventBusTest.TestSimplePost; 93 | var 94 | LEvent: IEventBusEvent; 95 | LMsg: string; 96 | begin 97 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 98 | LEvent := TEventBusEvent.Create; 99 | LMsg := 'TestSimplePost'; 100 | LEvent.Data := LMsg; 101 | 102 | GlobalEventBus.Post(LEvent); 103 | Assert.AreEqual(LMsg, Subscriber.LastEvent.Data); 104 | end; 105 | 106 | procedure TEventBusTest.TestSimplePostChannel; 107 | var 108 | LMsg: string; 109 | begin 110 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 111 | LMsg := 'TestSimplePost'; 112 | GlobalEventBus.Post('test_channel', 'TestSimplePost'); 113 | Assert.AreEqual(LMsg, ChannelSubscriber.LastChannelMsg); 114 | end; 115 | 116 | procedure TEventBusTest.TestSimplePostChannelOnBackgroundThread; 117 | begin 118 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 119 | 120 | TTask.Run( 121 | procedure 122 | begin 123 | GlobalEventBus.Post('test_channel', 'TestSimplePost'); 124 | end); 125 | 126 | // attend for max 5 seconds 127 | Assert.IsTrue(TWaitResult.wrSignaled = ChannelSubscriber.Event.WaitFor(5000), 'Timeout request'); 128 | Assert.AreNotEqual(MainThreadID, ChannelSubscriber.LastEventThreadID); 129 | end; 130 | 131 | procedure TEventBusTest.TestSimplePostOnBackgroundThread; 132 | var 133 | LEvent: IEventBusEvent; 134 | begin 135 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 136 | LEvent := TEventBusEvent.Create; 137 | 138 | TTask.Run( 139 | procedure 140 | begin 141 | GlobalEventBus.Post(LEvent); 142 | end); 143 | 144 | // attend for max 5 seconds 145 | Assert.IsTrue(TWaitResult.wrSignaled = Subscriber.Event.WaitFor(5000), 'Timeout request'); 146 | Assert.AreNotEqual(MainThreadID, Subscriber.LastEventThreadID); 147 | end; 148 | 149 | procedure TEventBusTest.TestRegisterAndFree; 150 | var 151 | LRaisedException: Boolean; 152 | begin 153 | LRaisedException := False; 154 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 155 | 156 | try 157 | Subscriber.Free; 158 | Subscriber := nil; 159 | GlobalEventBus.Post(TEventBusEvent.Create); 160 | except 161 | on E: Exception do LRaisedException := True; 162 | end; 163 | 164 | Assert.IsFalse(LRaisedException); 165 | end; 166 | 167 | procedure TEventBusTest.TestRegisterNewContext; 168 | var 169 | LEvent: IMainEvent; 170 | LMsg: string; 171 | begin 172 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 173 | LEvent := TMainEvent.Create; 174 | LMsg := 'TestPostOnMainThread'; 175 | LEvent.Data := LMsg; 176 | GlobalEventBus.RegisterNewContext( Subscriber, LEvent, 'TestCtx', 'MyNewContext'); 177 | 178 | GlobalEventBus.Post(LEvent, 'TestCtx'); 179 | Assert.IsNull( Subscriber.LastEvent); 180 | 181 | GlobalEventBus.Post(LEvent, 'MyNewContext'); 182 | Assert.AreEqual(LMsg, Subscriber.LastEvent.Data); 183 | Assert.AreEqual(MainThreadID, Subscriber.LastEventThreadID); 184 | end; 185 | 186 | procedure TEventBusTest.TestRegisterUnregisterChannels; 187 | var 188 | LRaisedException: Boolean; 189 | begin 190 | LRaisedException := False; 191 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 192 | 193 | try 194 | GlobalEventBus.UnregisterForChannels(ChannelSubscriber); 195 | except 196 | on E: Exception do LRaisedException := True; 197 | end; 198 | 199 | Assert.IsFalse(LRaisedException); 200 | end; 201 | 202 | procedure TEventBusTest.TestRegisterUnregisterEvents; 203 | var 204 | LRaisedException: Boolean; 205 | begin 206 | LRaisedException := False; 207 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 208 | 209 | try 210 | GlobalEventBus.UnregisterForEvents(Subscriber); 211 | except 212 | on E: Exception do LRaisedException := True; 213 | end; 214 | 215 | Assert.IsFalse(LRaisedException); 216 | end; 217 | 218 | procedure TEventBusTest.TestRegisterUnregisterMultipleSubscriberChannels; 219 | var 220 | LChannelSubscriber: TChannelSubscriber; 221 | LMsg: string; 222 | begin 223 | LChannelSubscriber := TChannelSubscriber.Create; 224 | try 225 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 226 | GlobalEventBus.RegisterSubscriberForChannels(LChannelSubscriber); 227 | GlobalEventBus.UnregisterForChannels(ChannelSubscriber); 228 | LMsg := 'TestSimplePost'; 229 | GlobalEventBus.Post('test_channel', LMsg); 230 | Assert.IsFalse(GlobalEventBus.IsRegisteredForChannels(ChannelSubscriber)); 231 | Assert.IsTrue(GlobalEventBus.IsRegisteredForChannels(LChannelSubscriber)); 232 | Assert.AreEqual(LMsg, LChannelSubscriber.LastChannelMsg); 233 | finally 234 | LChannelSubscriber.Free; 235 | end; 236 | end; 237 | 238 | procedure TEventBusTest.TestRegisterUnregisterMultipleSubscriberEvents; 239 | var 240 | LSubscriber: TSubscriberCopy; 241 | LEvent: IEventBusEvent; 242 | LMsg: string; 243 | begin 244 | LSubscriber := TSubscriberCopy.Create; 245 | try 246 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 247 | GlobalEventBus.RegisterSubscriberForEvents(LSubscriber); 248 | GlobalEventBus.UnregisterForEvents(Subscriber); 249 | LEvent := TEventBusEvent.Create; 250 | LMsg := 'TestSimplePost'; 251 | LEvent.Data := LMsg; 252 | GlobalEventBus.Post(LEvent); 253 | Assert.IsFalse(GlobalEventBus.IsRegisteredForEvents(Subscriber)); 254 | Assert.IsTrue(GlobalEventBus.IsRegisteredForEvents(LSubscriber)); 255 | Assert.AreEqual(LMsg, LSubscriber.LastEvent.Data); 256 | finally 257 | LSubscriber.Free; 258 | end; 259 | end; 260 | 261 | procedure TEventBusTest.TestAsyncPostChannel; 262 | var 263 | LMsg: string; 264 | begin 265 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 266 | LMsg := 'TestAsyncPost'; 267 | GlobalEventBus.Post('test_channel_async', LMsg); 268 | // attend for max 5 seconds 269 | Assert.IsTrue(TWaitResult.wrSignaled = ChannelSubscriber.Event.WaitFor(5000), 'Timeout request'); 270 | Assert.AreEqual(LMsg, ChannelSubscriber.LastChannelMsg); 271 | Assert.AreNotEqual(MainThreadID, ChannelSubscriber.LastEventThreadID); 272 | end; 273 | 274 | procedure TEventBusTest.TestBackgroundPost; 275 | var 276 | LEvent: IBackgroundEvent; 277 | LMsg: string; 278 | begin 279 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 280 | LEvent := TBackgroundEvent.Create; 281 | LMsg := 'TestBackgroundPost'; 282 | LEvent.Data := LMsg; 283 | GlobalEventBus.Post(LEvent); 284 | // attend for max 5 seconds 285 | Assert.IsTrue(TWaitResult.wrSignaled = Subscriber.Event.WaitFor(5000), 'Timeout request'); 286 | Assert.AreEqual(LMsg, Subscriber.LastEvent.Data); 287 | Assert.AreNotEqual(MainThreadID, Subscriber.LastEventThreadID); 288 | end; 289 | 290 | procedure TEventBusTest.TestBackgroundPostChannel; 291 | var 292 | LMsg: string; 293 | begin 294 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 295 | LMsg := 'TestBackgroundPost'; 296 | GlobalEventBus.Post('test_channel_bkg', LMSG); 297 | // attend for max 5 seconds 298 | Assert.IsTrue(TWaitResult.wrSignaled = ChannelSubscriber.Event.WaitFor(5000), 'Timeout request'); 299 | Assert.AreEqual(LMsg, ChannelSubscriber.LastChannelMsg); 300 | Assert.AreNotEqual(MainThreadID, ChannelSubscriber.LastEventThreadID); 301 | end; 302 | 303 | procedure TEventBusTest.TestBackgroundsPost; 304 | var 305 | LEvent: IBackgroundEvent; 306 | LMsg: string; 307 | I: Integer; 308 | begin 309 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 310 | 311 | for I := 1 to 10 do begin 312 | LEvent := TBackgroundEvent.Create; 313 | LMsg := 'TestBackgroundPost'; 314 | LEvent.Data := LMsg; 315 | LEvent.SequenceID := I; 316 | GlobalEventBus.Post(LEvent); 317 | end; 318 | 319 | for I := 0 to 50 do TThread.Sleep(10); 320 | Assert.AreEqual(10, Subscriber.Count); 321 | end; 322 | 323 | procedure TEventBusTest.TestBackgroundsPostChannel; 324 | var 325 | LMsg: string; 326 | I: Integer; 327 | begin 328 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 329 | 330 | for I := 1 to 10 do begin 331 | LMsg := Format('TestBackgroundPost%d',[I]); 332 | GlobalEventBus.Post('test_channel_bkg', LMsg); 333 | end; 334 | 335 | for I := 0 to 50 do TThread.Sleep(10); 336 | Assert.AreEqual(10, ChannelSubscriber.Count); 337 | end; 338 | 339 | procedure TEventBusTest.TestIsRegisteredFalseAfterUnregisterChannels; 340 | begin 341 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 342 | Assert.IsTrue(GlobalEventBus.IsRegisteredForChannels(ChannelSubscriber)); 343 | end; 344 | 345 | procedure TEventBusTest.TestIsRegisteredFalseAfterUnregisterEvents; 346 | begin 347 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 348 | Assert.IsTrue(GlobalEventBus.IsRegisteredForEvents(Subscriber)); 349 | end; 350 | 351 | procedure TEventBusTest.TestIsRegisteredTrueAfterRegisterChannels; 352 | begin 353 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 354 | GlobalEventBus.UnregisterForChannels(ChannelSubscriber); 355 | Assert.IsFalse(GlobalEventBus.IsRegisteredForChannels(ChannelSubscriber)); 356 | end; 357 | 358 | procedure TEventBusTest.TestIsRegisteredTrueAfterRegisterEvents; 359 | begin 360 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 361 | GlobalEventBus.UnregisterForEvents(Subscriber); 362 | Assert.IsFalse(GlobalEventBus.IsRegisteredForEvents(Subscriber)); 363 | end; 364 | 365 | procedure TEventBusTest.TestPostChannelOnMainThread; 366 | var 367 | LMsg: string; 368 | begin 369 | GlobalEventBus.RegisterSubscriberForChannels(ChannelSubscriber); 370 | LMsg := 'TestPostOnMainThread'; 371 | GlobalEventBus.Post('test_channel', LMsg); 372 | Assert.AreEqual(LMsg, ChannelSubscriber.LastChannelMsg); 373 | Assert.AreEqual(MainThreadID, ChannelSubscriber.LastEventThreadID); 374 | end; 375 | 376 | procedure TEventBusTest.TestPostContextKOOnMainThread; 377 | var 378 | LEvent: IMainEvent; 379 | LMsg: string; 380 | begin 381 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 382 | LEvent := TMainEvent.Create; 383 | LMsg := 'TestPostOnMainThread'; 384 | LEvent.Data := LMsg; 385 | GlobalEventBus.Post(LEvent, 'TestFoo'); 386 | Assert.IsNull(Subscriber.LastEvent); 387 | end; 388 | 389 | procedure TEventBusTest.TestPostContextOnMainThread; 390 | var 391 | LEvent: IMainEvent; 392 | LMsg: string; 393 | begin 394 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 395 | LEvent := TMainEvent.Create; 396 | LMsg := 'TestPostOnMainThread'; 397 | LEvent.Data := LMsg; 398 | GlobalEventBus.Post(LEvent, 'TestCtx'); 399 | Assert.AreEqual(LMsg, Subscriber.LastEvent.Data); 400 | Assert.AreEqual(MainThreadID, Subscriber.LastEventThreadID); 401 | end; 402 | 403 | procedure TEventBusTest.TestPostEntityWithChildObject; 404 | var 405 | LPerson: TPerson; 406 | LSubscriber: TPersonSubscriber; 407 | LEvent: IDEBEvent; 408 | begin 409 | LSubscriber := TPersonSubscriber.Create; 410 | try 411 | LSubscriber.OwnsObject:= True; 412 | GlobalEventBus.RegisterSubscriberForEvents(LSubscriber); 413 | LPerson := TPerson.Create; 414 | LPerson.Firstname := 'Howard'; 415 | LPerson.Lastname := 'Stark'; 416 | LPerson.Child := TPerson.Create; 417 | LPerson.Child.Firstname := 'Tony'; 418 | LPerson.Child.Lastname := 'Stark'; 419 | LEvent:= TDEBEvent.Create(LPerson); 420 | GlobalEventBus.Post( LEvent); 421 | Assert.AreEqual('Howard', LSubscriber.Person.Firstname); 422 | Assert.AreEqual('Tony', LSubscriber.Person.Child.Firstname); 423 | finally 424 | LSubscriber.Free; 425 | end; 426 | end; 427 | 428 | procedure TEventBusTest.TestPostEntityWithItsSelfInChildObject; 429 | var 430 | LPerson: TPerson; 431 | LSubscriber: TPersonSubscriber; 432 | LEvent: IDEBEvent; 433 | begin 434 | LSubscriber := TPersonSubscriber.Create; 435 | try 436 | LSubscriber.OwnsObject := True; 437 | GlobalEventBus.RegisterSubscriberForEvents(LSubscriber); 438 | LPerson := TPerson.Create; 439 | LPerson.Firstname := 'Howard'; 440 | LPerson.Lastname := 'Stark'; 441 | LPerson.Child := LPerson; 442 | LEvent:= TDEBEvent.Create(LPerson); 443 | GlobalEventBus.Post(LEvent); 444 | Assert.AreEqual('Howard', LSubscriber.Person.Firstname); 445 | Assert.AreEqual('Howard', LSubscriber.Person.Child.Firstname); 446 | finally 447 | LSubscriber.Free; 448 | end; 449 | end; 450 | 451 | procedure TEventBusTest.TestPostEntityWithObjectList; 452 | var 453 | LPerson: TPerson; 454 | LSubscriber: TPersonListSubscriber; 455 | LList: TObjectList; 456 | LEvent: IDEBEvent < TObjectList < TPerson >>; 457 | begin 458 | LSubscriber := TPersonListSubscriber.Create; 459 | try 460 | GlobalEventBus.RegisterSubscriberForEvents(LSubscriber); 461 | LList := TObjectList.Create; 462 | LPerson := TPerson.Create; 463 | LPerson.Firstname := 'Howard'; 464 | LPerson.Lastname := 'Stark'; 465 | LList.Add(LPerson); 466 | LPerson := TPerson.Create; 467 | LPerson.Firstname := 'Tony'; 468 | LPerson.Lastname := 'Stark'; 469 | LList.Add(LPerson); 470 | LEvent:= TDEBEvent < TObjectList < TPerson >> .Create(LList); 471 | GlobalEventBus.Post(LEvent); 472 | Assert.AreEqual(2, LSubscriber.PersonList.Count); 473 | LSubscriber.PersonList.Free; 474 | finally 475 | LSubscriber.Free; 476 | end; 477 | end; 478 | 479 | procedure TEventBusTest.TestPostOnMainThread; 480 | var 481 | LEvent: IMainEvent; 482 | LMsg: string; 483 | begin 484 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 485 | LEvent := TMainEvent.Create; 486 | LMsg := 'TestPostOnMainThread'; 487 | LEvent.Data := LMsg; 488 | GlobalEventBus.Post(LEvent); 489 | Assert.AreEqual(LMsg, Subscriber.LastEvent.Data); 490 | Assert.AreEqual(MainThreadID, Subscriber.LastEventThreadID); 491 | end; 492 | 493 | procedure TEventBusTest.TestAsyncPost; 494 | var 495 | LEvent: IAsyncEvent; 496 | LMsg: string; 497 | begin 498 | GlobalEventBus.RegisterSubscriberForEvents(Subscriber); 499 | LEvent := TAsyncEvent.Create; 500 | LMsg := 'TestAsyncPost'; 501 | LEvent.Data := LMsg; 502 | GlobalEventBus.Post(LEvent); 503 | // attend for max 5 seconds 504 | Assert.IsTrue(TWaitResult.wrSignaled = Subscriber.Event.WaitFor(5000), 'Timeout request'); 505 | Assert.AreEqual(LMsg, Subscriber.LastEvent.Data); 506 | Assert.AreNotEqual(MainThreadID, Subscriber.LastEventThreadID); 507 | end; 508 | 509 | 510 | procedure TEventBusTest.TestEmptySubscriber; 511 | var 512 | LSubscriber: TEmptySubscriber; 513 | begin 514 | LSubscriber := TEmptySubscriber.Create; 515 | 516 | Assert.WillRaise( 517 | procedure begin 518 | GlobalEventBus.RegisterSubscriberForEvents(LSubscriber); 519 | end 520 | , 521 | EObjectHasNoSubscriberMethods 522 | , 523 | 'Empty subscriber methods for Events'); 524 | 525 | Assert.WillRaise( 526 | procedure begin 527 | GlobalEventBus.RegisterSubscriberForChannels(LSubscriber); 528 | end 529 | , 530 | EObjectHasNoSubscriberMethods 531 | , 532 | 'Empty subscriber methods for Channels'); 533 | 534 | LSubscriber.Free; 535 | end; 536 | 537 | procedure TEventBusTest.TestInvalidArgNumberSubscriber; 538 | var 539 | LSubscriber: TInvalidArgNumSubscriber; 540 | begin 541 | LSubscriber := TInvalidArgNumSubscriber.Create; 542 | 543 | Assert.WillRaise( 544 | procedure begin 545 | GlobalEventBus.RegisterSubscriberForEvents(LSubscriber); 546 | end 547 | , 548 | EInvalidSubscriberMethod 549 | , 550 | 'Invalid subscriber method argument number'); 551 | 552 | Assert.WillRaise( 553 | procedure begin 554 | GlobalEventBus.RegisterSubscriberForChannels(LSubscriber); 555 | end 556 | , 557 | EInvalidSubscriberMethod 558 | , 559 | 'Invalid subscriber method argument number'); 560 | 561 | LSubscriber.Free; 562 | end; 563 | 564 | procedure TEventBusTest.TestInvalidArgTypeSubscriber; 565 | var 566 | LSubscriber: TInvalidArgTypeSubscriber; 567 | begin 568 | LSubscriber := TInvalidArgTypeSubscriber.Create; 569 | 570 | Assert.WillRaise( 571 | procedure begin 572 | GlobalEventBus.RegisterSubscriberForEvents(LSubscriber); 573 | end 574 | , 575 | EInvalidSubscriberMethod 576 | , 577 | 'Invalid subscriber method argument type'); 578 | 579 | Assert.WillRaise( 580 | procedure begin 581 | GlobalEventBus.RegisterSubscriberForChannels(LSubscriber); 582 | end 583 | , 584 | EInvalidSubscriberMethod 585 | , 586 | 'Invalid subscriber method argument type'); 587 | 588 | LSubscriber.Free; 589 | end; 590 | 591 | initialization 592 | TDUnitX.RegisterTestFixture(TEventBusTest); 593 | 594 | end. 595 | --------------------------------------------------------------------------------