jclrtti.pas

East make Tray Icon in delphi

      TmpLines2.Free;
    end;
  finally
    TmpLines.Free;
  end;
end;

procedure TJclInfoWriter.DoWriteCompleteLines;
var
  CRLFPos: Integer;
begin
  CRLFPos := StrLastPos(AnsiLineBreak, CurLine);
  if CRLFPos > 0 then
  begin
    PrimWrite(Copy(CurLine, 1, CRLFPos-1));
    Delete(FCurLine, 1, CRLFPos+1);
  end;
end;

procedure TJclInfoWriter.Indent;
begin
  IndentLevel := IndentLevel + 1;
end;

procedure TJclInfoWriter.Outdent;
begin
  IndentLevel := IndentLevel - 1;
end;

procedure TJclInfoWriter.Write(const S: string);
begin
  CurLine := CurLine + S;
  DoWrap;
  DoWriteCompleteLines;
end;

procedure TJclInfoWriter.Writeln(const S: string);
begin
  Write(S + AnsiLineBreak);
end;

//=== { TJclInfoStringsWriter } ==============================================

constructor TJclInfoStringsWriter.Create(const AStrings: TStrings;
  const AWrap: Integer);
begin
  inherited Create(AWrap);
  FStrings := AStrings;
end;

procedure TJclInfoStringsWriter.PrimWrite(const S: string);
begin
  Strings.Add(S);
end;

//=== { TJclTypeInfo } =======================================================

type
  TJclTypeInfo = class(TInterfacedObject, IJclTypeInfo)
  private
    FTypeData: PTypeData;
    FTypeInfo: PTypeInfo;
  protected
    function GetName: string;
    function GetTypeData: PTypeData;
    function GetTypeInfo: PTypeInfo;
    function GetTypeKind: TTypeKind;
    procedure WriteTo(const Dest: IJclInfoWriter); virtual;
    procedure DeclarationTo(const Dest: IJclInfoWriter); virtual;
  public
    constructor Create(ATypeInfo: PTypeInfo);
    property Name: string read GetName;
    property TypeData: PTypeData read GetTypeData;
    property TypeInfo: PTypeInfo read GetTypeInfo;
    property TypeKind: TTypeKind read GetTypeKind;
  end;

constructor TJclTypeInfo.Create(ATypeInfo: PTypeInfo);
begin
  inherited Create;
  FTypeInfo := ATypeInfo;
  FTypeData := TypInfo.GetTypeData(ATypeInfo);
end;

function TJclTypeInfo.GetName: string;
begin
  Result := TypeInfo.Name;
end;

function TJclTypeInfo.GetTypeData: PTypeData;
begin
  Result := FTypeData;
end;

function TJclTypeInfo.GetTypeInfo: PTypeInfo;
begin
  Result := FTypeInfo;
end;

function TJclTypeInfo.GetTypeKind: TTypeKind;
begin
  Result := TypeInfo.Kind
end;

procedure TJclTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  Dest.Writeln(LoadResString(@RsRTTIName) + Name);
  Dest.Writeln(LoadResString(@RsRTTITypeKind) + JclEnumValueToIdent(System.TypeInfo(TTypeKind),
    TypeInfo.Kind));
  Dest.Writeln(Format(LoadResString(@RsRTTITypeInfoAt), [TypeInfo]));
end;

procedure TJclTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  Dest.Write(Format(LoadResString(@RsDeclarationFormat), [Name]));
end;

//=== { TJclOrdinalTypeInfo } ================================================

type
  TJclOrdinalTypeInfo = class(TJclTypeInfo, IJclOrdinalTypeInfo)
  protected
    function GetOrdinalType: TOrdType;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
  public
    property OrdinalType: TOrdType read GetOrdinalType;
  end;

function TJclOrdinalTypeInfo.GetOrdinalType: TOrdType;
begin
  Result := TypeData.OrdType;
end;

procedure TJclOrdinalTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIOrdinalType) +
    JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
end;

//=== { TJclOrdinalRangeTypeInfo } ===========================================

type
  TJclOrdinalRangeTypeInfo = class(TJclOrdinalTypeInfo, IJclOrdinalRangeTypeInfo)
  protected
    function GetMinValue: Int64;
    function GetMaxValue: Int64;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property MinValue: Int64 read GetMinValue;
    property MaxValue: Int64 read GetMaxValue;
  end;

