rxprops.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995, 1996 AO ROSNO             }
{         Copyright (c) 1997 Master-Bank                }
{                                                       }
{*******************************************************}

unit RXProps;

interface

{$I RX.INC}

uses SysUtils, Classes, Graphics, Controls, Forms, TypInfo, VclUtils;

type

{ TPropInfoList }

  TPropInfoList = class(TObject)
  private
    FList: PPropList;
    FCount: Integer;
    FSize: Integer;
    function Get(Index: Integer): PPropInfo;
  public
    constructor Create(AObject: TObject; Filter: TTypeKinds);
    destructor Destroy; override;
    function Contains(P: PPropInfo): Boolean;
    function Find(const AName: string): PPropInfo;
    procedure Delete(Index: Integer);
    procedure Intersect(List: TPropInfoList);
    property Count: Integer read FCount;
    property Items[Index: Integer]: PPropInfo read Get; default;
  end;

{ TPropsStorage }

  TReadStrEvent = function(const ASection, Item, Default: string): string of object;
  TWriteStrEvent = procedure(const ASection, Item, Value: string) of object;
  TEraseSectEvent = procedure(const ASection: string) of object;

  TPropsStorage = class(TObject)
  private
    FObject: TObject;
    FOwner: TComponent;
    FPrefix: string;
    FSection: string;
    FOnReadString: TReadStrEvent;
    FOnWriteString: TWriteStrEvent;
    FOnEraseSection: TEraseSectEvent;
    function StoreIntegerProperty(PropInfo: PPropInfo): string;
    function StoreCharProperty(PropInfo: PPropInfo): string;
    function StoreEnumProperty(PropInfo: PPropInfo): string;
    function StoreFloatProperty(PropInfo: PPropInfo): string;
    function StoreStringProperty(PropInfo: PPropInfo): string;
    function StoreSetProperty(PropInfo: PPropInfo): string;
    function StoreClassProperty(PropInfo: PPropInfo): string;
    function StoreStringsProperty(PropInfo: PPropInfo): string;
    function StoreComponentProperty(PropInfo: PPropInfo): string;
{$IFDEF WIN32}
    function StoreLStringProperty(PropInfo: PPropInfo): string;
    function StoreWCharProperty(PropInfo: PPropInfo): string;
    function StoreVariantProperty(PropInfo: PPropInfo): string;
    procedure LoadLStringProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadWCharProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadVariantProperty(const S: string; PropInfo: PPropInfo);
{$ENDIF}
{$IFDEF RX_D4}
    function StoreInt64Property(PropInfo: PPropInfo): string;
    procedure LoadInt64Property(const S: string; PropInfo: PPropInfo);
{$ENDIF}
    procedure LoadIntegerProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadCharProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadEnumProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadFloatProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadStringProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadSetProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadClassProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadStringsProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadComponentProperty(const S: string; PropInfo: PPropInfo);
    function CreateInfoList(AComponent: TComponent; StoredList: TStrings): TStrings;
    procedure FreeInfoLists(Info: TStrings);
  protected
    function ReadString(const ASection, Item, Default: string): string; virtual;
    procedure WriteString(const ASection, Item, Value: string); virtual;
    procedure EraseSection(const ASection: string); virtual;
    function GetItemName(const APropName: string): string; virtual;
    function CreateStorage: TPropsStorage; virtual;
  public
    procedure StoreAnyProperty(PropInfo: PPropInfo);
    procedure LoadAnyProperty(PropInfo: PPropInfo);
    procedure StoreProperties(PropList: TStrings);
    procedure LoadProperties(PropList: TStrings);
    procedure LoadObjectsProps(AComponent: TComponent; StoredList: TStrings);
    procedure StoreObjectsProps(AComponent: TComponent; StoredList: TStrings);
    property AObject: TObject read FObject write FObject;
    property Prefix: string read FPrefix write FPrefix;
    property Section: string read FSection write FSection;
    property OnReadString: TReadStrEvent read FOnReadString write FOnReadString;
    property OnWriteString: TWriteStrEvent read FOnWriteString write FOnWriteString;
    property OnEraseSection: TEraseSectEvent read FOnEraseSection write FOnEraseSection;
  end;

