* Add delphi-compatible observers to classes

rtl/amicommon/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/atari/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/beos/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/embedded/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/freertos/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/gba/classes.pp

@@ -16,6 +16,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/haiku/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/macos/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/msdos/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/nativent/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/nds/classes.pp

@@ -16,6 +16,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/netware/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/netwlibc/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/objpas/classes/classes.inc

@@ -65,6 +65,9 @@ var
 { TStrings and TStringList implementations }
 {$i stringl.inc}
 
+{ ObservableMemberAttribute, TObservers and TObserverMapping}
+{$i observer.inc}
+
 { TThread implementation }
 
 { system independend threading code }

rtl/objpas/classes/classesh.inc

@@ -189,15 +189,289 @@ Type
   end;
 {$INTERFACES COM}
 
+{ ---------------------------------------------------------------------
+  Delphi Observer support
+  ---------------------------------------------------------------------}
+
+  TComponent = Class;
+  TStringList = Class;
+
   EObserver = Class(Exception);
 
+  IObserver = interface;
+{$IFDEF FPC_HAS_REFERENCE_PROCEDURE}
+  TObserverToggleEvent = reference to procedure(const aObserver: IObserver; const aValue: Boolean);
+{$ELSE}
+  TObserverToggleEvent = procedure(const aObserver: IObserver; const aValue: Boolean) of object;
+{$ENDIF}
+
+  IObserver = interface
+    ['{B03253D8-7720-4B68-B10A-E3E79B91ECD3}']
+    procedure Removed;
+    function GetActive: Boolean;
+    procedure SetActive(Value: Boolean);
+    function GetOnObserverToggle: TObserverToggleEvent;
+    procedure SetOnObserverToggle(aEvent: TObserverToggleEvent);
+    property OnObserverToggle: TObserverToggleEvent read GetOnObserverToggle write SetOnObserverToggle;
+    property Active: Boolean read GetActive write SetActive;
+  end;
+
+  ISingleCastObserver = interface(IObserver)
+    ['{D0395F17-52AA-4515-93A5-5B292F03AA7B}']
+  end;
+
+  IMultiCastObserver = interface(IObserver)
+    ['{C19CB01E-1233-4405-8A30-7987DF2C3690}']
+  end;
+
+  IEditFormatLink = interface
+    ['{D1CE0112-FA41-4922-A9F1-D4641C02AA05}']
+    function GetDisplayName: string;
+    function GetDisplayWidth: Integer;
+    function GetDisplayTextWidth: Integer;
+    function GetReadOnly: Boolean;
+    function GetVisible: Boolean;
+    function GetCurrency: Boolean;
+    function GetEditMask: string;
+    function GetAlignment: TAlignment;
+    function GetMaxLength: Integer;
+    property DisplayName: string read GetDisplayName;
+    property DisplayWidth: Integer read GetDisplayWidth;
+    property DisplayTextWidth: Integer read GetDisplayTextWidth;
+    property ReadOnly: Boolean read GetReadOnly;
+    property Visible: Boolean read GetVisible;
+    property Currency: Boolean read GetCurrency;
+    property EditMask: string read GetEditMask;
+    property Alignment: TAlignment read GetAlignment;
+    property MaxLength: Integer read GetMaxLength;
+  end;
+
+  IEditLinkObserver = interface(ISingleCastObserver)
+    ['{E88C2705-7C5A-4E66-9B81-447D05D5E640}']
+    procedure Update;
+    function Edit: Boolean;
+    procedure Reset;
+    procedure Modified;
+    function IsModified: Boolean;
+    function IsValidChar(aKey: Char): Boolean;
+    function IsRequired: Boolean;
+    function GetIsReadOnly: Boolean;
+    procedure SetIsReadOnly(Value: Boolean);
+    property IsReadOnly: Boolean read GetIsReadOnly write SetIsReadOnly;
+    function GetIsEditing: Boolean;
+    property IsEditing: Boolean read GetIsEditing;
+    procedure BeginUpdate;
+    procedure EndUpdate;
+    function GetUpdating: Boolean;
+    property Updating: Boolean read GetUpdating;
+    function GetFormatLink: IEditFormatLink;
+    property FormatLink: IEditFormatLink read GetFormatLink;
+  end;
+
+{$IFDEF FPC_HAS_REFERENCE_PROCEDURE}
+  TObserverGetCurrentEvent = reference to function: TVarRec;
+{$ELSE}
+  TObserverGetCurrentEvent = function: TVarRec of object;
+{$ENDIF}
+
+  IEditGridLinkObserver = interface(IEditLinkObserver)
+    ['{A911B648-E1E5-4EEC-9FEE-D8E62FFA0E71}']
+    function GetCurrent: TVarRec;
+    property Current: TVarRec read GetCurrent;
+    function GetOnObserverCurrent: TObserverGetCurrentEvent;
+    procedure SetOnObserverCurrent(aEvent: TObserverGetCurrentEvent);
+    property OnObserverCurrent: TObserverGetCurrentEvent read GetOnObserverCurrent write SetOnObserverCurrent;
+  end;
+
+  IPositionLinkObserver170 = interface
+    ['{FA45CF0C-E8DB-4F9E-B53F-E072C94659F6}']
+    procedure PosChanged;
+  end;
+
+  IPositionLinkObserver = interface(IPositionLinkObserver170)
+    ['{E78B0035-6802-447C-A80A-0AEC04AD851F}']
+    procedure PosChanging;
+  end;
+
+   IControlValueObserver = interface
+    ['{61DAC12C-B950-43CA-86B5-43D8E78012E8}']
+    procedure ValueModified;
+    procedure ValueUpdate;
+  end;
+
+  // May be implemented by EditLink or ControlValue observer
+  IObserverTrack = interface
+    ['{8B9F22C3-FDA3-45FD-99E1-5A88481A9F95}']
+    function GetTrack: Boolean;
+    property Track: Boolean read GetTrack;
+  end;
+
+  IIteratorLinkObserver = interface
+    ['{8429848A-4447-4211-93D2-745543C7AB57}']
+    procedure StartFrom(aPosition: Integer);
+    function MoveNext: Boolean;
+    procedure UpdateControlComponent(aControl: TComponent);
+    procedure Finish;
+  end;
+
+
+  { TObservers }
+  TIInterfaceArray = Array of IInterface;
+
+  TObservers = class
+  public type
+{$IFDEF FPC_HAS_REFERENCE_PROCEDURE}
+    TCanObserveEvent = reference to function(const aID: Integer): Boolean;
+    TObserverAddedEvent = reference to procedure(const aID: Integer; const aObserver: IObserver);
+{$ELSE}
+    TCanObserveEvent = function(const aID: Integer): Boolean of object;
+    TObserverAddedEvent = procedure(const aID: Integer; const aObserver: IObserver) of object;
+{$ENDIF}
+  private type
+
+    { TIDArray }
+
+    TIDArray = record
+      ID : Integer;
+      List : Array of IInterface;
+      Count : Integer;
+      Procedure Add(const aInterface : IInterface);
+      Procedure Remove(const aInterface : IInterface);
+      Function GetActive: IObserver;
+      Function GetSingleCast : ISingleCastObserver;
+    end;
+    PIDArray = ^TIDArray;
+
+    { TIDArrayList }
+
+    TIDArrayList = record
+      List : Array of TIDArray;
+      Count : Integer;
+      Function IndexOfID(aId : Integer) : Integer;
+      Function AddID(aId : Integer) : Integer;
+      Procedure AddInterface(aID : integer; aInterFace : IInterface);
+      Function GetIDArray(aIdx : Integer) : PIDArray;
+      Function GetIDArrayFromID(aId : Integer) : PIDArray;
+    end;
+  private
+    FList : TIDArrayList;
+    FCanObserve: TCanObserveEvent;
+    FObserverAdded: TObserverAddedEvent;
+  public
+    property OnCanObserve: TCanObserveEvent read FCanObserve write FCanObserve;
+    property OnObserverAdded: TObserverAddedEvent read FObserverAdded write FObserverAdded;
+
+    function CanObserve(const aID: Integer): Boolean; overload; virtual;
+    procedure AddObserver(const aID: Integer; const aIntf: IInterface); overload; virtual;
+    procedure AddObserver(const aIDs: Array of Integer; const aIntf: IInterface); overload; virtual;
+    procedure RemoveObserver(const aID: Integer; const aIntf: IInterface); overload; virtual;
+    procedure RemoveObserver(const aIDs: Array of Integer; const aIntf: IInterface); overload; virtual;
+    function IsObserving(const aID: Integer): Boolean; overload; virtual;
+    function TryIsObserving(const aID: Integer; out aIntf: IInterface): Boolean; virtual;
+    function GetSingleCastObserver(const aID: Integer): IInterface; virtual;
+    function GetMultiCastObserverArray(const aID: Integer) : TIInterfaceArray; virtual;
+  end;
+
+  { TLinkObservers }
+
+  TLinkObservers = class
+  protected
+    class function CheckObserving(const aObservers: TObservers; aID: Integer): Integer;
+  public
+    class function GetEditGridLink(const aObservers: TObservers): IEditGridLinkObserver; static;
+    class function GetEditLink(const aObservers: TObservers): IEditLinkObserver; static;
+    class procedure EditLinkUpdate(const aObservers: TObservers); static; inline;
+    class function EditLinkTrackUpdate(const aObservers: TObservers): Boolean; static;
+    class procedure EditLinkReset(const aObservers: TObservers); static; inline;
+    class procedure EditLinkModified(aObservers: TObservers); static; inline;
+    class function EditLinkIsModified(const aObservers: TObservers): Boolean; static; inline;
+    class function EditLinkIsValidChar(const aObservers: TObservers; aKey: Char): Boolean; static; inline;
+    class function EditLinkIsEditing(const aObservers: TObservers): Boolean; static; inline;
+    class function EditLinkEdit(const aObservers: TObservers): Boolean; static; inline;
+    class procedure EditLinkSetIsReadOnly(const aObservers: TObservers; AValue: Boolean); static; inline;
+    class function EditLinkIsReadOnly(const aObservers: TObservers): Boolean; static; inline;
+
+    class procedure EditGridLinkUpdate(const aObservers: TObservers); static; inline;
+    class procedure EditGridLinkReset(const aObservers: TObservers); static; inline;
+    class procedure EditGridLinkModified(const aObservers: TObservers); static; inline;
+    class function EditGridLinkIsModified(const aObservers: TObservers): Boolean; static; inline;
+    class function EditGridLinkIsValidChar(const aObservers: TObservers; aKey: Char): Boolean; static; inline;
+    class function EditGridLinkIsEditing(const aObservers: TObservers): Boolean; static; inline;
+    class function EditGridLinkEdit(const aObservers: TObservers): Boolean; static; inline;
+    class function EditGridLinkIsReadOnly(const aObservers: TObservers): Boolean; static; inline;
+    class procedure EditGridLinkSetIsReadOnly(const aObservers: TObservers; aValue: Boolean); static; inline;
+
+    class procedure PositionLinkPosChanged(const aObservers: TObservers); static;
+    class procedure PositionLinkPosChanging(const aObservers: TObservers); static;
+    class procedure ListSelectionChanged(const aObservers: TObservers); static;
+    class procedure ControlValueUpdate(aObservers: TObservers); static;
+    class procedure ControlValueModified(aObservers: TObservers); static;
+    class function ControlValueTrackUpdate(const aObservers: TObservers): Boolean; static;
+
+    class function AllowControlChange(const aObservers: TObservers): Boolean; static;
+    class procedure ControlChanged(const aObservers: TObservers); static;
+
+    class function AllowControlChange(const aControl: TComponent): Boolean; static;
+    class procedure ControlChanged(const aControl: TComponent); static;
+    class procedure IteratorLinkUpdateControlComponent(const aObservers: TObservers; aControl: TComponent); static;
+
+    class procedure IteratorLinkStartFrom(const aObservers: TObservers; aPosition: Integer); static;
+    class function IteratorLinkMoveNext(const aObservers: TObservers): Boolean; static;
+    class procedure IteratorLinkFinish(const aObservers: TObservers); static;
+  end;
+
+  { TObserverMapping }
+
+  TObserverMapping = class (Tobject)
+  private
+    FList: TStringList;
+  class var
+    _Instance: TObserverMapping;
+  protected
+    class property Instance: TObserverMapping read _instance;
+  protected
+    Property List : TStringList Read FList;
+  public const
+    EditLinkID = 1;
+    EditGridLinkID = 2;
+    PositionLinkID = 3;
+    ControlValueID = 4;
+    IteratorLinkID = 5;
+    MappedID = 100;
+  private
+    const MinPublicID = MappedID+1;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    class constructor Init;
+    class destructor Done;
+    class function GetObserverID(const aKey: string): Integer;
+    class procedure Clear;
+  end;
+
+  EObserverException = class(Exception);
+
+  ObservableMemberAttribute = class(TCustomAttribute)
+  strict protected
+    FMemberName: String;
+    FFramework: string;
+    FTrack: Boolean;
+  public
+    constructor Create(const aMemberName, aFramework: string; aTrack: Boolean); overload;
+    constructor Create(const aMemberName: string; aTrack: Boolean); overload;
+    constructor Create(const aMemberName: string); overload;
+    property MemberName: String read FMemberName;
+    property Framework: string read FFramework;
+    property Track: Boolean read FTrack;
+  end;
+
+
 { Forward class declarations }
 
   TStream = class;
   TFiler = class;
   TReader = class;
   TWriter = class;
