jclrtti.pas

East make Tray Icon in delphi

    if LastBit mod 8 <> 0 then
      Inc(ByteCount);
    FillChar(Value, ByteCount, 0);
  end;

begin
  BaseInfo := BaseType as IJclOrdinalRangeTypeInfo;
  FirstBit := BaseInfo.MinValue mod 8;
  ClearValue;
  Strings.BeginUpdate;
  try
  for I := 0 to Strings.Count - 1 do
    begin
      if Trim(Strings[I]) <> '' then
      begin
        FirstIdent := Trim(Strings[I]);
        RangePos := Pos('..', FirstIdent);
        if RangePos > 0 then
        begin
          LastIdent := Trim(StrRestOf(FirstIdent, RangePos + 2));
          FirstIdent := Trim(Copy(FirstIdent, 1, RangePos - 1));
        end
        else
          LastIdent := FirstIdent;
        if BaseInfo.TypeKind = tkEnumeration then
        begin
          FirstOrd := (BaseInfo as IJclEnumerationTypeInfo).IndexOfName(FirstIdent);
          LastOrd := (BaseInfo as IJclEnumerationTypeInfo).IndexOfName(LastIdent);
          if FirstOrd = -1 then
            raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [FirstIdent]);
          if LastOrd = -1 then
            raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [LastIdent]);
        end
        else
        begin
          FirstOrd := StrToInt(FirstIdent);
          LastOrd := StrToInt(LastIdent);
        end;
        Dec(FirstOrd, BaseInfo.MinValue);
        Dec(LastOrd, BaseInfo.MinValue);
        for CurOrd := FirstOrd to LastOrd do
          SetBitBuffer(Value, CurOrd + FirstBit);
      end;
    end;
  finally
    Strings.EndUpdate;
  end;
end;

procedure TJclSetTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIBasedOn));
  Dest.Indent;
  try
    BaseType.WriteTo(Dest);
  finally
    Dest.Outdent;
  end;
end;

procedure TJclSetTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  Base: IJclOrdinalTypeInfo;
  BaseEnum: IJclEnumerationTypeInfo;
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = set of ');
  Base := BaseType;

  if Base.Name[1] = '.' then
  begin
    if Base.QueryInterface(IJclEnumerationTypeInfo, BaseEnum) = S_OK then
      BaseEnum.DeclarationTo(Dest)
    else
      Dest.Write(LoadResString(@RsRTTITypeError));
  end
  else
    Dest.Write(Base.Name);
  if Name[1] <> '.' then
  begin
    Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType),
      TypeData.OrdType));
    Dest.Writeln('');
  end;
end;

//=== { TJclFloatTypeInfo } ==================================================

type
  TJclFloatTypeInfo = class(TJclTypeInfo, IJclFloatTypeInfo)
  protected
    function GetFloatType: TFloatType;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property FloatType: TFloatType read GetFloatType;
  end;

function TJclFloatTypeInfo.GetFloatType: TFloatType;
begin
  Result := TypeData.FloatType;
end;

procedure TJclFloatTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIFloatType) +
    JclEnumValueToIdent(System.TypeInfo(TFloatType), TypeData.FloatType));
end;

procedure TJclFloatTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  S: string;
  FT: TFloatType;
begin
  FT := FloatType;
  S := StrRestOf(JclEnumValueToIdent(System.TypeInfo(TFloatType), FT), 3);
  Dest.Writeln(Name + ' = type ' + S + ';');
end;

//=== { TJclStringTypeInfo } =================================================

type
  TJclStringTypeInfo = class(TJclTypeInfo, IJclStringTypeInfo)
  protected
    function GetMaxLength: Integer;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property MaxLength: Integer read GetMaxLength;
  end;

function TJclStringTypeInfo.GetMaxLength: Integer;
begin
  Result := TypeData.MaxLength;
end;

procedure TJclStringTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIMaxLen) + IntToStr(MaxLength));
end;

procedure TJclStringTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = ');
  Dest.Write('string[' + IntToStr(MaxLength) + ']');
  if Name[1] <> '.' then
    Dest.Writeln(';');
end;

//=== { TJclPropInfo } =======================================================