{ Utility routines }

procedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);
function CreateStoredItem(const CompName, PropName: string): string;
function ParseStoredItem(const Item: string; var CompName, PropName: string): Boolean;

const
{$IFDEF WIN32}
  sPropNameDelimiter: string = '_';
{$ELSE}
  sPropNameDelimiter: Char = '_';
{$ENDIF}

implementation

uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, Str16, {$ENDIF}
  Consts, rxStrUtils;

const
  sCount = 'Count';
  sItem = 'Item%d';
  sNull = '(null)';

type
  TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;

{$IFNDEF WIN32}
function GetEnumName(TypeInfo: PTypeInfo; Value: Integer): string;
begin
  Result := TypInfo.GetEnumName(TypeInfo, Value)^;
end;
{$ENDIF}

function GetPropType(PropInfo: PPropInfo): PTypeInfo;
begin
{$IFDEF RX_D3}
  Result := PropInfo^.PropType^;
{$ELSE}
  Result := PropInfo^.PropType;
{$ENDIF}
end;

{ TPropInfoList }

constructor TPropInfoList.Create(AObject: TObject; Filter: TTypeKinds);
begin
  if AObject <> nil then begin
    FCount := GetPropList(AObject.ClassInfo, Filter, nil);
    FSize := FCount * SizeOf(Pointer);
    GetMem(FList, FSize);
    GetPropList(AObject.ClassInfo, Filter, FList);
  end
  else begin
    FCount := 0;
    FList := nil;
  end;
end;

destructor TPropInfoList.Destroy;
begin
  if FList <> nil then FreeMem(FList, FSize);
end;

function TPropInfoList.Contains(P: PPropInfo): Boolean;
var
  I: Integer;
begin
  for I := 0 to FCount - 1 do
    with FList^[I]^ do
      if (PropType = P^.PropType) and (CompareText(Name, P^.Name) = 0) then
      begin
        Result := True;
        Exit;
      end;
  Result := False;
end;

function TPropInfoList.Find(const AName: string): PPropInfo;
var
  I: Integer;
begin
  for I := 0 to FCount - 1 do
    with FList^[I]^ do
      if (CompareText(Name, AName) = 0) then
      begin
        Result := FList^[I];
        Exit;
      end;
  Result := nil;
end;

procedure TPropInfoList.Delete(Index: Integer);
begin
  Dec(FCount);
  if Index < FCount then Move(FList^[Index + 1], FList^[Index],
    (FCount - Index) * SizeOf(Pointer));
end;

function TPropInfoList.Get(Index: Integer): PPropInfo;
begin
  Result := FList^[Index];
end;

procedure TPropInfoList.Intersect(List: TPropInfoList);
var
  I: Integer;
begin
  for I := FCount - 1 downto 0 do
    if not List.Contains(FList^[I]) then Delete(I);
end;

{ Utility routines }

function CreateStoredItem(const CompName, PropName: string): string;
begin
  Result := '';
  if (CompName <> '') and (PropName <> '') then
    Result := CompName + '.' + PropName;
end;

function ParseStoredItem(const Item: string; var CompName, PropName: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  if Length(Item) = 0 then Exit;
  I := Pos('.', Item);
  if I > 0 then begin
    CompName := Trim(Copy(Item, 1, I - 1));
    PropName := Trim(Copy(Item, I + 1, MaxInt));
    Result := (Length(CompName) > 0) and (Length(PropName) > 0);
  end;
end;

function ReplaceComponentName(const Item, CompName: string): string;
var
  ACompName, APropName: string;
begin
  Result := '';
  if ParseStoredItem(Item, ACompName, APropName) then
    Result := CreateStoredItem(CompName, APropName);
end;

procedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);
var
  I: Integer;
  Component: TComponent;
  CompName, PropName: string;