-  TComponent = class;
 
 { TFPList class }
 
@@ -804,8 +1078,6 @@ type
 
 { TStringList class }
 
-  TStringList = class;
-
   TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
 
 {$IFNDEF FPC_TESTGENERICS}
@@ -2119,10 +2391,12 @@ type
     FDesignInfo: Longint;
     FVCLComObject: Pointer;
     FComponentState: TComponentState;
+    FDObservers : TObservers;
     function GetComObject: IUnknown;
     function GetComponent(AIndex: Integer): TComponent;
     function GetComponentCount: Integer;
     function GetComponentIndex: Integer;
+    function GetObservers: TObservers;
     procedure Insert(AComponent: TComponent);
     procedure ReadLeft(Reader: TReader);
     procedure ReadTop(Reader: TReader);
@@ -2210,6 +2484,7 @@ type
     property DesignInfo: Longint read FDesignInfo write FDesignInfo;
     property Owner: TComponent read FOwner;
     property VCLComObject: Pointer read FVCLComObject write FVCLComObject;
+    Property Observers : TObservers Read GetObservers;
   published
     property Name: TComponentName read FName write SetName stored False;
     property Tag: PtrInt read FTag write FTag default 0;

rtl/objpas/classes/compon.inc

@@ -105,6 +105,13 @@ begin
     Result:=-1;
 end;
 
