jclrtti.pas

East make Tray Icon in delphi

    for I := 0 to PropertyCount-1 do
    begin
      Prop := Properties[I];
      Dest.Writeln(Prop.Name + ': ' + Prop.PropType.Name);
      Dest.Indent;
      try
        if Prop.HasIndex then
          Dest.Writeln(Format(cFmt1, [LoadResString(@RsRTTIIndex), Prop.Index]));
        if Prop.HasDefault then
          Dest.Writeln(Format(cFmt1, [LoadResString(@RsRTTIDefault), Prop.Default]));
        case Prop.ReaderType of
          pskStaticMethod:
            Dest.Writeln(Format(cFmt2,
              [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIStaticMethod),
               Pointer(Prop.ReaderValue)]));
          pskField:
            Dest.Writeln(Format(cFmt2,
              [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIField),
               Pointer(Prop.ReaderValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format(cFmt2,
              [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIVirtualMethod),
               Pointer(Prop.ReaderValue)]));
        end;
        case Prop.WriterType of
          pskStaticMethod:
            Dest.Writeln(Format(cFmt2,
              [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIStaticMethod),
               Pointer(Prop.WriterValue)]));
          pskField:
            Dest.Writeln(Format(cFmt2,
              [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIField),
               Pointer(Prop.WriterValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format(cFmt2,
              [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIVirtualMethod),
               Pointer(Prop.WriterValue)]));
        end;
        case Prop.StoredType of
          pskConstant:
            if Boolean(Prop.StoredValue) then
              Dest.Writeln(Format(cFmt3,
                [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTITrue)]))
            else
              Dest.Writeln(Format(cFmt3,
                [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIFalse)]));
          pskStaticMethod:
            Dest.Writeln(Format(cFmt4,
              [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIStaticMethod),
               Pointer(Prop.StoredValue)]));
          pskField:
            Dest.Writeln(Format(cFmt4,
              [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIField),
               Pointer(Prop.StoredValue)]));
          pskVirtualMethod:
            Dest.Writeln(Format(cFmt4,
              [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIVirtualMethod),
               Pointer(Prop.StoredValue)]));
        end;
      finally
        Dest.Outdent;
      end;
    end;
  finally
    Dest.Outdent;
  end;
end;

procedure TJclClassTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  IntfTbl: PInterfaceTable;
  I: Integer;
  Prop: IJclPropInfo;