function TJclOrdinalRangeTypeInfo.GetMinValue: Int64;
begin
  if OrdinalType = otULong then
    Result := Longword(TypeData.MinValue)
  else
    Result := TypeData.MinValue;
end;

function TJclOrdinalRangeTypeInfo.GetMaxValue: Int64;
begin
  if OrdinalType = otULong then
    Result := Longword(TypeData.MaxValue)
  else
    Result := TypeData.MaxValue;
end;

procedure TJclOrdinalRangeTypeInfo.WriteTo(const Dest: IJclInfoWriter);
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIMinValue) + IntToStr(MinValue));
  Dest.Writeln(LoadResString(@RsRTTIMaxValue) + IntToStr(MaxValue));
end;

procedure TJclOrdinalRangeTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
const
  cRange = '..';
begin
  Dest.Write(Name + ' = ');
  if TypeInfo.Kind in [tkChar, tkWChar] then
  begin
    if (MinValue < Ord(' ')) or (MinValue > Ord('~')) then
      Dest.Write('#' + IntToStr(MinValue) + cRange)
    else
      Dest.Write('''' + Chr(Byte(MinValue)) + '''' + cRange);
    if (MaxValue < Ord(' ')) or (MaxValue > Ord('~')) then
      Dest.Write('#' + IntToStr(MaxValue))
    else
      Dest.Write('''' + Chr(Byte(MaxValue)) + '''');
  end
  else
    Dest.Write(IntToStr(MinValue) + '..' + IntToStr(MaxValue));
  Dest.Writeln('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
end;

//=== { TJclEnumerationTypeInfo } ============================================

type
  TJclEnumerationTypeInfo = class(TJclOrdinalRangeTypeInfo, IJclEnumerationTypeInfo)
  protected
    function GetBaseType: IJclEnumerationTypeInfo;
    function GetNames(const I: Integer): string;
    {$IFDEF COMPILER6_UP}
    function GetUnitName: string;
    {$ENDIF COMPILER6_UP}
    function IndexOfName(const Name: string): Integer;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property BaseType: IJclEnumerationTypeInfo read GetBaseType;
    property Names[const I: Integer]: string read GetNames; default;
    {$IFDEF COMPILER6_UP}
    property UnitName: string read GetUnitName;
    {$ENDIF COMPILER6_UP}
  end;

function TJclEnumerationTypeInfo.GetBaseType: IJclEnumerationTypeInfo;
begin
  if TypeData.BaseType^ = TypeInfo then
    Result := Self
  else
    Result := TJclEnumerationTypeInfo.Create(TypeData.BaseType^);
end;

function TJclEnumerationTypeInfo.GetNames(const I: Integer): string;
var
  Base: IJclEnumerationTypeInfo;
  Idx: Integer;
  P: ^ShortString;
begin
  Base := BaseType;
  Idx := I;
  P := @Base.TypeData.NameList;
  while Idx <> 0 do
  begin
    Inc(Integer(P), Length(P^) + 1);
    Dec(Idx);
  end;
  Result := P^;
end;

{$IFDEF COMPILER6_UP}

function TJclEnumerationTypeInfo.GetUnitName: string;
var
  I: Integer;
  P: ^ShortString;
begin
  if BaseType.TypeInfo = TypeInfo then
  begin
    I := MaxValue - MinValue;
    P := @TypeData.NameList;
    while I >= 0 do
    begin
      Inc(Integer(P), Length(P^) + 1);
      Dec(I);
    end;
    Result := P^;
  end
  else
    Result := TypeData.NameList;
end;

{$ENDIF COMPILER6_UP}

function TJclEnumerationTypeInfo.IndexOfName(const Name: string): Integer;
begin
  Result := MaxValue;
  while (Result >= MinValue) and not AnsiSameText(Name, Names[Result]) do
    Dec(Result);
  if Result < MinValue then
    Result := -1;
end;

procedure TJclEnumerationTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  Idx: Integer;
  Prefix: string;
begin
  inherited WriteTo(Dest);
  {$IFDEF COMPILER6_UP}
  Dest.Writeln(LoadResString(@RsRTTIUnitName) + UnitName);
  {$ENDIF COMPILER6_UP}
  Dest.Write(LoadResString(@RsRTTINameList));
  Prefix := '(';
  for Idx := MinValue to MaxValue do
  begin
    Dest.Write(Prefix + Names[Idx]);
    Prefix := ', ';
  end;
  Dest.Writeln(')');
end;

procedure TJclEnumerationTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  Prefix: string;
  I: Integer;
begin
  if Name[1] <> '.' then
    Dest.Write(Name + ' = ');
  if BaseType.TypeInfo = TypeInfo then
  begin
    Dest.Write('(');
    Prefix := '';
    for I := MinValue to MaxValue do
    begin
      Dest.Write(Prefix + Names[I]);
      Prefix := ', ';
    end;
    Dest.Write(')');
  end
  else
    Dest.Write(Names[MinValue] + ' .. ' + Names[MaxValue]);
  if Name[1] <> '.' then
  begin
    Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType),
      TypeData.OrdType));
    Dest.Writeln('');
  end;