+function TComponent.GetObservers: TObservers;
+begin
+  if FDObservers=Nil then
+    FDObservers:=TObservers.Create;
+  Result:=FDObservers;
+end;
+
 
 Procedure TComponent.Insert(AComponent: TComponent);
 
@@ -472,6 +479,7 @@ Var
 
 begin
   Destroying;
+  FreeAndNil(FObservers);
   If Assigned(FFreeNotifies) then
     begin
     I:=FFreeNotifies.Count-1;

rtl/objpas/classes/observer.inc

@@ -0,0 +1,655 @@
+{ TObservers }
+
+function TObservers.CanObserve(const aID: Integer): Boolean;
+begin
+  Result:=Assigned(FCanObserve) and FCanObserve(aID);
+end;
+
+procedure TObservers.AddObserver(const aID: Integer; const aIntf: IInterface);
+
+var
+  I : integer;
+  P : PIDArray;
+  O : IObserver;
+  E : IEditLinkObserver;
+
+begin
+  if not Supports(aIntf,IObserver,O) then
+    raise EObserverException.Create(SErrNotIObserverInterface);
+  if not CanObserve(aID) then
+    raise EObserverException.Create(SErrUnsupportedObserver);
+  P:=FList.GetIDArrayFromID(aId);
+  if P=Nil then
+    FList.AddInterface(aID,aIntf)
+  else
+    begin
+    if not Supports(aIntf,ISingleCastObserver) then
+      P^.Add(aIntf)
+    else
+      begin
+      if Supports(aIntf,IEditLinkObserver,E) and Not E.IsReadOnly then
+        begin
+        // There can be only one editing link observer.
+        For I:=0 to P^.Count-1 do
+          if Supports(P^.List[I],IEditLinkObserver,E) then
+            if not E.IsReadOnly then
+              Raise EObserverException.Create(SErrOnlyOneEditingObserverAllowed)
+        end;
+      P^.Add(aIntf)
+      end;
+    end;
+  if Assigned(FObserverAdded) then
+   FObserverAdded(aId,O);
+end;
+
+procedure TObservers.AddObserver(const aIDs: array of Integer; const aIntf: IInterface);
+
+var
+  aID : integer;
+
+begin
+  for aID in aIDs do
+    AddObserver(aId,aIntf);
+end;
+
+procedure TObservers.RemoveObserver(const aID: Integer; const aIntf: IInterface);
+
+var
+  P : PIDArray;
+
+begin
+  P:=FList.GetIDArrayFromID(aID);
+  if P=Nil then
+    exit;
+  P^.Remove(aIntf);
+end;
+
+procedure TObservers.RemoveObserver(const aIDs: array of Integer; const aIntf: IInterface);
+
+var
+  aID : integer;
+
+begin
+  for aID in aIDs do
+    RemoveObserver(aId,aIntf);
+end;
+
+function TObservers.IsObserving(const aID: Integer): Boolean;
+
+var
+  O : IInterface;
+
+begin
+  Result:=TryIsObserving(aID,O);
+end;
+
+function TObservers.TryIsObserving(const aID: Integer; out aIntf: IInterface): Boolean;
+
+var
+  P : PIDArray;
+
+begin
+  aIntf:=Nil;
+  Result:=False;
+  P:=FList.GetIDArrayFromID(aID);
+  if P=Nil then
+    exit;
+  aIntf:=P^.GetActive;
+  Result:=aIntf<>Nil;
+end;
+
+function TObservers.GetSingleCastObserver(const aID: Integer): IInterface;
+
+var
+  P : PIDArray;
+
+begin
+  Result:=Nil;
+  P:=FList.GetIDArrayFromID(aID);
+  if P<>Nil then
+    Result:=P^.GetSingleCast;
+  if Result=Nil then
+    raise EObserverException.CreateFmt(SErrObserverNoSinglecast, [aID]);
+end;
+
+function TObservers.GetMultiCastObserverArray(const aID: Integer): TIInterfaceArray;
+
+var
+  aCount, I : Integer;
+  P : PIDArray;
+  O : IObserver;
+
+begin
+  Result:=[];
+  P:=FList.GetIDArrayFromId(aId);
+  if P=Nil then
+    exit;
+  SetLength(Result,P^.Count);
+  aCount:=0;
+  for I:=0 to P^.Count-1 do
+    if Supports(P^.List[I],IMultiCastObserver,O) then
+      if O.Active then
+        begin
+        Result[aCount]:=O;
+        Inc(aCount);
+        end;
+  SetLength(Result,aCount);
+  if aCount=0 then
+    raise EObserverException.CreateFmt(SerrObserverNoMulticastFound, [aID]);
+end;
+
+{ TObservers.TIDArray }
+
+procedure TObservers.TIDArray.Add(const aInterface: IInterface);
+begin
+  if Count=Length(List) then
+    SetLength(List,Count+10);
+  List[Count]:=aInterface;
+  Inc(Count);
+end;
+
+procedure TObservers.TIDArray.Remove(const aInterface: IInterface);
+
+var
+  I : Integer;
+
+begin
+  I:=Count-1;
+  While (I>=0) and (List[i]<>aInterface) do
+    Dec(I);
+  if (I>=0) then
+    List[i]:=Nil;
+end;
+
+function TObservers.TIDArray.GetActive: IObserver;
+
+var
+  I : integer;
+
+begin
+  Result:=Nil;
+  I:=Count-1;
+  While (Result=Nil) and (I>=0) do
+    begin
+    if Supports(List[I],IObserver,Result) then
+      if Not Result.Active then
+        Result:=nil;
+    Dec(I);
+    end;
+end;
+
+function TObservers.TIDArray.GetSingleCast: ISingleCastObserver;
+
+var
+  I : Integer;
+  E : IEditLinkObserver;
+
+begin
+  Result:=Nil;
+  I:=Count-1;
+  While (Result=Nil) and (I>=0) do
+    begin
+    Result:=nil;
+    if Supports(List[I],ISingleCastObserver,Result) then
+      begin
+      if Not (Result.Active
+              and Supports(Result,IEditLinkObserver,E)
+              and not E.IsReadOnly) then
+        Result:=nil;
+      end;
+    Dec(I);
+    end;
+end;
+
+{ TObservers.TIDArrayList }
+
+function TObservers.TIDArrayList.IndexOfID(aId: Integer): Integer;
+begin
+  Result:=Count-1;
+  While (Result>=0) and (List[Result].ID<>aID) do
+    Dec(Result);
+end;
+
+function TObservers.TIDArrayList.AddID(aId: Integer): Integer;
+begin
+  if Count=Length(List) then
+    SetLength(List,Count+10);
+  List[Count].ID:=aID;
+  Result:=Count;
+  Inc(Count);
+end;
+
+procedure TObservers.TIDArrayList.AddInterface(aID: integer;
+  aInterFace: IInterface);
+
+var
+  Idx : Integer;
+  P : PIDarray;
+
+begin
+  Idx:=AddID(aID);
+  P:=GetIDArray(Idx);
+  P^.Add(aInterface);
+end;
+
+function TObservers.TIDArrayList.GetIDArray(aIdx: Integer): PIDArray;
+begin
+  Result:=@List[aIdx];
+end;
+
+function TObservers.TIDArrayList.GetIDArrayFromID(aId: Integer): PIDArray;
+
+var
+  Idx : Integer;
+
+begin
+  Result:=Nil;
+  Idx:=IndexOfID(aId);
+  if Idx<>-1 then
+    Result:=GetIDArray(Idx);
+end;
+
+{ TLinkObservers }
+
+class function TLinkObservers.CheckObserving(const aObservers: TObservers; aID : Integer) : Integer;
+
+begin
+  Result:=aID;
+  if Not aObservers.IsObserving(aID) then
+    raise EObserverException.CreateFmt(SErrObserverNotAvailable,[aID]);
+end;
+
+class function TLinkObservers.GetEditGridLink(const aObservers: TObservers): IEditGridLinkObserver;
+
+var
+  aId: Integer;
+
+begin
+  aId:=CheckObserving(aObservers, TObserverMapping.EditGridLinkID);
+  Result:=aObservers.GetSingleCastObserver(aID) as IEditGridLinkObserver;
+end;
+
+class function TLinkObservers.GetEditLink(const aObservers: TObservers): IEditLinkObserver;
+
+var
+  aId: Integer;
+
+begin
+  aId:=CheckObserving(aObservers,TObserverMapping.EditLinkID);
+  Result:=aObservers.GetSingleCastObserver(aID) as IEditLinkObserver;
+end;
+
+class procedure TLinkObservers.EditLinkUpdate(const aObservers: TObservers);
+begin
+  GetEditLink(AObservers).Update;
+end;
+
+class function TLinkObservers.EditLinkTrackUpdate(const aObservers: TObservers): Boolean;
+
+var
+  E : IEditLinkObserver;
+  T : IObserverTrack;
+
+begin
+  Result:=False;
+  E:=GetEditLink(aObservers);
+  if Supports(E,IObserverTrack,T) then
+    if T.Track then
+      begin
+      Result:=true;
+      E.Update;
+      end;
+end;
+
+class procedure TLinkObservers.EditLinkReset(const aObservers: TObservers);
+begin
+  GetEditLink(AObservers).Reset;
+end;
+
+class procedure TLinkObservers.EditLinkModified(aObservers: TObservers);
+begin
+  GetEditLink(aObservers).Modified;
+end;
+
+class function TLinkObservers.EditLinkIsModified(const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditLink(aObservers).IsModified;
+end;
+
+class function TLinkObservers.EditLinkIsValidChar(const aObservers: TObservers; aKey: Char): Boolean;
+begin
+  Result:=GetEditLink(aObservers).IsValidChar(aKey);
+end;
+
+class function TLinkObservers.EditLinkIsEditing(const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditLink(aObservers).IsEditing;
+end;
+
+class function TLinkObservers.EditLinkEdit(const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditLink(aObservers).Edit;
+end;
+
+class procedure TLinkObservers.EditLinkSetIsReadOnly(const aObservers: TObservers; AValue: Boolean);
+begin
+  GetEditLink(aObservers).IsReadOnly:=aValue;
+end;
+
+class function TLinkObservers.EditLinkIsReadOnly(const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditLink(aObservers).IsReadOnly;
+end;
+
+class procedure TLinkObservers.EditGridLinkUpdate(const aObservers: TObservers);
+begin
+  GetEditGridLink(aObservers).Update;
+end;
+
+class procedure TLinkObservers.EditGridLinkReset(const aObservers: TObservers);
+begin
+  GetEditGridLink(aObservers).Reset;
+end;
+
+class procedure TLinkObservers.EditGridLinkModified(const aObservers: TObservers
+  );
+begin
+  GetEditGridLink(aObservers).Modified;
+end;
+
+class function TLinkObservers.EditGridLinkIsModified(const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditGridLink(aObservers).IsModified;
+end;
+
+class function TLinkObservers.EditGridLinkIsValidChar(const aObservers: TObservers; aKey: Char): Boolean;
+begin
+  Result:=GetEditGridLink(aObservers).IsValidChar(aKey);
+end;
+
+class function TLinkObservers.EditGridLinkIsEditing(const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditGridLink(aObservers).IsEditing
+end;
+
+class function TLinkObservers.EditGridLinkEdit(const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditGridLink(aObservers).Edit;
+end;
+
+class function TLinkObservers.EditGridLinkIsReadOnly(
+  const aObservers: TObservers): Boolean;
+begin
+  Result:=GetEditGridLink(aObservers).IsReadOnly;
+end;
+
+class procedure TLinkObservers.EditGridLinkSetIsReadOnly(const aObservers: TObservers; aValue: Boolean);
+
+begin
+  GetEditGridLink(aObservers).IsReadOnly:=aValue
+end;
+
+class procedure TLinkObservers.PositionLinkPosChanged(const aObservers: TObservers);
+
+var
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+  PL: IPositionLinkObserver;
+  PL170: IPositionLinkObserver170;
+
+begin
+  if Not aObservers.IsObserving(TObserverMapping.PositionLinkID) then
+    Exit;
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.PositionLinkID);
+  for Intf in IntfArray do
+    begin
+    if Supports(Intf,IPositionLinkObserver,PL) then
+      PL.PosChanged;
+    if Supports(Intf,IPositionLinkObserver170,PL170) then
+      PL.PosChanged;
+    end;
+end;
+
+class procedure TLinkObservers.PositionLinkPosChanging(const aObservers: TObservers);
+var
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+  PL: IPositionLinkObserver;
+  PL170: IPositionLinkObserver170;
+
+begin
+  if Not aObservers.IsObserving(TObserverMapping.PositionLinkID) then
+    Exit;
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.PositionLinkID);
+  for Intf in IntfArray do
+    begin
+    if Supports(Intf,IPositionLinkObserver,PL) then
+      PL.PosChanging;
+    if Supports(Intf,IPositionLinkObserver170,PL170) then
+      PL.PosChanging;
+    end;
+end;
+
+class procedure TLinkObservers.ListSelectionChanged(const aObservers: TObservers);
+
+begin
+  if AObservers.IsObserving(TObserverMapping.EditLinkID) then
+    if not TLinkObservers.EditLinkIsEditing(aObservers) then
+      EditLinkReset(AObservers)
+    else
+      begin
+      EditLinkModified(aObservers);
+      EditLinkTrackUpdate(aObservers);
+      PositionLinkPosChanged(aObservers);
+      end;
+  if aObservers.IsObserving(TObserverMapping.ControlValueID) then
+    begin
+    ControlValueModified(aObservers);
+    ControlValueTrackUpdate(aObservers);
+    end;
+  if aObservers.IsObserving(TObserverMapping.PositionLinkID) then
+    PositionLinkPosChanged(aObservers);
+end;
+
+class procedure TLinkObservers.ControlValueUpdate(aObservers: TObservers);
+
+var
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+  O: IControlValueObserver;
+
+begin
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.ControlValueID);
+  for Intf in IntfArray do
+    if Supports(Intf,IControlValueObserver,O) then
+      O.ValueUpdate;
+end;
+
+class procedure TLinkObservers.ControlValueModified(aObservers: TObservers);
+
+var
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+  O: IControlValueObserver;
+
+begin
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.ControlValueID);
+  for Intf in IntfArray do
+    if Supports(Intf,IControlValueObserver,O) then
+      O.ValueModified;
+end;
+
+class function TLinkObservers.ControlValueTrackUpdate(const aObservers: TObservers): Boolean;
+var
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+  O: IControlValueObserver;
+  T : IObserverTrack;
+
+begin
+  Result:=False;
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.ControlValueID);
+  for Intf in IntfArray do
+    if Supports(Intf,IControlValueObserver,O)
+       And Supports(O,IObserverTrack,T) then
+         if T.Track then
+           begin
+           Result:=true;
+           O.ValueUpdate;
+           end;
+
+end;
+
+class function TLinkObservers.AllowControlChange(const aObservers: TObservers): Boolean;
+
+begin
+  if aObservers.IsObserving(TObserverMapping.EditLinkID) then
+    Result:=TLinkObservers.EditLinkEdit(aObservers)
+  else
+    Result := True;
+end;
+
+class procedure TLinkObservers.ControlChanged(const aObservers: TObservers);
+
+begin
+  if (aObservers.IsObserving(TObserverMapping.EditLinkID))
+     and EditLinkEdit(aObservers) then
+    begin
+    EditLinkModified(aObservers);
+    EditLinkUpdate(aObservers);
+    end;
+  if aObservers.IsObserving(TObserverMapping.ControlValueID) then
+    begin
+    ControlValueModified(aObservers);
+    ControlValueUpdate(aObservers);
+    end;
+  if aObservers.IsObserving(TObserverMapping.PositionLinkID) then
+    PositionLinkPosChanged(aObservers);
+end;
+
+class function TLinkObservers.AllowControlChange(const aControl: TComponent): Boolean;
+begin
+  AllowControlChange(aControl.Observers);
+end;
+
+class procedure TLinkObservers.ControlChanged(const aControl: TComponent);
+begin
+  ControlChanged(aControl.Observers);
+end;
+
+class procedure TLinkObservers.IteratorLinkUpdateControlComponent(const aObservers: TObservers; aControl: TComponent);
+var
+  O : IIteratorLinkObserver;
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+
+begin
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.IteratorLinkID);
+  for Intf in IntfArray do
+    if Supports(Intf,IIteratorLinkObserver,O) then
+      O.UpdateControlComponent(aControl);
+end;
+
+class procedure TLinkObservers.IteratorLinkStartFrom(const aObservers: TObservers; aPosition: Integer);
+
+var
+  O : IIteratorLinkObserver;
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+
+begin
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.IteratorLinkID);
+  for Intf in IntfArray do
+    if Supports(Intf,IIteratorLinkObserver,O) then
+      O.StartFrom(aPosition);
+end;
+
+class function TLinkObservers.IteratorLinkMoveNext(const aObservers: TObservers): Boolean;
+
+var
+  O : IIteratorLinkObserver;
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+
+begin
+  Result:=false;
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.IteratorLinkID);
+  for Intf in IntfArray do
+    if Supports(Intf,IIteratorLinkObserver,O) then
+      Result:=Result or O.MoveNext;
+end;
+
+class procedure TLinkObservers.IteratorLinkFinish(const aObservers: TObservers);
+
+var
+  O : IIteratorLinkObserver;
+  IntfArray : TIInterfaceArray;
+  Intf : IInterface;
+
+begin
+  IntfArray:=aObservers.GetMultiCastObserverArray(TObserverMapping.IteratorLinkID);
+  for Intf in IntfArray do
+    if Supports(Intf,IIteratorLinkObserver,O) then
+      O.Finish;
+end;
+
+{ TObserverMapping }
+
+
+constructor TObserverMapping.Create;
+begin
+  FList:=TStringList.Create;
+  // Don't use sorted, as it will change the IDs as more records are added
+end;
+
+destructor TObserverMapping.Destroy;
+begin
+  FreeAndNil(FList);
+  inherited Destroy;
+end;
+
+class constructor TObserverMapping.Init;
+begin
+  _Instance:=TObserverMapping.Create;
+end;
+
+class destructor TObserverMapping.Done;
+begin
+  FreeAndNil(_Instance)
+end;
+
+class function TObserverMapping.GetObserverID(const aKey: string): Integer;
+begin
+  Result:=Instance.List.Indexof(aKey);
+  if Result=-1 then
+    Result:=Instance.List.Add(aKey);
+  Result:=Result+MinPublicID;
+end;
+
+class procedure TObserverMapping.Clear;
+begin
+  Instance.List.Clear;
+end;
+
+constructor ObservableMemberAttribute.Create(const aMemberName, aFramework: string; aTrack: Boolean);
+begin
+  inherited Create;
+  FFramework := AFramework;
+  FMemberName := AMemberName;
+  FTrack := ATrack;
+end;
+
+constructor ObservableMemberAttribute.Create(const aMemberName: string; aTrack: Boolean);
+begin
+  inherited Create;
+  FMemberName := AMemberName;
+  FTrack := ATrack;
+end;
+
+constructor ObservableMemberAttribute.Create(const aMemberName: string);
+begin
+  inherited Create;
+  FMemberName := AMemberName;
+end;
+
+

