freepascal.compiler/rtl/objpas/typinfo.pp

{
    $Id$
    This file is part of the Free Pascal run time library.

    Copyright (c) 1999-2000 by Florian Klaempfl
    member of the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{ This unit provides the same Functionality as the TypInfo Unit }
{ of Delphi                                                     }

unit typinfo;

  interface

{$MODE objfpc}

  uses SysUtils;


// temporary types:

    type
//       PShortString =^ShortString;
//       PByte        =^Byte;
//       PWord        =^Word;
//       PLongint     =^Longint;
//       PBoolean     =^Boolean;
//       PSingle      =^Single;
//       PDouble      =^Double;
//       PExtended    =^Extended;
//       PComp        =^Comp;
{$ifndef HASVARIANT}
       Variant      = Pointer;
{$endif}

{$MINENUMSIZE 1   this saves a lot of memory }
       // if you change one of the following enumeration types
       // you have also to change the compiler in an appropriate way !
       TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,
                   tkFloat,tkSet,tkMethod,tkSString,tkLString,tkAString,
                   tkWString,tkVariant,tkArray,tkRecord,tkInterface,
                   tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
                   tkDynArray,tkInterfaceRaw);

       TTOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);

       TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr);
       TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor,
                      mkClassProcedure, mkClassFunction);
       TParamFlags = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
       TIntfFlags = set of (ifHasGuid,ifDispInterface,ifDispatch);

{$MINENUMSIZE DEFAULT}

   const
      ptField = 0;
      ptStatic = 1;
      ptVirtual = 2;
      ptConst = 3;

      tkString        = tkSString;

   type
      TTypeKinds = set of TTypeKind;

{$PACKRECORDS 1}
      TTypeInfo = record
         Kind : TTypeKind;
         Name : ShortString;
         // here the type data follows as TTypeData record
      end;

      PTypeInfo = ^TTypeInfo;
      PPTypeInfo = ^PTypeInfo;

      PTypeData = ^TTypeData;
      TTypeData = packed record
         case TTypeKind of
            tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
              ();
            tkInteger,tkChar,tkEnumeration,tkWChar:
              (OrdType : TTOrdType;
               case TTypeKind of
                  tkInteger,tkChar,tkEnumeration,tkBool,tkWChar : (
                    MinValue,MaxValue : Longint;
                    case TTypeKind of
                      tkEnumeration:
                        (
                        BaseType : PTypeInfo;
                        NameList : ShortString)
                    );
                  tkSet:
                    (CompType : PTypeInfo)
              );
            tkFloat:
              (FloatType : TFloatType);
            tkSString:
              (MaxLength : Byte);
            tkClass:
              (ClassType : TClass;
               ParentInfo : PTypeInfo;
               PropCount : SmallInt;
               UnitName : ShortString
               // here the properties follow as array of TPropInfo
              );
            tkMethod:
              (MethodKind : TMethodKind;
               ParamCount : Byte;
               ParamList : array[0..1023] of Char
             {in reality ParamList is a array[1..ParamCount] of:
                  record
                    Flags : TParamFlags;
                    ParamName : ShortString;
                    TypeName : ShortString;
                  end;
              followed by
                  ResultType : ShortString}
              );
            tkInt64:
              (MinInt64Value, MaxInt64Value: Int64);
            tkQWord:
              (MinQWordValue, MaxQWordValue: QWord);
            tkInterface,
            tkInterfaceRaw:
              (
               IntfParent: PPTypeInfo;
               IID: PGUID;
               IIDStr: ShortString;
               IntfUnit: ShortString;
              );
      end;

      // unsed, just for completeness
      TPropData = packed record
        PropCount : Word;
        PropList : record end;
      end;

      PPropInfo = ^TPropInfo;
      TPropInfo = packed record
        PropType : PTypeInfo;
        GetProc : Pointer;
        SetProc : Pointer;
        StoredProc : Pointer;
        Index : Integer;
        Default : Longint;
        NameIndex : SmallInt;

        // contains the type of the Get/Set/Storedproc, see also ptxxx
        // bit 0..1 GetProc
        //     2..3 SetProc
        //     4..5 StoredProc
        //     6 : true, constant index property
        PropProcs : Byte;

        Name : ShortString;
      end;

      TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;

      PPropList = ^TPropList;
      TPropList = array[0..65535] of PPropInfo;

   const
      tkAny = [Low(TTypeKind)..High(TTypeKind)];
      tkMethods = [tkMethod];
      tkProperties = tkAny-tkMethods-[tkUnknown];