type
  TJclPropInfo = class(TInterfacedObject, IJclPropInfo)
  private
    FPropInfo: PPropInfo;
  protected
    function GetPropInfo: PPropInfo;
    function GetPropType: IJclTypeInfo;
    function GetReader: Pointer;
    function GetWriter: Pointer;
    function GetStoredProc: Pointer;
    function GetIndex: Integer;
    function GetDefault: Longint;
    function GetNameIndex: Smallint;
    function GetName: string;
    function GetSpecKind(const Value: Integer): TJclPropSpecKind;
    function GetSpecValue(const Value: Integer): Integer;
    function GetReaderType: TJclPropSpecKind;
    function GetWriterType: TJclPropSpecKind;
    function GetStoredType: TJclPropSpecKind;
    function GetReaderValue: Integer;
    function GetWriterValue: Integer;
    function GetStoredValue: Integer;
  public
    constructor Create(const APropInfo: PPropInfo);
    function IsStored(const AInstance: TObject): Boolean;
    function HasDefault: Boolean;
    function HasIndex: Boolean;

    property PropInfo: PPropInfo read GetPropInfo;
    property PropType: IJclTypeInfo read GetPropType;
    property Reader: Pointer read GetReader;
    property Writer: Pointer read GetWriter;
    property StoredProc: Pointer read GetStoredProc;
    property ReaderType: TJclPropSpecKind read GetReaderType;
    property WriterType: TJclPropSpecKind read GetWriterType;
    property StoredType: TJclPropSpecKind read GetStoredType;
    property ReaderValue: Integer read GetReaderValue;
    property WriterValue: Integer read GetWriterValue;
    property StoredValue: Integer read GetStoredValue;
    property Index: Integer read GetIndex;
    property Default: Longint read GetDefault;
    property NameIndex: Smallint read GetNameIndex;
    property Name: string read GetName;
  end;

constructor TJclPropInfo.Create(const APropInfo: PPropInfo);
begin
  inherited Create;
  FPropInfo := APropInfo;
end;

function TJclPropInfo.GetPropInfo: PPropInfo;
begin
  Result := FPropInfo;
end;

function TJclPropInfo.GetPropType: IJclTypeInfo;
begin
  Result := JclTypeInfo(PropInfo.PropType^);
end;

function TJclPropInfo.GetReader: Pointer;
begin
  Result := PropInfo.GetProc;
end;

function TJclPropInfo.GetWriter: Pointer;
begin
  Result := PropInfo.SetProc;
end;

function TJclPropInfo.GetStoredProc: Pointer;
begin
  Result := PropInfo.StoredProc;
end;

function TJclPropInfo.GetIndex: Integer;
begin
  Result := PropInfo.Index;
end;

function TJclPropInfo.GetDefault: Longint;
begin
  Result := PropInfo.Default;
end;

function TJclPropInfo.GetNameIndex: Smallint;
begin
  Result := PropInfo.NameIndex;
end;

function TJclPropInfo.GetName: string;
begin
  Result := PropInfo.Name;
end;

function TJclPropInfo.GetSpecKind(const Value: Integer): TJclPropSpecKind;
var
  P: Integer;

begin
  P := Value shr 24;
  case P of
    $00:
      if Value < 2 then
        Result := pskConstant
      else
        Result := pskStaticMethod;
    $FE:
      Result := pskVirtualMethod;
    $FF:
      Result := pskField;
  else
    Result := pskStaticMethod;
  end;
end;

function TJclPropInfo.GetSpecValue(const Value: Integer): Integer;
begin
  case GetSpecKind(Value) of
    pskStaticMethod, pskConstant:
      Result := Value;
    pskVirtualMethod:
      Result := Smallint(Value and $0000FFFF);
    pskField:
      Result := Value and $00FFFFFF;
  else
    Result := 0;
  end;
end;

function TJclPropInfo.GetReaderType: TJclPropSpecKind;
begin
  Result := GetSpecKind(Integer(Reader));
end;

function TJclPropInfo.GetWriterType: TJclPropSpecKind;
begin
  Result := GetSpecKind(Integer(Writer));
end;

function TJclPropInfo.GetStoredType: TJclPropSpecKind;
begin
  Result := GetSpecKind(Integer(StoredProc));
end;

function TJclPropInfo.GetReaderValue: Integer;
begin
  Result := GetSpecValue(Integer(Reader));
