fpc/packages/fcl-base/src/fpobserver.pp

{
    This file is part of the Free Component Library (FCL)
    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

unit fpobserver;

{$mode objfpc}{$H+}
{$interfaces corba}

interface

uses
  Classes, SysUtils, typinfo, contnrs;

Type

  TObservedHook = Class(TObject,IFPObserved)
  Protected
    FObservers : TFPList;
    FSender : TObject;
  Public
    // ASender will be the default sender.
    Constructor CreateSender(ASender : TObject);
    Destructor Destroy; override;
    Procedure FPOAttachObserver(AObserver : TObject);
    Procedure FPODetachObserver(AObserver : TObject);
    Procedure Changed;
    Procedure AddItem(AItem : TObject);
    Procedure DeleteItem(AItem : TObject);
    Procedure CustomNotify(Data : Pointer = Nil);
    Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer);
    Property Sender : TObject Read FSender;
  end;

//  EObserver = Class(Exception);


  { TBaseMediator }

  TMediatingEvent = Procedure(Sender : TObject; var Handled : Boolean) of object;

  TBaseMediator = Class(TComponent,IFPObserver)
  private
    FActive: Boolean;
    FOnObjectToView: TMediatingEvent;
    FOnViewToObject: TMediatingEvent;
    FReadOnly: Boolean;
    FTransferring : Boolean;
    FSubjectPropertyName: String;
    FSubject: TObject;
    FValueList: TObjectList;
    FViewPropertyName: String;
    procedure SetReadOnly(const AValue: Boolean);
    procedure SetValueList(const AValue: TObjectList);
    procedure SetViewPropertyName(const AValue: String); Virtual;
  Protected
    // Should return true (Default) if ViewPropertyName is published
    Class Function PublishedViewProperty : Boolean; virtual;
    // Should return true (Default) if SubjectPropertyName is published
    Class Function PublishedSubjectProperty : Boolean; virtual;
    // Set active. Descendents (such as list mediators) can override this.
    procedure SetActive(const AValue: Boolean); virtual;
    // set subject. Attaches observer and calls MaybeObjectToView
    procedure SetSubject(const AValue: TObject); virtual;
    // set subjectpropertyname. Checks if it exists, and calls MaybeObjectToView
    procedure SetSubjectPropertyName(const AValue: String); virtual;
    // Can be used in descendents to respond to onchange events
    Procedure ViewChangedHandler(Sender : TObject);  virtual;
    // Check if APropertyName is published property of AObject.
    // Only performed if both parameters are not empty.
    procedure CheckPropertyName(AObject: TObject; const APropertyName: String);
    // If all CheckObjectSubject and Active are true, call ObjectToView.
    Procedure MaybeObjectToView;
    // If all CheckObjectSubject and Active are true, call ViewToObject.
    Procedure MaybeViewToObject;
    // Check if Subject/View and property names are set up correctly.
    Function  CheckViewSubject : Boolean;
    // Override  next two for custom behaviour.
    // Copies Subject.SubjectPropertyName to View.ViewPropertyName.
    Procedure DoObjectToView; virtual;
    // Copies View.ViewPropertyName to Subject.SubjectPropertyName
    Procedure DoViewToObject; virtual;
    // Override these, and call inherited at the end.
    // Get View component. Typically a TCustomEdit instance.
    function  GetView : TObject; virtual;
    // Descendents should call this when the view changed.
    procedure ViewChanged; virtual;
    // Descendents should override this to handle changes in the value list
    procedure ValuelistChanged; virtual;
    // IFPObserver. Will call the necessary events.
    Procedure FPOObservedChanged(ASender : TObject; Operation : TFPObservedOperation; Data : Pointer);
    // Raise an error which shows more information about the control, subject and fieldname.
    Procedure RaiseMediatorError(Const Msg : String); overload;
    // Format version
    Procedure RaiseMediatorError(Const Fmt : String; Args : Array of const); overload;
    // View property that will be set by default
    Property ViewPropertyName : String Read FViewPropertyName Write SetViewPropertyName;
    // Is a copy operation View <-> Subject in progress ?
    Property Transferring : Boolean Read FTransferring;
  Public
    Destructor Destroy; override;
    // Copy subject to view. No check is done to see if all is well.
    Procedure ObjectToView;
    // Copy view to subject. No check is done to see if all is well.
    Procedure ViewToObject;
    // Minimum class that View must have to be handled by this mediator.
    class function ViewClass: TClass; virtual;
    // Composite mediator or not ?
    class function CompositeMediator : Boolean; virtual;
    // Subject. Must have IFPObserved interface
    Property Subject : TObject Read FSubject Write SetSubject;
    // View. Must have ViewPropertyName, if in use.
    Property View : TObject Read GetView;
    // Value list. To be used in mediators that use a dynamical value list
    // such as Listbox, combobox, groupbox.
    Property Valuelist : TObjectList Read FValueList Write SetValueList;
  Published
    // Property that will be copied to view.
    Property SubjectPropertyName : String Read FSubjectPropertyName Write SetSubjectPropertyName;
    // If not active, no copying is being done either way.
    Property Active : Boolean Read FActive Write SetActive;
    // If ReadOnly, only ObjectToView is used
    Property ReadOnly : Boolean Read FReadOnly Write SetReadOnly;
    // Can be used to copy data from control (view) to subject manually
    Property OnViewToObject : TMediatingEvent Read FOnViewToObject Write FOnViewToObject;
    // Can be used to copy data from control (view) to subject manually
    Property OnObjectToView : TMediatingEvent Read FOnObjectToView Write FOnObjectToView;
  end;
  TMediatorClass = Class of TBaseMediator;

  // Forward definitions
  TBaseListMediator = Class;

  { TComponentMediator }
  { General-purpose of Mediating views. Can be used on any form/component }

  TComponentMediator = Class(TBaseMediator)
    FViewComponent : TComponent;
  Protected
    function  GetView : TObject; override;
    procedure SetComponent(const AValue: TComponent);
  Public
    procedure Notification(AComponent: TComponent;  Operation: TOperation); override;
  Published
    // General component which can be set in Object Inspector
    Property ViewComponent : TComponent Read FViewComponent Write SetComponent;
    // Punlish property so it can be set in Object Inspector
    Property ViewPropertyName;
  end;

  { Event object used for OnBeforeSetupField event. Is used to allow formatting
    of fields before written to listview Caption or Items. }
  TOnBeforeSetupField = procedure(AObject: TObject; const AFieldName: string; var AValue: string) of object;

  { TListItemMediator }

  TListItemMediator = class(TObject, IFPObserver)
  private
    FSubject: TObject;
    FOnBeforeSetupField: TOnBeforeSetupField;
    FListMediator : TBaseListMediator;
    Function GetActive : Boolean;
  protected
    procedure SetSubject(const AValue: TObject); virtual;
    Procedure FPOObservedChanged(ASender : TObject; Operation : TFPObservedOperation; Data : Pointer); virtual;
    Procedure ObjectToView; virtual;
    Procedure ViewToObject; virtual;
  public
    destructor Destroy; override;
    procedure MaybeObjectToView;
    property OnBeforeSetupField: TOnBeforeSetupField read FOnBeforeSetupField write FOnBeforeSetupField;
    property Subject : TObject read FSubject write SetSubject;
    property Active : Boolean read GetActive;
  end;

  { TBaseListMediator - Base mediator that handles lists of objects.

    Needs a TList as subject. Items in list must have IFPObserved
    interface. It will create one (and use as subject) if passed a normal
    list or a collection.
  }

  TBaseListMediator = class(TBaseMediator)
  private
    FOnBeforeSetupField: TOnBeforeSetupField;
    FMediatorList: TFPObjectList;
    FListChanged : Boolean;
    procedure SetOnBeforeSetupField(const Value: TOnBeforeSetupField);
  protected
    // This needs to return false
    Class Function PublishedViewProperty : Boolean; override;
    // Descendents can override;
    Function AddObject(AObject: TObject; AIndex: Integer) : TListItemMediator; virtual;
    // Set all descendents to active
    procedure SetActive(const AValue: Boolean); override;
    // Must be overridden in descendents, and should return selected object
    function GetSelectedObject: TObject; virtual;
    // Must be overridden in descendents, and should set selected object
    procedure SetSelectedObject(const AValue: TObject); virtual;
    // Must be overridden in descendents to create an item mediator and add it to GUI control
    // Subject will be set after this call.
    Function CreateItemMediator(AData: TObject; ARow : integer) : TListItemMediator; virtual; abstract;
    // This frees the mediator. Descendents can override to additionally update the GUI control
    procedure DoDeleteItemMediator(AIndex : Integer; AMediator : TListItemMediator); virtual;
    // Creates a mediator for all items in the list. List Item Mediators are re-used (subject is set)
    procedure CreateSubMediators; virtual;
    // Does nothing
    procedure DoViewToObject; override;
    // Calls CreateSubMediators. Override for additional GUI setup.
    procedure DoObjectToView; override;
    // Additional checks on subject.
    procedure SetSubject(const AValue: TObject); override;

    Function FindObjectMediator(AObject : TObject; out AtIndex : Integer) : TListItemMediator;
    property MediatorList: TFPObjectList read FMediatorList;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    class function CompositeMediator: Boolean; override;
    // This should handle additional additem/deleteitem events
    Procedure ObservedChanged(ASender : TObject; Operation : TFPObservedOperation);
    // Selected item in the list.
    property SelectedObject: TObject read GetSelectedObject write SetSelectedObject;
  published
    // Event to setup fields in item mediators.
    property OnBeforeSetupField: TOnBeforeSetupField read FOnBeforeSetupField write SetOnBeforeSetupField;
  end;

  { TMediatorFieldInfo - Describe a column in a columnar list display }

  TMediatorFieldInfo = class(TCollectionItem)
  private
    FWidth: integer;
    FCaption: string;
    FPropName: string;
    FAlign: TAlignment;
    function GetCaption: string;
    procedure SetAlign(const AValue: TAlignment);
    procedure SetCaption(const AValue: string);
    procedure SetPropName(const AValue: string);
    procedure SetWidth(const AValue: Integer);
  protected
    function GetAsString: string; virtual;
    procedure SetAsString(const AValue: string); virtual;
    Procedure Change;
  public
    procedure Assign(Source: TPersistent); override;
    // Setting this will parse everything.
    property AsString: string read GetAsString write SetAsString;
  published
    // Property Caption to be used for column head.
    property Caption: string read GetCaption write SetCaption;
    // Property Name to be displayed in column
    property PropertyName: string read FPropName write SetPropName;
    // Width of column
    property Width: Integer read FWidth write SetWidth;
    // Alignment of column
    property Alignment: TAlignment read FAlign write SetAlign default taLeftJustify;
  end;

  TColumnsListMediator = Class;

  { TMediatorFieldInfoList - Collection describing the columns in a columnar list display }

  TMediatorFieldInfoList = class(TCollection)
  private
    FMediator : TColumnsListMediator;
    function GetAsString: string;
    function GetI(Index: integer): TMediatorFieldInfo;
    procedure SetI(Index: integer; const AValue: TMediatorFieldInfo);
  protected
    procedure Notify(Item: TCollectionItem;Action: TCollectionNotification); override;
    Property Mediator : TColumnsListMediator read FMediator;
  public
    // Adding items to the collection.
    function AddFieldInfo: TMediatorFieldInfo; overload;
    function AddFieldInfo (Const APropName : String; AFieldWidth : Integer) : TMediatorFieldInfo; overload;
    function AddFieldInfo (Const APropName,ACaption : String; AFieldWidth : Integer) : TMediatorFieldInfo; overload;
    function AddFieldInfo (Const APropName,ACaption : String; AFieldWidth : Integer; AAlignment : TAlignment) : TMediatorFieldInfo; overload;
    property FieldInfo[Index: integer]: TMediatorFieldInfo read GetI write SetI; default;
    property AsString: string read GetAsString;
  end;

  { TColumnsListItemMediator - List item mediator that can handle multiple columns }

  TColumnsListItemMediator = class(TListItemMediator)
  Private
    Function GetFieldsInfo: TMediatorFieldInfoList;
  Published
    property FieldsInfo: TMediatorFieldInfoList read GetFieldsInfo;
  end;

  { TColumnsListMediator - List mediator that handles multiple columns }

  TColumnsListMediator = class(TBaseListMediator)
  Private
    FFieldsInfo: TMediatorFieldInfoList;
    procedure SetFieldsInfo(const AValue: TMediatorFieldInfoList);
    function GetDisplayNames: string;
    procedure SetDisplayNames(const AValue: string);
    procedure FieldInfoChanged(Item: TMediatorFieldInfo; Action: TCollectionNotification); virtual;
  Protected
    Class Function PublishedSubjectProperty : Boolean; override;
    procedure ParseDisplayNames(const AValue: string);
    // Called by DoViewToObject prior to creating item mediators
    procedure CreateColumns; virtual;
    // Calls CreateColumns and CreateSubMediators. Override for additional GUI setup.
    procedure DoObjectToView; override;
  Public
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    // Can be used to set the column properties in 1 statement.
    property DisplayNames: string read GetDisplayNames write SetDisplayNames;
  Published
    // How to display the columns in the list.
    property FieldsInfo: TMediatorFieldInfoList read FFieldsInfo write SetFieldsInfo;
  end;

  { TMediatorDef - Mediator Definition Storage for MediatorManager }

  TMediatorDef = class(TCollectionItem)
  private
    FMC: TMediatorClass;
    FMSC: TClass;
    FPN: string;
    FPT: TTypeKinds;
  public
    // Return True if this definition handles the Subject,Gui,APropinfo trio
    function Handles(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): Boolean;
    // Return True if this definition matches 'closer' than M.
    // Note that both current and M must have Handles() returned true for this to be useful.
    function BetterMatch(M: TMediatorDef): Boolean;
    // Definition
    property MediatorClass: TMediatorClass read FMC write FMC;
    property MinSubjectClass: TClass read FMSC write FMSC;
    property PropertyTypes: TTypeKinds read FPT write FPT;
    property PropertyName: string read FPN write FPN;
  end;


  TMediatorDefs = class(TCollection)
  private
    function GetDef(Index: integer): TMediatorDef;
    procedure SetDef(Index: integer; const AValue: TMediatorDef);
  public
    function AddDef: TMediatorDef;
    property Defs[Index: integer]: TMediatorDef read GetDef write SetDef; default;
  end;


  TMediatorManager = class(TObject)
  private
    FDefs: TMediatorDefs;
  public
    constructor Create;
    destructor Destroy; override;
    // If APropName is empty or APropInfo is Nil, a composite mediator will be searched.
    function FindDefFor(ASubject: TObject; AGui: TComponent): TMediatorDef; overload;
    function FindDefFor(ASubject: TObject; AGui: TComponent; const APropName: string): TMediatorDef; overload;
    function FindDefFor(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): TMediatorDef; overload;
    function RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass): TMediatorDef; overload;
    function RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyName: string): TMediatorDef; overload;
    function RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyTypes: TTypeKinds): TMediatorDef; overload;
    property Defs: TMediatorDefs read FDefs;
  end;

  EMediator = class(Exception);