// general property handling
Function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;

Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string; AKinds : TTypeKinds) : PPropInfo;
Function GetPropInfo(Instance: TObject; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
Function GetPropInfo(Instance: TObject; const PropName: string): PPropInfo;
Function GetPropInfo(AClass: TClass; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
Function GetPropInfo(AClass: TClass; const PropName: string): PPropInfo;
Function FindPropInfo(Instance: TObject; const PropName: string): PPropInfo;
Function FindPropInfo(AClass:TClass;const PropName: string): PPropInfo;
Procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
Function  GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList) : Integer;

// Property information routines.
Function IsStoredProp(Instance: TObject;PropInfo : PPropInfo) : Boolean;
Function IsStoredProp(Instance: TObject; const PropName: string): Boolean;
Function IsPublishedProp(Instance: TObject; const PropName: string): Boolean;
Function IsPublishedProp(AClass: TClass; const PropName: string): Boolean;
Function PropType(Instance: TObject; const PropName: string): TTypeKind;
Function PropType(AClass: TClass; const PropName: string): TTypeKind;
Function PropIsType(Instance: TObject; const PropName: string; TypeKind: TTypeKind): Boolean;
Function PropIsType(AClass: TClass; const PropName: string; TypeKind: TTypeKind): Boolean;

// subroutines to read/write properties
Function  GetOrdProp(Instance: TObject; PropInfo : PPropInfo) : Longint;
Function  GetOrdProp(Instance: TObject; const PropName: string): Longint;
Procedure SetOrdProp(Instance: TObject; PropInfo : PPropInfo;  Value : Longint);
Procedure SetOrdProp(Instance: TObject; const PropName: string; Value: Longint);

Function  GetEnumProp(Instance: TObject; const PropName: string): string;
Function  GetEnumProp(Instance: TObject; const PropInfo: PPropInfo): string;
Procedure SetEnumProp(Instance: TObject; const PropName: string;const Value: string);
Procedure SetEnumProp(Instance: TObject; const PropInfo: PPropInfo;const Value: string);

Function  GetSetProp(Instance: TObject; const PropName: string): string;
Function  GetSetProp(Instance: TObject; const PropName: string; Brackets: Boolean): string;
Function  GetSetProp(Instance: TObject; const PropInfo: PPropInfo; Brackets: Boolean): string;
Procedure SetSetProp(Instance: TObject; const PropName: string; const Value: string);
Procedure SetSetProp(Instance: TObject; const PropInfo: PPropInfo; const Value: string);

Function  GetStrProp(Instance: TObject; PropInfo : PPropInfo) : Ansistring;
Function  GetStrProp(Instance: TObject; const PropName: string): string;
Procedure SetStrProp(Instance: TObject; const PropName: string; const Value: AnsiString);
Procedure SetStrProp(Instance: TObject; PropInfo : PPropInfo;  const Value : Ansistring);

Function  GetFloatProp(Instance: TObject; PropInfo : PPropInfo) : Extended;
Function  GetFloatProp(Instance: TObject; const PropName: string): Extended;
Procedure SetFloatProp(Instance: TObject; const PropName: string; Value: Extended);
Procedure SetFloatProp(Instance: TObject; PropInfo : PPropInfo;  Value : Extended);

Function  GetVariantProp(Instance: TObject; PropInfo : PPropInfo): Variant;
Function  GetVariantProp(Instance: TObject; const PropName: string): Variant;
Procedure SetVariantProp(Instance: TObject; const PropName: string; const Value: Variant);
Procedure SetVariantProp(Instance: TObject; PropInfo : PPropInfo; const Value: Variant);

Function  GetObjectProp(Instance: TObject; const PropName: string): TObject;
Function  GetObjectProp(Instance: TObject; const PropName: string; MinClass: TClass): TObject;
Function  GetObjectProp(Instance: TObject; PropInfo: PPropInfo; MinClass: TClass): TObject;
Procedure SetObjectProp(Instance: TObject; const PropName: string; Value: TObject);
Procedure SetObjectProp(Instance: TObject; PropInfo: PPropInfo; Value: TObject);

Function  GetObjectPropClass(Instance: TObject; const PropName: string): TClass;

Function  GetMethodProp(Instance: TObject; PropInfo: PPropInfo) : TMethod;
Function  GetMethodProp(Instance: TObject; const PropName: string): TMethod;
Procedure SetMethodProp(Instance: TObject; PropInfo: PPropInfo;  const Value : TMethod);
Procedure SetMethodProp(Instance: TObject; const PropName: string; const Value: TMethod);

Function  GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64;
Function  GetInt64Prop(Instance: TObject; const PropName: string): Int64;
Procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo;  const Value: Int64);
Procedure SetInt64Prop(Instance: TObject; const PropName: string;  const Value: Int64);

Function GetPropValue(Instance: TObject; const PropName: string): Variant;
Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
Procedure SetPropValue(Instance: TObject; const PropName: string; const Value: Variant);

// Auxiliary routines, which may be useful
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;
function SetToString(PropInfo: PPropInfo; Value: Integer) : String;
function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;

const
    BooleanIdents: array[Boolean] of String = ('False', 'True');
    DotSep: String = '.';

Type
  EPropertyError = Class(Exception);

Implementation

ResourceString
  SErrPropertyNotFound = 'Unknown property: "%s"';
  SErrUnknownEnumValue = 'Unknown enumeration value: "%s"';

