Browse Source

* Fixes for Thread safety in by Eric Grange

Michaël Van Canneyt 1 month ago
parent
commit
70f521e6d0

+ 359 - 145
packages/vcl-compat/src/system.messaging.pp

@@ -19,6 +19,9 @@ unit System.Messaging;
 {$modeswitch functionreferences}
 {$modeswitch functionreferences}
 {$modeswitch advancedrecords}
 {$modeswitch advancedrecords}
 
 
+{.$DEFINE DEBUG_SYSTEM_MESSAGING}
+{.$DEFINE DECLARE_COMPATIBLEMANAGER}
+
 interface
 interface
 
 
 uses
 uses
@@ -86,6 +89,7 @@ type
   end;
   end;
 
 
 
 
+{$ifdef DECLARE_COMPATIBLEMANAGER}
   { TMessageManager }
   { TMessageManager }
   // Default, delphi compatible implementation
   // Default, delphi compatible implementation
 
 
@@ -154,6 +158,7 @@ type
     procedure SendMessage(const Sender: TObject; AMessage: TMessageBase; ADispose: Boolean); override;
     procedure SendMessage(const Sender: TObject; AMessage: TMessageBase; ADispose: Boolean); override;
   end;
   end;
   TMessageManagerClass = class of TMessageManager;
   TMessageManagerClass = class of TMessageManager;