function MediatorManager: TMediatorManager;
Procedure MediatorError(Sender : TObject; Const Msg : String); overload;
Procedure MediatorError(Sender : TObject; Const Fmt : String; Args : Array of const); overload;

implementation


Resourcestring
  SErrNotObserver = 'Instance of class %s is not an observer.';
  SErrInvalidPropertyName = '%s is not a valid published property of class %s';
  SErrObjectCannotBeObserved = 'Cannot observe an instance of class %d';
  sErrInvalidFieldName      = 'No fieldname specified for column %d';
  sErrInvalidAlignmentChar  = 'Invalid alignment character "%s" specified for column %d';
  sErrInvalidWidthSpecifier = 'Invalid with "%s" specified for column %d';
  sErrNotListObject         = '%s is not a TObjectList';
  sErrCompositeNeedsList    = '%s needs a TObjectList class but is registered with %s';
  SErrActive                = 'Operation not allowed while the mediator is active';
  SErrNoGuiFieldName        = 'no gui fieldname set';
  SErrNoSubjectFieldName    = 'no subject fieldname set';

{ ---------------------------------------------------------------------
  Mediator global routines
  ---------------------------------------------------------------------}

Procedure MediatorError(Sender : TObject; Const Msg : String); overload;

Var
  M : TBaseMediator;
  C : TComponent;
  V,S : TObject;
  CN,SN,Err : String;