type
  PMethod = ^TMethod;

{ ---------------------------------------------------------------------
  Auxiliary methods
  ---------------------------------------------------------------------}

Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;

  Var PS : PShortString;
      PT : PTypeData;

begin
 PT:=GetTypeData(TypeInfo);
 // ^.BaseType);
 //      If PT^.MinValue<0 then Value:=Ord(Value<>0); {map to 0/1}
 PS:=@PT^.NameList;
 While Value>0 Do
  begin
    PS:=PShortString(pointer(PS)+PByte(PS)^+1);
    Dec(Value);
  end;
 Result:=PS^;
end;

Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;

  Var PS : PShortString;
      PT : PTypeData;
      Count : longint;

begin
  If Length(Name)=0 then exit(-1);
  PT:=GetTypeData(TypeInfo);
  Count:=0;
  Result:=-1;
  PS:=@PT^.NameList;
  While (Result=-1) and (PByte(PS)^<>0) do
    begin
    If CompareText(PS^, Name) = 0 then
      Result:=Count;
    PS:=PShortString(pointer(PS)+PByte(PS)^+1);
    Inc(Count);
    end;
end;

Function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;

Var
  I : Integer;
  PTI : PTypeInfo;

begin
  PTI:=GetTypeData(PropInfo^.PropType)^.CompType;
  Result:='';
  For I:=0 to SizeOf(Integer)*8-1 do
    begin
    if ((Value and 1)<>0) then
      begin
      If Result='' then
        Result:=GetEnumName(PTI,i)
      else
        Result:=Result+','+GetEnumName(PTI,I);
      end;
    Value:=Value shr 1;
    end;
  if Brackets then
    Result:='['+Result+']';
end;

Function SetToString(PropInfo: PPropInfo; Value: Integer) : String;

begin
  Result:=SetToString(PropInfo,Value,False);
end;

Const
  SetDelim = ['[',']',',',' '];

Function GetNextElement(Var S : String) : String;

Var
  J : Integer;

begin
  J:=1;
  Result:='';
  If Length(S)>0 then
    begin
    While (J<=Length(S)) and Not (S[j] in SetDelim) do
      Inc(j);
    Result:=Copy(S,1,j-1);
    Delete(S,1,j);
    end;
end;

Function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;


Var
  S,T : String;
  I : Integer;
  PTI : PTypeInfo;

begin
  Result:=0;
  PTI:=GetTypeData(PropInfo^.PropType)^.Comptype;
  S:=Value;
  I:=1;
  If Length(S)>0 then
    begin
    While (I<=Length(S)) and (S[i] in SetDelim) do
      Inc(I);
    Delete(S,1,i-1);
    end;
  While (S<>'') do
    begin
    T:=GetNextElement(S);
    if T<>'' then
      begin
      I:=GetEnumValue(PTI,T);
      if (I<0) then
        raise EPropertyError.CreateFmt(SErrUnknownEnumValue, [T]);
      Result:=Result or (1 shl i);
      end;
    end;
end;

Function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;

begin
  GetTypeData:=PTypeData(pointer(TypeInfo)+2+PByte(pointer(TypeInfo)+1)^);
end;

{ ---------------------------------------------------------------------
  Low-level calling of methods.
  ---------------------------------------------------------------------}

{$ASMMODE ATT}

Function CallIntegerFunc(s: Pointer; Address: Pointer; Index, IValue: LongInt): Int64; assembler;
      asm
         movl S,%esi
         movl Address,%edi
     // ? Indexed Function
         movl Index,%eax
         testl %eax,%eax
         je .LINoPush
         movl IValue,%eax
         pushl %eax
      .LINoPush:
         push %esi
         call %edi
         // now the result is in EDX:EAX
      end;

Function CallIntegerProc(s : Pointer;Address : Pointer;Value : Integer; INdex,IValue : Longint) : Integer;assembler;
      asm
         movl S,%esi
         movl Address,%edi
         // Push value to set
         movl Value,%eax
         pushl %eax
     // ? Indexed Procedure
         movl Index,%eax
         testl %eax,%eax
         je .LIPNoPush
         movl IValue,%eax
         pushl %eax
      .LIPNoPush:
         pushl %esi
         call %edi
      end;

Function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler;
      asm
         movl S,%esi
         movl Address,%edi
     // ? Indexed Function
         movl Index,%eax
         testl %eax,%eax
         je .LINoPush
         movl IValue,%eax
         pushl %eax
      .LINoPush:
         push %esi
         call %edi
         //
      end;

Function CallExtendedProc(s : Pointer;Address : Pointer;Value : Extended; INdex,IVAlue : Longint) : Integer;assembler;
      asm
         movl S,%esi
         movl Address,%edi
         // Push value to set
         leal Value,%eax
         pushl (%eax)
         pushl 4(%eax)
         pushl 8(%eax)
     // ? Indexed Procedure
         movl Index,%eax
         testl %eax,%eax
         je .LIPNoPush
         movl IValue,%eax
         pushl %eax
      .LIPNoPush:
         push %esi
         call %edi
      end;

