Chip 2002 September/Chip_2002-09_cd1.bin/zkuste/delphi/kolekce/d56/XMLCOMP.ZIP/DnXmlPropMapper.pas

Pascal/Delphi Source File | 2002-06-14 | 10KB | 322 lines

unit DnXmlPropMapper;

interface

uses
  Classes, SysUtils, TypInfo;

type
  {:Baseclass to derive your custom property mapper from. Object properties must be sorted so the
    readonly properties come first.}
  TDnXmlPropMapper = class
  private
    FObject: TObject;
    FStoreReadOnlyProps: Boolean;
  protected
    function GetCount: Integer; virtual; abstract;
    function GetIsStored(aIndex: Integer): Boolean; virtual; abstract;
    function GetValue(aIndex: Integer): string; virtual; abstract;
    procedure SetValue(aIndex: Integer; const Value: string); virtual; abstract;
    function GetPropName(aIndex: Integer): string; virtual; abstract;
    function GetIsObject(aIndex: Integer): Boolean; virtual; abstract;
    function GetIsAssignableObject(aIndex: Integer): Boolean; virtual; abstract;
    function GetIsRef(aIndex: Integer): Boolean; virtual; abstract;
    function GetObjectProp(aIndex: Integer): TObject; virtual; abstract;
    procedure SetObjectProp(aIndex: Integer; const Value: TObject); virtual; abstract;
    property TheObject: TObject read FObject;
  public
    {:Always use this constructor instead of the standard one! It takes the
      object of which the properties are needed.}
    constructor CreateWithObject(aObject: TObject); overload; virtual;
    property Count: Integer read GetCount;
    property IsStored[aIndex: Integer]: Boolean read GetIsStored;
    property Value[aIndex: Integer]: string read GetValue write SetValue;
    property PropName[aIndex: Integer]: string read GetPropName;
    property StoreReadOnlyProps: Boolean read FStoreReadOnlyProps write FStoreReadOnlyProps;
    // object specific
    property ObjectProp[aIndex: Integer]: TObject read GetObjectProp write SetObjectProp;
    property IsObject[aIndex: Integer]: Boolean read GetIsObject;
    property IsAssignableObject[aIndex: Integer]: Boolean read GetIsAssignableObject;
    property IsRef[aIndex: Integer]: Boolean read GetIsRef;
  end;

  TDnXmlRttiPropMapper = class(TDnXmlPropMapper)
  private
    FProps: TList;
    FPropKinds: TTypeKinds;
    function Props(aIndex: Integer): PPropInfo;
    procedure UpdateProps;
    procedure SetPropKinds(const Value: TTypeKinds);
  protected
    function GetCount: Integer; override;
    function GetIsStored(aIndex: Integer): Boolean; override;
    function GetValue(aIndex: Integer): string; override;
    procedure SetValue(aIndex: Integer; const Value: string); override;
    function GetPropName(aIndex: Integer): string; override;
    // object specific
    function GetIsObject(aIndex: Integer): Boolean; override;
    function GetIsAssignableObject(aIndex: Integer): Boolean; override;
    function GetIsRef(aIndex: Integer): Boolean; override;
    function GetObjectProp(aIndex: Integer): TObject; override;
    procedure SetObjectProp(aIndex: Integer; const Value: TObject); override;
  public
    constructor CreateWithObject(aObject: TObject); override;
    destructor Destroy; override;
    {:Which kind of properties to map. Kind not in the list will not be mapped.}
    property PropKinds: TTypeKinds read FPropKinds write SetPropKinds default tkProperties;
  end;

  TDnXmlPropMapperClass = class of TDnXmlPropMapper;

{:Returns the property mapper associated with a certain class. 0 <= aIndex < GetXmlPropMapperCount().}
function GetXmlPropMapper(aClass: TClass; aIndex: Integer): TDnXmlPropMapperClass;
{:Returns the number of property mappers associated with a certain class.}
function GetXmlPropMapperCount(aClass: TClass): Integer;
{:Registers (associates) a property mapper to a certain component class. The class must be derived from
  TComponent.}
procedure RegisterPropMapper(aClass: TComponentClass; aMapper: TDnXmlPropMapperClass);
{:Unregisters the propmapper (registered using the RegisterPropMapper routine) for a specific class.}
procedure UnregisterPropMapperForClass(aClass: TComponentClass; aMapper: TDnXmlPropMapperClass);
{:Unregisters the propmapper (registered using the RegisterPropMapper routine)  for all classes it was associated with.}
procedure UnregisterPropMapper(aMapper: TDnXmlPropMapperClass);

implementation

uses
  Contnrs;

var
  uClasses: TList = nil; { of TClass }
  uMappers: TObjectList = nil; { of TList of TDnXmlPropMapperClass }

function GetXmlPropMapper(aClass: TClass; aIndex: Integer): TDnXmlPropMapperClass;
var idx: Integer;
begin
  result := nil;
  for idx := 0 to uClasses.Count - 1 do
  begin
    if aClass.InheritsFrom(uClasses[idx]) then
    begin
      if aIndex < TList(uMappers[idx]).Count then
        result := TList(uMappers[idx])[aIndex]
      else
        Dec(aIndex, TList(uMappers[idx]).Count);
    end;
  end;
end;

function GetXmlPropMapperCount(aClass: TClass): Integer;
var idx: Integer;
begin
  result := 0;
  for idx := 0 to uClasses.Count - 1 do
  begin
    if aClass.InheritsFrom(uClasses[idx]) then
    begin
      result := result + TList(uMappers[idx]).Count;
    end;
  end;
end;