begin
  if (Sender=Nil) then
    Err:=Msg
  else If Sender is TBaseMediator then
    begin
    M:=TBaseMediator(Sender);
    V:=M.View;
    S:=M.Subject;
    CN:='';
    If Assigned(V) then
      begin
      if (V is TComponent) then
        begin
        C:=TComponent(V);
        CN:=C.Name;
        end;
      If (CN='') then
        CN:=C.ClassName+' instance';
      end
    else
      CN:='Nil';
    If Assigned(S) then
      SN:=S.ClassName
    else
      SN:='Nil';
    Err:=Format('Mediator %s (%s,%s,%s) : %s',[M.ClassName,SN,CN,M.SubjectPropertyName,Msg]);
    end
  else if (Sender is TComponent) and (TComponent(Sender).Name<>'') then
    Err:=Format('%s : %s',[TComponent(Sender).Name,Msg])
  else
    Err:=Format('%s : %s',[Sender.ClassName,Msg]);
  Raise EMediator.Create(Err);
end;

Procedure MediatorError(Sender : TObject; const Fmt : String; Args : Array of const); overload;

begin
  MediatorError(Sender,Format(Fmt,Args));
end;

Var
  MM : TMediatorManager;

function MediatorManager: TMediatorManager;
begin
  if (MM = nil) then
    MM := TMediatorManager.Create;
  Result := MM;