Function CallBooleanFunc(s : Pointer;Address : Pointer; Index,IValue : Longint) : Boolean;assembler;
      asm
         movl S,%esi
         movl Address,%edi
     // ? Indexed Function
         movl Index,%eax
         testl %eax,%eax
         je .LBNoPush
         movl IValue,%eax
         pushl %eax
      .LBNoPush:
         push %esi
         call %edi
      end;

// Assembler Functions can't have short stringreturn values.
// So we make a Procedure with var parameter.
// That's not true (FK)

Procedure CallSStringFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint;
                            Var Res: Shortstring);assembler;
      asm
         movl S,%esi
         movl Address,%edi
     // ? Indexed Function
         movl Index,%eax
         testl %eax,%eax
         jnz .LSSNoPush
         movl IValue,%eax
         pushl %eax
         // the result is stored in an invisible parameter
         pushl Res
      .LSSNoPush:
         push %esi
         call %edi
      end;

Procedure CallSStringProc(s : Pointer;Address : Pointer;Const Value : ShortString; INdex,IVAlue : Longint);assembler;
      asm
         movl S,%esi
         movl Address,%edi
         // Push value to set
         movl Value,%eax
         pushl %eax
     // ? Indexed Procedure
         movl Index,%eax
         testl %eax,%eax
         je .LSSPNoPush
         movl IValue,%eax
         pushl %eax
      .LSSPNoPush:
         pushl %esi
         call %edi
      end;

{ ---------------------------------------------------------------------
  Basic Type information functions.
  ---------------------------------------------------------------------}

Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;

var
         hp : PTypeData;
         i : longint;
         p : string;

begin
         P:=UpCase(PropName);
         while Assigned(TypeInfo) do
           begin
              // skip the name
              hp:=GetTypeData(Typeinfo);
    // the class info rtti the property rtti follows immediatly
              Result:=PPropInfo(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1+SizeOF(Word));
              for i:=1 to hp^.PropCount do
                begin
                   // found a property of that name ?
                   if Upcase(Result^.Name)=P then
                     exit;
                   // skip to next property
                   Result:=PPropInfo(pointer(@Result^.Name)+byte(Result^.Name[0])+1);
                end;
              // parent class
              Typeinfo:=hp^.ParentInfo;
           end;
         Result:=Nil;
end;

Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string; Akinds : TTypeKinds) : PPropInfo;

begin
  Result:=GetPropInfo(TypeInfo,PropName);
  If (Akinds<>[]) then
    If (Result<>Nil) then
      If Not (Result^.PropType^.Kind in AKinds) then
        Result:=Nil;
end;

Function GetPropInfo(AClass: TClass; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
begin
  Result:=GetPropInfo(PTypeInfo(AClass.ClassInfo),PropName,AKinds);
end;

Function GetPropInfo(Instance: TObject; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
begin
  Result:=GetPropInfo(Instance.ClassType,PropName,AKinds);
end;

Function GetPropInfo(Instance: TObject; const PropName: string): PPropInfo;
begin
  Result:=GetPropInfo(Instance,PropName,[]);
end;

Function GetPropInfo(AClass: TClass; const PropName: string): PPropInfo;
begin
  Result:=GetPropInfo(AClass,PropName,[]);
end;


Function FindPropInfo(Instance: TObject; const PropName: string): PPropInfo;
begin
  result:=GetPropInfo(Instance, PropName);
  if Result=nil then
    Raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName]);
end;


Function FindPropInfo(AClass:TClass;const PropName: string): PPropInfo;
begin
  result:=GetPropInfo(AClass,PropName);
  if result=nil then
    Raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName]);
end;

Function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;

begin
         case (PropInfo^.PropProcs shr 4) and 3 of
            ptfield:
              IsStoredProp:=PBoolean(Pointer(Instance)+Longint(PropInfo^.StoredProc))^;
            ptstatic:
              IsStoredProp:=CallBooleanFunc(Instance,PropInfo^.StoredProc,0,0);
            ptvirtual:
              IsStoredProp:=CallBooleanFunc(Instance,ppointer(Pointer(Instance.ClassType)+Longint(PropInfo^.StoredProc))^,0,0);
            ptconst:
              IsStoredProp:=LongBool(PropInfo^.StoredProc);
         end;
end;



Procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
{
        Store Pointers to property information in the list pointed
        to by proplist. PRopList must contain enough space to hold ALL
        properties.
}
Type PWord = ^Word;

Var TD : PTypeData;
          TP : PPropInfo;
          Count : Longint;

