├── .gitattributes ├── .gitignore ├── Clean.bat ├── LICENSE ├── Packages ├── btkEventBusD17.dpk ├── btkEventBusD17.dproj └── btkEventBusD17.res ├── README.md ├── Source └── btkEventBus.pas ├── Tests ├── DUnitX.btkEventBusTest.pas ├── DunitX.btkEventBus.dpr ├── DunitX.btkEventBus.dproj └── DunitX.btkEventBus.res └── btkEventBusD17ProjectGroup.groupproj /.gitattributes: -------------------------------------------------------------------------------- 1 | # Set the default behavior, in case people don't have core.autocrlf set. 2 | * text=auto 3 | 4 | *.pas text eol=crlf 5 | *.inc text eol=crlf 6 | *.dpk text eol=crlf 7 | *.dpr text eol=crlf -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | 25 | # Delphi compiler-generated binaries (safe to delete) 26 | *.exe 27 | *.dll 28 | *.bpl 29 | *.bpi 30 | *.dcp 31 | *.so 32 | *.apk 33 | *.drc 34 | *.map 35 | *.dres 36 | *.rsm 37 | *.tds 38 | *.dcu 39 | *.lib 40 | 41 | # Delphi autogenerated files (duplicated info) 42 | *.cfg 43 | *Resource.rc 44 | 45 | # Delphi local files (user-specific info) 46 | *.local 47 | *.identcache 48 | *.projdata 49 | *.tvsconfig 50 | *.dsk 51 | 52 | # Delphi history and backups 53 | __history/ 54 | *.~* 55 | -------------------------------------------------------------------------------- /Clean.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | echo Cleaning... 3 | del /f /q /s *.bak 4 | del /f /q /s *.dcu 5 | del /f /q /s *.ddp 6 | del /f /q /s *.~* 7 | del /f /q /s *.local 8 | del /f /q /s *.identcache 9 | del /f /q /s *.tvsconfig 10 | 11 | del /f /q /s *.bpl 12 | del /f /q /s *.cbk 13 | del /f /q /s *.dcp 14 | del /f /q /s *.dsk 15 | del /f /q /s *.rsm 16 | del /f /q /s *.skincfg 17 | del /f /q /s Tests\Bin\*.* 18 | 19 | for /f "tokens=* delims=" %%i in ('dir /s /b /a:d __history') do ( 20 | rd /s /q "%%i" 21 | ) 22 | if "%1"=="" goto :eof 23 | pause 24 | 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 BitecSPB 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /Packages/btkEventBusD17.dpk: -------------------------------------------------------------------------------- 1 | package btkEventBusD17; 2 | 3 | {$R *.res} 4 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 5 | {$ALIGN 8} 6 | {$ASSERTIONS ON} 7 | {$BOOLEVAL OFF} 8 | {$DEBUGINFO ON} 9 | {$EXTENDEDSYNTAX ON} 10 | {$IMPORTEDDATA ON} 11 | {$IOCHECKS ON} 12 | {$LOCALSYMBOLS ON} 13 | {$LONGSTRINGS ON} 14 | {$OPENSTRINGS ON} 15 | {$OPTIMIZATION OFF} 16 | {$OVERFLOWCHECKS OFF} 17 | {$RANGECHECKS OFF} 18 | {$REFERENCEINFO ON} 19 | {$SAFEDIVIDE OFF} 20 | {$STACKFRAMES ON} 21 | {$TYPEDADDRESS OFF} 22 | {$VARSTRINGCHECKS ON} 23 | {$WRITEABLECONST OFF} 24 | {$MINENUMSIZE 1} 25 | {$IMAGEBASE $400000} 26 | {$DEFINE DEBUG} 27 | {$ENDIF IMPLICITBUILDING} 28 | {$IMPLICITBUILD OFF} 29 | 30 | requires 31 | rtl; 32 | 33 | contains 34 | btkEventBus in '..\Source\btkEventBus.pas'; 35 | 36 | end. 37 | -------------------------------------------------------------------------------- /Packages/btkEventBusD17.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {2521B321-0F18-435C-8401-A75C946BBD04} 4 | btkEventBusD17.dpk 5 | 14.4 6 | None 7 | True 8 | Debug 9 | Win32 10 | 1 11 | Package 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Base 34 | true 35 | 36 | 37 | true 38 | Cfg_1 39 | true 40 | true 41 | 42 | 43 | true 44 | Base 45 | true 46 | 47 | 48 | true 49 | Cfg_2 50 | true 51 | true 52 | 53 | 54 | ..\Library\D17\$(Config) 55 | ..\Library\D17\$(Config) 56 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 57 | 1049 58 | true 59 | true 60 | System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) 61 | ..\Library\D17\$(Config) 62 | .\$(Platform)\$(Config) 63 | false 64 | false 65 | false 66 | false 67 | false 68 | 69 | 70 | rtl;$(DCC_UsePackage) 71 | $(BDS)\bin\delphi_PROJECTICNS.icns 72 | 73 | 74 | rtl;$(DCC_UsePackage) 75 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 76 | 1033 77 | true 78 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 79 | 80 | 81 | rtl;$(DCC_UsePackage) 82 | 83 | 84 | DEBUG;$(DCC_Define) 85 | true 86 | false 87 | true 88 | true 89 | true 90 | 91 | 92 | 1033 93 | true 94 | false 95 | 96 | 97 | false 98 | RELEASE;$(DCC_Define) 99 | 0 100 | false 101 | 102 | 103 | $(BDS)\bin\delphi_PROJECTICNS.icns 104 | 105 | 106 | 107 | MainSource 108 | 109 | 110 | 111 | 112 | Cfg_2 113 | Base 114 | 115 | 116 | Base 117 | 118 | 119 | Cfg_1 120 | Base 121 | 122 | 123 | 124 | Delphi.Personality.12 125 | Package 126 | 127 | 128 | 129 | btkEventBusD17.dpk 130 | 131 | 132 | True 133 | False 134 | 1 135 | 0 136 | 0 137 | 0 138 | False 139 | False 140 | False 141 | False 142 | False 143 | 1049 144 | 1251 145 | 146 | 147 | 148 | 149 | 1.0.0.0 150 | 151 | 152 | 153 | 154 | 155 | 1.0.0.0 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | False 171 | True 172 | False 173 | 174 | 175 | 12 176 | 177 | 178 | 179 | 180 | -------------------------------------------------------------------------------- /Packages/btkEventBusD17.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/global-system/DelphiEventBus/8d0850bae01fcc01a5b0dffce89a7dd7f19d2d19/Packages/btkEventBusD17.res -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | DelphiEventBus 2 | ============== 3 | 4 | Implementation of event bus pattern for Delphi XE 5 | 6 | EventBus is designed to provide interaction between different components, without increasing connectivity. 7 | 8 | ### Features 9 | 10 | - **Development** 11 | - The type of event is determined by the class. 12 | - Events are inherited. 13 | - The base class for any event is TbtkEventObject. 14 | - **Filtering** 15 | - Events can contain filters. 16 | - Filter values are case sensitive. 17 | - To declare filters, annotations of event class methods are used. 18 | - As a filter, functions without parameters are used that should return the filter value as a string. 19 | - Filters are identified by name. 20 | - The filter name is specified in the filter annotation. 21 | - Filter names are not case sensitive. 22 | - Filters use two modes: 23 | - Simple mode. 24 | - The event filter value corresponds to empty and exactly matching handler filter values. 25 | - This mode is used by default. 26 | - Hashable mode. 27 | - The event filter value only matches exactly the same handler filter value. 28 | - Hashing accelerates the formation of lists of handlers to be called. 29 | - Filter mode is specified in the filter annotation. 30 | - The base class contains one hash filter named "Topic" 31 | - **Handlers** 32 | - Adding event handlers is done by registering a listener on the bus. 33 | - Removal of event handlers is performed by unregistration of the listener in the bus. 34 | - The filter values of listener event handlers are set after registration. 35 | - Filter values are bound to the event type, and are equal for different handlers of the same event. 36 | - To declare handlers, annotations of listener methods are used. 37 | - Handlers must contain one input parameter with the class type of the event being processed. 38 | - The type of the handler parameter determines the events that it will process. 39 | - The handler is invoked for all heirs of the event processed by it. 40 | - Two types of event handlers are used: 41 | - Simple handlers. 42 | - When calling, the filtering conditions are taken into account. 43 | - The order of the call is not guaranteed. 44 | - Hooks. 45 | - Called before calling simple handlers. 46 | - Ignore filtering conditions. 47 | - The order of the call corresponds to the reverse order of registration. 48 | - The type of handler will be determined by annotation. 49 | 50 | ### Example of use 51 | ```delphi 52 | //event class declaration 53 | Type 54 | TFooEventObject = class(TbtkEventObject) 55 | //.......................... 56 | public 57 | const sFooFilterName = 'FooFilter'; 58 | 59 | constructor Create(ATopic: string; AFooFliter: string); 60 | 61 | [EventFilter(sFooFilterName)] //filter parameter declaration 62 | function FooFilter: string; 63 | 64 | //.......................... 65 | end; 66 | 67 | //preparation of the listener 68 | TFooEventListener = class 69 | //.......................... 70 | public 71 | 72 | [EventHandler] //handler declaration 73 | procedure FooHandler(AFooEvent: TFooEventObject); 74 | 75 | [EventHook] //hook declaration 76 | procedure FooHook(AEventObject: TFooEventObject); 77 | 78 | //.......................... 79 | end; 80 | 81 | EventBus := TbtkEventBus.GetEventBus('FooEventBus'); 82 | 83 | ListenerInfo := EventBus.Register(FooEventListener); 84 | 85 | //setting filter parameters 86 | ListenerInfo.HandlerFilters[TFooEventObject][TFooEventObject.sEventFilterTopicName].Value := 'TopicValue'; 87 | ListenerInfo.HandlerFilters[TFooEventObject][TFooEventObject.sFooFilterName].Value := 'FooFilterValue'; 88 | 89 | //creating and sending events 90 | EventBus.Send(TFooEventObject.Create('TopicValue', 'FooFilterValue')); 91 | 92 | //listener unregistration 93 | EventBus.Unregister(FooListener); 94 | ``` 95 | ### Minimalistic example of use eventhook 96 | ```delphi 97 | program EventHookExample; 98 | 99 | {$APPTYPE CONSOLE} 100 | 101 | uses 102 | System.SysUtils, 103 | btkEventBus; 104 | 105 | type 106 | TFooEventListener = class 107 | public 108 | [EventHook] //hook declaration 109 | procedure FooHook(EventObject: TbtkEventObject); 110 | end; 111 | 112 | { TFooEventListener } 113 | 114 | //hook implementation 115 | procedure TFooEventListener.FooHook(EventObject: TbtkEventObject); 116 | begin 117 | Writeln(Format('======'#13#10'Event with topic "%s" sended', [EventObject.Topic])); 118 | end; 119 | 120 | const 121 | ebFoo = 'FooEventBus'; 122 | var 123 | FooEventListener: TFooEventListener; 124 | FooTopicName: string; 125 | begin 126 | //register class for eventbus with name 'FooEventBus' 127 | RegisterEventBusClass(TbtkEventBus, ebFoo); 128 | 129 | FooEventListener := TFooEventListener.Create; 130 | try 131 | //register listener 132 | EventBus(ebFoo).Register(FooEventListener); 133 | 134 | Write('Write topic: '); 135 | ReadLn(FooTopicName); 136 | 137 | //create and send event 138 | EventBus(ebFoo).Send(TbtkEventObject.Create(FooTopicName)); 139 | finally 140 | FooEventListener.Free; 141 | end; 142 | Readln; 143 | end. 144 | ``` 145 | ### Minimalistic example of use eventhandler 146 | ```delphi 147 | program EventHookExample; 148 | 149 | {$APPTYPE CONSOLE} 150 | 151 | uses 152 | System.SysUtils, 153 | btkEventBus; 154 | 155 | type 156 | TFooEventListener = class 157 | public 158 | [EventHandler] //handler declaration 159 | procedure FooHandler(EventObject: TbtkEventObject); 160 | end; 161 | 162 | { TFooEventListener } 163 | 164 | //handler implementation 165 | procedure TFooEventListener.FooHandler(EventObject: TbtkEventObject); 166 | begin 167 | Writeln(Format('Event with topic "%s" sended', [EventObject.Topic])); 168 | end; 169 | 170 | const 171 | FooTopicName = 'FooTopic'; 172 | var 173 | FooEventListener: TFooEventListener; 174 | FooListenerInfo: TbtkListenerInfo; 175 | 176 | begin 177 | //register class for eventbus with empty name 178 | RegisterEventBusClass(TbtkEventBus); 179 | 180 | FooEventListener := TFooEventListener.Create; 181 | try 182 | //register listener and get listner info 183 | FooListenerInfo := EventBus.Register(FooEventListener); 184 | 185 | //set topicfilter for handler 186 | FooListenerInfo.HandlerFilters.Items[TbtkEventObject].Filters[TbtkEventObject.sEventFilterTopicName].Value := FooTopicName; 187 | 188 | //create and send event 189 | EventBus.Send(TbtkEventObject.Create(FooTopicName)); 190 | finally 191 | FooEventListener.Free; 192 | end; 193 | Readln; 194 | end. 195 | ``` 196 | -------------------------------------------------------------------------------- /Source/btkEventBus.pas: -------------------------------------------------------------------------------- 1 | { btkEventBus 2 | Author: S.Bugay 3 | Company: Business Technology, Saint Petersburg, Russia. All right reserved. 4 | Date creation: 21.08.2014 5 | 6 | Defenition: The implementation of a design pattern EventBus. 7 | EventBus, implements the functionality that is intended to simplify 8 | the exchange of data and communication between application components. 9 | } 10 | 11 | unit btkEventBus; 12 | 13 | interface 14 | 15 | uses 16 | System.SysUtils, 17 | System.Classes, 18 | System.Generics.Collections, 19 | System.Generics.Defaults, 20 | System.TypInfo, 21 | System.Rtti; 22 | 23 | type 24 | 25 | /// EventHookAttribute 26 | /// Attribute for annotating method of listener as event-hook. 27 | /// 28 | EventHookAttribute = class(TCustomAttribute); 29 | /// EventHandlerAttribute 30 | /// Attribute for annotating method of listener as event-handler. 31 | /// 32 | EventHandlerAttribute = class(TCustomAttribute); 33 | 34 | EEventBus = class(Exception) 35 | end; 36 | 37 | /// TEventFilterProperties 38 | /// Properties of eventfilter. 39 | /// efpIsPartOfHashingString - this property is responsible for adding the filter in a hash. 40 | /// Using filters as a hash to reduce handler-lists. This provides faster calling handlers, 41 | /// but forbids the use of empty values for hashed filters of listeners. 42 | /// efpCaseSensitive - This property determines how the filter values will be compared. 43 | /// 44 | TEventFilterProperties = set of (efpIsPartOfHashingString, efpCaseSensitive); 45 | 46 | /// EventFilterAttribute 47 | /// Attribute for annotating method of event-object as filter. 48 | /// 49 | EventFilterAttribute = class(TCustomAttribute) 50 | private 51 | FName: string; 52 | FProperties: TEventFilterProperties; 53 | public 54 | /// EventFilterAttribute.Name 55 | /// Used to identify filter. Must be unique for each filter of event. 56 | /// 57 | property Name: string read FName; 58 | /// EventFilterAttribute.Properties 59 | /// Contains the properties of the filter. 60 | /// See description of TEventFilterProperties for more info about filter properties. 61 | /// 62 | property Properties: TEventFilterProperties read FProperties; 63 | constructor Create(AName: string; AProperties: TEventFilterProperties = []); 64 | end; 65 | 66 | TbtkEventObject = class; 67 | TbtkEventObjectClass = class of TbtkEventObject; 68 | 69 | /// IbtkEventObject 70 | /// Need to prevent destruction of event-object while not all handlers of listeners have been handled 71 | /// 72 | IbtkEventObject = interface 73 | ['{F38E532F-1F8D-4950-AB31-D6B6E75B69A5}'] 74 | /// IbtkEventObject.Instance 75 | /// Returns instance of event-object. 76 | /// This object will be passed as a parameter for event-hooks and event-handlers. 77 | /// 78 | function Instance: TbtkEventObject; 79 | end; 80 | 81 | /// TbtkEventObject 82 | /// Base class of all event-objects. 83 | /// 84 | TbtkEventObject = class(TInterfacedObject, IbtkEventObject) 85 | private 86 | FTopic: string; 87 | 88 | public 89 | const sEventFilterTopicName = 'Topic'; 90 | 91 | /// TbtkEventObject.Instance 92 | /// Implements IbtkEventObject.Instance. 93 | /// 94 | function Instance: TbtkEventObject; 95 | 96 | /// TbtkEventObject.Create 97 | /// Used for initializing read-only properties of event-object. 98 | /// 99 | constructor Create(ATopic: string); 100 | 101 | /// TbtkEventObject.Topic 102 | /// Returns the value of the hashed filter "Topic". "Topic" is a basic filter 103 | /// that allows you to distribute the events in their context. 104 | /// 105 | [EventFilter(sEventFilterTopicName, [efpIsPartOfHashingString])] 106 | function Topic: string; 107 | end; 108 | 109 | /// TbtkEventFilterInfo 110 | /// Contains information about event-filter, and allows to get filter value of an event-object instance. 111 | /// 112 | TbtkEventFilterInfo = record 113 | strict private 114 | FFilterName: string; 115 | FProperties: TEventFilterProperties; 116 | FMethod: TRttiMethod; 117 | public 118 | /// TbtkEventFilterInfo.Create 119 | /// value of the annotation property "EventFilterAttribute.Name". 120 | /// value of the annotation property "EventFilterAttribute.Properties". 121 | /// Link to a describer of the method, that returns value of filter. 122 | /// 123 | constructor Create(AFilterName: string; AProperties: TEventFilterProperties; AMethod: TRttiMethod); 124 | /// TbtkEventFilterInfo.FilterName 125 | /// Contains the value of the annotation property "EventFilterAttribute.Name". 126 | /// 127 | property FilterName: string read FFilterName; 128 | /// TbtkEventFilterInfo.Properties 129 | /// Contains the value of the annotation property "EventFilterAttribute.Properties". 130 | /// 131 | property Properties: TEventFilterProperties read FProperties; 132 | /// TbtkEventFilterInfo.GetValueFor 133 | /// Returns filter value for instance of event-object. 134 | /// 135 | function GetValueFor(AInstance: TbtkEventObject): string; 136 | end; 137 | 138 | /// TbtkEventFiltersRTTIInfo 139 | /// Contains information about filters. 140 | /// 141 | TbtkEventFiltersRTTIInfo = record 142 | strict private 143 | type 144 | TEventObjectClass = TClass; 145 | TEventFilterName = string; 146 | TEventFilterInfoList = TList; 147 | TEventsFilterDictionary = TObjectDictionary; 148 | class var 149 | FEventsFilterDictionary: TEventsFilterDictionary; 150 | class constructor Create; 151 | class destructor Destroy; 152 | public 153 | /// TbtkEventFiltersClassInfo.GetInfoFor 154 | /// Returns a list, that contains information about filters of event-object. 155 | /// 156 | class function GetInfoFor(AEventObjectClass: TEventObjectClass): TEventFilterInfoList; static; 157 | end; 158 | 159 | /// TbtkEventHandlersRTTIInfo 160 | /// Contains information about handlers and hooks. 161 | /// 162 | TbtkEventHandlersRTTIInfo = record 163 | strict private 164 | type 165 | TListenerClass = TClass; 166 | TEventObjectClass = TbtkEventObjectClass; 167 | TEventHandlerMethodDictionary = TDictionary; 168 | TEventHookMethodDictionary = TDictionary; 169 | TEventsHandlerDictionary = TObjectDictionary; 170 | TEventsHookDictionary = TObjectDictionary; 171 | class var FEventsHandlerDictionary: TEventsHandlerDictionary; 172 | class var FEventsHookDictionary: TEventsHookDictionary; 173 | class constructor Create; 174 | class destructor Destroy; 175 | strict private 176 | FListenerClass: TListenerClass; 177 | public 178 | /// TbtkEventHandlersClassInfo.GetInfoFor 179 | /// Returns a structure, that contains information about hooks and handlers of listener. 180 | /// 181 | class function GetInfoFor(AListenerClass: TListenerClass): TbtkEventHandlersRTTIInfo; static; 182 | /// TbtkEventHandlersClassInfo.HandlerMethods 183 | /// Returns a dictionary that associates class of event-object with handler of listener. 184 | /// 185 | function HandlerMethods: TEventHandlerMethodDictionary; 186 | /// TbtkEventHandlersClassInfo.HookMethods 187 | /// Returns a dictionary that associates class of event-object with hook of listener. 188 | /// 189 | function HookMethods: TEventHookMethodDictionary; 190 | end; 191 | 192 | /// TbtkEventFilter 193 | /// Filter of the event-object or of the listener. 194 | /// 195 | TbtkEventFilter = class 196 | private 197 | FProperties: TEventFilterProperties; 198 | FValue: string; 199 | FNormalizedValue: string; 200 | FOnValueChanged: TNotifyEvent; 201 | procedure SetValue(const AValue: string); 202 | protected 203 | /// TbtkEventFilter.OnValueChanged 204 | /// It's necessary for call hash recalculating, when hashed filter value is changed. 205 | /// 206 | property OnValueChanged: TNotifyEvent read FOnValueChanged write FOnValueChanged; 207 | property NormalizedValue: string read FNormalizedValue; 208 | public 209 | constructor Create(AProperties: TEventFilterProperties; AValue: string); 210 | /// TbtkEventFilter.Properties 211 | /// See description of EventFilterAttribute.Properties for more 212 | /// info about the filter properties. 213 | /// 214 | property Properties: TEventFilterProperties read FProperties; 215 | /// TbtkEventFilter.Value 216 | /// Value of the filter. 217 | /// 218 | property Value: string read FValue write SetValue; 219 | end; 220 | 221 | TbtkHashingStringChangeNotifyEvent = procedure(ASender: TObject; AOldValue: string) of object; 222 | 223 | /// TbtkEventFilters 224 | /// Filters-dictionary of the event-object or of the listener. 225 | /// 226 | TbtkEventFilters = class(TObjectDictionary) 227 | private 228 | FHashingString: string; 229 | FHashingStringChanged: TbtkHashingStringChangeNotifyEvent; 230 | procedure UpdateHashingString; 231 | procedure FilterValueChanged(ASender: TObject); 232 | function GetFilters(AName: string): TbtkEventFilter; 233 | protected 234 | /// TbtkEventFilters.ValueNotify 235 | /// Sets the handler for the event "OnValueChanged" of filters. 236 | /// 237 | procedure ValueNotify(const Value: TbtkEventFilter; Action: TCollectionNotification); override; 238 | /// TbtkEventFilters.OnHashingStringChanged 239 | /// It's necessary for call hash recalculating, when hashed filter value is changed. 240 | /// 241 | property OnHashingStringChanged: TbtkHashingStringChangeNotifyEvent read FHashingStringChanged write FHashingStringChanged; 242 | public 243 | constructor Create(AEventObjectClass: TbtkEventObjectClass; AEventObject: TbtkEventObject = nil); 244 | /// TbtkEventFilters.HashingString 245 | /// See description of TEventFilterSetting for more info about the hashed filters. 246 | /// 247 | property HashingString: string read FHashingString; 248 | property Filters[AName: string]: TbtkEventFilter read GetFilters; default; 249 | end; 250 | 251 | /// IbtkCustomEventHandler 252 | /// Base interface for event-hooks and event-handlers. 253 | /// 254 | IbtkCustomEventHandler = interface 255 | function GetListener: TObject; 256 | function GetExtracted: Boolean; 257 | procedure SetExtracted(AValue: Boolean); 258 | /// IbtkCustomEventHandler.Invoke 259 | /// Calls event-hook or event-handler. 260 | /// 261 | procedure Invoke(AEventObject: IbtkEventObject); 262 | /// IbtkCustomEventHandler.Lock 263 | /// Used to provide thread safety. 264 | /// 265 | function Lock(ATimeout: Cardinal = INFINITE): Boolean; 266 | /// IbtkCustomEventHandler.Unlock 267 | /// Used to provide thread safety. 268 | /// 269 | procedure Unlock; 270 | /// IbtkCustomEventHandler.Listener 271 | /// Listener who owns an event-hook or event-handler. 272 | /// 273 | property Listener: TObject read GetListener; 274 | /// IbtkCustomEventHandler.Extracted 275 | /// Allows to check that the listener was not extracted from the eventbus. 276 | /// 277 | property Extracted: Boolean read GetExtracted write SetExtracted; 278 | end; 279 | 280 | /// IbtkEventHandler 281 | /// Allows to call event-handler and gain access to his filters. 282 | /// 283 | IbtkEventHandler = interface(IbtkCustomEventHandler) 284 | function GetFilters: TbtkEventFilters; 285 | /// TbtkEventHandler.Filters 286 | /// Reference to filters of event-handler. 287 | /// 288 | property Filters: TbtkEventFilters read GetFilters; 289 | end; 290 | 291 | /// IbtkEventHook 292 | /// Allows to call event-hook, and gain access to his absolute number. 293 | /// 294 | IbtkEventHook = interface(IbtkCustomEventHandler) 295 | function GetAbsoluteNumber: Integer; 296 | /// TbtkEventHook.AbsoluteNumber 297 | /// Ordinal number of hook. 298 | /// 299 | property AbsoluteNumber: Integer read GetAbsoluteNumber; 300 | end; 301 | 302 | TbtkCustomHandlerList = TList; 303 | TbtkHookList = TList; 304 | TbtkHandlerList = TList; 305 | 306 | /// TbtkCustomEventHandler 307 | /// Base class for event-hooks and event-handlers. 308 | /// 309 | TbtkCustomEventHandler = class(TInterfacedObject, IbtkCustomEventHandler) 310 | strict private 311 | FListener: TObject; 312 | FMethod: TRttiMethod; 313 | FExtracted: Boolean; 314 | function GetListener: TObject; 315 | function GetExtracted: Boolean; 316 | procedure SetExtracted(AValue: Boolean); 317 | public 318 | constructor Create(AListener: TObject; AMethod: TRttiMethod); virtual; 319 | /// TbtkCustomEventHandler.Invoke 320 | /// Implements IbtkCustomEventHandler.Invoke 321 | /// 322 | procedure Invoke(AEventObject: IbtkEventObject); inline; 323 | /// TbtkCustomEventHandler.Lock 324 | /// Implements IbtkCustomEventHandler.Lock 325 | /// 326 | function Lock(ATimeout: Cardinal = INFINITE): Boolean; 327 | /// TbtkCustomEventHandler.Unlock 328 | /// Implements IbtkCustomEventHandler.Unlock 329 | /// 330 | procedure Unlock; 331 | /// TbtkCustomEventHandler.Listener 332 | /// Implements IbtkCustomEventHandler.Listener 333 | /// 334 | property Listener: TObject read GetListener; 335 | /// TbtkCustomEventHandler.Extracted 336 | /// Implements IbtkCustomEventHandler.Extracted 337 | /// 338 | property Extracted: Boolean read GetExtracted write SetExtracted; 339 | end; 340 | 341 | /// TbtkEventHandler 342 | /// Allows to call event-handler and gain access to his filters. 343 | /// 344 | TbtkEventHandler = class(TbtkCustomEventHandler, IbtkEventHandler) 345 | private 346 | FFilters: TbtkEventFilters; 347 | FHashingStringChanged: TbtkHashingStringChangeNotifyEvent; 348 | procedure HashingStringChanged(ASender: TObject; AOldValue: string); 349 | function GetFilters: TbtkEventFilters; 350 | protected 351 | /// TbtkEventHandler.OnHashingStringChanged 352 | /// It's necessary for call hash recalculating, when hashed filter value is changed. 353 | /// 354 | property OnHashingStringChanged: TbtkHashingStringChangeNotifyEvent read FHashingStringChanged write FHashingStringChanged; 355 | public 356 | constructor Create(AListener: TObject; AMethod: TRttiMethod; AFilters: TbtkEventFilters); reintroduce; 357 | destructor Destroy; override; 358 | /// TbtkEventHandler.Filters 359 | /// Implements IbtkEventHandler.Filters 360 | /// 361 | property Filters: TbtkEventFilters read GetFilters; 362 | end; 363 | 364 | /// TbtkEventHook 365 | /// Allows to call event-hook, and gain access to his absolute number. 366 | /// 367 | TbtkEventHook = class(TbtkCustomEventHandler, IbtkEventHook) 368 | private 369 | FAbsoluteNumber: Integer; 370 | function GetAbsoluteNumber: Integer; 371 | class var HookCounter: Integer; 372 | public 373 | class constructor Create; 374 | constructor Create(AListener: TObject; AMethod: TRttiMethod); override; 375 | /// TbtkEventHook.AbsoluteNumber 376 | /// Implements IbtkEventHook.AbsoluteNumber 377 | /// 378 | property AbsoluteNumber: Integer read GetAbsoluteNumber; 379 | end; 380 | 381 | /// TbtkEventHookComparer 382 | /// Compares hooks by their AbsoluteNumber. 383 | /// 384 | TbtkEventHookComparer = class(TComparer) 385 | public 386 | function Compare(const Left, Right: IbtkEventHook): Integer; override; 387 | end; 388 | 389 | /// IbtkEventHandlerEnumerator 390 | /// Implement enumeration list of handlers. 391 | /// 392 | IbtkEventHandlerEnumerator = interface 393 | ['{9E2E497D-E4F8-48A0-8C47-8A7B337667B5}'] 394 | function GetCurrent: IbtkCustomEventHandler; 395 | function MoveNext: Boolean; 396 | property Current: IbtkCustomEventHandler read GetCurrent; 397 | end; 398 | 399 | /// TbtkEeventHandlerEnumerator 400 | /// Implement enumeration list of handlers. 401 | /// 402 | TbtkEventHandlerEnumerator = class(TInterfacedObject, IbtkEventHandlerEnumerator) 403 | private 404 | FHandlerList: TbtkCustomHandlerList; 405 | FIndex: Integer; 406 | function GetCurrent: IbtkCustomEventHandler; 407 | public 408 | constructor Create(AHooks: TbtkHookList; AHandlers: TbtkHandlerList); reintroduce; 409 | destructor Destroy; override; 410 | function MoveNext: Boolean; 411 | property Current: IbtkCustomEventHandler read GetCurrent; 412 | end; 413 | 414 | /// TbtkListenerInfo 415 | /// Contains information about listener. 416 | /// 417 | TbtkListenerInfo = class 418 | strict private 419 | FListener: TObject; 420 | FHandlersClassInfo: TbtkEventHandlersRTTIInfo; 421 | FHandlerFilters: TDictionary; 422 | procedure FillFilters; 423 | public 424 | constructor Create(AListener: TObject); 425 | destructor Destroy; override; 426 | /// TbtkListenerInfo.HookMethods 427 | /// Returns a dictionary that associates class of event-object with hook of listener. 428 | /// 429 | function HookMethods: TDictionary; 430 | /// TbtkListenerInfo.HandlerMethods 431 | /// Returns a dictionary that associates class of event-object with handler of listener. 432 | /// 433 | function HandlerMethods: TDictionary; 434 | /// TbtkListenerInfo.HandlerFilters 435 | /// Returns a dictionary that associates class of event-object with handler-filters of listener. 436 | /// 437 | function HandlerFilters: TDictionary; 438 | /// TbtkListenerInfo.Listener 439 | /// Reference to instance of listener. 440 | /// 441 | property Listener: TObject read FListener; 442 | end; 443 | 444 | /// TbtkEventHandlers 445 | /// Contains lists of all hooks and handlers for one event. 446 | /// 447 | TbtkEventHandlers = class 448 | private 449 | type 450 | THashingString = string; 451 | TbtkHandlerDictionary = TObjectDictionary; 452 | var 453 | FHookList: TbtkHookList; 454 | FHandlerLists: TbtkHandlerDictionary; 455 | 456 | procedure HashingStringChanged(ASender: TObject; AOldValue: string); 457 | public 458 | constructor Create; 459 | destructor Destroy; override; 460 | /// TbtkEventHandlers.HookList 461 | /// List of all hooks, that were set for this event. 462 | /// 463 | property HookList: TbtkHookList read FHookList; 464 | /// TbtkEventHandlers.HookList 465 | /// List of all handlers, that were set for this event. 466 | /// 467 | property HandlerLists: TbtkHandlerDictionary read FHandlerLists; 468 | end; 469 | 470 | TbtkEventExceptionHandler = reference to procedure(AException: Exception); 471 | 472 | /// IbtkEventBus 473 | /// Provides basic methods for working with EventBus. 474 | /// 475 | IbtkEventBus = interface 476 | ['{7736BD48-9E52-4FE5-885B-742AF54BF020}'] 477 | /// IbtkEventBus.Send 478 | /// Calls event handling. 479 | /// If an event handler raises an exception, process of calling other handlers 480 | /// not will aborted, but will be called ApplicationHandleException. 481 | /// For exception handling must specify "AExceptionHandler". 482 | /// 483 | procedure Send(AEventObject: IbtkEventObject; AExceptionHandler: TbtkEventExceptionHandler = nil); 484 | /// IbtkEventBus.Register 485 | /// Registers the listener. 486 | /// 487 | function Register(AListener: TObject): TbtkListenerInfo; 488 | /// IbtkEventBus.UnRegister 489 | /// Unregisters the listener. 490 | /// 491 | procedure UnRegister(AListener: TObject); 492 | end; 493 | 494 | /// TbtkCustomEventBus 495 | /// Allows you to create a new EventBus, 496 | /// or get access to the global named EventBus. 497 | /// 498 | TbtkCustomEventBus = class(TInterfacedObject, IbtkEventBus) 499 | private 500 | type 501 | TEventBusName = string; 502 | TEventBusInfo = record 503 | EventBus: IbtkEventBus; 504 | &Class: TClass; 505 | constructor Create(AEventBus: TbtkCustomEventBus); 506 | end; 507 | class var FEventBusDictionary: TDictionary; 508 | private 509 | FName: string; 510 | FListenersInfo: TObjectDictionary; 511 | FEventHandlers: TObjectDictionary; 512 | /// TbtkEventBus.AddFromListener 513 | /// Adds hooks and handlers of the listener. 514 | /// 515 | procedure AddFromListener(AEventObjectClass: TbtkEventObjectClass; AListenerInfo: TbtkListenerInfo); 516 | /// TbtkEventBus.RemoveFromListener 517 | /// Removes hooks and handlers of the listener. 518 | /// 519 | procedure RemoveFromListener(AEventObjectClass: TbtkEventObjectClass; AListenerInfo: TbtkListenerInfo); 520 | protected 521 | procedure InternalSend(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; AExceptionHandler: TbtkEventExceptionHandler); virtual; abstract; 522 | public 523 | class constructor Create; 524 | class destructor Destroy; 525 | /// TbtkEventBus.GetEventBus 526 | /// Returns the named global EventBus. If EventBus with that name does not exist, it is created. 527 | /// 528 | class function GetEventBus(AName: TEventBusName = ''): IbtkEventBus; 529 | constructor Create; virtual; 530 | destructor Destroy; override; 531 | /// TbtkEventBus.Send 532 | /// Implements TbtkEventBus.Send. 533 | /// 534 | procedure Send(AEventObject: IbtkEventObject; AExceptionHandler: TbtkEventExceptionHandler = nil); 535 | /// TbtkEventBus.Register 536 | /// Implements TbtkEventBus.Register. 537 | /// 538 | function Register(AListener: TObject): TbtkListenerInfo; 539 | /// TbtkEventBus.UnRegister 540 | /// Implements TbtkEventBus.UnRegister. 541 | /// 542 | procedure UnRegister(AListener: TObject); 543 | end; 544 | 545 | TbtkEventBusClass = class of TbtkCustomEventBus; 546 | 547 | TbtkCustomEventSender = class(TInterfacedObject) 548 | protected 549 | procedure DoExecuteHandlers(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; AExceptionHandler: TbtkEventExceptionHandler); 550 | public 551 | procedure Send(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; AExceptionHandler: TbtkEventExceptionHandler); virtual; abstract; 552 | end; 553 | 554 | TbtkEventBus = class(TbtkCustomEventBus) 555 | private 556 | FEventSender: T; 557 | protected 558 | procedure InternalSend(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; AExceptionHandler: TbtkEventExceptionHandler); override; 559 | public 560 | constructor Create; override; 561 | destructor Destroy; override; 562 | end; 563 | 564 | TbtkSyncEventSender = class(TbtkCustomEventSender) 565 | public 566 | procedure Send(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; AExceptionHandler: TbtkEventExceptionHandler); override; 567 | end; 568 | 569 | TbtkEventBus = TbtkEventBus; 570 | 571 | var 572 | ThreadLockWaitingTimeout: Cardinal = 30000; 573 | 574 | /// 575 | /// Registers EventBus class for the name. 576 | /// 577 | procedure RegisterEventBusClass(AClass: TbtkEventBusClass; AName: TbtkCustomEventBus.TEventBusName = ''); 578 | 579 | /// 580 | /// Returns the named global EventBus. 581 | /// 582 | /// 583 | /// Unlike method TbtkCustomEventBus.GetEventBus 584 | /// there is no need to know the class. 585 | /// Can only be used to call the registered EventBuses by RegisterEventBusClass. 586 | /// 587 | function EventBus(AName: TbtkCustomEventBus.TEventBusName = ''): IbtkEventBus; 588 | 589 | implementation 590 | 591 | var 592 | RttiContext: TRttiContext; 593 | EventBusClassDictionary: TDictionary; 594 | 595 | function NormalizeFilterName(AFilterName: string): string; 596 | begin 597 | Result := LowerCase(AFilterName); 598 | end; 599 | 600 | function NormalizeFilterValue(AFilterValue: string; ACaseSensitive: Boolean): string; 601 | begin 602 | if ACaseSensitive then 603 | Result := AFilterValue 604 | else 605 | Result := LowerCase(AFilterValue); 606 | end; 607 | 608 | procedure RegisterEventBusClass(AClass: TbtkEventBusClass; AName: TbtkCustomEventBus.TEventBusName); 609 | begin 610 | EventBusClassDictionary.AddOrSetValue(AName, AClass); 611 | end; 612 | 613 | function EventBus(AName: TbtkCustomEventBus.TEventBusName = ''): IbtkEventBus; 614 | var 615 | eventBusClass: TbtkEventBusClass; 616 | begin 617 | if not EventBusClassDictionary.TryGetValue(AName, eventBusClass) then 618 | raise EEventBus.CreateFmt('Not registred class for eventbus "%s"', [AName]); 619 | Result := eventBusClass.GetEventBus(AName); 620 | end; 621 | 622 | { EventFilterAttribute } 623 | 624 | constructor EventFilterAttribute.Create(AName: string; AProperties: TEventFilterProperties); 625 | begin 626 | inherited Create; 627 | FName := AName; 628 | FProperties := AProperties; 629 | end; 630 | 631 | { TbtkEventObject } 632 | 633 | constructor TbtkEventObject.Create(ATopic: string); 634 | begin 635 | inherited Create; 636 | FTopic := ATopic; 637 | end; 638 | 639 | function TbtkEventObject.Instance: TbtkEventObject; 640 | begin 641 | Result := Self; 642 | end; 643 | 644 | function TbtkEventObject.Topic: string; 645 | begin 646 | Result := FTopic; 647 | end; 648 | 649 | { TbtkEventFilterInfo } 650 | 651 | constructor TbtkEventFilterInfo.Create(AFilterName: string; AProperties: TEventFilterProperties; 652 | AMethod: TRttiMethod); 653 | begin 654 | FFilterName := AFilterName; 655 | FProperties := AProperties; 656 | FMethod := AMethod; 657 | end; 658 | 659 | function TbtkEventFilterInfo.GetValueFor(AInstance: TbtkEventObject): string; 660 | begin 661 | Result := FMethod.Invoke(AInstance, []).AsString; 662 | end; 663 | 664 | { TbtkEventFiltersClassInfo } 665 | 666 | class constructor TbtkEventFiltersRTTIInfo.Create; 667 | begin 668 | FEventsFilterDictionary := TEventsFilterDictionary.Create([doOwnsValues]); 669 | end; 670 | 671 | class destructor TbtkEventFiltersRTTIInfo.Destroy; 672 | begin 673 | FEventsFilterDictionary.Free; 674 | end; 675 | 676 | class function TbtkEventFiltersRTTIInfo.GetInfoFor(AEventObjectClass: TEventObjectClass): TEventFilterInfoList; 677 | var 678 | i, j: Integer; 679 | rMethods: TArray; 680 | rMethodAttributes: TArray; 681 | eventFilterInfoList: TEventFilterInfoList; 682 | 683 | begin 684 | if not FEventsFilterDictionary.TryGetValue(AEventObjectClass, eventFilterInfoList) then 685 | begin 686 | FEventsFilterDictionary.Add(AEventObjectClass, TEventFilterInfoList.Create); 687 | eventFilterInfoList := FEventsFilterDictionary[AEventObjectClass]; 688 | rMethods := RttiContext.GetType(AEventObjectClass).GetMethods; 689 | for i := 0 to Length(rMethods) - 1 do 690 | begin 691 | rMethodAttributes := rMethods[i].GetAttributes; 692 | for j := 0 to Length(rMethodAttributes) - 1 do 693 | if rMethodAttributes[j] is EventFilterAttribute then 694 | eventFilterInfoList.Add( 695 | TbtkEventFilterInfo.Create( 696 | EventFilterAttribute(rMethodAttributes[j]).Name, 697 | EventFilterAttribute(rMethodAttributes[j]).Properties, 698 | rMethods[i])); 699 | end; 700 | end; 701 | Result := eventFilterInfoList; 702 | end; 703 | 704 | function GetEventHandlerParameterType(AMethod: TRttiMethod): TbtkEventObjectClass; 705 | var 706 | rParameters: TArray; 707 | parameterType: TClass; 708 | begin 709 | rParameters := AMethod.GetParameters; 710 | 711 | if (AMethod.MethodKind = mkProcedure) and 712 | (Length(rParameters) = 1) and (rParameters[0].ParamType.IsInstance) then 713 | begin 714 | parameterType := rParameters[0].ParamType.AsInstance.MetaclassType; 715 | if parameterType.InheritsFrom(TbtkEventObject) then 716 | Exit(TbtkEventObjectClass(parameterType)); 717 | end; 718 | raise EEventBus.Create('Handler must be a procedure of object and contain the a single parameter of type ' + TbtkEventObject.ClassName); 719 | end; 720 | 721 | { TbtkEventHandlersClassInfo } 722 | 723 | class constructor TbtkEventHandlersRTTIInfo.Create; 724 | begin 725 | FEventsHandlerDictionary := TEventsHandlerDictionary.Create([doOwnsValues]); 726 | FEventsHookDictionary := TEventsHookDictionary.Create([doOwnsValues]); 727 | end; 728 | 729 | class destructor TbtkEventHandlersRTTIInfo.Destroy; 730 | begin 731 | FEventsHandlerDictionary.Free; 732 | FEventsHookDictionary.Free; 733 | end; 734 | 735 | class function TbtkEventHandlersRTTIInfo.GetInfoFor(AListenerClass: TListenerClass): TbtkEventHandlersRTTIInfo; 736 | var 737 | i, j: Integer; 738 | rMethods: TArray; 739 | rMethodAttributes: TArray; 740 | handlerMethods: TEventHandlerMethodDictionary; 741 | hookMethods: TEventHookMethodDictionary; 742 | begin 743 | Result.FListenerClass := AListenerClass; 744 | if not FEventsHandlerDictionary.ContainsKey(AListenerClass) then 745 | begin 746 | handlerMethods := TEventHandlerMethodDictionary.Create; 747 | hookMethods := TEventHandlerMethodDictionary.Create; 748 | rMethods := RttiContext.GetType(AListenerClass).GetMethods; 749 | for i := 0 to Length(rMethods) - 1 do 750 | begin 751 | rMethodAttributes := rMethods[i].GetAttributes; 752 | for j := 0 to Length(rMethodAttributes) - 1 do 753 | try 754 | if rMethodAttributes[j] is EventHandlerAttribute then 755 | handlerMethods.Add(GetEventHandlerParameterType(rMethods[i]), rMethods[i]) 756 | else 757 | if rMethodAttributes[j] is EventHookAttribute then 758 | hookMethods.Add(GetEventHandlerParameterType(rMethods[i]), rMethods[i]); 759 | except 760 | handlerMethods.Free; 761 | hookMethods.Free; 762 | raise; 763 | end; 764 | end; 765 | FEventsHandlerDictionary.Add(AListenerClass, handlerMethods); 766 | FEventsHookDictionary.Add(AListenerClass, hookMethods); 767 | end; 768 | end; 769 | 770 | function TbtkEventHandlersRTTIInfo.HandlerMethods: TEventHandlerMethodDictionary; 771 | begin 772 | Result := FEventsHandlerDictionary[FListenerClass]; 773 | end; 774 | 775 | function TbtkEventHandlersRTTIInfo.HookMethods: TEventHookMethodDictionary; 776 | begin 777 | Result := FEventsHookDictionary[FListenerClass]; 778 | end; 779 | 780 | { TbtkEventFilter } 781 | 782 | procedure TbtkEventFilter.SetValue(const AValue: string); 783 | begin 784 | FValue := AValue; 785 | FNormalizedValue := NormalizeFilterValue(FValue, efpCaseSensitive in Properties); 786 | if Assigned(FOnValueChanged) then 787 | FOnValueChanged(Self); 788 | end; 789 | 790 | constructor TbtkEventFilter.Create(AProperties: TEventFilterProperties; AValue: string); 791 | begin 792 | //Properties must be set befor Value 793 | FProperties := AProperties; 794 | SetValue(AValue); 795 | end; 796 | 797 | { TEventFilters } 798 | 799 | procedure TbtkEventFilters.UpdateHashingString; 800 | var 801 | i: Integer; 802 | filterPairs: TArray>; 803 | eventFilter: TbtkEventFilter; 804 | begin 805 | FHashingString := EmptyStr; 806 | filterPairs := ToArray; 807 | for i := 0 to Length(filterPairs) - 1 do 808 | begin 809 | eventFilter := filterPairs[i].Value; 810 | if efpIsPartOfHashingString in eventFilter.Properties then 811 | FHashingString := Format('%s%s=%s;', [FHashingString, NormalizeFilterName(filterPairs[i].Key), 812 | eventFilter.NormalizedValue]); 813 | end; 814 | end; 815 | 816 | procedure TbtkEventFilters.FilterValueChanged(ASender: TObject); 817 | var 818 | oldHashingString: string; 819 | begin 820 | if efpIsPartOfHashingString in TbtkEventFilter(ASender).Properties then 821 | begin 822 | oldHashingString := HashingString; 823 | UpdateHashingString; 824 | if oldHashingString <> HashingString then 825 | if Assigned(FHashingStringChanged) then 826 | FHashingStringChanged(Self, oldHashingString); 827 | end; 828 | end; 829 | 830 | function TbtkEventFilters.GetFilters(AName: string): TbtkEventFilter; 831 | begin 832 | Result := Items[NormalizeFilterName(AName)]; 833 | end; 834 | 835 | procedure TbtkEventFilters.ValueNotify(const Value: TbtkEventFilter; Action: TCollectionNotification); 836 | begin 837 | inherited; 838 | case Action of 839 | cnAdded: Value.OnValueChanged := FilterValueChanged; 840 | cnRemoved: ; 841 | cnExtracted: Value.OnValueChanged := nil; 842 | end; 843 | end; 844 | 845 | constructor TbtkEventFilters.Create(AEventObjectClass: TbtkEventObjectClass; AEventObject: TbtkEventObject); 846 | var 847 | i: Integer; 848 | filtersInfo: TList; 849 | filterValue: string; 850 | begin 851 | inherited Create([doOwnsValues]); 852 | filtersInfo := TbtkEventFiltersRTTIInfo.GetInfoFor(AEventObjectClass); 853 | for i := 0 to filtersInfo.Count - 1 do 854 | begin 855 | if Assigned(AEventObject) then 856 | filterValue := filtersInfo[i].GetValueFor(AEventObject) 857 | else 858 | filterValue := EmptyStr; 859 | Add(NormalizeFilterName(filtersInfo[i].FilterName), 860 | TbtkEventFilter.Create(filtersInfo[i].Properties, filterValue)); 861 | end; 862 | UpdateHashingString; 863 | end; 864 | 865 | { TbtkCustomEventHandler } 866 | 867 | function TbtkCustomEventHandler.GetListener: TObject; 868 | begin 869 | Result := FListener; 870 | end; 871 | 872 | function TbtkCustomEventHandler.GetExtracted: Boolean; 873 | begin 874 | Result := FExtracted; 875 | end; 876 | 877 | procedure TbtkCustomEventHandler.SetExtracted(AValue: Boolean); 878 | begin 879 | FExtracted := AValue; 880 | end; 881 | 882 | constructor TbtkCustomEventHandler.Create(AListener: TObject; AMethod: TRttiMethod); 883 | begin 884 | FListener := AListener; 885 | FMethod := AMethod; 886 | FExtracted := False; 887 | end; 888 | 889 | procedure TbtkCustomEventHandler.Invoke(AEventObject: IbtkEventObject); 890 | begin 891 | FMethod.Invoke(Listener, [AEventObject.Instance]); 892 | end; 893 | 894 | function TbtkCustomEventHandler.Lock(ATimeout: Cardinal): Boolean; 895 | begin 896 | Result := MonitorEnter(Self, ATimeout); 897 | end; 898 | 899 | procedure TbtkCustomEventHandler.Unlock; 900 | begin 901 | MonitorExit(Self); 902 | end; 903 | 904 | { TbtkEventHandler } 905 | 906 | function TbtkEventHandler.GetFilters: TbtkEventFilters; 907 | begin 908 | Result := FFilters; 909 | end; 910 | 911 | constructor TbtkEventHandler.Create(AListener: TObject; AMethod: TRttiMethod; AFilters: TbtkEventFilters); 912 | begin 913 | inherited Create(AListener, AMethod); 914 | FFilters := AFilters; 915 | FFilters.OnHashingStringChanged := HashingStringChanged; 916 | end; 917 | 918 | destructor TbtkEventHandler.Destroy; 919 | begin 920 | FFilters.OnHashingStringChanged := nil; 921 | inherited; 922 | end; 923 | 924 | procedure TbtkEventHandler.HashingStringChanged(ASender: TObject; AOldValue: string); 925 | begin 926 | if Assigned(FHashingStringChanged) then 927 | FHashingStringChanged(Self, AOldValue); 928 | end; 929 | 930 | { TbtkEventHook } 931 | 932 | function TbtkEventHook.GetAbsoluteNumber: Integer; 933 | begin 934 | Result := FAbsoluteNumber; 935 | end; 936 | 937 | class constructor TbtkEventHook.Create; 938 | begin 939 | HookCounter := 0; 940 | end; 941 | 942 | constructor TbtkEventHook.Create(AListener: TObject; AMethod: TRttiMethod); 943 | begin 944 | inherited; 945 | FAbsoluteNumber := HookCounter; 946 | Inc(HookCounter); 947 | end; 948 | 949 | { TbtkEventHookComparer } 950 | 951 | function TbtkEventHookComparer.Compare(const Left, Right: IbtkEventHook): Integer; 952 | begin 953 | Result := TComparer.Default.Compare(Left.AbsoluteNumber, Right.AbsoluteNumber); 954 | end; 955 | 956 | { TbtkEeventHandlerEnumerator } 957 | 958 | function TbtkEventHandlerEnumerator.GetCurrent: IbtkCustomEventHandler; 959 | begin 960 | Result := FHandlerList[FIndex]; 961 | end; 962 | 963 | constructor TbtkEventHandlerEnumerator.Create(AHooks: TbtkHookList; AHandlers: TbtkHandlerList); 964 | var 965 | i: Integer; 966 | begin 967 | inherited Create; 968 | FIndex := -1; 969 | FHandlerList := TbtkCustomHandlerList.Create; 970 | for i := AHooks.Count -1 downto 0 do 971 | FHandlerList.Add(AHooks[i]); 972 | for i := AHandlers.Count - 1 downto 0 do 973 | FHandlerList.Add(AHandlers[i]); 974 | end; 975 | 976 | destructor TbtkEventHandlerEnumerator.Destroy; 977 | begin 978 | FHandlerList.Free; 979 | inherited; 980 | end; 981 | 982 | function TbtkEventHandlerEnumerator.MoveNext: Boolean; 983 | begin 984 | if FIndex >= FHandlerList.Count then 985 | Exit(False); 986 | Inc(FIndex); 987 | Result := FIndex < FHandlerList.Count; 988 | end; 989 | 990 | { TbtkListenerInfo } 991 | 992 | procedure TbtkListenerInfo.FillFilters; 993 | var 994 | i: Integer; 995 | eventObjectClasses: TArray; 996 | begin 997 | eventObjectClasses := HandlerMethods.Keys.ToArray; 998 | for i := 0 to Length(eventObjectClasses) - 1 do 999 | HandlerFilters.Add(eventObjectClasses[i], TbtkEventFilters.Create(eventObjectClasses[i])); 1000 | end; 1001 | 1002 | constructor TbtkListenerInfo.Create(AListener: TObject); 1003 | begin 1004 | inherited Create; 1005 | FListener := AListener; 1006 | FHandlersClassInfo := TbtkEventHandlersRTTIInfo.GetInfoFor(AListener.ClassType); 1007 | FHandlerFilters := TDictionary.Create; 1008 | FillFilters; 1009 | end; 1010 | 1011 | destructor TbtkListenerInfo.Destroy; 1012 | begin 1013 | FHandlerFilters.Free; 1014 | inherited Destroy; 1015 | end; 1016 | 1017 | function TbtkListenerInfo.HookMethods: TDictionary; 1018 | begin 1019 | Result := FHandlersClassInfo.HookMethods; 1020 | end; 1021 | 1022 | function TbtkListenerInfo.HandlerMethods: TDictionary; 1023 | begin 1024 | Result := FHandlersClassInfo.HandlerMethods; 1025 | end; 1026 | 1027 | function TbtkListenerInfo.HandlerFilters: TDictionary; 1028 | begin 1029 | Result := FHandlerFilters; 1030 | end; 1031 | 1032 | { TbtkEventHandlers } 1033 | 1034 | constructor TbtkEventHandlers.Create; 1035 | begin 1036 | inherited Create; 1037 | FHookList := TbtkHookList.Create; 1038 | FHandlerLists := TbtkHandlerDictionary.Create([doOwnsValues]); 1039 | end; 1040 | 1041 | destructor TbtkEventHandlers.Destroy; 1042 | begin 1043 | FHookList.Free; 1044 | FHandlerLists.Free; 1045 | inherited; 1046 | end; 1047 | 1048 | procedure TbtkEventHandlers.HashingStringChanged(ASender: TObject; AOldValue: string); 1049 | var 1050 | eventHandler: IbtkEventHandler; 1051 | begin 1052 | eventHandler := HandlerLists[AOldValue].Extract(TbtkEventHandler(ASender)); 1053 | if HandlerLists[AOldValue].Count = 0 then 1054 | HandlerLists.Remove(AOldValue); 1055 | if not HandlerLists.ContainsKey(eventHandler.Filters.HashingString) then 1056 | HandlerLists.Add(eventHandler.Filters.HashingString, TbtkHandlerList.Create); 1057 | HandlerLists[eventHandler.Filters.HashingString].Add(eventHandler); 1058 | end; 1059 | 1060 | { TbtkCustomEventBus.TEventBusInfo } 1061 | 1062 | constructor TbtkCustomEventBus.TEventBusInfo.Create(AEventBus: TbtkCustomEventBus); 1063 | begin 1064 | EventBus := AEventBus; 1065 | &Class := AEventBus.ClassType; 1066 | end; 1067 | 1068 | { TbtkEventBus } 1069 | 1070 | procedure TbtkCustomEventBus.AddFromListener(AEventObjectClass: TbtkEventObjectClass; AListenerInfo: TbtkListenerInfo); 1071 | var 1072 | eventHashingString: string; 1073 | eventHandler: TbtkEventHandler; 1074 | eventHook: TbtkEventHook; 1075 | handlerList: TbtkHandlerList; 1076 | begin 1077 | if AListenerInfo.HandlerMethods.ContainsKey(AEventObjectClass) then 1078 | begin 1079 | eventHandler := TbtkEventHandler.Create(AListenerInfo.Listener, 1080 | AListenerInfo.HandlerMethods[AEventObjectClass], 1081 | AListenerInfo.HandlerFilters[AEventObjectClass]); 1082 | eventHandler.OnHashingStringChanged := FEventHandlers[AEventObjectClass].HashingStringChanged; 1083 | 1084 | eventHashingString := AListenerInfo.HandlerFilters[AEventObjectClass].HashingString; 1085 | if not FEventHandlers[AEventObjectClass].HandlerLists.TryGetValue(eventHashingString, handlerList) then 1086 | begin 1087 | handlerList := TbtkHandlerList.Create; 1088 | FEventHandlers[AEventObjectClass].HandlerLists.Add(eventHashingString, handlerList); 1089 | end; 1090 | handlerList.Add(eventHandler); 1091 | end; 1092 | 1093 | if AListenerInfo.HookMethods.ContainsKey(AEventObjectClass) then 1094 | begin 1095 | eventHook := TbtkEventHook.Create(AListenerInfo.Listener, AListenerInfo.HookMethods[AEventObjectClass]); 1096 | FEventHandlers[AEventObjectClass].HookList.Add(eventHook); 1097 | end; 1098 | end; 1099 | 1100 | procedure TbtkCustomEventBus.RemoveFromListener(AEventObjectClass: TbtkEventObjectClass; AListenerInfo: TbtkListenerInfo); 1101 | var 1102 | i: Integer; 1103 | eventHashingString: string; 1104 | handlerList: TbtkHandlerList; 1105 | handler: IbtkCustomEventHandler; 1106 | begin 1107 | if AListenerInfo.HandlerMethods.ContainsKey(AEventObjectClass) then 1108 | begin 1109 | eventHashingString := AListenerInfo.HandlerFilters[AEventObjectClass].HashingString; 1110 | handlerList := FEventHandlers[AEventObjectClass].HandlerLists[eventHashingString]; 1111 | for i := 0 to handlerList.Count - 1 do 1112 | begin 1113 | if handlerList[i].Listener = AListenerInfo.Listener then 1114 | begin 1115 | handler := handlerList[i]; 1116 | if handler.Lock(ThreadLockWaitingTimeout) then 1117 | try 1118 | handler.Extracted := True; 1119 | handlerList.Delete(i); 1120 | finally 1121 | handler.Unlock; 1122 | end 1123 | else 1124 | raise EEventBus.Create('Could not lock handler'); 1125 | if handlerList.Count = 0 then 1126 | FEventHandlers[AEventObjectClass].HandlerLists.Remove(eventHashingString); 1127 | Break; 1128 | end; 1129 | end; 1130 | end; 1131 | 1132 | if AListenerInfo.HookMethods.ContainsKey(AEventObjectClass) then 1133 | for i := FEventHandlers[AEventObjectClass].HookList.Count - 1 downto 0 do 1134 | if FEventHandlers[AEventObjectClass].HookList[i].Listener = AListenerInfo.Listener then 1135 | begin 1136 | handler := FEventHandlers[AEventObjectClass].HookList[i]; 1137 | if handler.Lock(ThreadLockWaitingTimeout) then 1138 | try 1139 | handler.Extracted := True; 1140 | FEventHandlers[AEventObjectClass].HookList.Delete(i); 1141 | finally 1142 | handler.Unlock; 1143 | end 1144 | else 1145 | raise EEventBus.Create('Could not lock handler'); 1146 | Break; 1147 | end; 1148 | end; 1149 | 1150 | class constructor TbtkCustomEventBus.Create; 1151 | begin 1152 | FEventBusDictionary := TDictionary.Create; 1153 | end; 1154 | 1155 | class destructor TbtkCustomEventBus.Destroy; 1156 | begin 1157 | FEventBusDictionary.Free; 1158 | end; 1159 | 1160 | class function TbtkCustomEventBus.GetEventBus(AName: TEventBusName): IbtkEventBus; 1161 | var 1162 | eventBus: TbtkCustomEventBus; 1163 | eventBusInfo: TEventBusInfo; 1164 | begin 1165 | if not FEventBusDictionary.TryGetValue(AName, eventBusInfo) then 1166 | begin 1167 | eventBus := Self.Create; 1168 | eventBus.FName := AName; 1169 | eventBusInfo := TEventBusInfo.Create(eventBus); 1170 | FEventBusDictionary.Add(AName, eventBusInfo); 1171 | end; 1172 | if not eventBusInfo.&Class.InheritsFrom(Self) then 1173 | raise EEventBus.Create('Incorrectly specified class of eventbus'); 1174 | Result := eventBusInfo.EventBus; 1175 | end; 1176 | 1177 | constructor TbtkCustomEventBus.Create; 1178 | begin 1179 | inherited Create; 1180 | FListenersInfo := TObjectDictionary.Create([doOwnsValues]); 1181 | FEventHandlers := TObjectDictionary.Create([doOwnsValues]); 1182 | end; 1183 | 1184 | destructor TbtkCustomEventBus.Destroy; 1185 | begin 1186 | if TbtkCustomEventBus.FEventBusDictionary.ContainsKey(FName) then 1187 | TbtkCustomEventBus.FEventBusDictionary.Remove(FName); 1188 | FListenersInfo.Free; 1189 | FEventHandlers.Free; 1190 | inherited Destroy; 1191 | end; 1192 | 1193 | procedure TbtkCustomEventBus.Send(AEventObject: IbtkEventObject; AExceptionHandler: TbtkEventExceptionHandler); 1194 | function FiltersMatch(AEventFilters: TbtkEventFilters; AHandlerFilters: TbtkEventFilters): Boolean; 1195 | var 1196 | i: Integer; 1197 | filterNames: TArray; 1198 | eventFilter, handlerFilter: TbtkEventFilter; 1199 | begin 1200 | Result := True; 1201 | filterNames := AEventFilters.Keys.ToArray; 1202 | for i := 0 to Length(filterNames) - 1 do 1203 | begin 1204 | eventFilter := AEventFilters[filterNames[i]]; 1205 | handlerFilter := AHandlerFilters[filterNames[i]]; 1206 | if not(efpIsPartOfHashingString in eventFilter.Properties) and 1207 | (handlerFilter.Value <> EmptyStr) and 1208 | (handlerFilter.NormalizedValue <> eventFilter.NormalizedValue) then 1209 | Exit(False); 1210 | end; 1211 | end; 1212 | 1213 | procedure SafeInvoke(AEventObject: IbtkEventObject; 1214 | AEventHandler: IbtkCustomEventHandler; AExceptionHandler: TbtkEventExceptionHandler); 1215 | begin 1216 | try 1217 | AEventHandler.Invoke(AEventObject); 1218 | except 1219 | on E: Exception do 1220 | begin 1221 | if Assigned(AExceptionHandler) then 1222 | AExceptionHandler(E) 1223 | else 1224 | ApplicationHandleException(Self); 1225 | end; 1226 | end; 1227 | end; 1228 | 1229 | var 1230 | i: Integer; 1231 | 1232 | eventClass: TbtkEventObjectClass; 1233 | eventFilters: TbtkEventFilters; 1234 | eventHandlers: TbtkEventHandlers; 1235 | eventHandlerList: TbtkHandlerList; 1236 | 1237 | hooks: TbtkHookList; 1238 | handlers: TbtkHandlerList; 1239 | begin 1240 | if not(AEventObject.Instance is TbtkEventObject) then 1241 | raise EEventBus.Create('Event object must be inherits from TbtkEventObject class'); 1242 | 1243 | hooks := TbtkHookList.Create; 1244 | handlers := TbtkHandlerList.Create; 1245 | try 1246 | 1247 | eventClass := TbtkEventObjectClass(AEventObject.Instance.ClassType); 1248 | while eventClass <> TbtkEventObject.ClassParent do 1249 | begin 1250 | eventFilters := TbtkEventFilters.Create(eventClass, AEventObject.Instance); 1251 | try 1252 | if FEventHandlers.TryGetValue(eventClass, eventHandlers) then 1253 | begin 1254 | hooks.AddRange(eventHandlers.HookList.ToArray); 1255 | 1256 | if eventHandlers.HandlerLists.TryGetValue(eventFilters.HashingString, eventHandlerList) then 1257 | for i := 0 to eventHandlerList.Count - 1 do 1258 | if FiltersMatch(eventFilters, eventHandlerList[i].Filters) then 1259 | handlers.Add(eventHandlerList[i]); 1260 | end; 1261 | finally 1262 | eventFilters.Free; 1263 | end; 1264 | eventClass := TbtkEventObjectClass(eventClass.ClassParent) 1265 | end; 1266 | 1267 | hooks.Sort(TbtkEventHookComparer.Create); 1268 | InternalSend(AEventObject, TbtkEventHandlerEnumerator.Create(hooks, handlers), AExceptionHandler); 1269 | 1270 | finally 1271 | hooks.Free; 1272 | handlers.Free; 1273 | end; 1274 | end; 1275 | 1276 | function TbtkCustomEventBus.Register(AListener: TObject): TbtkListenerInfo; 1277 | var 1278 | i: Integer; 1279 | handlerClasses: TArray; 1280 | hookClasses: TArray; 1281 | eventObjectClassList: TList; 1282 | begin 1283 | Assert(not FListenersInfo.ContainsKey(AListener), 'Listener already exists'); 1284 | FListenersInfo.Add(AListener, TbtkListenerInfo.Create(AListener)); 1285 | eventObjectClassList := TList.Create; 1286 | try 1287 | handlerClasses := FListenersInfo[AListener].HandlerMethods.Keys.ToArray; 1288 | hookClasses := FListenersInfo[AListener].HookMethods.Keys.ToArray; 1289 | eventObjectClassList.AddRange(handlerClasses); 1290 | for i := 0 to Length(hookClasses) - 1 do 1291 | if not eventObjectClassList.Contains(hookClasses[i]) then 1292 | eventObjectClassList.Add(hookClasses[i]); 1293 | 1294 | for i := 0 to eventObjectClassList.Count - 1 do 1295 | begin 1296 | if not FEventHandlers.ContainsKey(eventObjectClassList[i]) then 1297 | FEventHandlers.Add(eventObjectClassList[i], TbtkEventHandlers.Create); 1298 | AddFromListener(eventObjectClassList[i], FListenersInfo[AListener]); 1299 | end; 1300 | finally 1301 | eventObjectClassList.Free; 1302 | end; 1303 | Result := FListenersInfo[AListener]; 1304 | end; 1305 | 1306 | procedure TbtkCustomEventBus.UnRegister(AListener: TObject); 1307 | var 1308 | i: Integer; 1309 | handlerClasses: TArray; 1310 | hookClasses: TArray; 1311 | eventObjectClassList: TList; 1312 | begin 1313 | Assert(FListenersInfo.ContainsKey(AListener), 'Listener is not exists'); 1314 | eventObjectClassList := TList.Create; 1315 | try 1316 | handlerClasses := FListenersInfo[AListener].HandlerMethods.Keys.ToArray; 1317 | hookClasses := FListenersInfo[AListener].HookMethods.Keys.ToArray; 1318 | eventObjectClassList.AddRange(handlerClasses); 1319 | for i := 0 to Length(hookClasses) - 1 do 1320 | if not eventObjectClassList.Contains(hookClasses[i]) then 1321 | eventObjectClassList.Add(hookClasses[i]); 1322 | 1323 | for i := 0 to eventObjectClassList.Count - 1 do 1324 | begin 1325 | RemoveFromListener(eventObjectClassList[i], FListenersInfo[AListener]); 1326 | if (FEventHandlers[eventObjectClassList[i]].HandlerLists.Count = 0) 1327 | and (FEventHandlers[eventObjectClassList[i]].HookList.Count = 0) then 1328 | FEventHandlers.Remove(eventObjectClassList[i]); 1329 | end; 1330 | finally 1331 | eventObjectClassList.Free; 1332 | end; 1333 | FListenersInfo.Remove(AListener); 1334 | end; 1335 | 1336 | { TbtkCustomEventSender } 1337 | 1338 | procedure TbtkCustomEventSender.DoExecuteHandlers(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; 1339 | AExceptionHandler: TbtkEventExceptionHandler); 1340 | var 1341 | handler: IbtkCustomEventHandler; 1342 | begin 1343 | while AHandlerEnumerator.MoveNext do 1344 | try 1345 | handler := AHandlerEnumerator.Current; 1346 | handler.Lock(ThreadLockWaitingTimeout); 1347 | try 1348 | if not handler.Extracted then 1349 | handler.Invoke(AEventObject); 1350 | finally 1351 | handler.Unlock; 1352 | end; 1353 | except 1354 | on E: Exception do 1355 | begin 1356 | if Assigned(AExceptionHandler) then 1357 | AExceptionHandler(E) 1358 | else 1359 | ApplicationHandleException(Self); 1360 | end; 1361 | end; 1362 | end; 1363 | 1364 | { TbtkEventBus } 1365 | 1366 | constructor TbtkEventBus.Create; 1367 | begin 1368 | inherited; 1369 | FEventSender := T.Create; 1370 | end; 1371 | 1372 | destructor TbtkEventBus.Destroy; 1373 | begin 1374 | FEventSender := nil; 1375 | inherited; 1376 | end; 1377 | 1378 | procedure TbtkEventBus.InternalSend(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; AExceptionHandler: TbtkEventExceptionHandler); 1379 | begin 1380 | FEventSender.Send(AEventObject, AHandlerEnumerator, AExceptionHandler); 1381 | end; 1382 | 1383 | { TbtkSyncEventSender } 1384 | 1385 | procedure TbtkSyncEventSender.Send(AEventObject: IbtkEventObject; AHandlerEnumerator: IbtkEventHandlerEnumerator; 1386 | AExceptionHandler: TbtkEventExceptionHandler); 1387 | begin 1388 | DoExecuteHandlers(AEventObject, AHandlerEnumerator, AExceptionHandler); 1389 | end; 1390 | 1391 | initialization 1392 | RttiContext := TRttiContext.Create; 1393 | EventBusClassDictionary := TDictionary.Create; 1394 | 1395 | finalization 1396 | RttiContext.Free; 1397 | EventBusClassDictionary.Free; 1398 | 1399 | end. 1400 | -------------------------------------------------------------------------------- /Tests/DUnitX.btkEventBusTest.pas: -------------------------------------------------------------------------------- 1 | unit DUnitX.btkEventBusTest; 2 | 3 | interface 4 | uses 5 | SysUtils, 6 | Vcl.Forms, 7 | DUnitX.TestFramework, 8 | DUnitX.TestFixture, 9 | Delphi.Mocks, 10 | btkEventBus; 11 | 12 | type 13 | 14 | TbtkCustomTestEventObject = class(TbtkEventObject) 15 | private 16 | FHashedTestFilter: string; 17 | FNotHashedTestFilter: string; 18 | public 19 | const sEventHashedTestFilterName = 'HashedTestFilter'; 20 | const sEventNotHashedTestFilterName = 'NotHashedTestFilter'; 21 | 22 | constructor Create(ATopic: string; AHashedTestFilter: string; 23 | ANotHashedTestFilter: string); 24 | 25 | [EventFilter(sEventHashedTestFilterName, [efpIsPartOfHashingString])] 26 | function HashedTestFilter: string; 27 | [EventFilter(sEventNotHashedTestFilterName)] 28 | function NotHashedTestFilter: string; 29 | end; 30 | 31 | TbtkTestEventObject = class(TbtkCustomTestEventObject) 32 | private 33 | FNotHashedTestFilter2: string; 34 | 35 | public 36 | const sEventNotHashedTestFilter2Name = 'NotHashedTestFilter2'; 37 | 38 | constructor Create(ATopic: string; AHashedTestFilter: string; 39 | ANotHashedTestFilter: string; ANotHashedTestFilter2: string); 40 | 41 | [EventFilter(sEventNotHashedTestFilter2Name)] 42 | function NotHashedTestFilter2: string; 43 | end; 44 | 45 | TbtkCaseSensitiveTestEventObject = class(TbtkEventObject) 46 | private 47 | FHashedCaseSensitiveTestFilter: string; 48 | FHashedNotCaseSensitiveTestFilter: string; 49 | FNotHashedCaseSensitiveTestFilter: string; 50 | FNotHashedNotCaseSensitiveTestFilter: string; 51 | public 52 | const sEventHashedCaseSensitiveTestFilterName = 'HashedCaseSensitiveTestFilter'; 53 | const sEventHashedNotCaseSensitiveTestFilterName = 'HashedNotCaseSensitiveTestFilter'; 54 | const sEventNotHashedCaseSensitiveTestFilterName = 'NotHashedCaseSensitiveTestFilter'; 55 | const sEventNotHashedNotCaseSensitiveTestFilterName = 'NotHashedNotCaseSensitiveTestFilter'; 56 | 57 | constructor Create(ATopic: string; AHashedCaseSensitiveTestFilter: string; 58 | AHashedNotCaseSensitiveTestFilter: string; ANotHashedCaseSensitiveTestFilter: string; 59 | ANotHashedNotCaseSensitiveTestFilter: string); 60 | 61 | [EventFilter(sEventHashedCaseSensitiveTestFilterName, [efpIsPartOfHashingString, efpCaseSensitive])] 62 | function HashedCaseSensitiveTestFilter: string; 63 | [EventFilter(sEventHashedNotCaseSensitiveTestFilterName, [efpIsPartOfHashingString])] 64 | function HashedNotCaseSensitiveTestFilter: string; 65 | [EventFilter(sEventNotHashedCaseSensitiveTestFilterName, [efpCaseSensitive])] 66 | function NotHashedCaseSensitiveTestFilter: string; 67 | [EventFilter(sEventNotHashedNotCaseSensitiveTestFilterName)] 68 | function NotHashedNotCaseSensitiveTestFilter: string; 69 | end; 70 | 71 | TbtkTestEventListener = class 72 | public 73 | [EventHandler] 74 | procedure Handler(AEventObject: TbtkTestEventObject); virtual; abstract; 75 | [EventHandler] 76 | procedure HandlerForParentClass(AEventObject: TbtkCustomTestEventObject); virtual; abstract; 77 | [EventHook] 78 | procedure Hook(AEventObject: TbtkTestEventObject); virtual; abstract; 79 | [EventHook] 80 | procedure HookForParentClass(AEventObject: TbtkCustomTestEventObject); virtual; abstract; 81 | [EventHandler] 82 | procedure CaseSensitiveHandler(AEventObject: TbtkCaseSensitiveTestEventObject); virtual; abstract; 83 | end; 84 | 85 | TbtkTestInvalidEventListener = class 86 | public 87 | [EventHandler] 88 | procedure Handler(AEventObject: TObject); virtual; abstract; 89 | end; 90 | 91 | TbtkFakeExceptionHandler = class 92 | public 93 | procedure HandleException(ASender: TObject; AException: Exception); virtual; abstract; 94 | end; 95 | 96 | TbtkEventBusTest = class(TObject) 97 | public 98 | 99 | EventBus: IbtkEventBus; 100 | Listener: TMock; 101 | InvalidListener: TMock; 102 | ListenerInfo: TbtkListenerInfo; 103 | Listeners: array[0..2] of TMock; 104 | ListenersInfo: array[0..2] of TbtkListenerInfo; 105 | 106 | [Setup] 107 | procedure Setup; 108 | [TearDown] 109 | procedure TearDown; 110 | 111 | procedure RegisterListener; 112 | procedure UnRegisterListener; 113 | procedure RegisterInvalidListener; 114 | procedure RegisterListeners; 115 | procedure UnRegisterListeners; 116 | 117 | [Test] 118 | procedure Register_ListenerIsValid_WillNotRaise; 119 | [Test] 120 | procedure Register_ListenerIsNotValid_WillRaise; 121 | [Test] 122 | procedure Register_AlreadyRegisteredListener_WillRaise; 123 | [Test] 124 | procedure UnRegister_ListenerIsRegistered_WillNotRaise; 125 | [Test] 126 | procedure UnRegister_ListenerIsNotRegistered_WillRaise; 127 | [Test] 128 | procedure Send_AllFiltersIsEmpty_HandlerNotCalled; 129 | [Test] 130 | procedure Send_AllFiltersIsEmpty_HookCalled; 131 | [Test] 132 | procedure Send_AllFiltersOfListenerMatchWithParametersOfEvent_HandlerCalled; 133 | [Test] 134 | procedure Send_AllFiltersOfListenerMatchWithParametersOfEvent_HookCalled; 135 | [Test] 136 | procedure Send_AllFiltersOfListenerDifferentFromParametersOfEvent_HookCalled; 137 | [Test] 138 | procedure Send_AllFiltersOfListenerDifferentFromParametersOfEvent_HandlerNotCalled; 139 | [Test] 140 | procedure Send_SingleHashedFilterIsEmptyOtherFiltersLikeInEvent_HandlerNotCalled; 141 | [Test] 142 | procedure Send_NotHashedFiltersIsEmptyHashedFiltersLikeInEvent_HandlerCalled; 143 | [Test] 144 | procedure Send_2HashedFiltersInListenerMatchFiltersInEvent2NotHashedFilterMismatchFiltersInEvent_HandlerNotCalled; 145 | [Test] 146 | procedure Send_HandlerContainParentClassOfEvent_HandlerCalled; 147 | [Test] 148 | procedure Send_HookContainParentClassOfEvent_HookCalled; 149 | [Test] 150 | procedure Send_HandlerContainChildClassOfEvent_HandlerNotCalled; 151 | [Test] 152 | procedure Send_HookContainChildClassOfEvent_HookNotCalled; 153 | [Test] 154 | procedure Send_ExceptionWasRaisedInHandlerAndExceptionHandlerIsNotExist_WillNotRaiseAny; 155 | [Test] 156 | procedure Send_ExceptionRaisedInHandlerAndNotExistExceptionHandler_ApplicationHandleExceptionCalled; 157 | [Test] 158 | procedure Send_ExceptionRaisedInHandlerAndExistExceptionHandler_ApplicationHandleExceptionNotCalled; 159 | [Test] 160 | procedure Send_ExceptionRaisedInHandlerAndExistExceptionHandler_ExceptionHandlerCalled; 161 | [Test] 162 | procedure Send_ExceptionWasRaisedInHandlerAndExceptionHandlerIsExist_ExceptionInExceptionHandlerIsOriginalException; 163 | [Test] 164 | procedure Send_ExceptionWasRaisedInHandlerAndExceptionHandlerRaisedNothing_WillNotRaiseAny; 165 | [Test] 166 | procedure Send_ExceptionWasRaisedInHandlerAndExceptionHandlerRaisedAcquiredException_FinalExceptionIsOriginalException; 167 | [Test] 168 | procedure Send_ExceptionWasRaisedInHandlerAndExceptionHandlerRaisedOuterException_InnerExceptionOfFinalExceptionIsOriginalException; 169 | [Test] 170 | procedure Send_ExceptionRaisedInEachHooksAndHandlersRaisedAnException_AllHooksAndHandlersCalled; 171 | [Test] 172 | procedure Send_1Event3Listeners_EachHandlerCalledOnce; 173 | [Test] 174 | procedure Send_HashedCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerNotCalled; 175 | [Test] 176 | procedure Send_HashedNotCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerCalled; 177 | [Test] 178 | procedure Send_NotHashedCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerNotCalled; 179 | [Test] 180 | procedure Send_NotHashedNotCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerCalled; 181 | end; 182 | 183 | TbtkEventFiltersTest = class(TObject) 184 | public 185 | 186 | EventBus: IbtkEventBus; 187 | Listener: TMock; 188 | EventFilters: TbtkEventFilters; 189 | TestFilterName: string; 190 | procedure TryRequestEventFilter; 191 | 192 | [Setup] 193 | procedure Setup; 194 | [TearDown] 195 | procedure TearDown; 196 | 197 | [test] 198 | procedure Filters_FilterNameIsExist_WillNotRaise; 199 | [test] 200 | procedure Filters_FilterNameIsExistButContainsOtherCharacterCase_WillNotRaise; 201 | [test] 202 | procedure Filters_FilterNameIsNotExists_WillRaise; 203 | end; 204 | 205 | 206 | implementation 207 | 208 | uses 209 | System.Rtti; 210 | 211 | { TbtkCustomTestEventObject } 212 | 213 | constructor TbtkCustomTestEventObject.Create(ATopic, AHashedTestFilter, 214 | ANotHashedTestFilter: string); 215 | begin 216 | inherited Create(ATopic); 217 | FHashedTestFilter := AHashedTestFilter; 218 | FNotHashedTestFilter := ANotHashedTestFilter; 219 | end; 220 | 221 | function TbtkCustomTestEventObject.HashedTestFilter: string; 222 | begin 223 | Result := FHashedTestFilter; 224 | end; 225 | 226 | function TbtkCustomTestEventObject.NotHashedTestFilter: string; 227 | begin 228 | Result := FNotHashedTestFilter; 229 | end; 230 | 231 | { TbtkTestEventObject } 232 | 233 | constructor TbtkTestEventObject.Create(ATopic: string; AHashedTestFilter: string; 234 | ANotHashedTestFilter: string; ANotHashedTestFilter2: string); 235 | begin 236 | inherited Create(ATopic, AHashedTestFilter, ANotHashedTestFilter); 237 | FNotHashedTestFilter2 := ANotHashedTestFilter2; 238 | end; 239 | 240 | function TbtkTestEventObject.NotHashedTestFilter2: string; 241 | begin 242 | Result := FNotHashedTestFilter2; 243 | end; 244 | 245 | { TbtkCaseSensitiveTestEventObject } 246 | 247 | constructor TbtkCaseSensitiveTestEventObject.Create(ATopic: string; AHashedCaseSensitiveTestFilter: string; 248 | AHashedNotCaseSensitiveTestFilter: string; ANotHashedCaseSensitiveTestFilter: string; 249 | ANotHashedNotCaseSensitiveTestFilter: string); 250 | begin 251 | inherited Create(ATopic); 252 | FHashedCaseSensitiveTestFilter := AHashedCaseSensitiveTestFilter; 253 | FHashedNotCaseSensitiveTestFilter := AHashedNotCaseSensitiveTestFilter; 254 | FNotHashedCaseSensitiveTestFilter := ANotHashedCaseSensitiveTestFilter; 255 | FNotHashedNotCaseSensitiveTestFilter := ANotHashedNotCaseSensitiveTestFilter; 256 | end; 257 | 258 | function TbtkCaseSensitiveTestEventObject.HashedCaseSensitiveTestFilter: string; 259 | begin 260 | Result := FHashedCaseSensitiveTestFilter; 261 | end; 262 | 263 | function TbtkCaseSensitiveTestEventObject.HashedNotCaseSensitiveTestFilter: string; 264 | begin 265 | Result := FHashedNotCaseSensitiveTestFilter; 266 | end; 267 | 268 | function TbtkCaseSensitiveTestEventObject.NotHashedCaseSensitiveTestFilter: string; 269 | begin 270 | Result := FNotHashedCaseSensitiveTestFilter; 271 | end; 272 | 273 | function TbtkCaseSensitiveTestEventObject.NotHashedNotCaseSensitiveTestFilter: string; 274 | begin 275 | Result := FNotHashedNotCaseSensitiveTestFilter; 276 | end; 277 | 278 | { TbtkEventBusTest } 279 | 280 | procedure TbtkEventBusTest.Setup; 281 | var 282 | i: Integer; 283 | begin 284 | EventBus := TbtkEventBus.Create; 285 | Listener := TMock.Create; 286 | InvalidListener := TMock.Create; 287 | for i := Low(Listeners) to High(Listeners) do 288 | Listeners[i] := TMock.Create; 289 | end; 290 | 291 | procedure TbtkEventBusTest.TearDown; 292 | var 293 | i: Integer; 294 | begin 295 | Listener.Free; 296 | InvalidListener.Free; 297 | for i := Low(Listeners) to High(Listeners) do 298 | Listeners[i].Free; 299 | EventBus := nil; 300 | end; 301 | 302 | procedure TbtkEventBusTest.RegisterListener; 303 | begin 304 | ListenerInfo := EventBus.Register(Listener); 305 | end; 306 | 307 | procedure TbtkEventBusTest.UnRegisterListener; 308 | begin 309 | EventBus.UnRegister(Listener); 310 | end; 311 | 312 | procedure TbtkEventBusTest.RegisterInvalidListener; 313 | begin 314 | EventBus.Register(InvalidListener); 315 | end; 316 | 317 | procedure TbtkEventBusTest.RegisterListeners; 318 | var 319 | i: Integer; 320 | begin 321 | for i := Low(Listeners) to High(Listeners) do 322 | ListenersInfo[i] := EventBus.Register(Listeners[i]); 323 | end; 324 | 325 | procedure TbtkEventBusTest.UnRegisterListeners; 326 | var 327 | i: Integer; 328 | begin 329 | for i := Low(Listeners) to High(Listeners) do 330 | EventBus.UnRegister(Listeners[i]); 331 | end; 332 | 333 | procedure TbtkEventBusTest.Register_ListenerIsValid_WillNotRaise; 334 | begin 335 | Assert.WillNotRaiseAny(RegisterListener, 'Registration with valid listener generated an exception'); 336 | end; 337 | 338 | procedure TbtkEventBusTest.Register_ListenerIsNotValid_WillRaise; 339 | begin 340 | Assert.WillRaiseAny(RegisterInvalidListener, 'Registration with invalid listener not generated an exception'); 341 | end; 342 | 343 | procedure TbtkEventBusTest.Register_AlreadyRegisteredListener_WillRaise; 344 | begin 345 | RegisterListener; 346 | Assert.WillRaiseAny(RegisterListener, 'Re-registration of the listener not generated an exception'); 347 | UnRegisterListener; 348 | end; 349 | 350 | procedure TbtkEventBusTest.UnRegister_ListenerIsRegistered_WillNotRaise; 351 | begin 352 | RegisterListener; 353 | Assert.WillNotRaiseAny(UnRegisterListener, 'De-registering a registered listener generated an exception'); 354 | end; 355 | 356 | procedure TbtkEventBusTest.UnRegister_ListenerIsNotRegistered_WillRaise; 357 | begin 358 | Assert.WillRaiseAny(UnRegisterListener, 'De-registering a unregistered listener not generated an exception'); 359 | end; 360 | 361 | procedure TbtkEventBusTest.Send_AllFiltersIsEmpty_HandlerNotCalled; 362 | begin 363 | RegisterListener; 364 | try 365 | Listener.Setup.Expect.Never('Handler'); 366 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 367 | Listener.Verify; 368 | finally 369 | UnRegisterListener; 370 | end; 371 | end; 372 | 373 | procedure TbtkEventBusTest.Send_AllFiltersIsEmpty_HookCalled; 374 | begin 375 | RegisterListener; 376 | try 377 | Listener.Setup.Expect.Once('Hook'); 378 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 379 | Listener.Verify; 380 | finally 381 | UnRegisterListener; 382 | end; 383 | end; 384 | 385 | procedure TbtkEventBusTest.Send_AllFiltersOfListenerMatchWithParametersOfEvent_HandlerCalled; 386 | begin 387 | RegisterListener; 388 | try 389 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 390 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := 'HashedTestFilterValue'; 391 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := 'NotHashedTestFilterValue'; 392 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := 'NotHashedTestFilter2Value'; 393 | 394 | Listener.Setup.Expect.Once('Handler'); 395 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 396 | Listener.Verify; 397 | finally 398 | UnRegisterListener; 399 | end; 400 | end; 401 | 402 | procedure TbtkEventBusTest.Send_AllFiltersOfListenerMatchWithParametersOfEvent_HookCalled; 403 | begin 404 | RegisterListener; 405 | try 406 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 407 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := 'HashedTestFilterValue'; 408 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := 'NotHashedTestFilterValue'; 409 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := 'NotHashedTestFilter2Value'; 410 | 411 | Listener.Setup.Expect.Once('Hook'); 412 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 413 | Listener.Verify; 414 | finally 415 | UnRegisterListener; 416 | end; 417 | end; 418 | 419 | procedure TbtkEventBusTest.Send_AllFiltersOfListenerDifferentFromParametersOfEvent_HookCalled; 420 | begin 421 | RegisterListener; 422 | try 423 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := '-TopicValue'; 424 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := '-HashedTestFilterValue'; 425 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := '-NotHashedTestFilterValue'; 426 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := '-NotHashedTestFilter2Value'; 427 | 428 | Listener.Setup.Expect.Once('Hook'); 429 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 430 | Listener.Verify; 431 | finally 432 | UnRegisterListener; 433 | end; 434 | end; 435 | 436 | procedure TbtkEventBusTest.Send_AllFiltersOfListenerDifferentFromParametersOfEvent_HandlerNotCalled; 437 | begin 438 | RegisterListener; 439 | try 440 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := '-TopicValue'; 441 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := '-HashedTestFilterValue'; 442 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := '-NotHashedTestFilterValue'; 443 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := '-NotHashedTestFilter2Value'; 444 | 445 | Listener.Setup.Expect.Never('Handler'); 446 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 447 | 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 448 | Listener.Verify; 449 | finally 450 | UnRegisterListener; 451 | end; 452 | end; 453 | 454 | procedure TbtkEventBusTest.Send_SingleHashedFilterIsEmptyOtherFiltersLikeInEvent_HandlerNotCalled; 455 | begin 456 | RegisterListener; 457 | try 458 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 459 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := EmptyStr; 460 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := 'NotHashedTestFilterValue'; 461 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := 'NotHashedTestFilter2Value'; 462 | 463 | Listener.Setup.Expect.Never('Handler'); 464 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 465 | 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 466 | Listener.Verify; 467 | finally 468 | UnRegisterListener; 469 | end; 470 | end; 471 | 472 | procedure TbtkEventBusTest.Send_NotHashedFiltersIsEmptyHashedFiltersLikeInEvent_HandlerCalled; 473 | begin 474 | RegisterListener; 475 | try 476 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 477 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := 'HashedTestFilterValue'; 478 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := EmptyStr; 479 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := EmptyStr; 480 | 481 | Listener.Setup.Expect.Once('Handler'); 482 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 483 | 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 484 | Listener.Verify; 485 | finally 486 | UnRegisterListener; 487 | end; 488 | end; 489 | 490 | procedure TbtkEventBusTest.Send_2HashedFiltersInListenerMatchFiltersInEvent2NotHashedFilterMismatchFiltersInEvent_HandlerNotCalled; 491 | begin 492 | RegisterListener; 493 | try 494 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 495 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := 'HashedTestFilterValue'; 496 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := '-NotHashedTestFilterValue'; 497 | ListenerInfo.HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := '-NotHashedTestFilter2Value'; 498 | 499 | Listener.Setup.Expect.Never('Handler'); 500 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 501 | 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 502 | Listener.Verify; 503 | finally 504 | UnRegisterListener; 505 | end; 506 | end; 507 | 508 | procedure TbtkEventBusTest.Send_HandlerContainParentClassOfEvent_HandlerCalled; 509 | begin 510 | RegisterListener; 511 | try 512 | Listener.Setup.Expect.Once('HandlerForParentClass'); 513 | EventBus.Send(TbtkTestEventObject.Create('', '', 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 514 | Listener.Verify; 515 | finally 516 | UnRegisterListener; 517 | end; 518 | end; 519 | 520 | procedure TbtkEventBusTest.Send_HookContainParentClassOfEvent_HookCalled; 521 | begin 522 | RegisterListener; 523 | try 524 | Listener.Setup.Expect.Once('HookForParentClass'); 525 | EventBus.Send(TbtkTestEventObject.Create('', '', '', '')); 526 | Listener.Verify; 527 | finally 528 | UnRegisterListener; 529 | end; 530 | end; 531 | 532 | procedure TbtkEventBusTest.Send_HandlerContainChildClassOfEvent_HandlerNotCalled; 533 | begin 534 | RegisterListener; 535 | try 536 | Listener.Setup.Expect.Never('Handler'); 537 | EventBus.Send(TbtkCustomTestEventObject.Create('', '', '')); 538 | Listener.Verify; 539 | finally 540 | UnRegisterListener; 541 | end; 542 | end; 543 | 544 | procedure TbtkEventBusTest.Send_HookContainChildClassOfEvent_HookNotCalled; 545 | begin 546 | RegisterListener; 547 | try 548 | Listener.Setup.Expect.Never('Hook'); 549 | EventBus.Send(TbtkCustomTestEventObject.Create('', '', '')); 550 | Listener.Verify; 551 | finally 552 | UnRegisterListener; 553 | end; 554 | end; 555 | 556 | procedure TbtkEventBusTest.Send_ExceptionWasRaisedInHandlerAndExceptionHandlerIsNotExist_WillNotRaiseAny; 557 | var 558 | fakeExceptionHandler: TMock; 559 | begin 560 | fakeExceptionHandler := TMock.Create; 561 | Application.OnException := fakeExceptionHandler.Instance.HandleException; 562 | RegisterListener; 563 | try 564 | Listener.Setup.WillRaise('Handler', Exception); 565 | 566 | Assert.WillNotRaiseAny( 567 | procedure 568 | begin 569 | EventBus.Send(TbtkTestEventObject.Create('', '', '', '')) 570 | end); 571 | finally 572 | UnRegisterListener; 573 | Application.OnException := nil; 574 | fakeExceptionHandler.Free; 575 | end; 576 | end; 577 | 578 | procedure TbtkEventBusTest.Send_ExceptionRaisedInHandlerAndNotExistExceptionHandler_ApplicationHandleExceptionCalled; 579 | var 580 | fakeExceptionHandler: TMock; 581 | begin 582 | fakeExceptionHandler := TMock.Create; 583 | Application.OnException := fakeExceptionHandler.Instance.HandleException; 584 | RegisterListener; 585 | try 586 | Listener.Setup.WillRaise('Handler', Exception); 587 | fakeExceptionHandler.Setup.Expect.Once('HandleException'); 588 | 589 | EventBus.Send(TbtkTestEventObject.Create('', '', '', '')); 590 | fakeExceptionHandler.Verify; 591 | finally 592 | UnRegisterListener; 593 | Application.OnException := nil; 594 | fakeExceptionHandler.Free; 595 | end; 596 | end; 597 | 598 | procedure TbtkEventBusTest.Send_ExceptionRaisedInHandlerAndExistExceptionHandler_ApplicationHandleExceptionNotCalled; 599 | var 600 | fakeExceptionHandler: TMock; 601 | begin 602 | fakeExceptionHandler := TMock.Create; 603 | Application.OnException := fakeExceptionHandler.Instance.HandleException; 604 | RegisterListener; 605 | try 606 | Listener.Setup.WillRaise('Handler', Exception); 607 | fakeExceptionHandler.Setup.Expect.Never('HandleException'); 608 | 609 | EventBus.Send(TbtkTestEventObject.Create('', '', '', ''), 610 | procedure(AException: Exception) 611 | begin 612 | 613 | end); 614 | fakeExceptionHandler.Verify; 615 | finally 616 | UnRegisterListener; 617 | Application.OnException := nil; 618 | fakeExceptionHandler.Free; 619 | end; 620 | end; 621 | 622 | procedure TbtkEventBusTest.Send_ExceptionRaisedInHandlerAndExistExceptionHandler_ExceptionHandlerCalled; 623 | var 624 | fakeExceptionHandler: TMock; 625 | calledExceptionHandler: Boolean; 626 | begin 627 | fakeExceptionHandler := TMock.Create; 628 | Application.OnException := fakeExceptionHandler.Instance.HandleException; 629 | RegisterListener; 630 | try 631 | Listener.Setup.WillRaise('Handler', Exception); 632 | fakeExceptionHandler.Setup.Expect.Never('HandleException'); 633 | 634 | calledExceptionHandler := False; 635 | EventBus.Send(TbtkTestEventObject.Create('', '', '', ''), 636 | procedure(AException: Exception) 637 | begin 638 | calledExceptionHandler := True; 639 | end); 640 | Assert.IsTrue(calledExceptionHandler); 641 | finally 642 | UnRegisterListener; 643 | Application.OnException := nil; 644 | fakeExceptionHandler.Free; 645 | end; 646 | end; 647 | 648 | procedure TbtkEventBusTest.Send_ExceptionWasRaisedInHandlerAndExceptionHandlerIsExist_ExceptionInExceptionHandlerIsOriginalException; 649 | var 650 | originalException: Exception; 651 | exceptionInExceptionHandlerIsOriginalException: Boolean; 652 | begin 653 | RegisterListener; 654 | try 655 | originalException := Exception.Create(''); 656 | Listener.Setup.WillExecute('Handler', 657 | function (const args : TArray; const ReturnType : TRttiType) : TValue 658 | begin 659 | raise originalException; 660 | end); 661 | 662 | exceptionInExceptionHandlerIsOriginalException := False; 663 | EventBus.Send(TbtkTestEventObject.Create('', '', '', ''), 664 | procedure(AException: Exception) 665 | begin 666 | exceptionInExceptionHandlerIsOriginalException := AException = originalException; 667 | end); 668 | 669 | Assert.IsTrue(exceptionInExceptionHandlerIsOriginalException); 670 | finally 671 | UnRegisterListener; 672 | end; 673 | end; 674 | 675 | procedure TbtkEventBusTest.Send_ExceptionWasRaisedInHandlerAndExceptionHandlerRaisedNothing_WillNotRaiseAny; 676 | begin 677 | RegisterListener; 678 | try 679 | Listener.Setup.WillRaise('Handler', Exception, ''); 680 | 681 | Assert.WillNotRaiseAny( 682 | procedure 683 | begin 684 | EventBus.Send(TbtkTestEventObject.Create('', '', '', ''), 685 | procedure(AException: Exception) 686 | begin 687 | //nothing 688 | end) 689 | end); 690 | 691 | finally 692 | UnRegisterListener; 693 | end; 694 | end; 695 | 696 | procedure TbtkEventBusTest.Send_ExceptionWasRaisedInHandlerAndExceptionHandlerRaisedAcquiredException_FinalExceptionIsOriginalException; 697 | var 698 | originalException: Exception; 699 | finalExceptionIsOriginalException: Boolean; 700 | begin 701 | RegisterListener; 702 | try 703 | originalException := Exception.Create(''); 704 | Listener.Setup.WillExecute('Handler', 705 | function (const args : TArray; const ReturnType : TRttiType) : TValue 706 | begin 707 | raise originalException; 708 | end); 709 | 710 | finalExceptionIsOriginalException := False; 711 | try 712 | EventBus.Send(TbtkTestEventObject.Create('', '', '', ''), 713 | procedure(AException: Exception) 714 | begin 715 | raise Exception(AcquireExceptionObject); 716 | end); 717 | except 718 | on E: Exception do 719 | finalExceptionIsOriginalException := E = originalException; 720 | end; 721 | 722 | Assert.IsTrue(finalExceptionIsOriginalException); 723 | finally 724 | UnRegisterListener; 725 | end; 726 | end; 727 | 728 | procedure TbtkEventBusTest.Send_ExceptionWasRaisedInHandlerAndExceptionHandlerRaisedOuterException_InnerExceptionOfFinalExceptionIsOriginalException; 729 | var 730 | originalException: Exception; 731 | innerExceptionOfFinalExceptionIsOriginalException: Boolean; 732 | begin 733 | RegisterListener; 734 | try 735 | originalException := Exception.Create(''); 736 | Listener.Setup.WillExecute('Handler', 737 | function (const args : TArray; const ReturnType : TRttiType) : TValue 738 | begin 739 | raise originalException; 740 | end); 741 | 742 | innerExceptionOfFinalExceptionIsOriginalException := False; 743 | try 744 | EventBus.Send(TbtkTestEventObject.Create('', '', '', ''), 745 | procedure(AException: Exception) 746 | begin 747 | Exception.RaiseOuterException(Exception.Create('OuterException')); 748 | end); 749 | except 750 | on E: Exception do 751 | innerExceptionOfFinalExceptionIsOriginalException := E.InnerException = originalException; 752 | end; 753 | 754 | Assert.IsTrue(innerExceptionOfFinalExceptionIsOriginalException); 755 | finally 756 | UnRegisterListener; 757 | end; 758 | end; 759 | 760 | procedure TbtkEventBusTest.Send_ExceptionRaisedInEachHooksAndHandlersRaisedAnException_AllHooksAndHandlersCalled; 761 | var 762 | fakeExceptionHandler: TMock; 763 | begin 764 | fakeExceptionHandler := TMock.Create; 765 | Application.OnException := fakeExceptionHandler.Instance.HandleException; 766 | RegisterListener; 767 | try 768 | Listener.Setup.WillRaise('Handler', Exception); 769 | Listener.Setup.WillRaise('HandlerForParentClass', Exception); 770 | Listener.Setup.WillRaise('Hook', Exception); 771 | Listener.Setup.WillRaise('HookForParentClass', Exception); 772 | Listener.Setup.Expect.Once('Handler'); 773 | Listener.Setup.Expect.Once('HandlerForParentClass'); 774 | Listener.Setup.Expect.Once('Hook'); 775 | Listener.Setup.Expect.Once('HookForParentClass'); 776 | fakeExceptionHandler.Setup.Expect.AtLeast('HandleException', 4); 777 | 778 | EventBus.Send(TbtkTestEventObject.Create('', '', '', '')); 779 | fakeExceptionHandler.Verify; 780 | finally 781 | UnRegisterListener; 782 | Application.OnException := nil; 783 | fakeExceptionHandler.Free; 784 | end; 785 | end; 786 | 787 | procedure TbtkEventBusTest.Send_1Event3Listeners_EachHandlerCalledOnce; 788 | var 789 | i: Integer; 790 | begin 791 | RegisterListeners; 792 | try 793 | for i := Low(Listeners) to High(Listeners) do 794 | begin 795 | ListenersInfo[i].HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 796 | ListenersInfo[i].HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventHashedTestFilterName].Value := 'HashedTestFilterValue'; 797 | ListenersInfo[i].HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilterName].Value := 'NotHashedTestFilterValue'; 798 | ListenersInfo[i].HandlerFilters[TbtkTestEventObject][TbtkTestEventObject.sEventNotHashedTestFilter2Name].Value := 'NotHashedTestFilter2Value'; 799 | Listeners[i].Setup.Expect.Once('Handler'); 800 | end; 801 | EventBus.Send(TbtkTestEventObject.Create('TopicValue', 'HashedTestFilterValue', 'NotHashedTestFilterValue', 'NotHashedTestFilter2Value')); 802 | for i := Low(Listeners) to High(Listeners) do 803 | Listeners[i].Verify; 804 | finally 805 | UnRegisterListeners; 806 | end; 807 | end; 808 | 809 | procedure TbtkEventBusTest.Send_HashedCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerNotCalled; 810 | begin 811 | RegisterListener; 812 | try 813 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 814 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventHashedCaseSensitiveTestFilterName].Value := 'HashedCaseSensitiveTestFilterValue'; 815 | 816 | Listener.Setup.Expect.Never('CaseSensitiveHandler'); 817 | EventBus.Send(TbtkCaseSensitiveTestEventObject.Create('TopicValue', 'hasheDcasEsensitivEtesTfilteRvaluE', '', '', '')); 818 | Listener.Verify; 819 | finally 820 | UnRegisterListener; 821 | end; 822 | end; 823 | 824 | procedure TbtkEventBusTest.Send_HashedNotCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerCalled; 825 | begin 826 | RegisterListener; 827 | try 828 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 829 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventHashedNotCaseSensitiveTestFilterName].Value := 'HashedNotCaseSensitiveTestFilterValue'; 830 | 831 | Listener.Setup.Expect.Once('CaseSensitiveHandler'); 832 | EventBus.Send(TbtkCaseSensitiveTestEventObject.Create('TopicValue', '', 'hasheDnoTcasEsensitivEtesTfilteRvaluE', '', '')); 833 | Listener.Verify; 834 | finally 835 | UnRegisterListener; 836 | end; 837 | end; 838 | 839 | procedure TbtkEventBusTest.Send_NotHashedCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerNotCalled; 840 | begin 841 | RegisterListener; 842 | try 843 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 844 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventNotHashedCaseSensitiveTestFilterName].Value := 'NotHashedCaseSensitiveTestFilterValue'; 845 | 846 | Listener.Setup.Expect.Never('CaseSensitiveHandler'); 847 | EventBus.Send(TbtkCaseSensitiveTestEventObject.Create('TopicValue', '', '', 'noThasheDcasEsensitivEtesTfilteRvaluE', '')); 848 | Listener.Verify; 849 | finally 850 | UnRegisterListener; 851 | end; 852 | end; 853 | 854 | procedure TbtkEventBusTest.Send_NotHashedNotCaseSensitiveFilterOfListenerDifferentCaseWithParametersOfEvent_HandlerCalled; 855 | begin 856 | RegisterListener; 857 | try 858 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventFilterTopicName].Value := 'TopicValue'; 859 | ListenerInfo.HandlerFilters[TbtkCaseSensitiveTestEventObject][TbtkCaseSensitiveTestEventObject.sEventNotHashedNotCaseSensitiveTestFilterName].Value := 'NotHashedNotCaseSensitiveTestFilterValue'; 860 | 861 | Listener.Setup.Expect.Once('CaseSensitiveHandler'); 862 | EventBus.Send(TbtkCaseSensitiveTestEventObject.Create('TopicValue', '', '', '', 'noThasheDnoTcasEsensitivEtesTfilteRvaluE')); 863 | Listener.Verify; 864 | finally 865 | UnRegisterListener; 866 | end; 867 | end; 868 | 869 | { TbtkEventFiltersTest } 870 | 871 | procedure TbtkEventFiltersTest.TryRequestEventFilter; 872 | begin 873 | EventFilters[TestFilterName]; 874 | end; 875 | 876 | procedure TbtkEventFiltersTest.Setup; 877 | var 878 | listenerInfo: TbtkListenerInfo; 879 | begin 880 | EventBus := TbtkEventBus.Create; 881 | Listener := TMock.Create; 882 | listenerInfo := EventBus.Register(Listener); 883 | EventFilters := listenerInfo.HandlerFilters[TbtkTestEventObject]; 884 | end; 885 | 886 | procedure TbtkEventFiltersTest.TearDown; 887 | begin 888 | EventBus.UnRegister(Listener); 889 | Listener.Free; 890 | EventBus := nil; 891 | end; 892 | 893 | procedure TbtkEventFiltersTest.Filters_FilterNameIsExist_WillNotRaise; 894 | begin 895 | TestFilterName := 'Topic'; 896 | Assert.WillNotRaise(TryRequestEventFilter); 897 | end; 898 | 899 | procedure TbtkEventFiltersTest.Filters_FilterNameIsExistButContainsOtherCharacterCase_WillNotRaise; 900 | begin 901 | TestFilterName := 'tOPiC'; 902 | Assert.WillNotRaise(TryRequestEventFilter); 903 | end; 904 | 905 | procedure TbtkEventFiltersTest.Filters_FilterNameIsNotExists_WillRaise; 906 | begin 907 | TestFilterName := '-Topic'; 908 | Assert.WillRaise(TryRequestEventFilter); 909 | end; 910 | 911 | initialization 912 | TDUnitX.RegisterTestFixture(TbtkEventBusTest); 913 | TDUnitX.RegisterTestFixture(TbtkEventFiltersTest); 914 | 915 | finalization 916 | 917 | end. 918 | -------------------------------------------------------------------------------- /Tests/DunitX.btkEventBus.dpr: -------------------------------------------------------------------------------- 1 | program DunitX.btkEventBus; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | {$R *.res} 6 | 7 | uses 8 | System.SysUtils, 9 | DUnitX.TestRunner, 10 | DUnitX.TestFramework, 11 | DUnitX.AutoDetect.Console, 12 | DUnitX.Loggers.Console, 13 | DUnitX.btkEventBusTest in 'DUnitX.btkEventBusTest.pas'; 14 | 15 | var 16 | runner : ITestRunner; 17 | logger : ITestLogger; 18 | 19 | begin 20 | try 21 | //Create the runner 22 | runner := TDUnitX.CreateRunner; 23 | runner.UseRTTI := True; 24 | 25 | //tell the runner how we will log things 26 | logger := TDUnitXConsoleLogger.Create(false); 27 | runner.AddLogger(logger); 28 | 29 | //Run tests 30 | runner.Execute; 31 | 32 | //We don't want this happening when running under CI. 33 | System.Write('Done.. press key to quit.'); 34 | System.Readln; 35 | except 36 | on E: Exception do 37 | Writeln(E.ClassName, ': ', E.Message); 38 | end; 39 | end. 40 | -------------------------------------------------------------------------------- /Tests/DunitX.btkEventBus.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {ACE7160B-BBCB-4DA3-AF89-3D3E52474C65} 4 | 14.4 5 | None 6 | DunitX.btkEventBus.dpr 7 | True 8 | Debug 9 | Win32 10 | 1 11 | Console 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Base 34 | true 35 | 36 | 37 | true 38 | Cfg_1 39 | true 40 | true 41 | 42 | 43 | true 44 | Base 45 | true 46 | 47 | 48 | true 49 | Cfg_2 50 | true 51 | true 52 | 53 | 54 | true 55 | Cfg_2 56 | true 57 | true 58 | 59 | 60 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 61 | 1049 62 | ..\Library\D17\$(Config);$(DCC_UnitSearchPath) 63 | None 64 | System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) 65 | .\Bin\D17\$(Config) 66 | .\Bin\D17\$(Config) 67 | false 68 | false 69 | false 70 | false 71 | false 72 | 73 | 74 | dac170;DBXInterBaseDriver;DataSnapServer;DataSnapCommon;DbxCommonDriver;dbxcds;CustomIPTransport;dsnap;IndyIPServer;IndyCore;bindcompfmx;oraprov170;dbrtl;bindcomp;inetdb;xmlrtl;ibxpress;bindengine;soaprtl;DBXInformixDriver;DBXFirebirdDriver;inet;DBXSybaseASADriver;dbexpress;IndyIPClient;DBXSqliteDriver;fmx;IndySystem;DataSnapClient;DataSnapProviderClient;DBXOracleDriver;fmxase;odac170;IndyIPCommon;inetdbxpress;rtl;DbxClientDriver;IndyProtocols;DBXMySQLDriver;bindcompdbx;fmxobj;fmxdae;DataSnapIndy10ServerTransport;$(DCC_UsePackage) 75 | $(BDS)\bin\delphi_PROJECTICNS.icns 76 | 77 | 78 | None 79 | 1033 80 | cxPivotGridChartRS17;JvGlobus;JvMM;dxSkinBlueprintRS17;dxSkinHighContrastRS17;JvManagedThreads;dxSkinSevenRS17;dxSkinOffice2007BlackRS17;dac170;dxCoreRS17;cxPageControldxBarPopupMenuRS17;dxSkinXmas2008BlueRS17;JvCrypt;dxSkinSummer2008RS17;dxSkinBlueRS17;dxSkinDarkRoomRS17;dxPScxSchedulerLnkRS17;DBXInterBaseDriver;DataSnapServer;DataSnapCommon;tmsscriptervcl_xe3;dxPScxTLLnkRS17;JvNet;officeXPrt;JvDotNetCtrls;tmsscripter_xe3;dxRibbonRS17;DbxCommonDriver;cxDataRS17;vclimg;xhStd170;dxSkinsdxBarPainterRS17;dbxcds;dxPSdxDBTVLnkRS17;DatasnapConnectorsFreePascal;frxIBX17;JvXPCtrls;dxSkinMoneyTwinsRS17;SyntEdit16;vcldb;cxExportRS17;dxPSCoreRS17;dxBarExtItemsRS17;dxGDIPlusRS17;dxNavBarRS17;xf40_d_xe2;CustomIPTransport;cxLibraryRS17;cxGridRS17;dxSkinOffice2010BlackRS17;dsnap;IndyIPServer;xhExport170;IndyCore;dxSkinMcSkinRS17;CloudService;dxPScxCommonRS17;dxSkiniMaginaryRS17;frxDB17;dxSkinsdxDLPainterRS17;JvDB;JvRuntimeDesign;dxPScxVGridLnkRS17;JclDeveloperTools;dxSkinSevenClassicRS17;dxPScxExtCommonRS17;odacvcl170;TeeGL917;dxPScxSSLnkRS17;dxSkinLilianRS17;fs17;dxSkinOffice2010BlueRS17;dxPSdxLCLnkRS17;frxTee17;bindcompfmx;dxSkinOffice2010SilverRS17;vcldbx;oraprov170;fsTee17;cxSchedulerGridRS17;dbrtl;bindcomp;inetdb;frxcs17;JvPluginSystem;dxBarRS17;DBXOdbcDriver;dxBarDBNavRS17;JvCmp;dxSkinWhiteprintRS17;JvTimeFramework;xmlrtl;dxSkinsdxRibbonPainterRS17;ibxpress;dxDockingRS17;vclactnband;bindengine;soaprtl;fsADO17;bindcompvcl;dxBarExtDBItemsRS17;dxSkinOffice2007PinkRS17;Jcl;vclie;frxADO17;dxPSPrVwRibbonRS17;cxPageControlRS17;DragDropDXE3;dxSkinscxPCPainterRS17;xhChart170;dxmdsRS17;dxSkinTheAsphaltWorldRS17;DBXInformixDriver;Intraweb;dxPsPrVwAdvRS17;dxSkinSilverRS17;dxdborRS17;dsnapcon;DBXFirebirdDriver;inet;fsDB17;JvPascalInterpreter;vclx;dclfrxTee17;dxSkinStardustRS17;cxEditorsRS17;DBXSybaseASADriver;crcontrols170;dbexpress;IndyIPClient;JvBDE;ecComnD16;dxSkinVS2010RS17;cxTreeListdxBarPopupMenuRS17;dxThemeRS17;DBXSqliteDriver;dxPScxGridLnkRS17;fmx;AutoCadPckg;JvDlgs;IndySystem;dxSkinValentineRS17;vclib;inetdbbde;DataSnapClient;dxSkinDevExpressStyleRS17;DataSnapProviderClient;DBXSybaseASEDriver;cxBarEditItemRS17;dxServerModeRS17;cxSchedulerRS17;MetropolisUILiveTile;dxSkinPumpkinRS17;fsBDE17;dxPSLnksRS17;TeeUI917;cxVerticalGridRS17;dxPSdxDBOCLnkRS17;dxSkinSpringTimeRS17;vcldsnap;dacvcl170;dxSkinDevExpressDarkStyleRS17;DBXDb2Driver;DBXOracleDriver;dxSkinLiquidSkyRS17;JvCore;vclribbon;TeeDB917;cxSpreadSheetRS17;fmxase;vcl;TeeLanguage917;odac170;dxSkinOffice2007SilverRS17;IndyIPCommon;DBXMSSQLDriver;dxPSdxOCLnkRS17;dcldxSkinsCoreRS17;JvAppFrm;fsIBX17;TeeWorld917;inetdbxpress;webdsnap;dxSkinCoffeeRS17;JvDocking;adortl;dxSkinscxSchedulerPainterRS17;TeeTree2D17Tee9;JvWizards;JvHMI;frx17;dxtrmdRS17;TeeMaker117;dxPScxPCProdRS17;frxDBX17;JvBands;rtl;DbxClientDriver;dxTabbedMDIRS17;xhCntrls170;dxComnRS17;dxSkinSharpPlusRS17;dxSkinsCoreRS17;dxSkinLondonLiquidSkyRS17;dxdbtrRS17;TeePro917;JvSystem;dxSkinBlackRS17;svnui;dxorgcRS17;JvControls;IndyProtocols;DBXMySQLDriver;dxLayoutControlRS17;bindcompdbx;JvJans;JvPrintPreview;JvPageComps;JvStdCtrls;JvCustom;dxSkinOffice2007BlueRS17;dxPScxPivotGridLnkRS17;dxSpellCheckerRS17;vcltouch;dxSkinOffice2007GreenRS17;dxSkinSharpRS17;websnap;dxSkinFoggyRS17;dxTileControlRS17;VclSmp;dxSkinDarkSideRS17;cxPivotGridRS17;DataSnapConnectors;fmxobj;cxTreeListRS17;JclVcl;dxSkinGlassOceansRS17;dxPSdxFCLnkRS17;frxe17;svn;dxFlowChartRS17;fmxdae;TeeImage917;dxSkinsdxNavBarPainterRS17;bdertl;frxBDE17;Tee917;dxDBXServerModeRS17;DataSnapIndy10ServerTransport;dxSkinCaramelRS17;$(DCC_UsePackage) 81 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 82 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 83 | 84 | 85 | cxPivotGridChartRS17;dxSkinBlueprintRS17;dxSkinHighContrastRS17;dxSkinSevenRS17;dxSkinOffice2007BlackRS17;dac170;dxCoreRS17;cxPageControldxBarPopupMenuRS17;dxSkinXmas2008BlueRS17;dxSkinSummer2008RS17;dxSkinBlueRS17;dxSkinDarkRoomRS17;dxPScxSchedulerLnkRS17;DBXInterBaseDriver;DataSnapServer;DataSnapCommon;dxPScxTLLnkRS17;officeXPrt;dxRibbonRS17;DbxCommonDriver;cxDataRS17;vclimg;dxSkinsdxBarPainterRS17;dbxcds;dxPSdxDBTVLnkRS17;DatasnapConnectorsFreePascal;dxSkinMoneyTwinsRS17;vcldb;cxExportRS17;dxPSCoreRS17;dxBarExtItemsRS17;dxGDIPlusRS17;dxNavBarRS17;CustomIPTransport;cxLibraryRS17;cxGridRS17;dxSkinOffice2010BlackRS17;dsnap;IndyIPServer;IndyCore;dxSkinMcSkinRS17;dxPScxCommonRS17;dxSkiniMaginaryRS17;dxSkinsdxDLPainterRS17;dxPScxVGridLnkRS17;dxSkinSevenClassicRS17;dxPScxExtCommonRS17;odacvcl170;dxPScxSSLnkRS17;dxSkinLilianRS17;dxSkinOffice2010BlueRS17;dxPSdxLCLnkRS17;bindcompfmx;dxSkinOffice2010SilverRS17;oraprov170;cxSchedulerGridRS17;dbrtl;bindcomp;inetdb;dxBarRS17;DBXOdbcDriver;dxBarDBNavRS17;dxSkinWhiteprintRS17;xmlrtl;dxSkinsdxRibbonPainterRS17;ibxpress;dxDockingRS17;vclactnband;bindengine;soaprtl;bindcompvcl;dxBarExtDBItemsRS17;dxSkinOffice2007PinkRS17;vclie;dxPSPrVwRibbonRS17;cxPageControlRS17;DragDropDXE3;dxSkinscxPCPainterRS17;dxmdsRS17;dxSkinTheAsphaltWorldRS17;DBXInformixDriver;dxPsPrVwAdvRS17;dxSkinSilverRS17;dxdborRS17;dsnapcon;DBXFirebirdDriver;inet;vclx;dxSkinStardustRS17;cxEditorsRS17;DBXSybaseASADriver;crcontrols170;dbexpress;IndyIPClient;dxSkinVS2010RS17;cxTreeListdxBarPopupMenuRS17;dxThemeRS17;DBXSqliteDriver;dxPScxGridLnkRS17;fmx;IndySystem;dxSkinValentineRS17;vclib;DataSnapClient;dxSkinDevExpressStyleRS17;DataSnapProviderClient;DBXSybaseASEDriver;cxBarEditItemRS17;dxServerModeRS17;cxSchedulerRS17;dxSkinPumpkinRS17;dxPSLnksRS17;cxVerticalGridRS17;dxPSdxDBOCLnkRS17;dxSkinSpringTimeRS17;vcldsnap;dacvcl170;dxSkinDevExpressDarkStyleRS17;DBXDb2Driver;DBXOracleDriver;dxSkinLiquidSkyRS17;cxSpreadSheetRS17;fmxase;vcl;odac170;dxSkinOffice2007SilverRS17;IndyIPCommon;DBXMSSQLDriver;dxPSdxOCLnkRS17;dcldxSkinsCoreRS17;inetdbxpress;webdsnap;dxSkinCoffeeRS17;adortl;dxSkinscxSchedulerPainterRS17;dxtrmdRS17;dxPScxPCProdRS17;rtl;DbxClientDriver;dxTabbedMDIRS17;dxComnRS17;dxSkinSharpPlusRS17;dxSkinsCoreRS17;dxSkinLondonLiquidSkyRS17;dxdbtrRS17;dxSkinBlackRS17;dxorgcRS17;IndyProtocols;DBXMySQLDriver;dxLayoutControlRS17;bindcompdbx;dxSkinOffice2007BlueRS17;dxPScxPivotGridLnkRS17;dxSpellCheckerRS17;vcltouch;dxSkinOffice2007GreenRS17;dxSkinSharpRS17;websnap;dxSkinFoggyRS17;dxTileControlRS17;VclSmp;dxSkinDarkSideRS17;cxPivotGridRS17;DataSnapConnectors;fmxobj;cxTreeListRS17;dxSkinGlassOceansRS17;dxPSdxFCLnkRS17;dxFlowChartRS17;fmxdae;dxSkinsdxNavBarPainterRS17;dxDBXServerModeRS17;DataSnapIndy10ServerTransport;dxSkinCaramelRS17;$(DCC_UsePackage) 86 | 87 | 88 | DEBUG;$(DCC_Define) 89 | true 90 | false 91 | true 92 | true 93 | true 94 | 95 | 96 | false 97 | true 98 | 1033 99 | false 100 | 101 | 102 | false 103 | RELEASE;$(DCC_Define) 104 | 0 105 | false 106 | 107 | 108 | $(BDS)\bin\delphi_PROJECTICNS.icns 109 | 110 | 111 | 1033 112 | 113 | 114 | 115 | MainSource 116 | 117 | 118 | 119 | Cfg_2 120 | Base 121 | 122 | 123 | Base 124 | 125 | 126 | Cfg_1 127 | Base 128 | 129 | 130 | 131 | Delphi.Personality.12 132 | 133 | 134 | 135 | 136 | False 137 | False 138 | 1 139 | 0 140 | 0 141 | 0 142 | False 143 | False 144 | False 145 | False 146 | False 147 | 1049 148 | 1251 149 | 150 | 151 | 152 | 153 | 1.0.0.0 154 | 155 | 156 | 157 | 158 | 159 | 1.0.0.0 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | DunitX.btkEventBus.dpr 172 | 173 | 174 | 175 | 176 | 177 | False 178 | True 179 | False 180 | 181 | 182 | 12 183 | 184 | 185 | 186 | 187 | -------------------------------------------------------------------------------- /Tests/DunitX.btkEventBus.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/global-system/DelphiEventBus/8d0850bae01fcc01a5b0dffce89a7dd7f19d2d19/Tests/DunitX.btkEventBus.res -------------------------------------------------------------------------------- /btkEventBusD17ProjectGroup.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {04C46F45-C321-4960-971B-A155134499F6} 4 | 5 | 6 | 7 | 8 | 9 | 10 | Packages\btkEventBusD17.dproj 11 | 12 | 13 | 14 | Default.Personality.12 15 | 16 | 17 | 18 | 19 | 20 | 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 | --------------------------------------------------------------------------------