end;

{ TObservedHook }

constructor TObservedHook.CreateSender(ASender: TObject);
begin
  FSender:=ASender;
  If FSender=Nil then
    FSender:=Self;
end;

destructor TObservedHook.Destroy;
begin
  If Assigned(FObservers) then
    begin
    FPONotifyObservers(FSender,ooFree,Nil);
    FreeAndNil(FObservers);
    end;
  inherited Destroy;
end;

procedure TObservedHook.FPOAttachObserver(AObserver: TObject);

Var
  I : IFPObserver;

begin
  If Not AObserver.GetInterface(SGUIDObserver,I) then
    Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
  If not Assigned(FObservers) then
    FObservers:=TFPList.Create;
  FObservers.Add(I);
end;

procedure TObservedHook.FPODetachObserver(AObserver: TObject);

Var
  I : IFPObserver;

begin
  If Not AObserver.GetInterface(SGUIDObserver,I) then
    Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]);
  If Assigned(FObservers) then
    begin
    FObservers.Remove(I);
    If (FObservers.Count=0) then
      FreeAndNil(FObservers);
    end;
end;

procedure TObservedHook.Changed;
begin
  FPONotifyObservers(Sender,ooChange,Nil)
end;

procedure TObservedHook.AddItem(AItem: TObject);
begin
  FPONotifyObservers(FSender,ooAddItem,AItem);
end;

procedure TObservedHook.DeleteItem(AItem: TObject);
begin
  FPONotifyObservers(FSender,ooDeleteItem,AItem);
end;

procedure TObservedHook.CustomNotify(Data : Pointer = Nil);
begin
  FPONotifyObservers(FSender,ooCustom,Data);
end;

procedure TObservedHook.FPONotifyObservers(ASender: TObject;  AOperation: TFPObservedOperation; Data : Pointer);

Var
  O : TObject;
  I : Integer;
  Obs : IFPObserver;

begin
  If Assigned(FObservers) then
    For I:=FObservers.Count-1 downto 0 do
      begin
      Obs:=IFPObserver(FObservers[i]);
      Obs.FPOObservedChanged(ASender,AOperation,Data);
      end;
end;

{ TBaseMediator }

function TBaseMediator.GetView: TObject;
begin
  Result:=Nil;
end;

procedure TBaseMediator.ViewChanged;
begin
  If PublishedViewProperty then
    CheckPropertyName(View,ViewPropertyName);
  MaybeObjectToView
end;

procedure TBaseMediator.ValuelistChanged;
begin
  // Do nothing
end;

procedure TBaseMediator.SetActive(const AValue: Boolean);
begin
  if FActive=AValue then exit;
  FActive:=AValue;
  MaybeObjectToView;
end;

procedure TBaseMediator.SetReadOnly(const AValue: Boolean);
begin
  if FReadOnly=AValue then exit;
  FReadOnly:=AValue;
  MaybeObjectToView;
end;

procedure TBaseMediator.SetValueList(const AValue: TObjectList);

Var
  I : IFPObserved;

begin
  if FValueList=AValue then exit;
  If FValueList<>Nil then
      I.FPODetachObserver(Self);
  If Assigned(AValue) then
    begin
    FValueList:=AValue;
    If Assigned(AValue) then
      AValue.FPOAttachObserver(Self);
    end;
  FValueList:=AValue;
  ValueListChanged;
end;

procedure TBaseMediator.CheckPropertyName(AObject : TObject; const APropertyName : String);

begin
  If Assigned(AObject) and (APropertyName<>'') then
    If Not IsPublishedProp(AObject,APropertyName) then
      Raise EObserver.CreateFmt(SErrInvalidPropertyName,[APropertyName,AObject.ClassName]);
end;

procedure TBaseMediator.MaybeObjectToView;
begin
  If FActive and CheckViewSubject then
    ObjectToView
end;

procedure TBaseMediator.MaybeViewToObject;
begin
  If FActive and (Not ReadOnly) and CheckViewSubject then
    ViewToObject;
end;

function TBaseMediator.CheckViewSubject: Boolean;

Var
  O : TObject;

begin
  O:=GetView;
  Result:=Assigned(FSubject)
          and Assigned(O)
          and (ViewPropertyName<>'')
          and (SubjectPropertyName<>'');
end;

procedure TBaseMediator.SetSubjectPropertyName(const AValue: String);