begin
TD:=GetTypeData(TypeInfo);
// Get this objects TOTAL published properties count
TP:=(@TD^.UnitName+Length(TD^.UnitName)+1);
Count:=PWord(TP)^;
// Now point TP to first propinfo record.
Inc(Longint(TP),SizeOF(Word));
While Count>0 do
        begin
        PropList^[0]:=TP;
        Inc(Longint(PropList),SizeOf(Pointer));
        // Point to TP next propinfo record.
        // Located at Name[Length(Name)+1] !
        TP:=PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1);
        Dec(Count);
        end;
// recursive call for parent info.
If TD^.Parentinfo<>Nil then
        GetPropInfos (TD^.ParentInfo,PropList);
end;

Procedure InsertProp (PL : PProplist;PI : PPropInfo; Count : longint);

Var I : Longint;

begin
     I:=0;
     While (I<Count) and (PI^.Name>PL^[I]^.Name) do Inc(I);
     If I<Count then
       Move(PL^[I], PL^[I+1], (Count - I) * SizeOf(Pointer));
     PL^[I]:=PI;
end;

Function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
      PropList : PPropList) : Integer;

      {
        Store Pointers to property information OF A CERTAIN KIND in the list pointed
        to by proplist. PRopList must contain enough space to hold ALL
        properties.
      }
Var TempList : PPropList;
          PropInfo : PPropinfo;
          I,Count : longint;

begin
        Result:=0;
        Count:=GetTypeData(TypeInfo)^.Propcount;
        If Count>0 then
          begin
          GetMem(TempList,Count*SizeOf(Pointer));
          Try
            GetPropInfos(TypeInfo,TempList);
            For I:=0 to Count-1 do
              begin
              PropInfo:=TempList^[i];
              If PropInfo^.PropType^.Kind in TypeKinds then
                begin
                InsertProp(PropList,PropInfo,Result);
                Inc(Result);
                end;
              end;
          finally
            FreeMem(TempList,Count*SizeOf(Pointer));
          end;
          end;
end;

Procedure SetIndexValues (P: PPRopInfo; Var Index,IValue : Longint);

begin
    Index:=((P^.PropProcs shr 6) and 1);
    If Index<>0 then
      IValue:=P^.Index
    else
      IValue:=0;
end;

{ ---------------------------------------------------------------------
  Property access functions
  ---------------------------------------------------------------------}

{ ---------------------------------------------------------------------
  Ordinal properties
  ---------------------------------------------------------------------}

Function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;

var
         value,Index,Ivalue : longint;
         TypeInfo: PTypeInfo;

begin
         SetIndexValues(PropInfo,Index,Ivalue);
         case (PropInfo^.PropProcs) and 3 of
            ptfield:
              Value:=PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
            ptstatic:
              Value:=CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue);
            ptvirtual:
              Value:=CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue);
         end;
         { cut off unnecessary stuff }
         TypeInfo := PropInfo^.PropType;
         case TypeInfo^.Kind of
           tkChar, tkBool:
             Value:=Value and $ff;
           tkWChar:
             Value:=Value and $ffff;
           tkInteger:
             case GetTypeData(TypeInfo)^.OrdType of
                otSWord,otUWord:
                  Value:=Value and $ffff;
                otSByte,otUByte:
                  Value:=Value and $ff;
             end;
         end;
         GetOrdProp:=Value;
end;

Procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;
      Value : Longint);

var
        Index,IValue : Longint;
        DataSize: Integer;

