3083 lines
89 KiB
ObjectPascal
3083 lines
89 KiB
ObjectPascal
{**************************************************************************************************}
|
|
{ }
|
|
{ Project JEDI Code Library (JCL) }
|
|
{ }
|
|
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
|
|
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
|
|
{ License at http://www.mozilla.org/MPL/ }
|
|
{ }
|
|
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
|
|
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
|
|
{ and limitations under the License. }
|
|
{ }
|
|
{ The Original Code is JclRTTI.pas. }
|
|
{ }
|
|
{ The Initial Developer of the Original Code is Marcel Bestebroer. }
|
|
{ Portions created Marcel Bestebroer are Copyright (C) Marcel Bestebroer. All rights reserved. }
|
|
{ }
|
|
{ Contributor(s): }
|
|
{ Theo Bebekis }
|
|
{ Marcel Bestebroer (marcelb) }
|
|
{ Robert Marquardt (marquardt) }
|
|
{ Robert Rossmair (rrossmair) }
|
|
{ Matthias Thoma (mthoma) }
|
|
{ Petr Vones (pvones) }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
{ }
|
|
{ Various RunTime Type Information routines. Includes retrieving RTTI information for different }
|
|
{ types, declaring/generating new types, data conversion to user displayable values and 'is'/'as' }
|
|
{ operator hooking. }
|
|
{ }
|
|
{ Unit owner: Marcel Bestebroer }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
|
|
// Last modified: $Date: 2005/05/05 20:08:44 $
|
|
// For history see end of file
|
|
|
|
unit JclRTTI;
|
|
|
|
{$I jcl.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF HAS_UNIT_TYPES}
|
|
Types,
|
|
{$IFDEF CLR}
|
|
System.Runtime.InteropServices, System.Reflection, System.ComponentModel,
|
|
Variants,
|
|
{$ELSE}
|
|
{$IFDEF SUPPORTS_INLINE}
|
|
Windows,
|
|
{$ENDIF SUPPORTS_INLINE}
|
|
{$ENDIF CLR}
|
|
{$ELSE}
|
|
Windows,
|
|
{$ENDIF HAS_UNIT_TYPES}
|
|
Classes, SysUtils, TypInfo,
|
|
JclBase;
|
|
|
|
type
|
|
// TypeInfo writing
|
|
IJclInfoWriter = interface
|
|
['{7DAD522D-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetWrap: Integer;
|
|
procedure SetWrap(const Value: Integer);
|
|
procedure Write(const S: string);
|
|
procedure Writeln(const S: string = '');
|
|
procedure Indent;
|
|
procedure Outdent;
|
|
property Wrap: Integer read GetWrap write SetWrap;
|
|
end;
|
|
|
|
TJclInfoWriter = class(TInterfacedObject, IJclInfoWriter)
|
|
private
|
|
FCurLine: string;
|
|
FIndentLevel: Integer;
|
|
FWrap: Integer;
|
|
protected
|
|
function GetWrap: Integer;
|
|
procedure SetWrap(const Value: Integer);
|
|
procedure DoWrap;
|
|
procedure DoWriteCompleteLines;
|
|
procedure PrimWrite(const S: string); virtual; abstract;
|
|
|
|
property CurLine: string read FCurLine write FCurLine;
|
|
property IndentLevel: Integer read FIndentLevel write FIndentLevel;
|
|
public
|
|
constructor Create(const AWrap: Integer = 80);
|
|
destructor Destroy; override;
|
|
procedure Indent;
|
|
procedure Outdent;
|
|
procedure Write(const S: string);
|
|
procedure Writeln(const S: string = '');
|
|
|
|
property Wrap: Integer read GetWrap write SetWrap;
|
|
end;
|
|
|
|
TJclInfoStringsWriter = class(TJclInfoWriter)
|
|
private
|
|
FStrings: TStrings;
|
|
protected
|
|
procedure PrimWrite(const S: string); override;
|
|
public
|
|
constructor Create(const AStrings: TStrings; const AWrap: Integer = 80);
|
|
|
|
property Strings: TStrings read FStrings;
|
|
end;
|
|
|
|
// TypeInfo retrieval
|
|
IJclBaseInfo = interface
|
|
procedure WriteTo(const Dest: IJclInfoWriter);
|
|
procedure DeclarationTo(const Dest: IJclInfoWriter);
|
|
end;
|
|
|
|
IJclTypeInfo = interface(IJclBaseInfo)
|
|
['{7DAD5220-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetName: string;
|
|
function GetTypeData: PTypeData;
|
|
function GetTypeInfo: PTypeInfo;
|
|
function GetTypeKind: TTypeKind;
|
|
|
|
property Name: string read GetName;
|
|
property TypeData: PTypeData read GetTypeData;
|
|
property TypeInfo: PTypeInfo read GetTypeInfo;
|
|
property TypeKind: TTypeKind read GetTypeKind;
|
|
end;
|
|
|
|
// Ordinal types
|
|
IJclOrdinalTypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD5221-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetOrdinalType: TOrdType;
|
|
|
|
property OrdinalType: TOrdType read GetOrdinalType;
|
|
end;
|
|
|
|
IJclOrdinalRangeTypeInfo = interface(IJclOrdinalTypeInfo)
|
|
['{7DAD5222-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetMinValue: Int64;
|
|
function GetMaxValue: Int64;
|
|
|
|
property MinValue: Int64 read GetMinValue;
|
|
property MaxValue: Int64 read GetMaxValue;
|
|
end;
|
|
|
|
IJclEnumerationTypeInfo = interface(IJclOrdinalRangeTypeInfo)
|
|
['{7DAD5223-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetBaseType: IJclEnumerationTypeInfo;
|
|
function GetNames(const I: Integer): string;
|
|
{$IFDEF RTL140_UP}
|
|
function GetUnitName: string;
|
|
{$ENDIF RTL140_UP}
|
|
|
|
function IndexOfName(const Name: string): Integer;
|
|
|
|
property BaseType: IJclEnumerationTypeInfo read GetBaseType;
|
|
property Names[const I: Integer]: string read GetNames; default;
|
|
{$IFDEF RTL140_UP}
|
|
property UnitName: string read GetUnitName;
|
|
{$ENDIF RTL140_UP}
|
|
end;
|
|
|
|
IJclSetTypeInfo = interface(IJclOrdinalTypeInfo)
|
|
['{7DAD5224-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetBaseType: IJclOrdinalTypeInfo;
|
|
|
|
procedure GetAsList(const Value; const WantRanges: Boolean;
|
|
const Strings: TStrings);
|
|
procedure SetAsList(out Value; const Strings: TStrings);
|
|
|
|
property BaseType: IJclOrdinalTypeInfo read GetBaseType;
|
|
end;
|
|
|
|
// Float types
|
|
IJclFloatTypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD5225-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetFloatType: TFloatType;
|
|
|
|
property FloatType: TFloatType read GetFloatType;
|
|
end;
|
|
|
|
// Short string types
|
|
IJclStringTypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD5226-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetMaxLength: Integer;
|
|
|
|
property MaxLength: Integer read GetMaxLength;
|
|
end;
|
|
|
|
// Class types
|
|
TJclPropSpecKind = (pskNone, pskStaticMethod, pskVirtualMethod, pskField,
|
|
pskConstant);
|
|
|
|
IJclPropInfo = interface
|
|
['{7DAD5227-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetPropType: IJclTypeInfo;
|
|
function GetReader: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
function GetWriter: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
function GetStoredProc: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
function GetIndex: Integer;
|
|
function GetDefault: Longint;
|
|
function GetNameIndex: Smallint;
|
|
function GetName: string;
|
|
function GetReaderType: TJclPropSpecKind;
|
|
function GetWriterType: TJclPropSpecKind;
|
|
function GetStoredType: TJclPropSpecKind;
|
|
function GetReaderValue: Integer;
|
|
function GetWriterValue: Integer;
|
|
function GetStoredValue: Integer;
|
|
|
|
function IsStored(const AInstance: TObject): Boolean;
|
|
function HasDefault: Boolean;
|
|
function HasIndex: Boolean;
|
|
|
|
property PropType: IJclTypeInfo read GetPropType;
|
|
property Reader: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF} read GetReader;
|
|
property Writer: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF} read GetWriter;
|
|
property StoredProc: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF} 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;
|
|
|
|
IJclClassTypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD5228-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetClassRef: TClass;
|
|
function GetParent: IJclClassTypeInfo;
|
|
function GetTotalPropertyCount: Integer;
|
|
function GetPropertyCount: Integer;
|
|
function GetProperties(const PropIdx: Integer): IJclPropInfo;
|
|
function GetPropNames(const Name: string): IJclPropInfo;
|
|
function GetUnitName: string;
|
|
|
|
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 PropNames[const Name: string]: IJclPropInfo read GetPropNames;
|
|
property UnitName: string read GetUnitName;
|
|
end;
|
|
|
|
// Event types
|
|
IJclEventParamInfo = interface
|
|
['{7DAD5229-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetFlags: TParamFlags;
|
|
function GetName: string;
|
|
{$IFNDEF CLR}
|
|
function GetRecSize: Integer;
|
|
{$ENDIF ~CLR}
|
|
function GetTypeName: string;
|
|
function GetParam: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF};
|
|
|
|
property Flags: TParamFlags read GetFlags;
|
|
property Name: string read GetName;
|
|
{$IFNDEF CLR}
|
|
property RecSize: Integer read GetRecSize;
|
|
{$ENDIF ~CLR}
|
|
property TypeName: string read GetTypeName;
|
|
property Param: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF} read GetParam;
|
|
end;
|
|
|
|
IJclEventTypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD522A-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetMethodKind: TMethodKind;
|
|
function GetParameterCount: Integer;
|
|
function GetParameters(const ParamIdx: Integer): IJclEventParamInfo;
|
|
function GetResultTypeName: string;
|
|
|
|
property MethodKind: TMethodKind read GetMethodKind;
|
|
property ParameterCount: Integer read GetParameterCount;
|
|
property Parameters[const ParamIdx: Integer]: IJclEventParamInfo
|
|
read GetParameters;
|
|
property ResultTypeName: string read GetResultTypeName;
|
|
end;
|
|
|
|
// Interface types
|
|
IJclInterfaceTypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD522B-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetParent: IJclInterfaceTypeInfo;
|
|
function GetFlags: TIntfFlagsBase;
|
|
function GetGUID: TGUID;
|
|
{$IFDEF RTL140_UP}
|
|
function GetPropertyCount: Integer;
|
|
{$ENDIF RTL140_UP}
|
|
function GetUnitName: string;
|
|
|
|
property Parent: IJclInterfaceTypeInfo read GetParent;
|
|
property Flags: TIntfFlagsBase read GetFlags;
|
|
property GUID: TGUID read GetGUID;
|
|
{$IFDEF RTL140_UP}
|
|
property PropertyCount: Integer read GetPropertyCount;
|
|
{$ENDIF RTL140_UP}
|
|
property UnitName: string read GetUnitName;
|
|
end;
|
|
|
|
// Int64 types
|
|
IJclInt64TypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD522C-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetMinValue: Int64;
|
|
function GetMaxValue: Int64;
|
|
|
|
property MinValue: Int64 read GetMinValue;
|
|
property MaxValue: Int64 read GetMaxValue;
|
|
end;
|
|
|
|
{$IFDEF RTL140_UP}
|
|
// Dynamic array types
|
|
IJclDynArrayTypeInfo = interface(IJclTypeInfo)
|
|
['{7DAD522E-46EA-11D5-B0C0-4854E825F345}']
|
|
function GetElementSize: Longint;
|
|
function GetElementType: IJclTypeInfo;
|
|
function GetElementsNeedCleanup: Boolean;
|
|
function GetVarType: Integer;
|
|
function GetUnitName: string;
|
|
|
|
property ElementSize: Longint read GetElementSize;
|
|
property ElementType: IJclTypeInfo read GetElementType;
|
|
property ElementsNeedCleanup: Boolean read GetElementsNeedCleanup;
|
|
property VarType: Integer read GetVarType;
|
|
property UnitName: string read GetUnitName;
|
|
end;
|
|
{$ENDIF RTL140_UP}
|
|
|
|
EJclRTTIError = class(EJclError);
|
|
|
|
function JclTypeInfo(ATypeInfo: PTypeInfo): IJclTypeInfo;
|
|
|
|
// Enumeration types
|
|
const
|
|
PREFIX_CUT_LOWERCASE = 255;
|
|
PREFIX_CUT_EQUAL = 254;
|
|
|
|
MaxPrefixCut = 250;
|
|
|
|
function JclEnumValueToIdent(TypeInfo: PTypeInfo; const Value): string;
|
|
{$IFNDEF CLR}
|
|
function JclGenerateEnumType(const TypeName: ShortString;
|
|
const Literals: array of string): PTypeInfo;
|
|
function JclGenerateEnumTypeBasedOn(const TypeName: ShortString;
|
|
BaseType: PTypeInfo; const PrefixCut: Byte): PTypeInfo;
|
|
function JclGenerateSubRange(BaseType: PTypeInfo; const TypeName: string;
|
|
const MinValue, MaxValue: Integer): PTypeInfo;
|
|
{$ENDIF ~CLR}
|
|
|
|
// Integer types
|
|
function JclStrToTypedInt(Value: string; TypeInfo: PTypeInfo): Integer;
|
|
function JclTypedIntToStr(Value: Integer; TypeInfo: PTypeInfo): string;
|
|
|
|
// Sets
|
|
function JclSetToList(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean;
|
|
const WantRanges: Boolean; const Strings: TStrings): string;
|
|
function JclSetToStr(TypeInfo: PTypeInfo; const Value;
|
|
const WantBrackets: Boolean = False; const WantRanges: Boolean = False): string;
|
|
procedure JclStrToSet(TypeInfo: PTypeInfo; var SetVar; const Value: string);
|
|
procedure JclIntToSet(TypeInfo: PTypeInfo; var SetVar; const Value: Integer);
|
|
function JclSetToInt(TypeInfo: PTypeInfo; const SetVar): Integer;
|
|
{$IFNDEF CLR}
|
|
function JclGenerateSetType(BaseType: PTypeInfo; const TypeName: ShortString): PTypeInfo;
|
|
{$ENDIF ~CLR}
|
|
|
|
{$IFNDEF CLR}
|
|
// User generated type info managment
|
|
procedure RemoveTypeInfo(TypeInfo: PTypeInfo);
|
|
{$ENDIF ~CLR}
|
|
|
|
// Is/As hooking
|
|
function JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;
|
|
function JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean;
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFDEF HAS_UNIT_RTLCONSTS}
|
|
RtlConsts,
|
|
{$ENDIF HAS_UNIT_RTLCONSTS}
|
|
SysConst,
|
|
JclLogic, JclResources, JclStrings, JclSysUtils;
|
|
|
|
//=== { TJclInfoWriter } =====================================================
|
|
|
|
constructor TJclInfoWriter.Create(const AWrap: Integer);
|
|
begin
|
|
inherited Create;
|
|
Wrap := AWrap;
|
|
end;
|
|
|
|
destructor TJclInfoWriter.Destroy;
|
|
begin
|
|
if CurLine <> '' then
|
|
Writeln('');
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclInfoWriter.GetWrap: Integer;
|
|
begin
|
|
Result := FWrap;
|
|
end;
|
|
|
|
procedure TJclInfoWriter.SetWrap(const Value: Integer);
|
|
begin
|
|
FWrap := Value;
|
|
end;
|
|
|
|
procedure TJclInfoWriter.DoWrap;
|
|
const
|
|
{$IFDEF CLR}
|
|
WrapChars: array[0..33] of Char = (
|
|
#0, #1, #2, #3, #4, #5, #6, #7, #8, #9, #10, #11, #12, #13, #14, #15,
|
|
#16, #17, #18, #19, #20, #21, #22, #23, #24, #25, #26, #27, #28, #29,
|
|
#30, #31, #32, '-');
|
|
{$ELSE}
|
|
WrapChars = [#0..' ', '-'];
|
|
{$ENDIF CLR}
|
|
var
|
|
TmpLines: TStringList;
|
|
I: Integer;
|
|
TmpLines2: TStringList;
|
|
EndedInCRLF: Boolean;
|
|
LineBreakLength: Integer;
|
|
begin
|
|
LineBreakLength := Length(AnsiLineBreak);
|
|
EndedInCRLF := Copy(CurLine, Length(CurLine) - LineBreakLength + 1, LineBreakLength) = AnsiLineBreak;
|
|
TmpLines := TStringList.Create;
|
|
try
|
|
TmpLines.Text := CurLine;
|
|
TmpLines2 := TStringList.Create;
|
|
try
|
|
I := TmpLines.Count-1;
|
|
if not EndedInCRLF then
|
|
Dec(I);
|
|
while I >= 0 do
|
|
begin
|
|
TmpLines[I] := StringOfChar(' ', 2 * IndentLevel) + TmpLines[I];
|
|
if (Wrap > 0) and (Length(TmpLines[I]) > Wrap) then
|
|
begin
|
|
TmpLines2.Text := WrapText(
|
|
TmpLines[I],
|
|
AnsiLineBreak + StringOfChar(' ', 2 * (IndentLevel+1)),
|
|
WrapChars,
|
|
Wrap);
|
|
TmpLines.Delete(I);
|
|
TmpLines.Insert(I, Copy(TmpLines2.Text, 1,
|
|
Length(TmpLines2.Text) - 2));
|
|
end;
|
|
Dec(I);
|
|
end;
|
|
CurLine := TmpLines.Text;
|
|
if not EndedInCRLF then
|
|
Delete(FCurLine, Length(FCurLine) - LineBreakLength + 1, LineBreakLength);
|
|
finally
|
|
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
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIName + Name);
|
|
Dest.Writeln(RsRTTITypeKind + JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TTypeKind),
|
|
TypeInfo.Kind));
|
|
Dest.Writeln(Format(RsRTTITypeInfoAt, [TypeInfo]));
|
|
{$ELSE}
|
|
Dest.Writeln(LoadResString(@RsRTTIName) + Name);
|
|
Dest.Writeln(LoadResString(@RsRTTITypeKind) + JclEnumValueToIdent(System.TypeInfo(TTypeKind),
|
|
TypeInfo.Kind));
|
|
Dest.Writeln(Format(LoadResString(@RsRTTITypeInfoAt), [TypeInfo]));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
procedure TJclTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
|
|
begin
|
|
{$IFDEF CLR}
|
|
Dest.Write(Format(RsDeclarationFormat, [Name]));
|
|
{$ELSE}
|
|
Dest.Write(Format(LoadResString(@RsDeclarationFormat), [Name]));
|
|
{$ENDIF CLR}
|
|
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);
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIOrdinalType +
|
|
JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ELSE}
|
|
Dest.Writeln(LoadResString(@RsRTTIOrdinalType) +
|
|
JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ENDIF CLR}
|
|
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);
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIMinValue + IntToStr(MinValue));
|
|
Dest.Writeln(RsRTTIMaxValue + IntToStr(MaxValue));
|
|
{$ELSE}
|
|
Dest.Writeln(LoadResString(@RsRTTIMinValue) + IntToStr(MinValue));
|
|
Dest.Writeln(LoadResString(@RsRTTIMaxValue) + IntToStr(MaxValue));
|
|
{$ENDIF CLR}
|
|
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));
|
|
{$IFDEF CLR}
|
|
Dest.Writeln('; // ' + JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ELSE}
|
|
Dest.Writeln('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
//=== { TJclEnumerationTypeInfo } ============================================
|
|
|
|
type
|
|
TJclEnumerationTypeInfo = class(TJclOrdinalRangeTypeInfo, IJclEnumerationTypeInfo)
|
|
protected
|
|
function GetBaseType: IJclEnumerationTypeInfo;
|
|
function GetNames(const I: Integer): string;
|
|
{$IFDEF RTL140_UP}
|
|
function GetUnitName: string;
|
|
{$ENDIF RTL140_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 RTL140_UP}
|
|
property UnitName: string read GetUnitName;
|
|
{$ENDIF RTL140_UP}
|
|
end;
|
|
|
|
function TJclEnumerationTypeInfo.GetBaseType: IJclEnumerationTypeInfo;
|
|
begin
|
|
{$IFDEF CLR}
|
|
if TypeData.ParentInfo = TypeInfo then
|
|
Result := Self
|
|
else
|
|
Result := TJclEnumerationTypeInfo.Create(TypeData.ParentInfo);
|
|
{$ELSE}
|
|
if TypeData.BaseType^ = TypeInfo then
|
|
Result := Self
|
|
else
|
|
Result := TJclEnumerationTypeInfo.Create(TypeData.BaseType^);
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclEnumerationTypeInfo.GetNames(const I: Integer): string;
|
|
var
|
|
Base: IJclEnumerationTypeInfo;
|
|
{$IFNDEF CLR}
|
|
Idx: Integer;
|
|
P: ^ShortString;
|
|
{$ENDIF ~CLR}
|
|
begin
|
|
Base := BaseType;
|
|
{$IFDEF CLR}
|
|
if (I >= 0) and (I < Length(Enum.GetNames(Base.TypeInfo))) then
|
|
Result := Enum.GetNames(Base.TypeInfo)[I]
|
|
else
|
|
Result := '';
|
|
{$ELSE}
|
|
Idx := I;
|
|
P := @Base.TypeData.NameList;
|
|
while Idx <> 0 do
|
|
begin
|
|
Inc(Integer(P), Length(P^) + 1);
|
|
Dec(Idx);
|
|
end;
|
|
Result := P^;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
{$IFDEF RTL140_UP}
|
|
|
|
function TJclEnumerationTypeInfo.GetUnitName: string;
|
|
{$IFDEF CLR}
|
|
begin
|
|
Result := BaseType.TypeData.EnumUnitName;
|
|
end;
|
|
{$ELSE}
|
|
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 CLR}
|
|
|
|
{$ENDIF RTL140_UP}
|
|
|
|
function TJclEnumerationTypeInfo.IndexOfName(const Name: string): Integer;
|
|
begin
|
|
Result := MaxValue;
|
|
while (Result >= MinValue) and
|
|
{$IFDEF CLR}
|
|
not SameText(Name, Names[Result]) do
|
|
{$ELSE}
|
|
not AnsiSameText(Name, Names[Result]) do
|
|
{$ENDIF CLR}
|
|
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 CLR}
|
|
Dest.Writeln(RsRTTIUnitName + UnitName);
|
|
Dest.Write(RsRTTINameList);
|
|
{$ELSE}
|
|
{$IFDEF RTL140_UP}
|
|
Dest.Writeln(LoadResString(@RsRTTIUnitName) + UnitName);
|
|
{$ENDIF RTL140_UP}
|
|
Dest.Write(LoadResString(@RsRTTINameList));
|
|
{$ENDIF CLR}
|
|
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
|
|
{$IFDEF CLR}
|
|
Dest.Write('; // ' + JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ELSE}
|
|
Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ENDIF CLR}
|
|
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
|
|
{$IFDEF CLR}
|
|
Result := JclTypeInfo(TypeData.CompType) as IJclOrdinalTypeInfo;
|
|
{$ELSE}
|
|
Result := JclTypeInfo(TypeData.CompType^) as IJclOrdinalTypeInfo;
|
|
{$ENDIF CLR}
|
|
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;
|
|
if LastBit mod 8 <> 0 then
|
|
Inc(ByteCount);
|
|
{$IFDEF CLR}
|
|
// "set of" is a "array of Byte"
|
|
while ByteCount > 0 do
|
|
TDynByteArray(Value)[ByteCount - 1] := 0;
|
|
{$ELSE}
|
|
FillChar(Value, ByteCount, 0);
|
|
{$ENDIF CLR}
|
|
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);
|
|
{$IFDEF CLR}
|
|
if FirstOrd = -1 then
|
|
raise EJclRTTIError.CreateFmt(RsRTTIUnknownIdentifier, [FirstIdent]);
|
|
if LastOrd = -1 then
|
|
raise EJclRTTIError.CreateFmt(RsRTTIUnknownIdentifier, [LastIdent]);
|
|
{$ELSE}
|
|
if FirstOrd = -1 then
|
|
raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [FirstIdent]);
|
|
if LastOrd = -1 then
|
|
raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [LastIdent]);
|
|
{$ENDIF CLR}
|
|
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);
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIBasedOn);
|
|
{$ELSE}
|
|
Dest.Writeln(LoadResString(@RsRTTIBasedOn));
|
|
{$ENDIF CLR}
|
|
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
|
|
{$IFDEF CLR}
|
|
if Supports(Base, IJclEnumerationTypeInfo, BaseEnum) then
|
|
BaseEnum.DeclarationTo(Dest)
|
|
else
|
|
Dest.Write(RsRTTITypeError);
|
|
{$ELSE}
|
|
if Base.QueryInterface(IJclEnumerationTypeInfo, BaseEnum) = S_OK then
|
|
BaseEnum.DeclarationTo(Dest)
|
|
else
|
|
Dest.Write(LoadResString(@RsRTTITypeError));
|
|
{$ENDIF CLR}
|
|
end
|
|
else
|
|
Dest.Write(Base.Name);
|
|
if Name[1] <> '.' then
|
|
begin
|
|
{$IFDEF CLR}
|
|
Dest.Write('; // ' + JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ELSE}
|
|
Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));
|
|
{$ENDIF CLR}
|
|
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);
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIFloatType +
|
|
JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TFloatType), TypeData.FloatType));
|
|
{$ELSE}
|
|
Dest.Writeln(LoadResString(@RsRTTIFloatType) +
|
|
JclEnumValueToIdent(System.TypeInfo(TFloatType), TypeData.FloatType));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
procedure TJclFloatTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
|
|
var
|
|
S: string;
|
|
FT: TFloatType;
|
|
begin
|
|
FT := FloatType;
|
|
{$IFDEF CLR}
|
|
S := StrRestOf(JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TFloatType), FT), 3);
|
|
{$ELSE}
|
|
S := StrRestOf(JclEnumValueToIdent(System.TypeInfo(TFloatType), FT), 3);
|
|
{$ENDIF CLR}
|
|
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);
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIMaxLen + IntToStr(MaxLength));
|
|
{$ELSE}
|
|
Dest.Writeln(LoadResString(@RsRTTIMaxLen) + IntToStr(MaxLength));
|
|
{$ENDIF CLR}
|
|
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: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
function GetWriter: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
function GetStoredProc: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
function GetIndex: Integer;
|
|
function GetDefault: Longint;
|
|
function GetNameIndex: Smallint;
|
|
function GetName: string;
|
|
{$IFDEF CLR}
|
|
function MethodInfoToPropSecpKind(Info: MethodInfo): TJclPropSpecKind;
|
|
{$ENDIF CLR}
|
|
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: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF} read GetReader;
|
|
property Writer: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF} read GetWriter;
|
|
property StoredProc: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF} 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
|
|
{$IFDEF CLR}
|
|
Result := JclTypeInfo(PropInfo.PropType);
|
|
{$ELSE}
|
|
Result := JclTypeInfo(PropInfo.PropType^);
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetReader: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := (PropInfo as PropertyInfo).GetGetMethod;
|
|
{$ELSE}
|
|
Result := PropInfo.GetProc;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetWriter: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := (PropInfo as PropertyInfo).GetSetMethod;
|
|
{$ELSE}
|
|
Result := PropInfo.SetProc;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetStoredProc: {$IFDEF CLR}MethodInfo{$ELSE}Pointer{$ENDIF};
|
|
{$IFDEF CLR}
|
|
var
|
|
I: Integer;
|
|
Accessors: array of MethodInfo;
|
|
Attributes: array of Attribute;
|
|
begin
|
|
Result := nil;
|
|
Attributes := Attribute.GetCustomAttributes(PropInfo, True);
|
|
|
|
// .NET serializing system: NonSerializedAttribute
|
|
for I := 0 to Length(Attributes) - 1 do
|
|
if Attributes[I] is NonSerializedAttribute then
|
|
Exit;
|
|
|
|
// .NET form designer storage: DesignerSerializationVisibilityAttribute
|
|
for I := 0 to Length(Attributes) - 1 do
|
|
if Attributes[I] is DesignerSerializationVisibilityAttribute then
|
|
Exit;
|
|
|
|
if PropInfo is PropertyInfo then
|
|
begin
|
|
Accessors := PropertyInfo(PropInfo).GetAccessors;
|
|
for I := 0 to High(Accessors) do
|
|
begin
|
|
if Accessors[I].ReturnType.Equals(TypeOf(System.Boolean)) and
|
|
Accessors[I].Name.StartsWith('stored_') then
|
|
begin
|
|
Result := Accessors[I];
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
Result := PropInfo.StoredProc;
|
|
end;
|
|
{$ENDIF CLR}
|
|
|
|
function TJclPropInfo.GetIndex: Integer;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Integer($8000000);
|
|
{$ELSE}
|
|
Result := PropInfo.Index;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetDefault: Longint;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := GetOrdPropDefault(PropInfo);
|
|
{$ELSE}
|
|
Result := PropInfo.Default;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetNameIndex: Smallint;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := 0;
|
|
{$ELSE}
|
|
Result := PropInfo.NameIndex;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetName: string;
|
|
begin
|
|
Result := PropInfo.Name;
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
function TJclPropInfo.MethodInfoToPropSecpKind(Info: MethodInfo): TJclPropSpecKind;
|
|
begin
|
|
if Info.IsStatic then
|
|
Result := pskStaticMethod
|
|
else
|
|
if Info.IsVirtual then
|
|
Result := pskVirtualMethod
|
|
else
|
|
Result := pskNone;
|
|
end;
|
|
{$ENDIF CLR}
|
|
|
|
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
|
|
{$IFDEF CLR}
|
|
Result := MethodInfoToPropSecpKind(Reader);
|
|
{$ELSE}
|
|
Result := GetSpecKind(Integer(Reader));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetWriterType: TJclPropSpecKind;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := MethodInfoToPropSecpKind(Writer);
|
|
{$ELSE}
|
|
Result := GetSpecKind(Integer(Writer));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetStoredType: TJclPropSpecKind;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := MethodInfoToPropSecpKind(StoredProc);
|
|
{$ELSE}
|
|
Result := GetSpecKind(Integer(StoredProc));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetReaderValue: Integer;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := 0;
|
|
{$ELSE}
|
|
Result := GetSpecValue(Integer(Reader));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetWriterValue: Integer;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := 0;
|
|
{$ELSE}
|
|
Result := GetSpecValue(Integer(Writer));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclPropInfo.GetStoredValue: Integer;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := 0;
|
|
{$ELSE}
|
|
Result := GetSpecValue(Integer(StoredProc));
|
|
{$ENDIF CLR}
|
|
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 GetPropNames(const Name: string): 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 PropNames[const Name: string]: IJclPropInfo read GetPropNames;
|
|
property UnitName: string read GetUnitName;
|
|
end;
|
|
|
|
function TJclClassTypeInfo.GetClassRef: TClass;
|
|
begin
|
|
Result := TypeData.ClassType;
|
|
end;
|
|
|
|
function TJclClassTypeInfo.GetParent: IJclClassTypeInfo;
|
|
begin
|
|
{$IFDEF CLR}
|
|
if (TypeData.ParentInfo <> nil) then
|
|
Result := JclTypeInfo(TypeData.ParentInfo) as IJclClassTypeInfo
|
|
{$ELSE}
|
|
if (TypeData.ParentInfo <> nil) and (TypeData.ParentInfo^ <> nil) then
|
|
Result := JclTypeInfo(TypeData.ParentInfo^) as IJclClassTypeInfo
|
|
{$ENDIF CLR}
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TJclClassTypeInfo.GetTotalPropertyCount: Integer;
|
|
begin
|
|
Result := TypeData.PropCount;
|
|
end;
|
|
|
|
function TJclClassTypeInfo.GetPropertyCount: Integer;
|
|
{$IFDEF CLR}
|
|
begin
|
|
Result := TypeData.PropCount;
|
|
end;
|
|
{$ELSE}
|
|
var
|
|
PropData: ^TPropData;
|
|
begin
|
|
PropData := @TypeData.UnitName;
|
|
Inc(Integer(PropData), 1 + Length(UnitName));
|
|
Result := PropData.PropCount;
|
|
end;
|
|
{$ENDIF CLR}
|
|
|
|
function TJclClassTypeInfo.GetProperties(const PropIdx: Integer): IJclPropInfo;
|
|
{$IFDEF CLR}
|
|
var
|
|
List: TPropList;
|
|
begin
|
|
if PropIdx + 1 > TypeData.PropCount then
|
|
Result := Parent.Properties[PropIdx - TypeData.PropCount]
|
|
else
|
|
begin
|
|
List := GetPropInfos(TypeInfo);
|
|
if PropIdx > 0 then
|
|
Result := TJclPropInfo.Create(List[PropIdx])
|
|
else
|
|
Result := TJclPropInfo.Create(List[0]);
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
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;
|
|
{$ENDIF CLR}
|
|
|
|
function TJclClassTypeInfo.GetPropNames(const Name: string): IJclPropInfo;
|
|
var
|
|
PropInfo: PPropInfo;
|
|
begin
|
|
PropInfo := GetPropInfo(TypeInfo, Name);
|
|
if PropInfo <> nil then
|
|
Result := TJclPropInfo.Create(PropInfo)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TJclClassTypeInfo.GetUnitName: string;
|
|
begin
|
|
Result := TypeData.UnitName;
|
|
end;
|
|
|
|
procedure TJclClassTypeInfo.WriteTo(const Dest: IJclInfoWriter);
|
|
const
|
|
{$IFDEF CLR}
|
|
cFmt1 = '[%s %d]';
|
|
cFmt2 = '[%s %s %s]';
|
|
cFmt3 = '[%s=%s]';
|
|
cFmt4 = '[%s=%s %s]';
|
|
{$ELSE}
|
|
cFmt1 = '[%s %d]';
|
|
cFmt2 = '[%s %s $%p]';
|
|
cFmt3 = '[%s=%s]';
|
|
cFmt4 = '[%s=%s $%p]';
|
|
{$ENDIF CLR}
|
|
var
|
|
I: Integer;
|
|
Prop: IJclPropInfo;
|
|
begin
|
|
inherited WriteTo(Dest);
|
|
Dest.Writeln(RsRTTIClassName + ClassRef.ClassName);
|
|
Dest.Writeln(RsRTTIParent + Parent.ClassRef.ClassName);
|
|
Dest.Writeln(RsRTTIUnitName + UnitName);
|
|
Dest.Writeln(RsRTTIPropCount + IntToStr(PropertyCount) + ' (' +
|
|
IntToStr(TotalPropertyCount) + ')');
|
|
Dest.Indent;
|
|
try
|
|
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, [RsRTTIIndex, Prop.Index]));
|
|
if Prop.HasDefault then
|
|
Dest.Writeln(Format(cFmt1, [RsRTTIDefault, Prop.Default]));
|
|
case Prop.ReaderType of
|
|
pskStaticMethod:
|
|
Dest.Writeln(Format(cFmt2, [RsRTTIPropRead, RsRTTIStaticMethod,
|
|
{$IFDEF CLR}
|
|
Prop.Reader.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.ReaderValue)]));
|
|
{$ENDIF CLR}
|
|
pskField:
|
|
Dest.Writeln(Format(cFmt2, [RsRTTIPropRead, RsRTTIField,
|
|
{$IFDEF CLR}
|
|
Prop.Reader.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.ReaderValue)]));
|
|
{$ENDIF CLR}
|
|
pskVirtualMethod:
|
|
Dest.Writeln(Format(cFmt2, [RsRTTIPropRead, RsRTTIVirtualMethod,
|
|
{$IFDEF CLR}
|
|
Prop.Reader.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.ReaderValue)]));
|
|
{$ENDIF CLR}
|
|
end;
|
|
case Prop.WriterType of
|
|
pskStaticMethod:
|
|
Dest.Writeln(Format(cFmt2, [RsRTTIPropWrite, RsRTTIStaticMethod,
|
|
{$IFDEF CLR}
|
|
Prop.Writer.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.WriterValue)]));
|
|
{$ENDIF CLR}
|
|
pskField:
|
|
Dest.Writeln(Format(cFmt2, [RsRTTIPropWrite, RsRTTIField,
|
|
{$IFDEF CLR}
|
|
Prop.Writer.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.WriterValue)]));
|
|
{$ENDIF CLR}
|
|
pskVirtualMethod:
|
|
Dest.Writeln(Format(cFmt2, [RsRTTIPropWrite, RsRTTIVirtualMethod,
|
|
{$IFDEF CLR}
|
|
Prop.Writer.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.WriterValue)]));
|
|
{$ENDIF CLR}
|
|
end;
|
|
case Prop.StoredType of
|
|
pskConstant:
|
|
if Boolean(Prop.StoredValue) then
|
|
Dest.Writeln(Format(cFmt3, [RsRTTIPropStored, RsRTTITrue]))
|
|
else
|
|
Dest.Writeln(Format(cFmt3, [RsRTTIPropStored, RsRTTIFalse]));
|
|
pskStaticMethod:
|
|
Dest.Writeln(Format(cFmt4, [RsRTTIPropStored, RsRTTIStaticMethod,
|
|
{$IFDEF CLR}
|
|
Prop.StoredProc.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.StoredValue)]));
|
|
{$ENDIF CLR}
|
|
pskField:
|
|
Dest.Writeln(Format(cFmt4, [RsRTTIPropStored, RsRTTIField,
|
|
{$IFDEF CLR}
|
|
Prop.StoredProc.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.StoredValue)]));
|
|
{$ENDIF CLR}
|
|
pskVirtualMethod:
|
|
Dest.Writeln(Format(cFmt4, [RsRTTIPropStored, RsRTTIVirtualMethod,
|
|
{$IFDEF CLR}
|
|
Prop.StoredProc.ToString()]));
|
|
{$ELSE}
|
|
Pointer(Prop.StoredValue)]));
|
|
{$ENDIF CLR}
|
|
end;
|
|
finally
|
|
Dest.Outdent;
|
|
end;
|
|
end;
|
|
finally
|
|
Dest.Outdent;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclClassTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
|
|
var
|
|
{$IFDEF CLR}
|
|
IntfTbl: array of &Type;
|
|
{$ELSE}
|
|
IntfTbl: PInterfaceTable;
|
|
{$ENDIF CLR}
|
|
I: Integer;
|
|
Prop: IJclPropInfo;
|
|
begin
|
|
if (Parent <> nil) and
|
|
{$IFDEF CLR}
|
|
not SameText(Parent.Name, 'TObject') then
|
|
{$ELSE}
|
|
not AnsiSameText(Parent.Name, 'TObject') then
|
|
{$ENDIF CLR}
|
|
begin
|
|
Dest.Write(Name + ' = class(' + Parent.Name);
|
|
{$IFDEF CLR}
|
|
IntfTbl := ClassRef.ClassInfo.GetInterfaces;
|
|
if IntfTbl <> nil then
|
|
for I := 0 to High(IntfTbl) do
|
|
Dest.Write(', [''' + JclGUIDToString(IntfTbl[I].TypeData.Guid) + ''']');
|
|
{$ELSE}
|
|
IntfTbl := ClassRef.GetInterfaceTable;
|
|
if IntfTbl <> nil then
|
|
for I := 0 to IntfTbl.EntryCount-1 do
|
|
Dest.Write(', [''' + JclGUIDToString(IntfTbl.Entries[I].IID) + ''']');
|
|
{$ENDIF CLR}
|
|
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
|
|
{$IFDEF CLR}
|
|
pskStaticMethod:
|
|
Dest.Write(Format(' read [static method %s]', [Prop.Reader.ToString()]));
|
|
pskField:
|
|
Dest.Write(Format(' read [field %s]', [Prop.Reader.ToString()]));
|
|
pskVirtualMethod:
|
|
Dest.Write(Format(' read [virtual method %s]', [Prop.Reader.ToString()]));
|
|
{$ELSE}
|
|
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)]));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
case Prop.WriterType of
|
|
{$IFDEF CLR}
|
|
pskStaticMethod:
|
|
Dest.Write(Format(' write [static method %s]', [Prop.Writer.ToString()]));
|
|
pskField:
|
|
Dest.Write(Format(' write [field %s]', [Prop.Writer.ToString()]));
|
|
pskVirtualMethod:
|
|
Dest.Write(Format(' write [virtual method %s]', [Prop.Writer.ToString()]));
|
|
{$ELSE}
|
|
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)]));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
case Prop.StoredType of
|
|
pskConstant:
|
|
if Boolean(Prop.StoredValue) then
|
|
Dest.Write(' stored = True')
|
|
else
|
|
Dest.Write(' stored = False');
|
|
{$IFDEF CLR}
|
|
pskStaticMethod:
|
|
Dest.Write(Format(' stored = [static method %s]', [Prop.StoredProc.ToString()]));
|
|
pskField:
|
|
Dest.Write(Format(' stored = [field %s]', [Prop.StoredProc.ToString()]));
|
|
pskVirtualMethod:
|
|
Dest.Write(Format(' stored = [virtual method %s]', [Prop.StoredProc.ToString()]));
|
|
{$ELSE}
|
|
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)]));
|
|
{$ENDIF CLR}
|
|
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: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF};
|
|
protected
|
|
function GetFlags: TParamFlags;
|
|
function GetName: string;
|
|
function GetRecSize: Integer;
|
|
function GetTypeName: string;
|
|
function GetParam: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF};
|
|
public
|
|
constructor Create(const AParam: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF});
|
|
|
|
property Flags: TParamFlags read GetFlags;
|
|
property Name: string read GetName;
|
|
property RecSize: Integer read GetRecSize;
|
|
property TypeName: string read GetTypeName;
|
|
property Param: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF} read GetParam;
|
|
end;
|
|
|
|
constructor TJclEventParamInfo.Create(const AParam: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF});
|
|
begin
|
|
inherited Create;
|
|
FParam := AParam;
|
|
end;
|
|
|
|
function TJclEventParamInfo.GetFlags: TParamFlags;
|
|
{$IFDEF CLR}
|
|
var
|
|
Attr: Attribute;
|
|
{$ENDIF CLR}
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := [];
|
|
if FParam.IsOut then
|
|
Result := [pfOut]
|
|
else
|
|
if FParam.ParameterType.IsByRef then
|
|
Result := [pfVar]
|
|
else
|
|
if FindAttribute(FParam.ParameterType, TypeOf(TConstantParamAttribute), Attr) then
|
|
Result := [pfConst];
|
|
|
|
with FParam.ParameterType do
|
|
if IsArray or (IsByRef and HasElementType and GetElementType.IsArray) then
|
|
Include(Result, pfArray);
|
|
{$ELSE}
|
|
Result := TParamFlags(PByte(Param)^);
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclEventParamInfo.GetName: string;
|
|
{$IFDEF CLR}
|
|
begin
|
|
Result := FParam.Name;
|
|
end;
|
|
{$ELSE}
|
|
var
|
|
PName: PShortString;
|
|
begin
|
|
PName := Param;
|
|
Inc(Integer(PName));
|
|
Result := PName^;
|
|
end;
|
|
{$ENDIF CLR}
|
|
|
|
function TJclEventParamInfo.GetRecSize: Integer;
|
|
begin
|
|
Result := 3 + Length(Name) + Length(TypeName);
|
|
end;
|
|
|
|
function TJclEventParamInfo.GetTypeName: string;
|
|
{$IFDEF CLR}
|
|
begin
|
|
Result := FParam.ParameterType.Name;
|
|
end;
|
|
{$ELSE}
|
|
var
|
|
PName: PShortString;
|
|
begin
|
|
PName := Param;
|
|
Inc(Integer(PName));
|
|
Inc(Integer(PName), PByte(PName)^ + 1);
|
|
Result := PName^;
|
|
end;
|
|
{$ENDIF CLR}
|
|
|
|
function TJclEventParamInfo.GetParam: {$IFDEF CLR}ParameterInfo{$ELSE}Pointer{$ENDIF};
|
|
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;
|
|
{$IFNDEF CLR}
|
|
var
|
|
I: Integer;
|
|
Param: Pointer;
|
|
{$ENDIF ~CLR}
|
|
begin
|
|
Result := nil;
|
|
{$IFDEF CLR}
|
|
if ParamIdx < TypeData.ParamCount then
|
|
Result := TJclEventParamInfo.Create(TypeData.Params[ParamIdx]);
|
|
{$ELSE}
|
|
Param := @TypeData.ParamList[0];
|
|
I := ParamIdx;
|
|
while I >= 0 do
|
|
begin
|
|
Result := TJclEventParamInfo.Create(Param);
|
|
Inc(Integer(Param), Result.RecSize);
|
|
Dec(I);
|
|
end;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclEventTypeInfo.GetResultTypeName: string;
|
|
{$IFDEF CLR}
|
|
begin
|
|
Result := TypeData.ResultTypeName;
|
|
end;
|
|
{$ELSE}
|
|
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;
|
|
{$ENDIF CLR}
|
|
|
|
procedure TJclEventTypeInfo.WriteTo(const Dest: IJclInfoWriter);
|
|
var
|
|
I: Integer;
|
|
Param: IJclEventParamInfo;
|
|
ParamFlags: TParamFlags;
|
|
begin
|
|
inherited WriteTo(Dest);
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIMethodKind +
|
|
JclEnumValueToIdent(Borland.Delphi.System.TypeInfo(TMethodKind), TypeData.MethodKind));
|
|
Dest.Writeln(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(RsRTTIName + Param.Name);
|
|
Dest.Writeln(RsRTTIType + Param.TypeName);
|
|
Dest.Writeln(RsRTTIFlags +
|
|
JclSetToStr(Borland.Delphi.System.TypeInfo(TParamFlags), ParamFlags, True, False));
|
|
end;
|
|
finally
|
|
Dest.Outdent;
|
|
end;
|
|
if MethodKind = mkFunction then
|
|
Dest.Writeln(RsRTTIReturnType + ResultTypeName);
|
|
{$ELSE}
|
|
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);
|
|
{$ENDIF CLR}
|
|
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];
|
|
{$IFDEF CLR}
|
|
if pfVar in Param.Flags then
|
|
Dest.Write(RsRTTIVar)
|
|
else
|
|
if pfConst in Param.Flags then
|
|
Dest.Write(RsRTTIConst)
|
|
else
|
|
if pfOut in Param.Flags then
|
|
Dest.Write(RsRTTIOut);
|
|
{$ELSE}
|
|
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));
|
|
{$ENDIF CLR}
|
|
Dest.Write(Param.Name);
|
|
if Param.TypeName <> '' then
|
|
begin
|
|
Dest.Write(': ');
|
|
{$IFDEF CLR}
|
|
if pfArray in Param.Flags then
|
|
Dest.Write(RsRTTIArrayOf);
|
|
if AnsiSameText(Param.TypeName, 'TVarRec') and (pfArray in Param.Flags) then
|
|
Dest.Write(TrimRight(RsRTTIConst))
|
|
{$ELSE}
|
|
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)))
|
|
{$ENDIF CLR}
|
|
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 RTL140_UP}
|
|
function GetPropertyCount: Integer;
|
|
{$ENDIF RTL140_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 RTL140_UP}
|
|
property PropertyCount: Integer read GetPropertyCount;
|
|
{$ENDIF RTL140_UP}
|
|
property UnitName: string read GetUnitName;
|
|
end;
|
|
|
|
function TJclInterfaceTypeInfo.GetParent: IJclInterfaceTypeInfo;
|
|
begin
|
|
{$IFDEF CLR}
|
|
if TypeInfo.BaseType <> nil then
|
|
Result := JclTypeInfo(TypeInfo.BaseType) as IJclInterfaceTypeInfo
|
|
{$ELSE}
|
|
if (TypeData.IntfParent <> nil) and (TypeData.IntfParent^ <> nil) then
|
|
Result := JclTypeInfo(TypeData.IntfParent^) as IJclInterfaceTypeInfo
|
|
{$ENDIF CLR}
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TJclInterfaceTypeInfo.GetFlags: TIntfFlagsBase;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := [];
|
|
{$ELSE}
|
|
Result := TypeData.IntfFlags;
|
|
{$ENDIF CLR}
|
|
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 RTL140_UP}
|
|
function TJclInterfaceTypeInfo.GetPropertyCount: Integer;
|
|
{$IFDEF CLR}
|
|
begin
|
|
Result := TypeData.PropCount;
|
|
end;
|
|
{$ELSE}
|
|
var
|
|
PropData: ^TPropData;
|
|
begin
|
|
PropData := @TypeData.IntfUnit;
|
|
Inc(Integer(PropData), 1 + Length(UnitName));
|
|
Result := PropData.PropCount;
|
|
end;
|
|
{$ENDIF CLR}
|
|
{$ENDIF RTL140_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
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIGUID + JclGuidToString(GUID));
|
|
IntfFlags := Flags;
|
|
Dest.Writeln(RsRTTIFlags + JclSetToStr(Borland.Delphi.System.TypeInfo(TIntfFlagsBase),
|
|
IntfFlags, True, False));
|
|
Dest.Writeln(RsRTTIUnitName + UnitName);
|
|
if Parent <> nil then
|
|
Dest.Writeln(RsRTTIParent + Parent.Name);
|
|
Dest.Writeln(RsRTTIPropCount + IntToStr(PropertyCount));
|
|
{$ELSE}
|
|
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 RTL140_UP}
|
|
Dest.Writeln(LoadResString(@RsRTTIPropCount) + IntToStr(PropertyCount));
|
|
{$ENDIF RTL140_UP}
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
procedure TJclInterfaceTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
|
|
begin
|
|
Dest.Write(Name + ' = ');
|
|
if ifDispInterface in Flags then
|
|
Dest.Write('dispinterface')
|
|
else
|
|
Dest.Write('interface');
|
|
if (Parent <> nil) and not (ifDispInterface in Flags) and not
|
|
AnsiSameText(Parent.Name, 'IUnknown') then
|
|
Dest.Write('(' + Parent.Name + ')');
|
|
Dest.Writeln(' // unit ' + UnitName);
|
|
Dest.Indent;
|
|
try
|
|
if ifHasGuid in Flags then
|
|
Dest.Writeln('[''' + JclGuidToString(GUID) + ''']');
|
|
finally
|
|
Dest.Outdent;
|
|
Dest.Writeln('end;');
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclInt64TypeInfo } ==================================================
|
|
|
|
type
|
|
TJclInt64TypeInfo = class(TJclTypeInfo, IJclInt64TypeInfo)
|
|
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 TJclInt64TypeInfo.GetMinValue: Int64;
|
|
begin
|
|
Result := TypeData.MinInt64Value;
|
|
end;
|
|
|
|
function TJclInt64TypeInfo.GetMaxValue: Int64;
|
|
begin
|
|
Result := TypeData.MaxInt64Value;
|
|
end;
|
|
|
|
procedure TJclInt64TypeInfo.WriteTo(const Dest: IJclInfoWriter);
|
|
begin
|
|
inherited WriteTo(Dest);
|
|
{$IFDEF CLR}
|
|
Dest.Writeln(RsRTTIMinValue + IntToStr(MinValue));
|
|
Dest.Writeln(RsRTTIMaxValue + IntToStr(MaxValue));
|
|
{$ELSE}
|
|
Dest.Writeln(LoadResString(@RsRTTIMinValue) + IntToStr(MinValue));
|
|
Dest.Writeln(LoadResString(@RsRTTIMaxValue) + IntToStr(MaxValue));
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
procedure TJclInt64TypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
|
|
begin
|
|
Dest.Writeln(Name + ' = ' + IntToStr(MinValue) + ' .. ' + IntToStr(MaxValue) + ';');
|
|
end;
|
|
|
|
//=== { TJclDynArrayTypeInfo } ===============================================
|
|
|
|
{$IFDEF RTL140_UP}
|
|
|
|
type
|
|
TJclDynArrayTypeInfo = class(TJclTypeInfo, IJclDynArrayTypeInfo)
|
|
protected
|
|
function GetElementSize: Longint;
|
|
function GetElementType: IJclTypeInfo;
|
|
function GetElementsNeedCleanup: Boolean;
|
|
function GetVarType: Integer;
|
|
function GetUnitName: string;
|
|
procedure WriteTo(const Dest: IJclInfoWriter); override;
|
|
procedure DeclarationTo(const Dest: IJclInfoWriter); override;
|
|
public
|
|
property ElementSize: Longint read GetElementSize;
|
|
property ElementType: IJclTypeInfo read GetElementType;
|
|
property ElementsNeedCleanup: Boolean read GetElementsNeedCleanup;
|
|
property VarType: Integer read GetVarType;
|
|
property UnitName: string read GetUnitName;
|
|
end;
|
|
|
|
function TJclDynArrayTypeInfo.GetElementSize: Longint;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.SizeOf(TypeInfo.GetElementType);
|
|
{$ELSE}
|
|
Result := TypeData.elSize;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclDynArrayTypeInfo.GetElementType: IJclTypeInfo;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := JclTypeInfo(TypeInfo.GetElementType);
|
|
{$ELSE}
|
|
if TypeData.elType = nil then
|
|
begin
|
|
if TypeData.elType2 <> nil then
|
|
Result := JclTypeInfo(TypeData.elType2^)
|
|
else
|
|
Result := nil;
|
|
end
|
|
else
|
|
Result := JclTypeInfo(TypeData.elType^);
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclDynArrayTypeInfo.GetElementsNeedCleanup: Boolean;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := False;
|
|
{$ELSE}
|
|
Result := TypeData.elType <> nil;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclDynArrayTypeInfo.GetVarType: Integer;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Variant.VarType(TypeInfo);
|
|
{$ELSE}
|
|
Result := TypeData.varType;
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function TJclDynArrayTypeInfo.GetUnitName: string;
|
|
begin
|
|
Result := TypeData.DynUnitName;
|
|
end;
|
|
|
|
procedure TJclDynArrayTypeInfo.WriteTo(const Dest: IJclInfoWriter);
|
|
begin
|
|
inherited WriteTo(Dest);
|
|
Dest.Writeln(RsRTTIElSize + IntToStr(ElementSize));
|
|
if ElementType = nil then
|
|
Dest.Writeln(RsRTTIElType + RsRTTITypeError)
|
|
else
|
|
if ElementType.Name[1] <> '.' then
|
|
Dest.Writeln(RsRTTIElType + ElementType.Name)
|
|
else
|
|
begin
|
|
Dest.Writeln(RsRTTIElType);
|
|
Dest.Indent;
|
|
try
|
|
ElementType.WriteTo(Dest);
|
|
finally
|
|
Dest.Outdent;
|
|
end;
|
|
end;
|
|
Dest.Write(RsRTTIElNeedCleanup);
|
|
if ElementsNeedCleanup then
|
|
Dest.Writeln(RsRTTITrue)
|
|
else
|
|
Dest.Writeln(RsRTTIFalse);
|
|
Dest.Writeln(RsRTTIVarType + IntToStr(VarType));
|
|
Dest.Writeln(RsRTTIUnitName + UnitName);
|
|
end;
|
|
|
|
procedure TJclDynArrayTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);
|
|
begin
|
|
if Name[1] <> '.' then
|
|
Dest.Write(Name + ' = ' + RsRTTIArrayOf)
|
|
else
|
|
Dest.Write(RsRTTIArrayOf);
|
|
if ElementType = nil then
|
|
Dest.Write(RsRTTITypeError)
|
|
else
|
|
if ElementType.Name[1] = '.' then
|
|
ElementType.DeclarationTo(Dest)
|
|
else
|
|
Dest.Write(ElementType.Name);
|
|
if Name[1] <> '.' then
|
|
Dest.Writeln('; // Unit ' + UnitName);
|
|
end;
|
|
|
|
{$ENDIF RTL140_UP}
|
|
|
|
//=== Typeinfo retrieval =====================================================
|
|
|
|
function JclTypeInfo(ATypeInfo: PTypeInfo): IJclTypeInfo;
|
|
begin
|
|
case ATypeInfo.Kind of
|
|
tkInteger, tkChar, tkWChar:
|
|
Result := TJclOrdinalRangeTypeInfo.Create(ATypeInfo);
|
|
tkEnumeration:
|
|
Result := TJclEnumerationTypeInfo.Create(ATypeInfo);
|
|
tkSet:
|
|
Result := TJclSetTypeInfo.Create(ATypeInfo);
|
|
tkFloat:
|
|
Result := TJclFloatTypeInfo.Create(ATypeInfo);
|
|
tkString:
|
|
Result := TJclStringTypeInfo.Create(ATypeInfo);
|
|
tkClass:
|
|
Result := TJclClassTypeInfo.Create(ATypeInfo);
|
|
tkMethod:
|
|
Result := TJclEventTypeInfo.Create(ATypeInfo);
|
|
tkInterface:
|
|
Result := TJclInterfaceTypeInfo.Create(ATypeInfo);
|
|
tkInt64:
|
|
Result := TJclInt64TypeInfo.Create(ATypeInfo);
|
|
{$IFDEF RTL140_UP}
|
|
tkDynArray:
|
|
Result := TJclDynArrayTypeInfo.Create(ATypeInfo);
|
|
{$ENDIF RTL140_UP}
|
|
else
|
|
Result := TJclTypeInfo.Create(ATypeInfo);
|
|
end;
|
|
end;
|
|
|
|
//=== User generated type info managment =====================================
|
|
|
|
{$IFNDEF CLR}
|
|
var
|
|
TypeList: TThreadList;
|
|
|
|
type
|
|
PTypeItem = ^TTypeItem;
|
|
TTypeItem = record
|
|
TypeInfo: PTypeInfo;
|
|
RefCount: Integer;
|
|
end;
|
|
|
|
procedure FreeTypeData(const TypeInfo: PTypeInfo);
|
|
var
|
|
TD: PTypeData;
|
|
begin
|
|
TD := GetTypeData(TypeInfo);
|
|
if TypeInfo.Kind = tkSet then
|
|
RemoveTypeInfo(TD^.CompType^)
|
|
else
|
|
if (TypeInfo.Kind = tkEnumeration) and (TD^.BaseType^ <> TypeInfo) then
|
|
RemoveTypeInfo(GetTypeData(TypeInfo)^.BaseType^);
|
|
FreeMem(GetTypeData(TypeInfo)^.BaseType);
|
|
FreeMem(TypeInfo);
|
|
end;
|
|
|
|
procedure AddType(const TypeInfo: PTypeInfo);
|
|
var
|
|
Item: PTypeItem;
|
|
begin
|
|
New(Item);
|
|
try
|
|
Item.TypeInfo := TypeInfo;
|
|
Item.RefCount := 1;
|
|
TypeList.Add(Item);
|
|
except
|
|
Dispose(Item);
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
procedure DeleteType(const TypeItem: PTypeItem);
|
|
begin
|
|
FreeTypeData(TypeItem.TypeInfo);
|
|
TypeList.Remove(TypeItem);
|
|
Dispose(TypeItem);
|
|
end;
|
|
|
|
procedure DoRefType(const TypeInfo: PTypeInfo; Add: Integer);
|
|
var
|
|
I: Integer;
|
|
List: TList;
|
|
begin
|
|
List := TypeList.LockList;
|
|
try
|
|
I := List.Count-1;
|
|
while (I >= 0) and (PTypeItem(List[I]).TypeInfo <> TypeInfo) do
|
|
Dec(I);
|
|
if I > -1 then
|
|
Inc(PTypeItem(List[I]).RefCount, Add);
|
|
finally
|
|
TypeList.UnlockList;
|
|
end;
|
|
end;
|
|
|
|
procedure ReferenceType(const TypeInfo: PTypeInfo);
|
|
begin
|
|
DoRefType(TypeInfo, 1);
|
|
end;
|
|
|
|
procedure DeReferenceType(const TypeInfo: PTypeInfo);
|
|
begin
|
|
DoRefType(TypeInfo, -1);
|
|
end;
|
|
|
|
procedure ClearInfoList;
|
|
var
|
|
L: TList;
|
|
begin
|
|
L := TypeList.LockList;
|
|
try
|
|
while L.Count > 0 do
|
|
RemoveTypeInfo(PTypeItem(L[L.Count-1])^.TypeInfo);
|
|
finally
|
|
TypeList.UnlockList;
|
|
end;
|
|
end;
|
|
|
|
procedure NewInfoItem(const TypeInfo: PTypeInfo);
|
|
begin
|
|
TypeList.Add(TypeInfo);
|
|
end;
|
|
|
|
procedure RemoveTypeInfo(TypeInfo: PTypeInfo);
|
|
var
|
|
I: Integer;
|
|
List: TList;
|
|
Item: PTypeItem;
|
|
begin
|
|
Item := nil;
|
|
List := TypeList.LockList;
|
|
try
|
|
I := List.Count-1;
|
|
while (I >= 0) and (PTypeItem(List[I]).TypeInfo <> TypeInfo) do
|
|
Dec(I);
|
|
if I > -1 then
|
|
Item := PTypeItem(List[I]);
|
|
finally
|
|
TypeList.UnlockList;
|
|
end;
|
|
if Item <> nil then
|
|
begin
|
|
Dec(Item.RefCount);
|
|
if Item.RefCount <= 0 then
|
|
DeleteType(Item);
|
|
end;
|
|
end;
|
|
{$ENDIF ~CLR}
|
|
|
|
//=== Enumerations ===========================================================
|
|
|
|
function JclEnumValueToIdent(TypeInfo: PTypeInfo; const Value): string;
|
|
var
|
|
MinEnum: Integer;
|
|
MaxEnum: Integer;
|
|
EnumVal: Int64;
|
|
OrdType: TOrdType;
|
|
begin
|
|
OrdType := GetTypeData(TypeInfo).OrdType;
|
|
MinEnum := GetTypeData(TypeInfo).MinValue;
|
|
MaxEnum := GetTypeData(TypeInfo).MaxValue;
|
|
case OrdType of
|
|
otSByte:
|
|
EnumVal := Smallint(Value);
|
|
otUByte:
|
|
EnumVal := Byte(Value);
|
|
otSWord:
|
|
EnumVal := Shortint(Value);
|
|
otUWord:
|
|
EnumVal := Word(Value);
|
|
otSLong:
|
|
EnumVal := Integer(Value);
|
|
otULong:
|
|
EnumVal := Longword(Value);
|
|
else
|
|
EnumVal := 0;
|
|
end;
|
|
// Check range...
|
|
if (EnumVal < MinEnum) or (EnumVal > MaxEnum) then
|
|
{$IFDEf CLR}
|
|
Result := Format(RsRTTIValueOutOfRange, [RsRTTIOrdinal + IntToStr(EnumVal)])
|
|
{$ELSE}
|
|
Result := Format(LoadResString(@RsRTTIValueOutOfRange),
|
|
[LoadResString(@RsRTTIOrdinal) + IntToStr(EnumVal)])
|
|
{$ENDIF CLR}
|
|
else
|
|
Result := GetEnumName(TypeInfo, EnumVal);
|
|
end;
|
|
|
|
{$IFNDEF CLR}
|
|
function JclGenerateEnumType(const TypeName: ShortString;
|
|
const Literals: array of string): PTypeInfo;
|
|
type
|
|
PInteger = ^Integer;
|
|
var
|
|
StringSize: Integer;
|
|
I: Integer;
|
|
TypeData: PTypeData;
|
|
CurName: PShortString;
|
|
begin
|
|
StringSize := 0;
|
|
for I := Low(Literals) to High(Literals) do
|
|
StringSize := StringSize + 1 + Length(Literals[I]);
|
|
Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) +
|
|
(2*SizeOf(Integer)) + SizeOf(PPTypeInfo) +
|
|
StringSize {$IFDEF RTL140_UP}+ 1{$ENDIF RTL140_UP});
|
|
try
|
|
with Result^ do
|
|
begin
|
|
Kind := tkEnumeration;
|
|
Name := TypeName;
|
|
end;
|
|
TypeData := GetTypeData(Result);
|
|
TypeData^.BaseType := AllocMem(SizeOf(Pointer));
|
|
if Length(Literals) < 256 then
|
|
TypeData^.OrdType := otUByte
|
|
else
|
|
if Length(Literals) < 65536 then
|
|
TypeData^.OrdType := otUWord
|
|
else
|
|
TypeData^.OrdType := otULong;
|
|
TypeData^.MinValue := 0;
|
|
TypeData^.MaxValue := Length(Literals)-1;
|
|
TypeData^.BaseType^ := Result; // No sub-range: basetype points to itself
|
|
CurName := @TypeData^.NameList;
|
|
for I := Low(Literals) to High(Literals) do
|
|
begin
|
|
CurName^ := Literals[I];
|
|
Inc(Integer(CurName), Length(Literals[I])+1);
|
|
end;
|
|
{$IFDEF RTL140_UP}
|
|
CurName^ := ''; // Unit name unknown
|
|
{$ENDIF RTL140_UP}
|
|
AddType(Result);
|
|
except
|
|
try
|
|
ReallocMem(Result, 0);
|
|
except
|
|
Result := nil;
|
|
end;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
function JclGenerateEnumTypeBasedOn(const TypeName: ShortString;
|
|
BaseType: PTypeInfo; const PrefixCut: Byte): PTypeInfo;
|
|
var
|
|
BaseInfo: IJclTypeInfo;
|
|
BaseKind: TTypeKind;
|
|
Literals: array of string;
|
|
I: Integer;
|
|
S: string;
|
|
begin
|
|
BaseInfo := JclTypeInfo(BaseType);
|
|
BaseKind := BaseInfo.TypeKind;
|
|
if BaseInfo.TypeKind <> tkEnumeration then
|
|
raise EJclRTTIError.CreateResFmt(@RsRTTIInvalidBaseType, [BaseInfo.Name,
|
|
JclEnumValueToIdent(System.TypeInfo(TTypeKind), BaseKind)]);
|
|
with BaseInfo as IJclEnumerationTypeInfo do
|
|
begin
|
|
SetLength(Literals, MaxValue - MinValue + 1);
|
|
for I := MinValue to MaxValue do
|
|
begin
|
|
S := Names[I];
|
|
if PrefixCut = PREFIX_CUT_LOWERCASE then
|
|
while (Length(S) > 0) and (S[1] in AnsiLowercaseLetters) do
|
|
Delete(S, 1, 1);
|
|
if (PrefixCut > 0) and (PrefixCut < MaxPrefixCut) then
|
|
Delete(S, 1, PrefixCut);
|
|
if S = '' then
|
|
S := Names[I];
|
|
Literals[I- MinValue] := S;
|
|
end;
|
|
if PrefixCut = PREFIX_CUT_EQUAL then
|
|
begin
|
|
S := Literals[High(Literals)];
|
|
I := High(Literals)-1;
|
|
while (I >= 0) and (S > '') do
|
|
begin
|
|
while Copy(Literals[I], 1, Length(S)) <> S do
|
|
Delete(S, Length(S), 1);
|
|
Dec(I);
|
|
end;
|
|
if S > '' then
|
|
for I := Low(Literals) to High(Literals) do
|
|
begin
|
|
Literals[I] := StrRestOf(Literals[I], Length(S));
|
|
if Literals[I] = '' then
|
|
Literals[I] := Names[I + MinValue];
|
|
end;
|
|
end;
|
|
end;
|
|
Result := JclGenerateEnumType(TypeName, Literals);
|
|
end;
|
|
|
|
function JclGenerateSubRange(BaseType: PTypeInfo; const TypeName: string;
|
|
const MinValue, MaxValue: Integer): PTypeInfo;
|
|
var
|
|
TypeData: PTypeData;
|
|
begin
|
|
Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) +
|
|
(2*SizeOf(Integer)) + SizeOf(PPTypeInfo));
|
|
try
|
|
with Result^ do
|
|
begin
|
|
Kind := BaseType^.Kind;
|
|
Name := TypeName;
|
|
end;
|
|
TypeData := GetTypeData(Result);
|
|
TypeData^.OrdType := GetTypeData(BaseType)^.OrdType;
|
|
TypeData^.MinValue := MinValue;
|
|
TypeData^.MaxValue := MaxValue;
|
|
TypeData^.BaseType := AllocMem(SizeOf(Pointer));
|
|
TypeData^.BaseType^ := BaseType;
|
|
AddType(Result);
|
|
except
|
|
try
|
|
ReallocMem(Result, 0);
|
|
except
|
|
Result := nil;
|
|
end;
|
|
raise;
|
|
end;
|
|
ReferenceType(BaseType);
|
|
end;
|
|
{$ENDIF ~CLR}
|
|
|
|
//=== Integers ===============================================================
|
|
|
|
function JclStrToTypedInt(Value: string; TypeInfo: PTypeInfo): Integer;
|
|
var
|
|
Conv: TIdentToInt;
|
|
HaveConversion: Boolean;
|
|
Info: IJclTypeInfo;
|
|
RangeInfo: IJclOrdinalRangeTypeInfo;
|
|
TmpVal: Int64;
|
|
begin
|
|
if TypeInfo <> nil then
|
|
Conv := FindIdentToInt(TypeInfo)
|
|
else
|
|
Conv := nil;
|
|
HaveConversion := (@Conv <> nil) and Conv(Value, Result);
|
|
if not HaveConversion then
|
|
begin
|
|
if TypeInfo <> nil then
|
|
begin
|
|
Info := JclTypeInfo(TypeInfo);
|
|
{$IFDEF CLR}
|
|
if not Supports(Info, IJclOrdinalRangeTypeInfo, RangeInfo) then
|
|
{$ELSE}
|
|
if Info.QueryInterface(IJclOrdinalRangeTypeInfo, RangeInfo) <> S_OK then
|
|
{$ENDIF CLR}
|
|
RangeInfo := nil;
|
|
TmpVal := StrToInt64(Value);
|
|
if (RangeInfo <> nil) and ((TmpVal < RangeInfo.MinValue) or
|
|
(TmpVal > RangeInfo.MaxValue)) then
|
|
{$IFDEF CLR}
|
|
raise EConvertError.CreateFmt(SInvalidInteger, [Value]);
|
|
{$ELSE}
|
|
raise EConvertError.CreateResFmt(@SInvalidInteger, [Value]);
|
|
{$ENDIF CLR}
|
|
Result := Integer(TmpVal);
|
|
end
|
|
else
|
|
Result := StrToInt(Value)
|
|
end;
|
|
end;
|
|
|
|
function JclTypedIntToStr(Value: Integer; TypeInfo: PTypeInfo): string;
|
|
var
|
|
Conv: TIntToIdent;
|
|
HaveConversion: Boolean;
|
|
begin
|
|
if TypeInfo <> nil then
|
|
Conv := FindIntToIdent(TypeInfo)
|
|
else
|
|
Conv := nil;
|
|
HaveConversion := (@Conv <> nil) and Conv(Value, Result);
|
|
if not HaveConversion then
|
|
begin
|
|
if (TypeInfo <> nil) and (GetTypeData(TypeInfo).OrdType = otULong) then
|
|
Result := IntToStr(Int64(Cardinal(Value)))
|
|
else
|
|
Result := IntToStr(Value)
|
|
end;
|
|
end;
|
|
|
|
//=== Sets ===================================================================
|
|
|
|
function JclSetToList(TypeInfo: PTypeInfo; const Value;
|
|
const WantBrackets: Boolean; const WantRanges: Boolean;
|
|
const Strings: TStrings): string;
|
|
var
|
|
SetType: IJclSetTypeInfo;
|
|
I: Integer;
|
|
begin
|
|
I := Strings.Count;
|
|
Result := '';
|
|
SetType := JclTypeInfo(TypeInfo) as IJclSetTypeInfo;
|
|
SetType.GetAsList(Value, WantRanges, Strings);
|
|
for I := I to Strings.Count - 1 do
|
|
begin
|
|
if Result <> '' then
|
|
Result := Result + ', ' + Strings[I]
|
|
else
|
|
Result := Result + Strings[I];
|
|
end;
|
|
if WantBrackets then
|
|
Result := '[' + Result + ']';
|
|
end;
|
|
|
|
function JclSetToStr(TypeInfo: PTypeInfo; const Value;
|
|
const WantBrackets: Boolean; const WantRanges: Boolean): string;
|
|
var
|
|
Dummy: TStringList;
|
|
begin
|
|
Dummy := TStringList.Create;
|
|
try
|
|
Result := JclSetToList(TypeInfo, Value, WantBrackets, WantRanges, Dummy);
|
|
finally
|
|
Dummy.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure JclStrToSet(TypeInfo: PTypeInfo; var SetVar; const Value: string);
|
|
var
|
|
SetInfo: IJclSetTypeInfo;
|
|
S: TStringList;
|
|
begin
|
|
SetInfo := JclTypeInfo(TypeInfo) as IJclSetTypeInfo;
|
|
S := TStringList.Create;
|
|
try
|
|
StrToStrings(Value, ',', S);
|
|
if S.Count > 0 then
|
|
begin
|
|
if S[0][1] = '[' then
|
|
begin
|
|
S[0] := Copy(S[0], 2, Length(S[0]));
|
|
S[S.Count-1] := Copy(S[S.Count-1], 1,
|
|
Length(S[S.Count-1]) - 1);
|
|
end;
|
|
end;
|
|
SetInfo.SetAsList(SetVar, S);
|
|
finally
|
|
S.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure JclIntToSet(TypeInfo: PTypeInfo; var SetVar; const Value: Integer);
|
|
var
|
|
BitShift: Integer;
|
|
TmpInt64: Int64;
|
|
EnumMin: Integer;
|
|
EnumMax: Integer;
|
|
ResBytes: Integer;
|
|
CompType: PTypeInfo;
|
|
begin
|
|
CompType := GetTypeData(TypeInfo).CompType{$IFNDEF CLR}^{$ENDIF};
|
|
EnumMin := GetTypeData(CompType).MinValue;
|
|
EnumMax := GetTypeData(CompType).MaxValue;
|
|
ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;
|
|
BitShift := EnumMin mod 8;
|
|
TmpInt64 := Longword(Value) shl BitShift;
|
|
{$IFDEF CLR}
|
|
SetVar := BitConverter.GetBytes(TmpInt64);
|
|
{$ELSE}
|
|
Move(TmpInt64, SetVar, ResBytes);
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
function JclSetToInt(TypeInfo: PTypeInfo; const SetVar): Integer;
|
|
var
|
|
BitShift: Integer;
|
|
TmpInt64: Int64;
|
|
EnumMin: Integer;
|
|
EnumMax: Integer;
|
|
ResBytes: Integer;
|
|
CompType: PTypeInfo;
|
|
begin
|
|
CompType := GetTypeData(TypeInfo).CompType{$IFNDEF CLR}^{$ENDIF};
|
|
EnumMin := GetTypeData(CompType).MinValue;
|
|
EnumMax := GetTypeData(CompType).MaxValue;
|
|
ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;
|
|
BitShift := EnumMin mod 8;
|
|
if (EnumMax - EnumMin) > 32 then
|
|
{$IFDEF CLR}
|
|
raise EJclRTTIError.CreateFmt(RsRTTIValueOutOfRange,
|
|
[IntToStr(EnumMax - EnumMin) + ' ' + RsRTTIBits]);
|
|
TmpInt64 := BitConverter.ToInt64(TDynByteArray(SetVar), 0);
|
|
TmpInt64 := TmpInt64 shr BitShift;
|
|
Result := BitConverter.ToInt32(Copy(BitConverter.GetBytes(TmpInt64), 0, ResBytes), 0);
|
|
{$ELSE}
|
|
raise EJclRTTIError.CreateResFmt(@RsRTTIValueOutOfRange,
|
|
[IntToStr(EnumMax - EnumMin) + ' ' + LoadResString(@RsRTTIBits)]);
|
|
Result := 0;
|
|
TmpInt64 := 0;
|
|
Move(SetVar, TmpInt64, ResBytes + 1);
|
|
TmpInt64 := TmpInt64 shr BitShift;
|
|
Move(TmpInt64, Result, ResBytes);
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
{$IFNDEF CLR}
|
|
function JclGenerateSetType(BaseType: PTypeInfo;
|
|
const TypeName: ShortString): PTypeInfo;
|
|
var
|
|
TypeData: PTypeData;
|
|
ValCount: Integer;
|
|
begin
|
|
Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) + SizeOf(PPTypeInfo));
|
|
try
|
|
with Result^ do
|
|
begin
|
|
Kind := tkSet;
|
|
Name := TypeName;
|
|
end;
|
|
with GetTypeData(BaseType)^ do
|
|
ValCount := MaxValue - MinValue + (MinValue mod 8);
|
|
TypeData := GetTypeData(Result);
|
|
case ValCount of
|
|
0..8:
|
|
TypeData^.OrdType := otUByte;
|
|
9..16:
|
|
TypeData^.OrdType := otUWord;
|
|
17..32:
|
|
TypeData^.OrdType := otULong;
|
|
33..64:
|
|
Byte(TypeData^.OrdType) := 8;
|
|
65..128:
|
|
Byte(TypeData^.OrdType) := 16;
|
|
129..256:
|
|
Byte(TypeData^.OrdType) := 32;
|
|
else
|
|
Byte(TypeData^.OrdType) := 255;
|
|
end;
|
|
TypeData^.CompType := AllocMem(SizeOf(Pointer));
|
|
TypeData^.CompType^ := BaseType;
|
|
AddType(Result);
|
|
except
|
|
try
|
|
ReallocMem(Result, 0);
|
|
except
|
|
Result := nil;
|
|
end;
|
|
raise;
|
|
end;
|
|
ReferenceType(BaseType);
|
|
end;
|
|
|
|
//=== Is/As hooking ==========================================================
|
|
|
|
type
|
|
PReadLoc = ^TReadLoc;
|
|
TReadLoc = packed record
|
|
{$IFDEF OPTIMIZATION_ON}
|
|
Code: array [0..9] of Byte;
|
|
{$ELSE}
|
|
Code: array [0..17] of Byte;
|
|
{$ENDIF OPTIMIZATION_ON}
|
|
OpCode_Call: Byte;
|
|
CallOffset: Longint;
|
|
end;
|
|
|
|
PJmp = ^TJmp;
|
|
TJmp = packed record
|
|
case OpCodeJmp: Byte of
|
|
$E9:
|
|
(JmpOffset: Longint);
|
|
$FF:
|
|
(OpCode2: Byte;
|
|
EntryOffset: Longint);
|
|
end;
|
|
{$ENDIF ~CLR}
|
|
|
|
// Copied from System.pas (_IsClass function)
|
|
|
|
function JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;
|
|
{$IFDEF CLR}
|
|
begin
|
|
Result := (AnObj <> nil) and (AClass.ClassInfo.IsInstanceOfType(AnObj));
|
|
end;
|
|
{$ELSE}
|
|
asm
|
|
{ -> EAX left operand (class) }
|
|
{ EDX VMT of right operand }
|
|
{ <- AL left is derived from right }
|
|
TEST EAX,EAX
|
|
JE @@exit
|
|
@@loop:
|
|
MOV EAX,[EAX]
|
|
CMP EAX,EDX
|
|
JE @@success
|
|
MOV EAX,[EAX].vmtParent
|
|
TEST EAX,EAX
|
|
JNE @@loop
|
|
JMP @@exit
|
|
@@success:
|
|
MOV AL,1
|
|
@@exit:
|
|
end;
|
|
{$ENDIF ~CLR}
|
|
|
|
function JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean;
|
|
var
|
|
CurClass: TClass;
|
|
CurClass2: TClass;
|
|
begin
|
|
Result := AnObj <> nil;
|
|
if Result then
|
|
begin
|
|
CurClass := AnObj.ClassType;
|
|
Result := False;
|
|
while not Result and (CurClass <> nil) do
|
|
begin
|
|
Result := CurClass.ClassNameIs(AClass.ClassName);
|
|
if not Result then
|
|
CurClass := CurClass.ClassParent;
|
|
end;
|
|
if CurClass <> nil then
|
|
CurClass := CurClass.ClassParent;
|
|
CurClass2 := AClass.ClassParent;
|
|
while Result and (CurClass <> nil) and (CurClass2 <> nil) do
|
|
begin
|
|
Result := CurClass.ClassNameIs(CurClass2.ClassName);
|
|
if Result then
|
|
begin
|
|
CurClass := CurClass.ClassParent;
|
|
CurClass2 := CurClass2.ClassParent;
|
|
end;
|
|
end;
|
|
Result := Result and (CurClass = CurClass2);
|
|
end;
|
|
end;
|
|
|
|
function JclAsClass(const AnObj: TObject; const AClass: TClass): TObject;
|
|
begin
|
|
if (AnObj = nil) or (AnObj is AClass) then
|
|
Result := AnObj
|
|
else
|
|
{$IFDEF CLR}
|
|
raise EInvalidCast.Create(SInvalidCast);
|
|
{$ELSE}
|
|
raise EInvalidCast.CreateRes(@SInvalidCast);
|
|
{$ENDIF CLR}
|
|
end;
|
|
|
|
{$IFNDEF CLR}
|
|
initialization
|
|
TypeList := TThreadList.Create;
|
|
|
|
finalization
|
|
ClearInfoList;
|
|
FreeAndNil(TypeList);
|
|
{$ENDIF ~CLR}
|
|
|
|
// History:
|
|
|
|
// $Log: JclRTTI.pas,v $
|
|
// Revision 1.24 2005/05/05 20:08:44 ahuser
|
|
// JCL.NET support
|
|
//
|
|
// Revision 1.23 2005/03/14 08:46:53 rrossmair
|
|
// - check-in in preparation for release 1.95
|
|
//
|
|
// Revision 1.22 2005/03/08 16:10:08 marquardt
|
|
// standard char sets extended and used, some optimizations for string literals
|
|
//
|
|
// Revision 1.21 2005/03/08 08:33:17 marquardt
|
|
// overhaul of exceptions and resourcestrings, minor style cleaning
|
|
//
|
|
// Revision 1.20 2005/03/06 18:15:02 marquardt
|
|
// JclGUIDToString and JclStringToGUID moved to JclSysUtils.pas, CrLf replaced by AnsiLineBreak
|
|
//
|
|
// Revision 1.19 2005/03/01 00:10:26 ahuser
|
|
// Delphi 2005 inline support
|
|
//
|
|
// Revision 1.18 2005/02/24 16:34:40 marquardt
|
|
// remove divider lines, add section lines (unfinished)
|
|
//
|
|
// Revision 1.17 2004/11/15 05:25:28 mthoma
|
|
// Fixed #1055.
|
|
//
|
|
// Revision 1.16 2004/10/17 20:25:21 mthoma
|
|
// style cleaning, adjusting contributors
|
|
//
|
|
// Revision 1.15 2004/09/30 07:50:29 marquardt
|
|
// remove JclIsClass pure pascal contributions
|
|
//
|
|
// Revision 1.14 2004/08/03 07:22:37 marquardt
|
|
// resourcestring cleanup
|
|
//
|
|
// Revision 1.13 2004/08/01 05:52:11 marquardt
|
|
// move constructors/destructors
|
|
//
|
|
// Revision 1.12 2004/07/31 06:21:01 marquardt
|
|
// fixing TStringLists, adding BeginUpdate/EndUpdate, finalization improved
|
|
//
|
|
// Revision 1.11 2004/07/28 18:00:51 marquardt
|
|
// various style cleanings, some minor fixes
|
|
//
|
|
// Revision 1.10 2004/06/14 11:05:51 marquardt
|
|
// symbols added to all ENDIFs and some other minor style changes like removing IFOPT
|
|
//
|
|
// Revision 1.9 2004/06/11 14:08:51 twm
|
|
// Bugfix: now uses AnsiLineBreak rather than AnsiCrLf so it will work with unix systems
|
|
//
|
|
// Revision 1.8 2004/05/05 00:09:59 mthoma
|
|
// Updated headers: Added donors as contributors, adjusted the initial authors, added cvs names when they were not obvious. Changed $data to $date where necessary,
|
|
//
|
|
// Revision 1.7 2004/04/23 22:08:39 mthoma
|
|
// Removed non delphi language version of JclIsClass.
|
|
//
|
|
// Revision 1.6 2004/04/15 16:19:36
|
|
// add pure pascal implementation (JclIsClass)
|
|
//
|
|
// Revision 1.5 2004/04/06 04:53:18
|
|
// adapt compiler conditions, add log entry
|
|
//
|
|
|
|
end.
|