begin
  if FSubjectPropertyName=AValue then exit;
  If PublishedSubjectProperty then
    CheckPropertyName(FSubject,AValue);
  FSubjectPropertyName:=AValue;
  MaybeObjectToView;
end;


procedure TBaseMediator.SetSubject(const AValue: TObject);

Var
  I : IFPObserved;

begin
  if FSubject=AValue then exit;
  If PublishedSubjectProperty then
    CheckPropertyName(AValue,FSubjectPropertyName);
  If FSubject<>Nil then
    If FSubject.GetInterface(SGUIDObserved,I) then
      I.FPODetachObserver(Self);
  If (AValue<>Nil) then
    begin
    If not AValue.GetInterface(SGUIDObserved,I) then
      Raise EObserver.CreateFmt(SErrObjectCannotBeObserved,[AValue.ClassName]);
    FSubject:=AValue;
    I.FPOAttachObserver(Self);
    end
  else
    FSubject:=AValue;
  MaybeObjectToView;
end;

procedure TBaseMediator.SetViewPropertyName(const AValue: String);
begin
  if FViewPropertyName=AValue then exit;
  If PublishedViewProperty then
    CheckPropertyName(GetView,AValue);
  FViewPropertyName:=AValue;
  MaybeObjectToView;
end;

class function TBaseMediator.PublishedViewProperty: Boolean;
begin
  Result:=True;
end;

class function TBaseMediator.PublishedSubjectProperty: Boolean;
begin
  Result:=True;
end;

procedure TBaseMediator.ViewChangedHandler(Sender: TObject);
begin
  MaybeViewToObject;
end;


procedure TBaseMediator.FPOObservedChanged(ASender: TObject;
  Operation: TFPObservedOperation; Data : Pointer);


begin
  If (ASender=FSubject) then
    begin
    If Operation=ooChange then
      MaybeObjectToView
    else if Operation=ooFree then
      FSubject:=Nil;
    end
  else if (ASender=FValueList) then
    begin
    If Operation=ooChange then
      ValueListChanged
    else if Operation=ooFree then
      FValueList:=Nil;
    end;
end;

procedure TBaseMediator.RaiseMediatorError(const Msg: String);
begin
  MediatorError(Self,Msg);
end;

procedure TBaseMediator.RaiseMediatorError(const Fmt: String;
  Args: array of const);
begin
  RaiseMediatorError(Format(FMT,Args));
end;

destructor TBaseMediator.Destroy;
begin
  Subject:=Nil;
  ValueList:=Nil;
  inherited Destroy;
end;

procedure TBaseMediator.DoObjectToView;

begin
  SetPropValue(GetView,ViewPropertyName,GetPropValue(FSubject,FSubjectPropertyName));
end;

procedure TBaseMediator.DoViewToObject;

begin
  SetPropValue(FSubject,FSubjectPropertyName,GetPropValue(GetView,ViewPropertyName));
end;

procedure TBaseMediator.ObjectToView;

Var
  B : Boolean;

begin
  If Not FTransferring then
    begin
    FTransferring:=True;
    try
      B:=False;
      If Assigned(FOnObjectToView) then
        FOnObjectToView(Self,B);
      If not B then
        DoObjectToView;
    finally
      FTransferring:=False;
    end;
    end;
end;

procedure TBaseMediator.ViewToObject;

Var
  B : Boolean;

begin
  If Not FTransferring then
    begin
    FTransferring:=True;
    try
      B:=False;
      If Assigned(FONViewToObject) then
        FONViewToObject(Self,B);
      If not B then
      DoViewToObject;
    finally
      FTransferring:=False;
    end;
    end;
end;

class function TBaseMediator.ViewClass: TClass;
begin
  Result:=TObject;
end;

class function TBaseMediator.CompositeMediator: Boolean;
begin
  Result:=False;
end;

{ TComponentMediator }

function TComponentMediator.GetView: TObject;
begin
  Result:=FViewComponent;
end;

procedure TComponentMediator.SetComponent(const AValue: TComponent);
begin
  If (Avalue=FViewComponent) then
    Exit;
  If Assigned(FViewComponent) then
    FViewComponent.RemoveFreeNotification(Self);
  FViewComponent:=AValue;
  If Assigned(FViewComponent) then
    FViewComponent.FreeNotification(Self);
  ViewChanged;
end;

procedure TComponentMediator.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  If (Operation=opRemove) and (AComponent=FViewComponent) then
    begin
    FViewComponent:=Nil;
    ViewChanged;
    end;
end;

{ TMediatorDef }

function TMediatorDef.Handles(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): Boolean;
var
  N: string;
begin
  if (APropInfo = nil) then
    Result := FMC.CompositeMediator
  else
  begin
    N      := APropInfo^.Name;
    Result := True;
  end;
  if not Result then
    Exit; // ==>
  // At least the classes must match
  Result := AGui.InheritsFrom(FMC.ViewClass) and ASubject.InheritsFrom(FMSC);
  if Result and not FMC.CompositeMediator then
    if (PropertyName <> '') then
      Result := (CompareText(N, PropertyName) = 0)
    else // Property kind should match. Note that property MUST be set to something.
      Result := (APropInfo^.PropType^.Kind in PropertyTypes); // If PropertyName is set, it must match
end;