begin
         if PropInfo^.PropType^.Kind <> tkClass then
           { cut off unnecessary stuff }
           case GetTypeData(PropInfo^.PropType)^.OrdType of
      otSWord,otUWord:
        begin
                  Value:=Value and $ffff;
                  DataSize := 2;
                end;
      otSByte,otUByte:
        begin
                  Value:=Value and $ff;
                  DataSize := 1;
              end;
    else
        DataSize := 4;
           end
         else
           DataSize := 4;
         SetIndexValues(PropInfo,Index,Ivalue);
         case (PropInfo^.PropProcs shr 2) and 3 of
            ptfield:
              case DataSize of
                1: PByte(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Byte(Value);
                2: PWord(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Word(Value);
                4: PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
              end;
            ptstatic:
              CallIntegerProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
            ptvirtual:
              CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
         end;
end;


Function GetOrdProp(Instance: TObject; const PropName: string): Longint;

begin
  Result:=GetOrdProp(Instance,FindPropInfo(Instance,PropName));
end;

Procedure SetOrdProp(Instance: TObject; const PropName: string;  Value: Longint);
begin
  SetOrdProp(Instance,FindPropInfo(Instance,PropName),Value);
end;

Function GetEnumProp(Instance: TObject; Const PropInfo: PPropInfo): string;
begin
  Result:=GetEnumName(PropInfo^.PropType, GetOrdProp(Instance, PropInfo));
end;

Function GetEnumProp(Instance: TObject; const PropName: string): string;

begin
  Result:=GetEnumProp(Instance,FindPropInfo(Instance,PropName));
end;

Procedure SetEnumProp(Instance: TObject; const PropName: string;  const Value: string);
begin
  SetEnumProp(Instance,FindPropInfo(Instance,PropName),Value);
end;

Procedure SetEnumProp(Instance: TObject; Const PropInfo : PPropInfo; const Value: string);

Var
  PV : Longint;

begin
  If PropInfo<>Nil then
    begin
    PV:=GetEnumValue(PropInfo^.PropType, Value);
    if (PV<0) then
      raise EPropertyError.CreateFmt(SErrUnknownEnumValue, [Value]);
    SetOrdProp(Instance, PropInfo,PV);
    end;
end;

{ ---------------------------------------------------------------------
  Set properties
  ---------------------------------------------------------------------}

Function GetSetProp(Instance: TObject; const PropName: string): string;

begin
  Result:=GetSetProp(Instance,PropName,False);
end;

Function GetSetProp(Instance: TObject; const PropName: string; Brackets: Boolean): string;
begin
  Result:=GetSetProp(Instance,FindPropInfo(Instance,PropName),Brackets);
end;

Function GetSetProp(Instance: TObject; const PropInfo: PPropInfo; Brackets: Boolean): string;

begin
  Result:=SetToString(PropInfo,GetOrdProp(Instance,PropInfo),Brackets);
end;

Procedure SetSetProp(Instance: TObject; const PropName: string; const Value: string);
begin
  SetSetProp(Instance,FindPropInfo(Instance,PropName),Value);
end;


Procedure SetSetProp(Instance: TObject; const PropInfo: PPropInfo; const Value: string);
begin
  SetOrdProp(Instance,PropInfo,StringToSet(PropInfo,Value));
end;

{ ---------------------------------------------------------------------
  Object properties
  ---------------------------------------------------------------------}

Function GetObjectProp(Instance: TObject; const PropName: string): TObject;
begin
  Result:=GetObjectProp(Instance,PropName,Nil);
end;

Function GetObjectProp(Instance: TObject; const PropName: string; MinClass: TClass): TObject;
begin
  Result:=GetObjectProp(Instance,FindPropInfo(Instance,PropName),MinClass);
end;

Function GetObjectProp(Instance: TObject; PropInfo : PPropInfo; MinClass: TClass): TObject;
begin
  Result:=TObject(GetOrdProp(Instance,PropInfo));
  If (MinClass<>Nil) and (Result<>Nil) Then
    If Not Result.InheritsFrom(MinClass) then
      Result:=Nil;
end;

Procedure SetObjectProp(Instance: TObject; const PropName: string;  Value: TObject);
begin
  SetObjectProp(Instance,FindPropInfo(Instance,PropName),Value);
end;

Procedure SetObjectProp(Instance: TObject; PropInfo : PPropInfo;  Value: TObject);
begin
  SetOrdProp(Instance,PropInfo,Integer(Value));
end;

Function GetObjectPropClass(Instance: TObject; const PropName: string): TClass;
begin
  Result:=GetTypeData(FindPropInfo(Instance,PropName)^.PropType)^.ClassType;
end;

{ ---------------------------------------------------------------------
  String properties
  ---------------------------------------------------------------------}

Function GetStrProp(Instance: TObject; PropInfo: PPropInfo): AnsiString;
var
      Index, IValue: LongInt;
      ShortResult: ShortString;
begin
      SetIndexValues(PropInfo, Index, IValue);
      case Propinfo^.PropType^.Kind of
        tkSString:
          case (PropInfo^.PropProcs) and 3 of
            ptField:
              Result := PShortString(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
            ptStatic:
              begin
                CallSStringFunc(Instance, PropInfo^.GetProc, Index, IValue, ShortResult);
                Result := ShortResult;
              end;
            ptVirtual:
              begin
                CallSStringFunc(Instance, PPointer(Pointer(Instance.ClassType) +
                  LongWord(PropInfo^.GetProc))^, Index, IValue, ShortResult);
              Result := ShortResult;
            end;
          end;
        tkAString:
          case (PropInfo^.PropProcs) and 3 of
            ptField:
              Result := PAnsiString(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
            ptStatic:
              Pointer(Result) := Pointer(LongWord(CallIntegerFunc(Instance, PropInfo^.GetProc, Index, IValue)));
            ptVirtual:
              Pointer(Result) := Pointer(LongWord(CallIntegerFunc(Instance,
                PPointer(Pointer(Instance.ClassType) + LongWord(PropInfo^.GetProc))^, Index, IValue)));
          end;
        else
          // Property is neither of type AnsiString nor of type ShortString
          SetLength(Result, 0);
      end;
end;

Procedure SetAStrProp(Instance : TObject;PropInfo : PPropInfo;
      const Value : AnsiString);

{
Dirty trick based on fact that AnsiString is just a pointer,
hence can be treated like an integer type.
}
var
         Index,Ivalue : Longint;

begin
         SetIndexValues(PropInfo,Index,IValue);
         case (PropInfo^.PropProcs shr 2) and 3 of
            ptfield:
              PAnsiString(Pointer(Instance) + Longint(PropInfo^.SetProc))^ := Value;
            ptstatic:
              CallIntegerProc(Instance,PropInfo^.SetProc,Longint(Pointer(Value)),Index,IValue);
            ptvirtual:
              CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Longint(Pointer(Value)),Index,IValue);
         end;
end;

Procedure SetSStrProp(Instance : TObject;PropInfo : PPropInfo;
      const Value : ShortString);

Var Index,IValue: longint;

begin
      SetIndexValues(PRopInfo,Index,IValue);
         case (PropInfo^.PropProcs shr 2) and 3 of
            ptfield:
              PShortString(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
            ptstatic:
              CallSStringProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
            ptvirtual:
              CallSStringProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
         end;
end;

Procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
      const Value : AnsiString);

begin
      Case Propinfo^.PropType^.Kind of
        tkSString : SetSStrProp(Instance,PropInfo,Value);
        tkAString : SetAStrProp(Instance,Propinfo,Value);
      end;
end;


Function GetStrProp(Instance: TObject; const PropName: string): string;
begin
  Result:=GetStrProp(Instance,FindPropInfo(Instance,PropName));
end;

Procedure SetStrProp(Instance: TObject; const PropName: string; const Value: AnsiString);
begin
  SetStrProp(Instance,FindPropInfo(Instance,PropName),Value);
end;

{ ---------------------------------------------------------------------
  Float properties
  ---------------------------------------------------------------------}

Function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;

var
         Index,Ivalue : longint;
         Value : Extended;

begin
         SetIndexValues(PropInfo,Index,Ivalue);
         case (PropInfo^.PropProcs) and 3 of
            ptfield:
              Case GetTypeData(PropInfo^.PropType)^.FloatType of
               ftSingle:
                 Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
               ftDouble:
                 Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
               ftExtended:
                 Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
               ftcomp:
                 Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
               { Uncommenting this code results in a internal error!!
               ftFixed16:
                 Value:=PFixed16(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
               ftfixed32:
                 Value:=PFixed32(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
               }
               end;
            ptstatic:
              Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue);
            ptvirtual:
              Value:=CallExtendedFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue);
         end;
         Result:=Value;
end;

Procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
      Value : Extended);

       Var IValue,Index : longint;

begin
         SetIndexValues(PropInfo,Index,Ivalue);
         case (PropInfo^.PropProcs shr 2) and 3 of
            ptfield:
              Case GetTypeData(PropInfo^.PropType)^.FloatType of
               ftSingle:
                 PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
               ftDouble:
                 PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
               ftExtended:
                 PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
               ftcomp:
                 PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Comp(Value);
               { Uncommenting this code results in a internal error!!
               ftFixed16:
                 PFixed16(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
               ftfixed32:
                 PFixed32(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
               }
               end;
            ptstatic:
              CallExtendedProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
            ptvirtual:
              CallExtendedProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
         end;
end;

Function GetFloatProp(Instance: TObject; const PropName: string): Extended;
begin
  Result:=GetFloatProp(Instance,FindPropInfo(Instance,PropName))
end;

Procedure SetFloatProp(Instance: TObject; const PropName: string;  Value: Extended);
begin
  SetFloatProp(Instance,FindPropInfo(Instance,PropName),Value);
end;

{ ---------------------------------------------------------------------
  Variant properties
  ---------------------------------------------------------------------}

Function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;

begin
         {!!!!!!!!!!!}
         Result:=nil;
end;

Procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
      const Value: Variant);

begin
         {!!!!!!!!!!!}
end;

Function GetVariantProp(Instance: TObject; const PropName: string): Variant;
begin
  Result:=GetVariantProp(Instance,FindPropInfo(Instance,PropName));
end;

Procedure SetVariantProp(Instance: TObject; const PropName: string;  const Value: Variant);
begin
  SetVariantprop(instance,FindpropInfo(Instance,PropName),Value);
end;


{ ---------------------------------------------------------------------
  Method properties
  ---------------------------------------------------------------------}


Function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;

var
         value: PMethod;
         Index,Ivalue : longint;

begin
         SetIndexValues(PropInfo,Index,Ivalue);
         case (PropInfo^.PropProcs) and 3 of
            ptfield:
              Value:=PMethod(Pointer(Instance)+Longint(PropInfo^.GetProc));
            ptstatic:
              Value:=PMethod(LongInt(CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue)));
            ptvirtual:
              Value:=PMethod(LongInt(CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue)));
         end;
         GetMethodProp:=Value^;
end;

Procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
      const Value : TMethod);