+{$ENDIF DECLARE_COMPATIBLEMANAGER}
 
 
 { ---------------------------------------------------------------------
 { ---------------------------------------------------------------------
   TMessageClientList
   TMessageClientList
@@ -163,14 +168,20 @@ type
    // Used as default.
    // Used as default.
    // Set TBaseMessageManager.DefaultManagerClass if you want to change the default.
    // Set TBaseMessageManager.DefaultManagerClass if you want to change the default.
 
 
+  TMessageClientList = class;
+
   { TMessageClient }
   { TMessageClient }
 
 
-  TMessageClient = class (TCollectionItem)
-  Public
-    Disabled : boolean; // Unsubscribed but not yet deleted...
+  TMessageClient = class
+  Protected
+    Disabled : Boolean; // Unsubscribed but not yet deleted...
     ClientID : TMessageSubscriptionId;
     ClientID : TMessageSubscriptionId;
   Public
   Public
-    constructor Create(aCollection : TCollection; aClientID : TMessageSubscriptionId); overload;
+    constructor Create(aClientID : TMessageSubscriptionId);
+
+    function SameListener(const aListener: TMessageListener) : Boolean; virtual; abstract;
+    function SameListenerMethod(const aListenerMethod: TMessageListenerMethod) : Boolean; virtual; abstract;
+
     Procedure CallNotify(Sender : TObject; aMessage : TMessageBase); virtual; abstract;
     Procedure CallNotify(Sender : TObject; aMessage : TMessageBase); virtual; abstract;
   end;
   end;
 
 
@@ -182,7 +193,11 @@ type
   Protected
   Protected
     Property Listener : TMessageListener Read FListener;
     Property Listener : TMessageListener Read FListener;
   Public
   Public
-    constructor Create(aCollection : TCollection; aClientID : TMessageSubscriptionId; aListener: TMessageListener); overload;
+    constructor Create(aClientID : TMessageSubscriptionId; aListener: TMessageListener);
+
+    function SameListener(const aListener: TMessageListener) : Boolean; override;
+    function SameListenerMethod(const aListenerMethod: TMessageListenerMethod) : Boolean; override;
+
     Procedure CallNotify(Sender : TObject; aMessage : TMessageBase); override;
     Procedure CallNotify(Sender : TObject; aMessage : TMessageBase); override;
   end;
   end;
 
 
@@ -190,25 +205,60 @@ type
 
 
   TMessageListenerMethodClient = class(TMessageClient)
   TMessageListenerMethodClient = class(TMessageClient)
   Private
   Private
-    FListener: TMessageListenerMethod;
+    FListenerMethod: TMessageListenerMethod;
+    {$ifdef DEBUG_SYSTEM_MESSAGING}
+    FListenerClassname : shortstring;
+    {$endif}
   Protected
   Protected
-    Property Listener : TMessageListenerMethod Read FListener;
+    Property ListenerMethod : TMessageListenerMethod Read FListenerMethod;
   Public
   Public
-    constructor Create(aCollection : TCollection; aClientID : TMessageSubscriptionId; aListener: TMessageListenerMethod); overload;
+    constructor Create(aClientID : TMessageSubscriptionId; aListenerMethod: TMessageListenerMethod);
+
+    function SameListener(const aListener: TMessageListener) : Boolean; override;
+    function SameListenerMethod(const aListenerMethod: TMessageListenerMethod) : Boolean; override;
+
     Procedure CallNotify(Sender : TObject; aMessage : TMessageBase); override;
     Procedure CallNotify(Sender : TObject; aMessage : TMessageBase); override;
   end;
   end;
 
 
   { TMessageClientList }
   { TMessageClientList }
 
 
-  TMessageClientList = class(TCollection)
+  (*
+  List with a delayed released of its items
+
+  When an item is "removed" it's marked as Disabled and FDisabledCount is increased
+  When FDisabledCount goes above cRemoveDisabledTreshold the RemoveDisabled
+  method is triggered which performs the actual release & packs the internal list
+
+  Class isn't thread-safe and should be protected by message manager
+
+  *)
+  TMessageClientList = class
   private
   private
-    FBusy : Boolean;
-  Protected
-    Procedure Update(aItem: TCollectionItem); override;
-    procedure RemoveDisabled; virtual;
-    Property Busy : Boolean Read FBusy Write FBusy;
+    FItems : array of TMessageClient;
+    FCount : Integer;
+    FUpdateCount : Integer;
+    FDisabledCount : Integer;
+
+  protected
+    function GetItems(aIndex : Integer) : TMessageClient;
+    procedure AddClient(aClient : TMessageClient);
+
+    // Wait until at least that many items have been removed before packing
+    const cRemoveDisabledTreshold = 10;
+
+    procedure RemoveDisabled;
+
   public
   public
-    constructor Create(aItemClass : TCollectionItemClass);
+    constructor Create(aItemClass : TClass);
+    destructor Destroy; override;
+
+    // Use Begin/EndUpdate to protect a loop that's susceptible of triggering Remove
+    procedure BeginUpdate;
+    procedure EndUpdate;
+
+    property Items[aIndex : Integer] : TMessageClient read GetItems;
+    property Count : Integer read FCount;
+
     function Add(aId : Integer; const aListener: TMessageListener) : TMessageClient; virtual;
     function Add(aId : Integer; const aListener: TMessageListener) : TMessageClient; virtual;
     function Add(aId : Integer; const aListenerMethod: TMessageListenerMethod): TMessageClient; virtual;
     function Add(aId : Integer; const aListenerMethod: TMessageListenerMethod): TMessageClient; virtual;
     procedure NotifyClients(const Sender: TObject; const aMessage: TMessageBase);
     procedure NotifyClients(const Sender: TObject; const aMessage: TMessageBase);
@@ -216,62 +266,119 @@ type
     function IndexOf(const aClientID: TMessageSubscriptionId) : integer; virtual; overload;
     function IndexOf(const aClientID: TMessageSubscriptionId) : integer; virtual; overload;
     function IndexOf(const aListener: TMessageListener): integer; virtual; overload;
     function IndexOf(const aListener: TMessageListener): integer; virtual; overload;
     function IndexOf(const aListenerMethod: TMessageListenerMethod): integer; virtual; overload;
     function IndexOf(const aListenerMethod: TMessageListenerMethod): integer; virtual; overload;
+
     procedure Remove(aIndex : Integer);
     procedure Remove(aIndex : Integer);
+    procedure Clear;
   end;
   end;
 
 
   { TSimpleMessageManager }
   { TSimpleMessageManager }
 
 
   TSimpleMessageManager = class(TBaseMessageManager)
   TSimpleMessageManager = class(TBaseMessageManager)
   protected
   protected
-    Type
+    type
        TMessageClientListDict = specialize TObjectDictionary<TClass, TMessageClientList>;
        TMessageClientListDict = specialize TObjectDictionary<TClass, TMessageClientList>;
-  Private
+
+  private
     FMessageClients: TMessageClientListDict;
     FMessageClients: TMessageClientListDict;
-  Protected
+
+  protected
+    FLockCount : Integer;
+
     function CreateMessageTypeDict: TMessageClientListDict; virtual;
     function CreateMessageTypeDict: TMessageClientListDict; virtual;
     function CreateMessageClientList: TMessageClientList; virtual;
     function CreateMessageClientList: TMessageClientList; virtual;
-    Function GetList(const aMessageClass: TClass; Out aList : TMessageClientList) : Boolean;
-    Function GetOrCreateList(const aMessageClass: TClass) : TMessageClientList;
+    function GetList(const aMessageClass: TClass; out aList : TMessageClientList) : Boolean;
+    function GetOrCreateList(const aMessageClass: TClass) : TMessageClientList;
+
+    procedure Lock;
+    procedure UnLock;
+
   public
   public
     constructor Create; override;
     constructor Create; override;
     destructor Destroy; override;
     destructor Destroy; override;
+
     function SubscribeToMessage(const aMessageClass: TClass; const aListener: TMessageListener): TMessageSubscriptionId; override;
     function SubscribeToMessage(const aMessageClass: TClass; const aListener: TMessageListener): TMessageSubscriptionId; override;
     function SubscribeToMessage(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod): TMessageSubscriptionId; override;
     function SubscribeToMessage(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod): TMessageSubscriptionId; override;
+
     // Immediate not used, it will break during sending of message
     // Immediate not used, it will break during sending of message
     procedure Unsubscribe(const aMessageClass: TClass; SubscriptionId: TMessageSubscriptionId; Immediate: Boolean = False); override;
     procedure Unsubscribe(const aMessageClass: TClass; SubscriptionId: TMessageSubscriptionId; Immediate: Boolean = False); override;
     procedure Unsubscribe(const aMessageClass: TClass; const aListener: TMessageListener; Immediate: Boolean = False); override;
     procedure Unsubscribe(const aMessageClass: TClass; const aListener: TMessageListener; Immediate: Boolean = False); override;
     procedure Unsubscribe(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod; Immediate: Boolean = False); override;
     procedure Unsubscribe(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod; Immediate: Boolean = False); override;
+
     procedure SendMessage(const Sender: TObject; aMessage: TMessageBase; aDispose: Boolean); override;
     procedure SendMessage(const Sender: TObject; aMessage: TMessageBase; aDispose: Boolean); override;
   end;
   end;
 
 
+  {$ifndef DECLARE_COMPATIBLEMANAGER}
+  TMessageManager = class (TSimpleMessageManager) end;
+  {$endif}
+
 implementation
 implementation
 
 
+{$ifdef DEBUG_SYSTEM_MESSAGING}
+uses fresnel.wasm.api;
+{$endif}
+
+// SameMethode
+//
+function SameMethod(const aMethod1, aMethod2 : TMessageListenerMethod) : Boolean; inline;
+begin
+  Result :=     (TMethod(aMethod1).Code = TMethod(aMethod2).Code)
+            and (TMethod(aMethod1).Data = Tmethod(aMethod2).Data);
+end;
+
 { TMessageListenerMethodClient }
 { TMessageListenerMethodClient }
 
 
-constructor TMessageListenerMethodClient.Create(aCollection: TCollection;  aClientID: TMessageSubscriptionId; aListener: TMessageListenerMethod);
+constructor TMessageListenerMethodClient.Create(aClientID: TMessageSubscriptionId; aListenerMethod: TMessageListenerMethod);
 begin
 begin
-  Inherited Create(aCollection,aClientID);
-  FListener:=aListener;
+  inherited Create(aClientID);
+  FListenerMethod := aListenerMethod;
+  {$ifdef DEBUG_SYSTEM_MESSAGING}
+  FListenerClassname := TObject(TMethod(aListenerMethod).Data).ClassName;
+  {$endif}
 end;
 end;
 
 
-procedure TMessageListenerMethodClient.CallNotify(Sender: TObject;
-  aMessage: TMessageBase);
+function TMessageListenerMethodClient.SameListener(const aListener: TMessageListener): Boolean;
 begin
 begin
-  FListener(Sender,aMessage);
+  Result := False;
+end;
+
+function TMessageListenerMethodClient.SameListenerMethod(const aListenerMethod: TMessageListenerMethod): Boolean;
+begin
+  Result := SameMethod(aListenerMethod, FListenerMethod);
+end;
+
+procedure TMessageListenerMethodClient.CallNotify(Sender: TObject; aMessage: TMessageBase);
+begin
+  {$ifdef DEBUG_SYSTEM_MESSAGING}
+  if Disabled then
+  begin
+    __fresnel_console_log('TMessageListenerMethodClient.CallNotify DISABLED');
+    __fresnel_console_log(FListenerClassname);
+  end;
+  {$endif}
+  FListenerMethod(Sender, aMessage);
 end;
 end;
 
 
 { TMessageListenerClient }
 { TMessageListenerClient }
 
 
-constructor TMessageListenerClient.Create(aCollection: TCollection;
-  aClientID: TMessageSubscriptionId; aListener: TMessageListener);
+constructor TMessageListenerClient.Create(aClientID: TMessageSubscriptionId; aListener: TMessageListener);
+begin
+  inherited Create(aClientID);
+  FListener := aListener;
+end;
+
+function TMessageListenerClient.SameListener(const aListener: TMessageListener): Boolean;
 begin
 begin
-  Inherited Create(aCollection,aClientID);
-  FListener:=aListener;
+  Result := (aListener = FListener);
+end;
+
+function TMessageListenerClient.SameListenerMethod(const aListenerMethod: TMessageListenerMethod): Boolean;
+begin
+  Result := False;
 end;
 end;
 
 
 procedure TMessageListenerClient.CallNotify(Sender: TObject; aMessage: TMessageBase);
 procedure TMessageListenerClient.CallNotify(Sender: TObject; aMessage: TMessageBase);
 begin
 begin
-  FListener(Sender,aMessage);
+  FListener(Sender, aMessage);
 end;
 end;
 
 
 { TSimpleMessageManager }
 { TSimpleMessageManager }
@@ -309,12 +416,29 @@ end;
 function TSimpleMessageManager.GetOrCreateList(const aMessageClass: TClass): TMessageClientList;
 function TSimpleMessageManager.GetOrCreateList(const aMessageClass: TClass): TMessageClientList;
 
 
 begin
 begin
-  if GetList(aMessageClass,Result) then
-    exit;
-  Result:=CreateMessageClientList;
+  if GetList(aMessageClass, Result) then
+    Exit;
+
+  Result := CreateMessageClientList;
   FMessageClients.Add(AMessageClass, Result);
   FMessageClients.Add(AMessageClass, Result);
 end;
 end;
 
 
+procedure TSimpleMessageManager.Lock;
+begin
+  {$ifdef DEBUG_SYSTEM_MESSAGING}
+  if FLockCount > 0 then
+    __fresnel_console_log('ALREADY LOCKED');
+  {$endif}
+  TMonitor.Enter(Self);
+  Inc(FLockCount);
+end;
+
+procedure TSimpleMessageManager.UnLock;
+begin
+  Dec(FLockCount);
+  TMonitor.Exit(Self);
+end;
+
 
 
 function TSimpleMessageManager.SubscribeToMessage(const aMessageClass: TClass; const aListener: TMessageListener) : TMessageSubscriptionId;
 function TSimpleMessageManager.SubscribeToMessage(const aMessageClass: TClass; const aListener: TMessageListener) : TMessageSubscriptionId;
 
 
@@ -322,20 +446,29 @@ var
   Clients: TMessageClientList;
   Clients: TMessageClientList;
 
 
 begin
 begin
-  Clients:=GetOrCreateList(aMessageClass);
-  Result:=GenerateClientID;
-  Clients.Add(Result,AListener);
+  Lock;
+  try
+    Clients:=GetOrCreateList(aMessageClass);
+    Result:=GenerateClientID;
+    Clients.Add(Result,AListener);
+  finally
+    UnLock;
+  end;
 end;
 end;
 
 
 function TSimpleMessageManager.SubscribeToMessage(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod): TMessageSubscriptionId;
 function TSimpleMessageManager.SubscribeToMessage(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod): TMessageSubscriptionId;
 
 
 var
 var
   Clients: TMessageClientList;
   Clients: TMessageClientList;
-
 begin
 begin
-  Clients:=GetOrCreateList(aMessageClass);
-  Result:=GenerateClientID;
-  Clients.Add(Result,AListenerMethod);
+  Lock;
+  try
+    Clients:=GetOrCreateList(aMessageClass);
+    Result:=GenerateClientID;
+    Clients.Add(Result,AListenerMethod);
+  finally
+    UnLock;
+  end;
 end;
 end;
 
 
 procedure TSimpleMessageManager.Unsubscribe(const aMessageClass: TClass; const aListener: TMessageListener; Immediate: Boolean);
 procedure TSimpleMessageManager.Unsubscribe(const aMessageClass: TClass; const aListener: TMessageListener; Immediate: Boolean);
@@ -345,11 +478,16 @@ var
   Idx : Integer;
   Idx : Integer;
 
 
 begin
 begin
-  if Not FMessageClients.TryGetValue(aMessageClass,Clients) then
-    exit;
-  Idx:=Clients.IndexOf(aListener);
-  if Idx<>-1 then
-    Clients.Remove(Idx);
+  Lock;
+  try
+    if Not FMessageClients.TryGetValue(aMessageClass,Clients) then
+      exit;
+    Idx:=Clients.IndexOf(aListener);
+    if Idx >= 0 then
+      Clients.Remove(Idx);
+  finally
+    UnLock;
+  end;
 end;
 end;
 
 
 procedure TSimpleMessageManager.Unsubscribe(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod; Immediate: Boolean);
 procedure TSimpleMessageManager.Unsubscribe(const aMessageClass: TClass; const aListenerMethod: TMessageListenerMethod; Immediate: Boolean);
@@ -357,13 +495,24 @@ procedure TSimpleMessageManager.Unsubscribe(const aMessageClass: TClass; const a
 var
 var
   Clients : TMessageClientList;
   Clients : TMessageClientList;
   Idx : Integer;
   Idx : Integer;
-
 begin
 begin
-  if Not FMessageClients.TryGetValue(aMessageClass,Clients) then
-    exit;
-  Idx:=Clients.IndexOf(aListenerMethod);
-  if Idx<>-1 then
-    Clients.Remove(Idx);
+  Lock;
+  try
+    if not FMessageClients.TryGetValue(aMessageClass,Clients) then
+      Exit;
+
+    Idx:=Clients.IndexOf(aListenerMethod);
+    if Idx >= 0 then
+      Clients.Remove(Idx)
+    else
+    begin
+      {$ifdef DEBUG_SYSTEM_MESSAGING}
+      __fresnel_console_log('TSimpleMessageManager.Unsubscribe NOT FOUND for ' + aMessageClass.ClassName);
+      {$endif}
+    end;
+  finally
+    UnLock;
+  end;
 end;
 end;
 
 
 procedure TSimpleMessageManager.Unsubscribe(const aMessageClass: TClass; SubscriptionId: TMessageSubscriptionId; Immediate: Boolean);
 procedure TSimpleMessageManager.Unsubscribe(const aMessageClass: TClass; SubscriptionId: TMessageSubscriptionId; Immediate: Boolean);
@@ -372,10 +521,16 @@ var
   Idx : Integer;
   Idx : Integer;
 
 
 begin
 begin
-  if Not FMessageClients.TryGetValue(aMessageClass,Clients) then
-    exit;
-  Idx:=Clients.IndexOf(SubscriptionId);
-  Clients.Remove(Idx);
+  Lock;
+  try
+     if Not FMessageClients.TryGetValue(aMessageClass,Clients) then
+       exit;
+     Idx:=Clients.IndexOf(SubscriptionId);
+     if Idx >= 0 then
+       Clients.Remove(Idx);
+  finally
+    UnLock;
+  end;
 end;
 end;
 
 
 procedure TSimpleMessageManager.SendMessage(const Sender: TObject;
 procedure TSimpleMessageManager.SendMessage(const Sender: TObject;
@@ -385,111 +540,122 @@ var
   Clients: TMessageClientList;
   Clients: TMessageClientList;
 begin
 begin
   if (AMessage=nil) then exit;
   if (AMessage=nil) then exit;
+
+  Lock;
   try
   try
-    if not GetList(aMessage.ClassType,Clients) then
-      exit;
-    Clients.NotifyClients(Sender,AMessage);
+    try
+      if GetList(aMessage.ClassType, Clients) then
+        Clients.NotifyClients(Sender, aMessage);
+    finally
+      if ADispose then
+        AMessage.Free;
+    end;
   finally
   finally
-    if ADispose then
-      AMessage.Free;
+    UnLock;
   end;
   end;
 end;
 end;
 
 
 { TClientList }
 { TClientList }
 
 
-procedure TMessageClientList.Update(aItem: TCollectionItem);
+constructor TMessageClientList.Create(aItemClass : TClass);
 begin
 begin
-  inherited Update(aItem);
-  if (aItem=Nil) and not Busy then
-    RemoveDisabled;
+  Inherited Create;
+  Assert(aItemClass.InheritsFrom(TMessageClient));  // for backward compatibility
 end;
 end;
 
 
-constructor TMessageClientList.Create(aItemClass : TCollectionItemClass);
+destructor TMessageClientList.Destroy;
 begin
 begin
-  Inherited Create(aItemClass);
+  Clear;
+  inherited Destroy;
 end;
 end;
 
 
-function TMessageClientList.Add(aId: Integer; const aListener: TMessageListener ): TMessageClient;
+procedure TMessageClientList.BeginUpdate;
+begin
+  Inc(FUpdateCount);
+end;
 
 
+procedure TMessageClientList.EndUpdate;
 begin
 begin
-  FBusy:=True;// Prevent cleaning
-  try
-    Result:=TMessageListenerClient.Create(Self,aId,aListener);
-  finally
-    FBusy:=False;
+  Dec(FUpdateCount);
+  if FUpdateCount <= 0 then
+  begin
+    if FUpdateCount < 0 then
+      raise EListError.Create('TMessageClientList.EndUpdate unbalanced');
+    if FDisabledCount > cRemoveDisabledTreshold then
+      RemoveDisabled;
   end;
   end;
 end;
 end;
 
 
-function TMessageClientList.Add(aId: Integer; const aListenerMethod: TMessageListenerMethod): TMessageClient;
-
+function TMessageClientList.Add(aId: Integer; const aListener: TMessageListener ): TMessageClient;
 begin
 begin
-  FBusy:=True;// Prevent cleaning
-  try
-    Result:=TMessageListenerMethodClient.Create(Self,aID,aListenerMethod);
-  finally
-    FBusy:=False;
-  end;
+  Result := TMessageListenerClient.Create(aId, aListener);
+  AddClient(Result);
 end;
 end;
 
 
-procedure TMessageClientList.NotifyClients(const Sender: TObject;
-  const aMessage: TMessageBase);
+function TMessageClientList.Add(aId: Integer; const aListenerMethod: TMessageListenerMethod): TMessageClient;
+begin
+  Result:=TMessageListenerMethodClient.Create(aID, aListenerMethod);
+  AddClient(Result);
+end;
 
 
+procedure TMessageClientList.NotifyClients(const Sender: TObject; const aMessage: TMessageBase);
 var
 var
-  Listener: TMessageClient;
-  I : integer;
-
+  lMessageClient: TMessageClient;
+  i : Integer;
 begin
 begin
   BeginUpdate;
   BeginUpdate;
   try
   try
-    for I:=0 to Count-1 do
-      begin
-      Listener:=TMessageClient(Items[I]);
-      if Not Listener.Disabled then
-        Listener.CallNotify(Sender, AMessage)
-      end;
+    for i:=0 to Count-1 do
+    begin
+      lMessageClient := FItems[i];
+      if not lMessageClient.Disabled then
+        lMessageClient.CallNotify(Sender, AMessage)
+    end;
   finally
   finally
     EndUpdate;
     EndUpdate;
   end;
   end;
 end;
 end;
 
 
 function TMessageClientList.IndexOf(const aClientID: TMessageSubscriptionId): integer;
 function TMessageClientList.IndexOf(const aClientID: TMessageSubscriptionId): integer;
+var
+  i : Integer;
+  lItem : TMessageClient;
 begin
 begin
-  Result:=Count-1;
-  While (Result>=0) and (TMessageClient(Items[Result]).ClientID<>aClientID) do
-    Dec(Result);
+  for i := 0 to Count-1 do
+  begin
+    lItem := Items[i];
+    if (not lItem.Disabled) and (lItem.ClientID = aClientID) then
+      Exit(i);
+  end;
+  Result := -1;
 end;
 end;
 
 
 function TMessageClientList.IndexOf(const aListener: TMessageListener): integer;
 function TMessageClientList.IndexOf(const aListener: TMessageListener): integer;
-
-  Function IsMatch(C : TMessageClient) : Boolean;
-
-  var
-    L : TMessageListenerClient absolute C;
-
+var
+  i : Integer;
+  lItem : TMessageClient;
+begin
+  for i := 0 to Count-1 do
   begin
   begin
-    Result:=(C is TMessageListenerClient) and (L.Listener=aListener);
+    lItem := Items[i];
+    if (not lItem.Disabled) and lItem.SameListener(aListener) then
+      Exit(i);
   end;
   end;
-
-begin
-  Result:=Count-1;
-  While (Result>=0) and Not IsMatch(TMessageClient(Items[Result])) do
-    Dec(Result);
+  Result := -1;
 end;
 end;
 
 
 function TMessageClientList.IndexOf(const aListenerMethod: TMessageListenerMethod): integer;
 function TMessageClientList.IndexOf(const aListenerMethod: TMessageListenerMethod): integer;
-  Function IsMatch(C : TMessageClient) : Boolean;
-
-  var
-    L : TMessageListenerMethodClient absolute C;
-
+var
+  i : Integer;
+  lItem : TMessageClient;
+begin
+  for i := 0 to Count-1 do
   begin
   begin
-    Result:=(C is TMessageListenerMethodClient) and (L.Listener=aListenerMethod);
+    lItem := Items[i];
+    if (not lItem.Disabled) and lItem.SameListenerMethod(aListenerMethod) then
+      Exit(i);
   end;
   end;
-
-begin
-  Result:=Count-1;
-  While (Result>=0) and Not IsMatch(TMessageClient(Items[Result])) do
-    Dec(Result);
+  Result := -1;
 end;
 end;
 
 
 procedure TMessageClientList.Remove(aIndex: Integer);
 procedure TMessageClientList.Remove(aIndex: Integer);
@@ -501,44 +667,94 @@ procedure TMessageClientList.Remove(aIndex: Integer);
   This can change the indexes in the list if done incorrectly.
   This can change the indexes in the list if done incorrectly.
 
 
   So we can only delete when all messages have been processed.
   So we can only delete when all messages have been processed.
-  We use the standard TCollection Begin/EndUdpate mechansim for this.
 }
 }
 
 
 begin
 begin
-  if (aIndex<0) or (aIndex>=Count) then exit;
+  if Cardinal(aIndex) >= Cardinal(Count) then
+    raise ERangeError.CreateFmt('TMessageClientList.Remove invalid index (%d)', [ aIndex ]);
+
+  // Begin/EnUpdate is here to "less delay" the delayed release
+  // not sure if it's worth it, can probably be dropped
   BeginUpdate;
   BeginUpdate;
   try
   try
-    TMessageClient(Items[aIndex]).Disabled:=True;
+    if FItems[aIndex].Disabled then
+      raise EListError.CreateFmt('TMessageClientList.Remove already removed (%d)', [ aIndex ]);
+    FItems[aIndex].Disabled := True;
+    Inc(FDisabledCount);
   finally
   finally
     EndUpdate;
     EndUpdate;
   end;
   end;
 end;
 end;
 
 
-procedure TMessageClientList.RemoveDisabled;
+procedure TMessageClientList.Clear;
+var
+  i : Integer;
+begin
+  if FUpdateCount > 0 then
+    raise Exception.Create('TMessageClientList.Clear while an update is ongoing (NOT supported yet)');
+
+  for i := 0 to Count-1 do
+    FreeAndNil(FItems[i]);
+  SetLength(FItems, 0);
+  FDisabledCount := 0;
+end;
+
+function TMessageClientList.GetItems(aIndex: Integer): TMessageClient;
+begin
+  Result := FItems[aIndex];
+end;
 
 
+procedure TMessageClientList.AddClient(aClient: TMessageClient);
 var
 var
-  I : Integer;
+  lCapacity : Integer;
+begin
+  lCapacity := Length(FItems);
+  if Count = lCapacity then
+  begin
+    lCapacity := lCapacity + (lCapacity shr 2) + 8;
+    SetLength(FItems, lCapacity);
+  end;
+
+  FItems[FCount] := aClient;
+  Inc(FCount);
+end;
 
 
+procedure TMessageClientList.RemoveDisabled;
+var
+  iSrc, iDest : Integer;
 begin
 begin
-  FBusy:=True;
-  BeginUpdate;
-  try
-    for I:=Count-1 downto 0 do
-      if TMessageClient(Items[I]).Disabled then
-        Delete(I);
-  finally
-    EndUpdate;
-    FBusy:=False;
+  if FUpdateCount > 0 then
+    raise Exception.Create('TMessageClientList.RemoveDisabled while an update is ongoing');
+
+  iDest := 0;
+  for iSrc := 0 to Count-1 do
+  begin
+    if FItems[iSrc].Disabled then
+    begin
+      FreeAndNil(FItems[iSrc]);
+      Dec(FCount);
+      Dec(FDisabledCount);
+    end
+    else
+    begin
+      if iSrc <> iDest then
+        FItems[iDest] := FItems[iSrc];
+      Inc(iDest);
+    end;
+  end;
+
+  // if less 25% used, relinquish 50%
+  if iDest < (Length(FItems) shr 2) then
+  begin
+    SetLength(FItems, Length(FItems) shr 1);
   end;
   end;
 end;
 end;
 
 
 { TClient }
 { TClient }
 
 
-
-constructor TMessageClient.Create(aCollection: TCollection; aClientID: TMessageSubscriptionId);
+constructor TMessageClient.Create(aClientID: TMessageSubscriptionId);
 begin
 begin
-  Disabled:=False; // Safety: set before inherited, make sure cleanup does not happen.
-  Inherited Create(aCollection);
+  inherited Create;
   ClientID:=aClientID;
   ClientID:=aClientID;
 end;
 end;
 
 
@@ -578,6 +794,8 @@ begin
   SendMessage(Sender,aMessage,True);
   SendMessage(Sender,aMessage,True);
 end;
 end;
 
 
+{$ifdef DECLARE_COMPATIBLEMANAGER}
+
 { TMessageManager.TListenerWithId }
 { TMessageManager.TListenerWithId }
 
 
 constructor TMessageManager.TListenerWithId.Create(const aId: TMessageSubscriptionId; const aListenerMethod: TMessageListenerMethod);
 constructor TMessageManager.TListenerWithId.Create(const aId: TMessageSubscriptionId; const aListenerMethod: TMessageListenerMethod);
@@ -605,12 +823,8 @@ begin
 end;
 end;
 
 
 function TMessageManager.TListenerWithId.Matches(aListener: TMessageListenerMethod): Boolean;
 function TMessageManager.TListenerWithId.Matches(aListener: TMessageListenerMethod): Boolean;
-Var
-  M1,M2 : TMethod;
 begin
 begin
-  M1:=TMethod(aListener);
-  M2:=TMethod(ListenerMethod);
-  Result:=(M1.Code=M2.Code) and (M2.Data=M2.Data);
+  Result := SameMethod(aListener, ListenerMethod);
 end;
 end;
 
 
 procedure TMessageManager.TListenerWithId.MarkAsRemoved;
 procedure TMessageManager.TListenerWithId.MarkAsRemoved;
@@ -711,7 +925,7 @@ begin
   Idx:=FList.Count-1;
   Idx:=FList.Count-1;
   While (Idx>=0) and not FList[Idx].Matches(Index) do
   While (Idx>=0) and not FList[Idx].Matches(Index) do
     Dec(Idx);
     Dec(Idx);
-  If Idx>0 then
+  If Idx >= 0 then
     DoUnsubscribe(Idx);
     DoUnsubscribe(Idx);
 end;
 end;
 
 
@@ -724,7 +938,7 @@ begin
   Idx:=FList.Count-1;
   Idx:=FList.Count-1;
   While (Idx>=0) and not FList[Idx].Matches(aListener) do
   While (Idx>=0) and not FList[Idx].Matches(aListener) do
     Dec(Idx);
     Dec(Idx);
-  If Idx>0 then
+  If Idx >= 0 then
     DoUnsubscribe(Idx);
     DoUnsubscribe(Idx);
 end;
 end;
 
 
@@ -736,7 +950,7 @@ begin
   Idx:=FList.Count-1;
   Idx:=FList.Count-1;
   While (Idx>=0) and not FList[Idx].Matches(aListener) do
   While (Idx>=0) and not FList[Idx].Matches(aListener) do
     Dec(Idx);
     Dec(Idx);
-  If Idx>0 then
+  If Idx >= 0 then
     DoUnsubscribe(Idx);
     DoUnsubscribe(Idx);
 end;
 end;
 
 
@@ -868,6 +1082,7 @@ begin
   end
   end
 end;
 end;
 
 
+{$endif DECLARE_COMPATIBLEMANAGER}
 
 
 constructor TMessage.Create(const aValue: T);
 constructor TMessage.Create(const aValue: T);
 begin
 begin
@@ -894,6 +1109,5 @@ begin
   inherited Destroy;
   inherited Destroy;
 end;
 end;
 
 
-
 end.
 end.
 
 

+ 1 - 0
packages/vcl-compat/tests/testcompat.lpi

@@ -39,6 +39,7 @@
       <Unit>
       <Unit>
         <Filename Value="utmessagemanager.pp"/>
         <Filename Value="utmessagemanager.pp"/>
         <IsPartOfProject Value="True"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="utMessageManager"/>
       </Unit>
       </Unit>
       <Unit>
       <Unit>
         <Filename Value="utcdevices.pas"/>
         <Filename Value="utcdevices.pas"/>

+ 1 - 0
packages/vcl-compat/tests/testcompat.lpr

@@ -4,6 +4,7 @@ program testcompat;
 
 
 uses
 uses
   {$IFDEF UNIX}cwstring, cthreads,{$ENDIF}
   {$IFDEF UNIX}cwstring, cthreads,{$ENDIF}
+  fpmonitor,
   Classes, consoletestrunner, tcnetencoding, tciotuils, 
   Classes, consoletestrunner, tcnetencoding, tciotuils, 
   utmessagemanager, utcdevices, utcanalytics, utcimagelist, 
   utmessagemanager, utcdevices, utcanalytics, utcimagelist, 
   utcnotifications, utcjson, utcpush, utchash, utcregex, 
   utcnotifications, utcjson, utcpush, utchash, utcregex,