function TMediatorDef.BetterMatch(M: TMediatorDef): Boolean;
begin
  Result := (M = nil);
  if not Result then
  begin
    Result := (FMC.CompositeMediator = M.MediatorClass.CompositeMediator);
    if Result then
    begin
      Result := (PropertyName <> '') and (M.PropertyName = '');
      if not Result then
      begin
        // M's property matches closer
        Result := not ((M.PropertyName <> '') and (PropertyName = ''));
        if Result then
        begin
          // Properties are on equal level. Check GUI class.
          // Closer GUI class ?
          Result := FMC.ViewClass.InheritsFrom(M.MediatorClass.ViewClass);
          if not Result then
          begin
            // M's GUI class matches closer ?
            Result := not (M.MediatorClass.ViewClass.InheritsFrom(FMC.ViewClass));
            if Result then
            begin
              // GUI classes are on equal level (different branches in tree). Check subject class.
              // Closer Subject class ?
              Result := FMSC.InheritsFrom(M.FMSC);
              if not Result then
                // M's subject class matches closer ?
                Result := not M.FMSC.InheritsFrom(FMSC);
            end;
          end;
        end;
      end;
    end;
  end;
end;

{ TMediatorDefs }

function TMediatorDefs.GetDef(Index: integer): TMediatorDef;
begin
  Result := TMediatorDef(Items[Index]);
end;

procedure TMediatorDefs.SetDef(Index: integer; const AValue: TMediatorDef);
begin
  Items[Index] := AValue;
end;

function TMediatorDefs.AddDef: TMediatorDef;
begin
  Result := Add as TMediatorDef;
end;

{ TMediatorManager }

constructor TMediatorManager.Create;
begin
  FDefs := TMediatorDefs.Create(TMediatorDef);
end;

destructor TMediatorManager.Destroy;
begin
  FreeAndNil(FDefs);
  inherited Destroy;
end;

function TMediatorManager.FindDefFor(ASubject: TObject; AGui: TComponent): TMediatorDef;
begin
  Result := FindDefFor(ASubject, AGUI, PPropInfo(nil));
end;

function TMediatorManager.FindDefFor(ASubject: TObject; AGui: TComponent; const APropName: string): TMediatorDef;
var
  propinfo: PPropInfo;
begin
  propinfo := GetPropInfo(ASubject, APropName);
  Result := FindDefFor(ASubject, AGUI, propinfo);
end;

function TMediatorManager.FindDefFor(ASubject: TObject; AGui: TComponent; APropInfo: PPropInfo): TMediatorDef;
var
  D: TMediatorDef;
  I: integer;
begin
  Result := nil;
  for I := 0 to FDefs.Count - 1 do
  begin
    D := FDefs[I];
    if D.Handles(ASubject, AGUI, APropInfo) then
      if (D.BetterMatch(Result)) then
        Result := D;
  end;
end;

function TMediatorManager.RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass): TMediatorDef;

begin
  Result      := FDefs.AddDef;
  Result.MediatorClass := MediatorClass;
  Result.FMSC := MinSubjectClass;
  Result.FPN  := '';
  Result.FPT  := tkProperties - [tkClass, tkInterface, tkDynArray, tkObject, tkInterfaceRaw];
end;

function TMediatorManager.RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyName: string): TMediatorDef;

begin
  Result      := FDefs.AddDef;
  Result.MediatorClass := MediatorClass;
  Result.FMSC := MinSubjectClass;
  Result.FPN  := PropertyName;
  Result.FPT  := [];
end;

function TMediatorManager.RegisterMediator(MediatorClass: TMediatorClass; MinSubjectClass: TClass; PropertyTypes: TTypeKinds): TMediatorDef;

begin
  Result      := FDefs.AddDef;
  Result.MediatorClass := MediatorClass;
  Result.FMSC := MinSubjectClass;
  Result.FPN  := '';
  Result.FPT  := PropertyTypes;
end;

{ TListItemMediator }


function TListItemMediator.GetActive: Boolean;
begin
  Result:=False;
  If Assigned(FListMediator) then
    Result:=FListMediator.Active;
end;

procedure TListItemMediator.SetSubject(const AValue: TObject);

Var
  I : IFPObserved;

begin
  if Avalue=FSubject then
    Exit;
  If FSubject<>Nil then
    If FSubject.GetInterface(SGUIDObserved,I) then
      I.FPODetachObserver(Self);
  FSubject:=AValue;
  If (FSubject<>Nil) then
    begin
    If not FSubject.GetInterface(SGUIDObserved,I) then
      Raise EObserver.CreateFmt(SErrObjectCannotBeObserved,[FSubject.ClassName]);
    I.FPOAttachObserver(Self);
    end;
  MaybeObjectToView
end;

procedure TListItemMediator.FPOObservedChanged(ASender: TObject;
  Operation: TFPObservedOperation; Data : Pointer);
begin
  If Operation=ooFree then
    FSubject:=Nil
  else
    MaybeObjectToView;
end;

procedure TListItemMediator.ObjectToView;
begin
  // Do nothing
end;

procedure TListItemMediator.ViewToObject;
begin
  // Do nothing
end;

destructor TListItemMediator.Destroy;
begin
  Subject:=Nil;
  inherited Destroy;
end;

procedure TListItemMediator.MaybeObjectToView;
begin
  If Assigned(FSubject) and Active then
    ObjectToView;
end;

{ TMediatorFieldInfo }

procedure TMediatorFieldInfo.Change;

begin
  FPONotifyObservers(Self,ooChange,Nil);
end;

function TMediatorFieldInfo.GetCaption: string;
begin
  Result:=FCaption;
  If (Result='') then
    Result:=FPropName;
end;

procedure TMediatorFieldInfo.SetAlign(const AValue: TAlignment);
begin
  If AValue=fAlign then Exit;
  FAlign:=AValue;
  Change;
end;