procedure RegisterPropMapper(aClass: TComponentClass; aMapper: TDnXmlPropMapperClass);
var idx: Integer;
    mappers: TList;
begin
  Assert(aClass <> nil);
  Assert(aMapper <> nil);

  idx := uClasses.IndexOf(aClass);
  if idx <> -1 then
    mappers := TList(uMappers[idx])
  else
  begin
    mappers := TList.Create;
    uMappers.Add(mappers);
    uClasses.Add(aClass);
  end;

  mappers.Add(aMapper);
end;

procedure UnregisterPropMapperForClass(aClass: TComponentClass; aMapper: TDnXmlPropMapperClass);
var idx: Integer;
    mappers: TList;
begin
  Assert(aClass <> nil);

  if aClass <> nil then
  begin
    idx := uClasses.IndexOf(aClass);
    if idx = -1 then
      raise Exception.CreateFmt('There was no mapper registered for class %s', [aClass.ClassName]);
    mappers := TList(uMappers[idx]);
    mappers.Remove(aMapper);
    if mappers.Count = 0 then
    begin
      uClasses.Delete(idx);
      uMappers.Delete(idx);
    end
  end;
end;

procedure UnregisterPropMapper(aMapper: TDnXmlPropMapperClass);
var idx: Integer;
    mappers: TList;
begin
  Assert(aMapper <> nil);

  idx := 0;
  while idx < uMappers.Count - 1 do
  begin
    mappers := TList(uMappers[idx]);
    mappers.Remove(aMapper);
    if mappers.Count = 0 then
    begin
      uMappers.Delete(idx);
      uClasses.Delete(idx);
    end
    else
      inc(idx);
  end;
end;

{ TDnXmlPropMapper }

constructor TDnXmlPropMapper.CreateWithObject(aObject: TObject);
begin
  inherited Create;
  Assert(aObject <> nil);
  FObject := aObject;
end;

{ TDnXmlRttiPropMapper }

constructor TDnXmlRttiPropMapper.CreateWithObject(aObject: TObject);
begin
  inherited;
  FPropKinds := tkProperties;
  UpdateProps;
end;

destructor TDnXmlRttiPropMapper.Destroy;
begin
  FProps.Free;
  inherited;
end;

function TDnXmlRttiPropMapper.GetCount: Integer;
begin
  result := FProps.Count;
end;

function TDnXmlRttiPropMapper.GetIsObject(aIndex: Integer): Boolean;
begin
  result := Props(aIndex).PropType^.Kind = tkClass;
end;

function TDnXmlRttiPropMapper.GetIsStored(aIndex: Integer): Boolean;
begin
  result := IsStoredProp(TheObject, FProps[aIndex]);
  if result then
  begin
    if not StoreReadOnlyProps then
    begin
      if not IsObject[aIndex] then
        result := Assigned(Props(aIndex).SetProc);
    end;
  end;
end;

function TDnXmlRttiPropMapper.GetPropName(aIndex: Integer): string;
begin
  result := Props(aIndex).Name;
end;

function TDnXmlRttiPropMapper.GetValue(aIndex: Integer): string;
begin
  Assert(not IsObject[aIndex]);
  result := GetPropValue(TheObject, PropName[aIndex]);
end;

procedure TDnXmlRttiPropMapper.SetValue(aIndex: Integer; const Value: string);
begin
  Assert(not IsObject[aIndex]);
  SetPropValue(TheObject, PropName[aIndex], Value);
end;

function TDnXmlRttiPropMapper.GetObjectProp(aIndex: Integer): TObject;
begin
  Assert(IsObject[aIndex]);
  result := TObject(GetOrdProp(TheObject, FProps[aIndex]));
end;

procedure TDnXmlRttiPropMapper.SetObjectProp(aIndex: Integer; const Value: TObject);
begin
  Assert(IsAssignableObject[aIndex]);
  SetOrdProp(TheObject, FProps[aIndex], Integer(Value));
end;

function TDnXmlRttiPropMapper.GetIsRef(aIndex: Integer): Boolean;
begin
  Assert(IsObject[aIndex]);

  if GetObjectProp(aIndex) is TComponent then
    result := TComponent(ObjectProp[aIndex]).Owner <> TheObject
  else
    result := False;
end;

function TDnXmlRttiPropMapper.GetIsAssignableObject(
  aIndex: Integer): Boolean;
begin
  Assert(IsObject[aIndex]);
  result := Assigned(Props(aIndex).SetProc);
end;

function TDnXmlRttiPropMapper.Props(aIndex: Integer): PPropInfo;
begin
  result := PPropInfo(FProps[aIndex]);
end;

procedure TDnXmlRttiPropMapper.UpdateProps;
var temp: PPropList;
    count,i: Integer;
begin
  count := GetTypeData(FObject.ClassInfo).PropCount;
  GetMem(temp, count * SizeOf(PPropInfo));
  try
    GetPropInfos(FObject.ClassInfo, temp);

    FProps := TList.Create;
    // filter props
    for i := 0 to count - 1 do
    begin
      if temp[i].PropType^.Kind in PropKinds then
        FProps.Add(temp[i]);
    end;
  finally
    FreeMem(temp);
  end;
end;

procedure TDnXmlRttiPropMapper.SetPropKinds(const Value: TTypeKinds);
begin
  if FPropKinds <> Value then
  begin
    FPropKinds := Value;
    UpdateProps;
  end;
end;

initialization
  uClasses := TList.Create;
  uMappers := TObjectList.Create;
  RegisterPropMapper(TComponent, TDnXmlRttiPropMapper);

finalization
  uClasses.Free;
  uMappers.Free;
  UnRegisterPropMapper(TDnXmlRttiPropMapper);

end.