var
        Index,IValue : Longint;

begin
         SetIndexValues(PropInfo,Index,Ivalue);
         case (PropInfo^.PropProcs shr 2) and 3 of
            ptfield:
              PMethod(Pointer(Instance)+Longint(PropInfo^.SetProc))^ := Value;
            ptstatic:
              CallIntegerProc(Instance,PropInfo^.SetProc,Integer(@Value), Index, IValue);
            ptvirtual:
              CallIntegerProc(Instance,
                PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,
                Integer(@Value), Index, IValue);
         end;
end;

Function GetMethodProp(Instance: TObject; const PropName: string): TMethod;
begin
  Result:=GetMethodProp(Instance,FindPropInfo(Instance,PropName));
end;

Procedure SetMethodProp(Instance: TObject; const PropName: string;  const Value: TMethod);
begin
  SetMethodProp(Instance,FindPropInfo(Instance,PropName),Value);
end;

{ ---------------------------------------------------------------------
  Int64 properties
  ---------------------------------------------------------------------}

Function GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64;
var
  Index, IValue: LongInt;
begin
      SetIndexValues(PropInfo,Index,Ivalue);
      case PropInfo^.PropProcs and 3 of
        ptfield:
          Result := PInt64(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
        ptstatic:
          Result := CallIntegerFunc(Instance, PropInfo^.GetProc, Index, IValue);
        ptvirtual:
          Result := CallIntegerFunc(Instance,
            PPointer(Pointer(Instance.ClassType) + LongInt(PropInfo^.GetProc))^,
            Index, IValue);
      end;
end;

procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo; const Value: Int64);
var
  Index, IValue: LongInt;