procedure TMediatorFieldInfo.SetCaption(const AValue: string);
begin
  If AValue=Caption then Exit;
  FCaption:=AValue;
  Change;
end;

procedure TMediatorFieldInfo.SetPropName(const AValue: string);
begin
  If AValue=FPropName then Exit;
  FPropName:=AValue;
  Change;
end;

procedure TMediatorFieldInfo.SetWidth(const AValue: Integer);
begin
  If (FWidth=AValue) then Exit;
  FWidth:=AValue;
  Change;
end;

const
  AlignChars: array[TAlignMent] of char     = ('l', 'r', 'c');

function TMediatorFieldInfo.GetAsString: string;
begin
  Result := Format('%s|%s|%d|%s', [PropertyName, AlignChars[Alignment], Width, Caption]);
end;

procedure TMediatorFieldInfo.SetAsString(const AValue: string);

  Function GetToken(Var S : String) : String;

  Var
    P : Integer;

  begin
    P:=Pos('|',S);
    If P=0 then P:=Length(S)+1;
    Result:=Copy(S,1,P-1);
    Delete(S,1,P);
  end;

var
  V,S: string;
  A: TAlignment;
  I: integer;

begin
  V:=S;
  I := 0;
  PropertyName:=GetToken(V);
  if (PropertyName = '') then
    MediatorError(Self,SErrInvalidFieldName, [Index + 1]);
  Alignment:=taLeftJustify;
  Width:=50;
  S:=GetToken(V);
  if (S<>'') then
    begin
    if (length(S)<>1) then
      MediatorError(Self,SErrInvalidAlignmentChar, [S,Index+1]);
    for A := Low(Talignment) to High(TAlignment) do
      if (Upcase(AlignChars[A])=Upcase(S[1])) then
        Alignment := A;
    S:=GetToken(V);
    if (S<>'') then
      begin
      if not TryStrToInt(S,i) then
        MediatorError(Self,SErrInvalidWidthSpecifier,[S]);
      Width:=I;
      S:=getToken(V);
      if (S<>'') then
        Caption := S;
      end;
    end;
end;

procedure TMediatorFieldInfo.Assign(Source: TPersistent);

Var
  M : TMediatorFieldInfo;

begin
  if (Source is TMediatorFieldInfo) then
    begin
    M:=Source as TMediatorFieldInfo;
    FWidth:=M.FWidth;
    FCaption:=M.FCaption;
    FPropName:=M.FPropname;
    FAlign:=M.FAlign;
    end
  else
    inherited Assign(Source);
end;

{ TColumnsListItemMediator }

function TColumnsListItemMediator.GetFieldsInfo: TMediatorFieldInfoList;
begin
  If Assigned(FListmediator) and (FListMediator is TColumnsListMediator) then
    Result:=TColumnsListMediator(FListMediator).FFieldsInfo;
end;

{ TBaseListMediator }

procedure TBaseListMediator.SetOnBeforeSetupField(
  const Value: TOnBeforeSetupField);

var
  I: integer;
begin
  FOnBeforeSetupField := Value;
  for I := 0 to FMediatorList.Count - 1 do
    TListItemMediator(FMediatorList[i]).OnBeforeSetupField := Value;
end;

class function TBaseListMediator.PublishedViewProperty: Boolean;
begin
  Result:=False;
end;

procedure TBaseListMediator.SetActive(const AValue: Boolean);

Var
  i : Integer;

begin
  inherited SetActive(AValue);
  If AValue then
    For I:=0 to MediatorList.Count-1 do
      TListItemMediator(MediatorList[i]).MaybeObjectToView;
end;

function TBaseListMediator.GetSelectedObject: TObject;
begin
  Result := nil;
end;

procedure TBaseListMediator.SetSelectedObject(const AValue: TObject);
begin
  // Do nothing
end;

procedure TBaseListMediator.DoDeleteItemMediator(AIndex: Integer;
  AMediator: TListItemMediator);
begin
  MediatorList.Delete(AIndex);
end;

Function TBaseListMediator.AddObject(AObject : TObject; AIndex : Integer) : TListItemMediator;


begin
  Result:=CreateItemMediator(AObject,AIndex);
  If (Result<>Nil) then
    begin
    Result.FListMediator:=Self;
    Result.Subject:=AObject;
    MediatorList.Add(Result);
    end;
end;

procedure TBaseListMediator.CreateSubMediators;

var
  I : integer;
  Model : TObjectList;
  
begin
  Model:=Subject as TObjectList;
  for i := 0 to Model.Count - 1 do
    begin
    if i < MediatorList.Count then
      TListItemMediator(MediatorList[i]).Subject := Model[i]
    else
      AddObject(Model[i], i);
    end;
  for i := MediatorList.Count-1 downto Model.Count do
    DoDeleteItemMediator(I,TListItemMediator(MediatorList[i]));
  FListChanged:=False;
end;

procedure TBaseListMediator.DoViewToObject;
begin
  // Do nothing
end;

procedure TBaseListMediator.DoObjectToView;
begin
  CreateSubMediators;
end;

procedure TBaseListMediator.SetSubject(const AValue: TObject);

Var
  V : TOBject;

begin
  if (AValue <> nil) then
    begin
    V:=Nil;
    if (AValue is TObjectList) then
      V:=AValue
    else If (AValue is TList) then
      V:=AValue
    else If (AValue is TCollection) then
      V:=AValue;
    if (V=Nil) then
      RaiseMediatorError(SErrNotListObject, [AValue.ClassName]);
    end;
  FListChanged:=True;
  inherited SetSubject(AValue)
end;

function TBaseListMediator.FindObjectMediator(AObject: TObject; out
  AtIndex: Integer): TListItemMediator;