rtl/objpas/rtlconst.inc

@@ -580,6 +580,14 @@ ResourceString
   sCannotManuallyConstructDevice = 'Manual construction of TDeviceInfo is not supported'; 
   SArgumentOutOfRange = 'Argument out of range';
 
+  { Classes observer support }
+  SErrNotIObserverInterface = 'Interface is not an IObserver interface';
+  SErrUnsupportedObserver = 'Observer type not supported';
+  SErrOnlyOneEditingObserverAllowed = 'Only one editing link observer is allowed';
+  SErrObserverNoSinglecast = 'No singlecast observer interface found';
+  SerrObserverNoMulticastFound = 'No multicast observer interface (%d) found';
+  SErrObserverNotAvailable = 'Observer type (%d) not available';
+
 implementation
 
 end.

rtl/os2/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/sinclairql/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/symbian/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/unix/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$h+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/wasi/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/watcom/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/wii/classes.pp

@@ -16,6 +16,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/win16/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/win32/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/win64/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}

rtl/wince/classes.pp

@@ -15,6 +15,7 @@
 
 {$mode objfpc}
 {$H+}
+{$modeswitch advancedrecords}
 {$IF FPC_FULLVERSION>=30301}
 {$modeswitch FUNCTIONREFERENCES}
 {$define FPC_HAS_REFERENCE_PROCEDURE}