begin
  if (Parent <> nil) and not AnsiSameText(Parent.Name, 'TObject') then
  begin
    Dest.Write(Name + ' = class(' + Parent.Name);
    IntfTbl := ClassRef.GetInterfaceTable;
    if IntfTbl <> nil then
      for I := 0 to IntfTbl.EntryCount-1 do
        Dest.Write(', [''' + JclGUIDToString(IntfTbl.Entries[I].IID) + ''']');
    Dest.Writeln(') // unit ' + UnitName);
  end
  else
    Dest.Writeln(Name + ' = class // unit ' + UnitName);
  if PropertyCount > 0 then
  begin
    Dest.Writeln('published');
    Dest.Indent;
    try
      for I := 0 to PropertyCount-1 do
      begin
        Prop := Properties[I];
        Dest.Write('property ' + Prop.Name + ': ' +  Prop.PropType.Name);
        if Prop.HasIndex then
          Dest.Write(Format(' index %d', [Prop.Index]));

        case Prop.ReaderType of
          pskStaticMethod:
            Dest.Write(Format(' read [static method $%p]',
              [Pointer(Prop.ReaderValue)]));
          pskField:
            Dest.Write(Format(' read [field $%p]',
              [Pointer(Prop.ReaderValue)]));
          pskVirtualMethod:
            Dest.Write(Format(' read [virtual method $%p]',
              [Pointer(Prop.ReaderValue)]));
        end;

        case Prop.WriterType of
          pskStaticMethod:
            Dest.Write(Format(' write [static method $%p]',
              [Pointer(Prop.WriterValue)]));
          pskField:
            Dest.Write(Format(' write [field $%p]',
              [Pointer(Prop.WriterValue)]));
          pskVirtualMethod:
            Dest.Write(Format(' write [virtual method $%p]',
              [Pointer(Prop.WriterValue)]));
        end;

        case Prop.StoredType of
          pskConstant:
            if Boolean(Prop.StoredValue) then
              Dest.Write(' stored = True')
            else
              Dest.Write(' stored = False');
          pskStaticMethod:
            Dest.Write(Format(' stored = [static method $%p]',
              [Pointer(Prop.StoredValue)]));
          pskField:
            Dest.Write(Format(' stored = [field $%p]',
              [Pointer(Prop.StoredValue)]));
          pskVirtualMethod:
            Dest.Write(Format(' stored = [virtual method $%p]',
              [Pointer(Prop.StoredValue)]));
        end;
        if Prop.HasDefault then
          Dest.Write(' default ' + IntToStr(Prop.Default));
        Dest.Writeln(';');
      end;
    finally
      Dest.Outdent;
    end;
  end;
  Dest.Writeln('end;');
end;

//=== { TJclEventParamInfo } =================================================

type
  TJclEventParamInfo = class(TInterfacedObject, IJclEventParamInfo)
  private
    FParam: Pointer;
  protected
    function GetFlags: TParamFlags;
    function GetName: string;
    function GetRecSize: Integer;
    function GetTypeName: string;
    function GetParam: Pointer;
  public
    constructor Create(const AParam: Pointer);

    property Flags: TParamFlags read GetFlags;
    property Name: string read GetName;
    property RecSize: Integer read GetRecSize;
    property TypeName: string read GetTypeName;
    property Param: Pointer read GetParam;
  end;

constructor TJclEventParamInfo.Create(const AParam: Pointer);
begin
  inherited Create;
  FParam := AParam;
end;

function TJclEventParamInfo.GetFlags: TParamFlags;
begin
  Result := TParamFlags(PByte(Param)^);
end;

function TJclEventParamInfo.GetName: string;
var
  PName: PShortString;
begin
  PName := Param;
  Inc(Integer(PName));
  Result := PName^;
end;

function TJclEventParamInfo.GetRecSize: Integer;
begin
  Result := 3 + Length(Name) + Length(TypeName);
end;

function TJclEventParamInfo.GetTypeName: string;
var
  PName: PShortString;
begin
  PName := Param;
  Inc(Integer(PName));
  Inc(Integer(PName), PByte(PName)^ + 1);
  Result := PName^;
end;

function TJclEventParamInfo.GetParam: Pointer;
begin
  Result := FParam;
end;

//=== { TJclEventTypeInfo } ==================================================

type
  TJclEventTypeInfo = class(TJclTypeInfo, IJclEventTypeInfo)
  protected
    function GetMethodKind: TMethodKind;
    function GetParameterCount: Integer;
    function GetParameters(const ParamIdx: Integer): IJclEventParamInfo;
    function GetResultTypeName: string;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property MethodKind: TMethodKind read GetMethodKind;
    property ParameterCount: Integer read GetParameterCount;
    property Parameters[const ParamIdx: Integer]: IJclEventParamInfo
      read GetParameters;
    property ResultTypeName: string read GetResultTypeName;
  end;

function TJclEventTypeInfo.GetMethodKind: TMethodKind;
begin
  Result := TypeData.MethodKind;
end;

function TJclEventTypeInfo.GetParameterCount: Integer;
begin
  Result := TypeData.ParamCount;
end;

function TJclEventTypeInfo.GetParameters(const ParamIdx: Integer): IJclEventParamInfo;
var
  I: Integer;
  Param: Pointer;
begin
  Param := @TypeData.ParamList[0];
  I := ParamIdx;
  Result := nil;
  while I >= 0 do
  begin
    Result := TJclEventParamInfo.Create(Param);
    Inc(Integer(Param), Result.RecSize);
    Dec(I);
  end;
end;

function TJclEventTypeInfo.GetResultTypeName: string;
var
  LastParam: IJclEventParamInfo;
  ResPtr: PShortString;
begin
  if MethodKind = mkFunction then
  begin
    if ParameterCount > 0 then
    begin
      LastParam := Parameters[ParameterCount-1];
      ResPtr := Pointer(Longint(LastParam.Param) + LastParam.RecSize);
    end
    else
      ResPtr := @TypeData.ParamList[0];
    Result := ResPtr^;
  end
  else
    Result := '';
end;

procedure TJclEventTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  I: Integer;
  Param: IJclEventParamInfo;
  ParamFlags: TParamFlags;
begin
  inherited WriteTo(Dest);
  Dest.Writeln(LoadResString(@RsRTTIMethodKind) +
    JclEnumValueToIdent(System.TypeInfo(TMethodKind), TypeData.MethodKind));
  Dest.Writeln(LoadResString(@RsRTTIParamCount) + IntToStr(ParameterCount));
  Dest.Indent;
  try
    for I := 0 to ParameterCount-1 do
    begin
      if I > 0 then
        Dest.Writeln('');
      Param := Parameters[I];
      ParamFlags := Param.Flags;
      Dest.Writeln(LoadResString(@RsRTTIName) + Param.Name);
      Dest.Writeln(LoadResString(@RsRTTIType) + Param.TypeName);
      Dest.Writeln(LoadResString(@RsRTTIFlags) +
        JclSetToStr(System.TypeInfo(TParamFlags), ParamFlags, True, False));
    end;
  finally
    Dest.Outdent;
  end;
  if MethodKind = mkFunction then
    Dest.Writeln(LoadResString(@RsRTTIReturnType) + ResultTypeName);
end;

procedure TJclEventTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
var
  Prefix: string;
  I: Integer;
  Param: IJclEventParamInfo;
begin
  Dest.Write(Name + ' = ');
  if MethodKind = mkFunction then
    Dest.Write('function')
  else
    Dest.Write('procedure');
  Prefix := '(';
  for I := 0 to ParameterCount-1 do
  begin
    Dest.Write(Prefix);
    Prefix := '; ';
    Param := Parameters[I];
    if pfVar in Param.Flags then
      Dest.Write(LoadResString(@RsRTTIVar))
    else
    if pfConst in Param.Flags then
      Dest.Write(LoadResString(@RsRTTIConst))
    else
    if pfOut in Param.Flags then
      Dest.Write(LoadResString(@RsRTTIOut));
    Dest.Write(Param.Name);
    if Param.TypeName <> '' then
    begin
      Dest.Write(': ');
      if pfArray in Param.Flags then
        Dest.Write(LoadResString(@RsRTTIArrayOf));
      if AnsiSameText(Param.TypeName, 'TVarRec') and (pfArray in Param.Flags) then
        Dest.Write(TrimRight(LoadResString(@RsRTTIConst)))
      else
        Dest.Write(Param.TypeName);
    end;
  end;
  if ParameterCount <> 0 then
    Dest.Write(')');
  if MethodKind = mkFunction then
    Dest.Write(': ' + ResultTypeName);
  Dest.Writeln(' of object;');
end;

//=== { TJclInterfaceTypeInfo } ==============================================

type
  TJclInterfaceTypeInfo = class(TJclTypeInfo, IJclInterfaceTypeInfo)
  protected
    function GetParent: IJclInterfaceTypeInfo;
    function GetFlags: TIntfFlagsBase;
    function GetGUID: TGUID;
    {$IFDEF COMPILER6_UP}
    function GetPropertyCount: Integer;
    {$ENDIF COMPILER6_UP}
    function GetUnitName: string;
    procedure WriteTo(const Dest: IJclInfoWriter); override;
    procedure DeclarationTo(const Dest: IJclInfoWriter); override;
  public
    property Parent: IJclInterfaceTypeInfo read GetParent;
    property Flags: TIntfFlagsBase read GetFlags;
    property GUID: TGUID read GetGUID;
    {$IFDEF COMPILER6_UP}
    property PropertyCount: Integer read GetPropertyCount;
    {$ENDIF COMPILER6_UP}
    property UnitName: string read GetUnitName;
  end;

function TJclInterfaceTypeInfo.GetParent: IJclInterfaceTypeInfo;
begin
  if (TypeData.IntfParent <> nil) and (TypeData.IntfParent^ <> nil) then
    Result := JclTypeInfo(TypeData.IntfParent^) as IJclInterfaceTypeInfo
  else
    Result := nil;
end;

function TJclInterfaceTypeInfo.GetFlags: TIntfFlagsBase;
begin
  Result := TypeData.IntfFlags;
end;

const
  NullGUID: TGUID = '{00000000-0000-0000-0000-000000000000}';

function TJclInterfaceTypeInfo.GetGUID: TGUID;
begin
  if ifHasGuid in Flags then
    Result := TypeData.Guid
  else
    Result := NullGUID;
end;

{$IFDEF COMPILER6_UP}
function TJclInterfaceTypeInfo.GetPropertyCount: Integer;
var
  PropData: ^TPropData;
begin
  PropData := @TypeData.IntfUnit;
  Inc(Integer(PropData), 1 + Length(UnitName));
  Result := PropData.PropCount;
end;
{$ENDIF COMPILER6_UP}

function TJclInterfaceTypeInfo.GetUnitName: string;
begin
  Result := TypeData.IntfUnit;
end;

procedure TJclInterfaceTypeInfo.WriteTo(const Dest: IJclInfoWriter);
var
  IntfFlags: TIntfFlagsBase;
begin
  inherited WriteTo(Dest);
  if ifHasGuid in Flags then
    Dest.Writeln(LoadResString(@RsRTTIGUID) + JclGuidToString(GUID));
  IntfFlags := Flags;
  Dest.Writeln(LoadResString(@RsRTTIFlags) + JclSetToStr(System.TypeInfo(TIntfFlagsBase),
    IntfFlags, True, False));
  Dest.Writeln(LoadResString(@RsRTTIUnitName) + UnitName);
  if Parent <> nil then
    Dest.Writeln(LoadResString(@RsRTTIParent) + Parent.Name);
  {$IFDEF COMPILER6_UP}
  Dest.Writeln(LoadResString(@RsRTTIPropCount) + IntToStr(PropertyCount));
  {$ENDIF COMPILER6_UP}
end;

procedure TJclInterfaceTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
begin
  Dest.Write(Name + ' = ');