begin
  AtIndex:=FMediatorList.Count-1;
  While (AtIndex>=0) and (TListItemMediator(FMediatorList[AtIndex]).Subject<>AObject) do
    Dec(AtIndex);
  If (AtIndex=-1) then
    Result:=Nil
  else
    Result:=TListItemMediator(FMediatorList[AtIndex]);
end;

constructor TBaseListMediator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMediatorList := TFPObjectList.Create;
  Active        := False;
  ViewPropertyName:='Caption';
end;

destructor TBaseListMediator.Destroy;
begin
  FreeAndNil(FMediatorList);
  inherited Destroy;
end;

class function TBaseListMediator.CompositeMediator: Boolean;
begin
  Result:=True;
end;

procedure TBaseListMediator.ObservedChanged(ASender: TObject;
  Operation: TFPObservedOperation);

var
  M     : TListItemMediator;
  Model : TObjectList;
  I     : Integer;

begin
  // Do not call inherited, it will rebuild the list !!
  Case Operation of
    ooAddItem    : AddObject(ASender,TObjectList(Subject).Count-1); // always at the end...
    ooDeleteItem : begin
                   M:=FindObjectMediator(ASender,I);
                   if M<>nil then
                     DoDeleteItemMediator(I,M);
                   end;
    ooChange    : begin
                   Model:=(Subject as TObjectList);
                   if FListChanged or (TObjectList(Model).Count<>MediatorList.Count) or (Model.Count=0) then // Safety measure
                     MaybeObjectToView;
                   end;
  end;

end;

{ TColumnsListMediator }

procedure TColumnsListMediator.SetFieldsInfo(
  const AValue: TMediatorFieldInfoList);
begin
  FFieldsInfo.Assign(AValue);
end;

function TColumnsListMediator.GetDisplayNames: string;
begin
  Result := FFieldsInfo.AsString;
end;

procedure TColumnsListMediator.SetDisplayNames(const AValue: string);
begin
  SubjectPropertyName:=AValue;
  ParseDisplayNames(AValue);
end;

procedure TColumnsListMediator.FieldInfoChanged(Item: TMediatorFieldInfo;
  Action: TCollectionNotification);
begin
  If Active  then
    RaiseMediatorError(SErrActive);
end;

class function TColumnsListMediator.PublishedSubjectProperty: Boolean;
begin
  Result:=False;
end;

procedure TColumnsListMediator.ParseDisplayNames(const AValue: string);

  Function GetToken(Var S : String) : String;

  Var
    P : Integer;

  begin
    P:=Pos(';',S);
    If P=0 then P:=Length(S)+1;
    Result:=Copy(S,1,P-1);
    Delete(S,1,P);
  end;

var
  I : integer;
  lField : string;
  MFI : TMediatorFieldInfo;
  A,S : String;

begin
  FFieldsInfo.Clear;
  A:=AValue;
  Repeat
    S:=GetToken(A);
    If (S<>'') then
      begin
      MFI:=FFieldsInfo.AddFieldInfo;
      MFI.AsString:=S;
      end;
  until (S='');
end;

procedure TColumnsListMediator.CreateColumns;
begin
  // Do nothing. Must be implemented by descendent objects.
end;

procedure TColumnsListMediator.DoObjectToView;
begin
  CreateColumns;
  inherited DoObjectToView;
end;

constructor TColumnsListMediator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFieldsInfo:=TMediatorFieldInfoList.create(TMediatorFieldInfo);
  SubjectPropertyName:='Caption';
end;

destructor TColumnsListMediator.Destroy;
begin
  FreeAndNil(FFieldsInfo);
  inherited Destroy;
end;

{ TMediatorFieldInfoList }

function TMediatorFieldInfoList.GetAsString: string;

var
  I: integer;
begin
  Result := '';
  for I := 0 to Count - 1 do
  begin
    if (Result <> '') then
      Result := Result + ';';
    Result := Result + FieldInfo[i].AsString;
  end;
end;

function TMediatorFieldInfoList.GetI(Index: integer): TMediatorFieldInfo;
begin
  Result := TMediatorFieldInfo(Items[Index]);
end;

procedure TMediatorFieldInfoList.SetI(Index: integer;
  const AValue: TMediatorFieldInfo);

begin
  Items[Index] := AValue;
end;

procedure TMediatorFieldInfoList.Notify(Item: TCollectionItem;
  Action: TCollectionNotification);
begin
  inherited Notify(Item, Action);
  If Assigned(FMediator) then
    FMediator.FieldInfoChanged(Item as TMediatorFieldInfo,Action)
end;

function TMediatorFieldInfoList.AddFieldInfo: TMediatorFieldInfo;
begin
  Result := Add as TMediatorFieldInfo;
end;

function TMediatorFieldInfoList.AddFieldInfo(const APropName: String;
  AFieldWidth: Integer): TMediatorFieldInfo;
begin
  Result:=AddFieldInfo();
  Result.PropertyName:=APropName;
  Result.Width:=AFieldWidth;
end;

function TMediatorFieldInfoList.AddFieldInfo(const APropName, ACaption: String;
  AFieldWidth: Integer): TMediatorFieldInfo;
begin
  Result:=AddFieldInfo(APropName,AFieldWidth);
  Result.Caption:=ACaption;
end;

function TMediatorFieldInfoList.AddFieldInfo(const APropName, ACaption: String;
  AFieldWidth: Integer; AAlignment: TAlignment): TMediatorFieldInfo;
begin
  Result:=AddFieldInfo(APropName,ACaption,AFieldWidth);
  Result.Alignment:=AAlignment;
end;

end.