begin
      SetIndexValues(PropInfo,Index,Ivalue);
      case PropInfo^.PropProcs and 3 of
        ptfield:
          PInt64(Pointer(Instance)+Longint(PropInfo^.GetProc))^ := Value;
        ptstatic:
          CallIntegerProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
        ptvirtual:
          CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
      end;
end;

Function GetInt64Prop(Instance: TObject; const PropName: string): Int64;
begin
  Result:=GetInt64Prop(Instance,FindPropInfo(Instance,PropName));
end;

Procedure SetInt64Prop(Instance: TObject; const PropName: string; const Value: Int64);
begin
  SetInt64Prop(Instance,FindPropInfo(Instance,PropName),Value);
end;


{ ---------------------------------------------------------------------
  All properties through variant.
  ---------------------------------------------------------------------}

Function GetPropValue(Instance: TObject; const PropName: string): Variant;
begin
  Result:=GetPropValue(Instance,PropName,True);
end;

Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
begin
end;

Procedure SetPropValue(Instance: TObject; const PropName: string;  const Value: Variant);
begin
end;

{ ---------------------------------------------------------------------
  Easy access methods that appeared in Delphi 5
  ---------------------------------------------------------------------}

Function IsPublishedProp(Instance: TObject; const PropName: string): Boolean;
begin
  Result:=GetPropInfo(Instance,PropName)<>Nil;
end;

Function IsPublishedProp(AClass: TClass; const PropName: string): Boolean;
begin
  Result:=GetPropInfo(AClass,PropName)<>Nil;
end;

Function PropIsType(Instance: TObject; const PropName: string; TypeKind: TTypeKind): Boolean;
begin
  Result:=FindPropInfo(Instance,PropName)^.PropType^.Kind=TypeKind
end;

Function PropIsType(AClass: TClass; const PropName: string; TypeKind: TTypeKind): Boolean;
begin
  Result:=PropType(AClass,PropName)=TypeKind
end;

Function PropType(Instance: TObject; const PropName: string): TTypeKind;
begin
  Result:=FindPropInfo(Instance,PropName)^.PropType^.Kind;
end;

Function PropType(AClass: TClass; const PropName: string): TTypeKind;
begin
  Result:=FindPropInfo(AClass,PropName)^.PropType^.Kind;
end;

Function IsStoredProp(Instance: TObject; const PropName: string): Boolean;
begin
  Result:=IsStoredProp(instance,FindPropInfo(Instance,PropName));
end;

end.
{
  $Log$
  Revision 1.10  2001-07-29 13:37:46  peter
    * merged completion from v10

  Revision 1.9  2001/07/06 14:56:06  peter
    * merged more D5/D6 stuff from v10

  Revision 1.8  2001/06/27 21:37:38  peter
    * v10 merges

  Revision 1.7  2001/02/15 22:40:22  sg
  * Fixed SetOrdProp for class instance properties (merged from fixbranch)

  Revision 1.6  2000/12/13 23:28:17  sg
  * Merged bugfix for bug 1273 from fixbranch
  * Fixed typo in SetFloatProp
  * Rewrote GetStrProp, now all AnsiString will be correctly
    reference counted

  Revision 1.5  2000/11/25 18:36:55  sg
  * (Final) fix for AnsiString reference counter problem in SetStrProp

  Revision 1.4  2000/11/04 16:28:26  florian
    * interfaces support

  Revision 1.3  2000/07/17 08:37:58  sg
  * Fixed GetEnumValue (bug #1049, reported by Neil Graham)

  Revision 1.2  2000/07/13 11:33:52  michael
  + removed logs

}