begin
  if (AStoredList = nil) or (AComponent = nil) then Exit;
  for I := AStoredList.Count - 1 downto 0 do begin
    if ParseStoredItem(AStoredList[I], CompName, PropName) then
    begin
      if FromForm then begin
        Component := AComponent.FindComponent(CompName);
        if Component = nil then AStoredList.Delete(I)
        else AStoredList.Objects[I] := Component;
      end
      else begin
        Component := TComponent(AStoredList.Objects[I]);
        if Component <> nil then
          AStoredList[I] := ReplaceComponentName(AStoredList[I], Component.Name)
        else AStoredList.Delete(I);
      end;
    end
    else AStoredList.Delete(I);
  end;
end;

{$IFDEF WIN32}
function FindGlobalComponent(const Name: string): TComponent;
var
  I: Integer;
begin
  for I := 0 to Screen.FormCount - 1 do begin
    Result := Screen.Forms[I];
    if CompareText(Name, Result.Name) = 0 then Exit;
  end;
  for I := 0 to Screen.DataModuleCount - 1 do begin
    Result := Screen.DataModules[I];
    if CompareText(Name, Result.Name) = 0 then Exit;
  end;
  Result := nil;
end;
{$ENDIF}

{ TPropsStorage }

function TPropsStorage.GetItemName(const APropName: string): string;
begin
  Result := Prefix + APropName;
end;

procedure TPropsStorage.LoadAnyProperty(PropInfo: PPropInfo);
var
  S, Def: string;
begin
  try
    if PropInfo <> nil then begin
      case PropInfo^.PropType^.Kind of
        tkInteger: Def := StoreIntegerProperty(PropInfo);
        tkChar: Def := StoreCharProperty(PropInfo);
        tkEnumeration: Def := StoreEnumProperty(PropInfo);
        tkFloat: Def := StoreFloatProperty(PropInfo);
{$IFDEF WIN32}
        tkWChar: Def := StoreWCharProperty(PropInfo);
        tkLString: Def := StoreLStringProperty(PropInfo);
  {$IFNDEF RX_D3} { - Delphi 2.0, C++Builder 1.0 }
        tkLWString: Def := StoreLStringProperty(PropInfo);
  {$ENDIF}
        tkVariant: Def := StoreVariantProperty(PropInfo);
{$ENDIF WIN32}
{$IFDEF RX_D4}
        tkInt64: Def := StoreInt64Property(PropInfo);
{$ENDIF}
        tkString: Def := StoreStringProperty(PropInfo);
        tkSet: Def := StoreSetProperty(PropInfo);
        tkClass: Def := '';
        else Exit;
      end;
      if (Def <> '') or (PropInfo^.PropType^.Kind in [tkString, tkClass])
{$IFDEF WIN32}
        or (PropInfo^.PropType^.Kind in [tkLString,
          {$IFNDEF RX_D3} tkLWString, {$ENDIF} tkWChar])
{$ENDIF WIN32}
      then
        S := Trim(ReadString(Section, GetItemName(PropInfo^.Name), Def))
      else S := '';
      case PropInfo^.PropType^.Kind of
        tkInteger: LoadIntegerProperty(S, PropInfo);
        tkChar: LoadCharProperty(S, PropInfo);
        tkEnumeration: LoadEnumProperty(S, PropInfo);
        tkFloat: LoadFloatProperty(S, PropInfo);
{$IFDEF WIN32}
        tkWChar: LoadWCharProperty(S, PropInfo);
        tkLString: LoadLStringProperty(S, PropInfo);
  {$IFNDEF RX_D3} { - Delphi 2.0, C++Builder 1.0 }
        tkLWString: LoadLStringProperty(S, PropInfo);
  {$ENDIF}
        tkVariant: LoadVariantProperty(S, PropInfo);
{$ENDIF WIN32}
{$IFDEF RX_D4}
        tkInt64: LoadInt64Property(S, PropInfo);
{$ENDIF}
        tkString: LoadStringProperty(S, PropInfo);
        tkSet: LoadSetProperty(S, PropInfo);
        tkClass: LoadClassProperty(S, PropInfo);
      end;
    end;
  except
    { ignore any exception }
  end;
end;

procedure TPropsStorage.StoreAnyProperty(PropInfo: PPropInfo);
var
  S: string;