end;

//=== { TJclSetTypeInfo } ====================================================

type
  TJclSetTypeInfo = class(TJclOrdinalTypeInfo, IJclSetTypeInfo)
  protected
    function GetBaseType: IJclOrdinalTypeInfo;
    procedure GetAsList(const Value; const WantRanges: Boolean;
      const Strings: TStrings);
    procedure SetAsList(out Value; const Strings: TStrings);
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property BaseType: IJclOrdinalTypeInfo read GetBaseType;
  end;

function TJclSetTypeInfo.GetBaseType: IJclOrdinalTypeInfo;
begin
  Result := JclTypeInfo(TypeData.CompType^) as IJclOrdinalTypeInfo;
end;

procedure TJclSetTypeInfo.GetAsList(const Value; const WantRanges: Boolean;
  const Strings: TStrings);
var
  BaseInfo: IJclOrdinalRangeTypeInfo;
  FirstBit: Byte;
  LastBit: Byte;
  Bit: Byte;
  StartBit: Integer;

  procedure AddRange;
  var
    FirstOrdNum: Int64;
    LastOrdNum: Int64;
    OrdNum: Int64;
  begin
    FirstOrdNum := (StartBit - FirstBit) + BaseInfo.MinValue;
    LastOrdNum := (Bit - 1 - FirstBit) + BaseInfo.MinValue;
    if WantRanges and (LastOrdNum <> FirstOrdNum) then
    begin
      if BaseInfo.TypeKind = tkEnumeration then
        Strings.Add((BaseInfo as IJclEnumerationTypeInfo).Names[FirstOrdNum] +
          ' .. ' + (BaseInfo as IJclEnumerationTypeInfo).Names[LastOrdNum])
      else
        Strings.Add(IntToStr(FirstOrdNum) + ' .. ' + IntToStr(LastOrdNum));
    end
    else
    begin
      OrdNum := FirstOrdNum;
      while OrdNum <= LastOrdNum do
      begin
        if BaseInfo.TypeKind = tkEnumeration then
          Strings.Add((BaseInfo as IJclEnumerationTypeInfo).Names[OrdNum])
        else
          Strings.Add(IntToStr(OrdNum));
        Inc(OrdNum);
      end;
    end;
  end;

begin
  BaseInfo := BaseType as IJclOrdinalRangeTypeInfo;
  FirstBit := BaseInfo.MinValue mod 8;
  LastBit := BaseInfo.MaxValue - (BaseInfo.MinValue - FirstBit);
  Bit := FirstBit;
  StartBit := -1;
  Strings.BeginUpdate;
  try
    while Bit <= LastBit do
    begin
      if TestBitBuffer(Value, Bit) then
      begin
        if StartBit = -1 then
          StartBit := Bit;
      end
      else
      begin
        if StartBit <> -1 then
        begin
          AddRange;
          StartBit := -1;
        end;
      end;
      Inc(Bit);
    end;
    if StartBit <> -1 then
      AddRange;
  finally
    Strings.EndUpdate;
  end;
end;

procedure TJclSetTypeInfo.SetAsList(out Value; const Strings: TStrings);
var
  BaseInfo: IJclOrdinalRangeTypeInfo;
  FirstBit: Integer;
  I: Integer;
  FirstIdent: string;
  LastIdent: string;
  RangePos: Integer;
  FirstOrd: Int64;
  LastOrd: Int64;
  CurOrd: Integer;

  procedure ClearValue;
  var
    LastBit: Integer;
    ByteCount: Integer;
  begin
    LastBit := BaseInfo.MaxValue - BaseInfo.MinValue + 1 + FirstBit;
    ByteCount := (LastBit - FirstBit) div 8;