end;

function TJclPropInfo.GetWriterValue: Integer;
begin
  Result := GetSpecValue(Integer(Writer));
end;

function TJclPropInfo.GetStoredValue: Integer;
begin
  Result := GetSpecValue(Integer(StoredProc));
end;

function TJclPropInfo.IsStored(const AInstance: TObject): Boolean;
begin
  Result := IsStoredProp(AInstance, FPropInfo);
end;

function TJclPropInfo.HasDefault: Boolean;
begin
  Result := Longword(Default) <> $80000000;
end;

function TJclPropInfo.HasIndex: Boolean;
begin
  Result := Longword(Index) <> $80000000;
end;

//=== { TJclClassTypeInfo } ==================================================

type
  TJclClassTypeInfo = class(TJclTypeInfo, IJclClassTypeInfo)
  protected
    function GetClassRef: TClass;
    function GetParent: IJclClassTypeInfo;
    function GetTotalPropertyCount: Integer;
    function GetPropertyCount: Integer;
    function GetProperties(const PropIdx: Integer): IJclPropInfo;
    function GetUnitName: string;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property ClassRef: TClass read GetClassRef;
    property Parent: IJclClassTypeInfo read GetParent;
    property TotalPropertyCount: Integer read GetTotalPropertyCount;
    property PropertyCount: Integer read GetPropertyCount;
    property Properties[const PropIdx: Integer]: IJclPropInfo
      read GetProperties;
    property UnitName: string read GetUnitName;
  end;

function TJclClassTypeInfo.GetClassRef: TClass;
begin
  Result := TypeData.ClassType;
end;

function TJclClassTypeInfo.GetParent: IJclClassTypeInfo;
begin
  if (TypeData.ParentInfo <> nil) and (TypeData.ParentInfo^ <> nil) then
    Result := JclTypeInfo(TypeData.ParentInfo^) as IJclClassTypeInfo
  else
    Result := nil;
end;

function TJclClassTypeInfo.GetTotalPropertyCount: Integer;
begin
  Result := TypeData.PropCount;
end;

function TJclClassTypeInfo.GetPropertyCount: Integer;
var
  PropData: ^TPropData;
begin
  PropData := @TypeData.UnitName;
  Inc(Integer(PropData), 1 + Length(UnitName));
  Result := PropData.PropCount;
end;

function TJclClassTypeInfo.GetProperties(const PropIdx: Integer): IJclPropInfo;
var
  PropData: ^TPropData;
  Prop: PPropInfo;
  Idx: Integer;
  RecSize: Integer;
begin
  PropData := @TypeData.UnitName;
  Inc(Integer(PropData), 1 + Length(UnitName));
  if PropIdx + 1 > PropData.PropCount then
    Result := Parent.Properties[PropIdx - PropData.PropCount]
  else
  begin
    Prop := PPropInfo(PropData);
    Inc(Integer(Prop), 2);
    if PropIdx > 0 then
    begin
      RecSize := SizeOf(TPropInfo) - SizeOf(ShortString);
      Idx := PropIdx;
      while Idx > 0 do
      begin
        Inc(Integer(Prop), RecSize);
        Inc(Integer(Prop), 1 + PByte(Prop)^);
        Dec(Idx);
      end;
    end;
    Result := TJclPropInfo.Create(Prop);
  end;
end;

function TJclClassTypeInfo.GetUnitName: string;
begin
  Result := TypeData^.UnitName;
end;

procedure TJclClassTypeInfo.WriteTo(const Dest: IJclInfoWriter);
const
  cFmt1 = '[%s %d]';
  cFmt2 = '[%s %s $%p]';
  cFmt3 = '[%s=%s]';
  cFmt4 = '[%s=%s $%p]';
var
  I: Integer;
  Prop: IJclPropInfo;
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIClassName) + ClassRef.ClassName);
  Dest.Writeln(LoadResString(@RsRTTIParent) + Parent.ClassRef.ClassName);
  Dest.Writeln(LoadResString(@RsRTTIUnitName) + UnitName);
  Dest.Writeln(LoadResString(@RsRTTIPropCount) + IntToStr(PropertyCount) + ' (' +
    IntToStr(TotalPropertyCount) + ')');
  Dest.Indent;
  try