begin
  if PropInfo <> nil then begin
    case PropInfo^.PropType^.Kind of
      tkInteger: S := StoreIntegerProperty(PropInfo);
      tkChar: S := StoreCharProperty(PropInfo);
      tkEnumeration: S := StoreEnumProperty(PropInfo);
      tkFloat: S := StoreFloatProperty(PropInfo);
{$IFDEF WIN32}
      tkLString: S := StoreLStringProperty(PropInfo);
  {$IFNDEF RX_D3} { - Delphi 2.0, C++Builder 1.0 }
      tkLWString: S := StoreLStringProperty(PropInfo);
  {$ENDIF}
      tkWChar: S := StoreWCharProperty(PropInfo);
      tkVariant: S := StoreVariantProperty(PropInfo);
{$ENDIF WIN32}
{$IFDEF RX_D4}
      tkInt64: S := StoreInt64Property(PropInfo);
{$ENDIF}
      tkString: S := StoreStringProperty(PropInfo);
      tkSet: S := StoreSetProperty(PropInfo);
      tkClass: S := StoreClassProperty(PropInfo);
      else Exit;
    end;
    if (S <> '') or (PropInfo^.PropType^.Kind in [tkString
      {$IFDEF WIN32}, tkLString, {$IFNDEF RX_D3} tkLWString, {$ENDIF}
      tkWChar {$ENDIF WIN32}]) then
      WriteString(Section, GetItemName(PropInfo^.Name), Trim(S));
  end;
end;

function TPropsStorage.StoreIntegerProperty(PropInfo: PPropInfo): string;
begin
  Result := IntToStr(GetOrdProp(FObject, PropInfo));
end;

function TPropsStorage.StoreCharProperty(PropInfo: PPropInfo): string;
begin
  Result := Char(GetOrdProp(FObject, PropInfo));
end;

function TPropsStorage.StoreEnumProperty(PropInfo: PPropInfo): string;
begin
  Result := GetEnumName(GetPropType(PropInfo), GetOrdProp(FObject, PropInfo));
end;

function TPropsStorage.StoreFloatProperty(PropInfo: PPropInfo): string;
const
{$IFDEF WIN32}
  Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
{$ELSE}
  Precisions: array[TFloatType] of Integer = (7, 15, 18, 18);
{$ENDIF}
begin
  Result := ReplaceStr(FloatToStrF(GetFloatProp(FObject, PropInfo), ffGeneral,
    Precisions[GetTypeData(GetPropType(PropInfo))^.FloatType], 0), 
    DecimalSeparator, '.');
end;

function TPropsStorage.StoreStringProperty(PropInfo: PPropInfo): string;
begin
  Result := GetStrProp(FObject, PropInfo);
end;

{$IFDEF WIN32}
function TPropsStorage.StoreLStringProperty(PropInfo: PPropInfo): string;
begin
  Result := GetStrProp(FObject, PropInfo);
end;

function TPropsStorage.StoreWCharProperty(PropInfo: PPropInfo): string;
begin
  Result := Char(GetOrdProp(FObject, PropInfo));
end;

function TPropsStorage.StoreVariantProperty(PropInfo: PPropInfo): string;
begin
  Result := GetVariantProp(FObject, PropInfo);
end;
{$ENDIF}

{$IFDEF RX_D4}
function TPropsStorage.StoreInt64Property(PropInfo: PPropInfo): string;
begin
  Result := IntToStr(GetInt64Prop(FObject, PropInfo));
end;
{$ENDIF}

function TPropsStorage.StoreSetProperty(PropInfo: PPropInfo): string;
var
  TypeInfo: PTypeInfo;
  W: Cardinal;
  I: Integer;
begin
  Result := '[';
  W := GetOrdProp(FObject, PropInfo);
  TypeInfo := GetTypeData(GetPropType(PropInfo))^.CompType{$IFDEF RX_D3}^{$ENDIF};
  for I := 0 to SizeOf(TCardinalSet) * 8 - 1 do
    if I in TCardinalSet(W) then begin
      if Length(Result) <> 1 then Result := Result + ',';
      Result := Result + GetEnumName(TypeInfo, I);
    end;
  Result := Result + ']';