unit PropUtl;

interface
uses
  SysUtils, Classes, TypInfo, Stru;

type
  EUnsupportedTypeKind = class(Exception);
  EUnsupportedOrdType = class(Exception);
  EUnsupportedFloatType = class(Exception);

function ClassGetPropStr(c: TObject; j: integer;
  var AValue: AnsiString): boolean;

function ClassGetPropNameAndValue(c: TObject; j: integer; var AName: shortstring;
  var AValue: AnsiString): boolean;
{ returns true if j is valid index in c's properties and sets AName to the
  name of property of given index and AValue to it's value;
  returns false if j is out of range }

function ClassSetPropStr(c: TObject; const AName: shortstring;
  const AValue: AnsiString): integer;overload;
{ returns > 0 if c has property of name AName and sets it's value to AValue;
  the return value is size of the property (if tkLString then its sum of
  length(string) + 4 i.e. size used to store it to stream),
  returns 0 if c has no property with name AName }

function ClassSetPropStr(c: TObject; i: integer; const AValue: AnsiString): integer;overload;

function FillEnumNames(c: TObject; const AName: string; Items: TStrings): boolean;overload;
  { Fills Items with names of allowed values for property AName of object c }

{v0.24}
function FillEnumNames(APropInfo: PPropInfo; Items: TStrings): boolean;overload;
{/v0.24}

function FillPropNames(c: TObject; const AfterName: string;
  var FirstPropIndex:integer; Items: TStrings): boolean;
  { Fill Items with names of properties published in given object c;
    if AfterName <> '', then fills only with names of those properties that
    are defined after property of the name AfterName and the FirstPropIndex is set
    to the index of the first property that is after AfterName property. }

function GetPropIndex(c: TObject; const APropName: string): integer;
  { Returns index of the objects' published property with a name = APropName;
    -1 if not found. }

function ClassSumStringLength(c: TObject): integer;
  { return sum of all lengths of all c's published properties of
    type = tkLString }

function ClassReadPropsFromStream(c: TObject; FromPropIndex: integer;
  {v0.06}MaxSize: integer; {/v0.06} AStream: TStream): integer;
  { Read values of all published properties with field index value FromPropIndex
    and higher from AStream (if MaxSize <> 0, then reads from stream maximaly
    that count of bytes) }

function ClassWritePropsToStream(c: TObject; FromPropIndex: integer; AStream: TStream): integer;
  { Read values of all published properties with field index value = FromPropIndex
    and higher from AStream }

{v0.21}
{function GetClass(const AClassTypeName: string): TClass;}
{/v0.21}

{v0.22}
function ClassGetMethod(c: TObject; const AMethodName: shortstring;
  var AMethod: TMethod): boolean; overload;

function ClassGetMethod(c: TObject; i: integer;
  var AMethod: TMethod): boolean;overload;

function ClassSetMethod(c: TObject; const AMethodName: shortstring;
  const AMethod: TMethod): boolean; overload;
function ClassSetMethod(c: TObject; i: integer; const AMethod: TMethod): boolean; overload;
{/v0.22}

{v0.23}
function ClassGetPropInfo(c: TObject; const APropName: string; var APropInfo: PPropInfo): boolean;
{/v0.23}

implementation

function GetTypeKindEnumName(tk: TTypeKind): shortstring;
begin
  GetTypeKindEnumName := inttostr(integer(tk));
end;

function GetEnumPropStr(c: TObject; pi: PPropInfo): shortstring;
var
  i: integer;
begin
  i := GetOrdProp(c, pi);
  GetEnumPropStr := GetEnumName(pi^.PropType^, i);
end;

procedure SetEnumPropStr(c: TObject; pi: PPropInfo; const AValue: shortstring);
var i: integer;
begin
  i := GetEnumValue(pi^.PropType^, AValue);
  SetOrdProp(c, pi, i);
end;

function GetPropIndex(c: TObject; const APropName: string): integer;
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  pi: PPropInfo;
  j:integer;
begin
  Result := -1;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  for j := 0 to td^.PropCount - 1 do begin
    pi := pl[j];
    if pi^.Name = APropName then begin
      Result := j;
      exit;
    end;
  end;
end;

{v0.23}
function ClassGetPropInfo(c: TObject; const APropName: string; var APropInfo: PPropInfo): boolean;
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  pi: PPropInfo;
  j:integer;
begin
  Result := false;
  APropInfo := nil;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  for j := 0 to td^.PropCount - 1 do begin
    pi := pl[j];
    if pi^.Name = APropName then begin
      Result := true;
      APropInfo := pi;
      exit;
    end;
  end;
end;
{/v0.23}

{/v0.24}
function FillEnumNames(APropInfo: PPropInfo; Items: TStrings): boolean;
  { Fills Items with names of allowed values }
var
{  ti: PTypeInfo;}
  pi: PPropInfo;
  td: PTypeData;
  s: string;
  i: integer;
begin
  Result := false;
  pi := APropInfo;
  if pi = nil then
    exit;
  if pi^.PropType^^.Kind <> tkEnumeration then
    exit;
  if Items = nil then
    exit;
  {v0.31}
  Items.Clear;
  {/v0.31}
  td := GetTypeData(pi^.PropType^);
  if td = nil then
    exit;
  for i := td^.MinValue to td^.MaxValue do begin
    s := GetEnumName(pi^.PropType^, i);
    if s <> '' then begin
      Items.Add(s);
    end;
  end;
  Result := true;
end;
{/v0.24}

function FillEnumNames(c: TObject; const AName: string; Items: TStrings):boolean;
  { Fills Items with names of allowed values for property AName of object c }
var
  ti: PTypeInfo;
  pi: PPropInfo;
{v0.24}
{/v0.24
  td: PTypeData;
  s: string;
  i: integer;}
begin
  {v0.24}{/v0.24
  FillEnumNames := false;}
  ti := PTypeInfo(c.ClassInfo);
  pi := GetPropInfo(ti, AName);
  Result := FillEnumNames(pi, Items);
  {v0.24}{/v0.24
  if pi = nil then
    exit;
  if pi^.PropType^^.Kind <> tkEnumeration then
    exit;
  if Items = nil then
    exit;
  td := GetTypeData(pi^.PropType^);
  if td = nil then
    exit;
  for i := td^.MinValue to td^.MaxValue do begin
    s := GetEnumName(pi^.PropType^, i);
    if s <> '' then begin
      Items.Add(s);
    end;
  end;
  FillEnumNames := true;}
end;

function FillPropNames(c: TObject; const AfterName: string;
  var FirstPropIndex:integer; Items: TStrings):boolean;
  { Fill Items with names of properties published in given object c;
    if AfterName <> '', then fills only with names of those properties that
    are defined after property of the name AfterName and the FirstPropIndex is set
    to the index of the first property that is after AfterName property. }
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  pi: PPropInfo;
  j:integer;
  isAfter:boolean;
begin
  Result := false;
  if Items = nil then
    exit;
  Items.Clear;
  isAfter := (AfterName = '');
  FirstPropIndex := 0;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  for j := 0 to td^.PropCount - 1 do begin
    pi := pl[j];
    if not isAfter then begin
      isAfter := (pi^.Name = AfterName);
      if isAfter then
        FirstPropIndex := j + 1;
    end else begin
      Items.Add(pi^.Name);
    end;
  end;
  Result := true;
end;

function GetTypeSize(tk: TTypeKind; const td: TTypeData): integer;
var r: integer;
begin
  case tk of
    {tkUnknown,}
    tkInteger, tkChar, tkEnumeration, tkWChar: begin
      case td.OrdType of
        otSByte, otUByte: r := 1;
        otSWord, otUWord: r := 2;
        otSLong: r := 4;
      else
       raise EUnsupportedOrdType.Create('GetTypeSize ' + IntToStr(ord(td.OrdType)));
      end;
    end;
    tkFloat: begin
      case td.FloatType of
        ftSingle: r := 4;
        ftDouble: r := 8;
        ftExtended: r := 10;
        ftComp: r := 8;
        ftCurr: r := 8;
      else
        raise EUnsupportedFloatType.Create('GetTypeSize ' + IntToStr(ord(td.FloatType)));
      end;
    end;
    tkString: begin
      r := td.MaxLength + 1;
    end;
    tkSet: begin
      r := 32;
    end;
    {tkClass,
    tkMethod,}
    {v0.22}
    tkMethod: begin
      r := sizeof(TMethod);{8 4;}
    end;
    {/v0.22}
    tkWString, tkLString: begin
      r := 4;
    end;
    {
    tkVariant,
    tkArray,
    tkRecord,
    tkInterface,
    tkInt64,
    tkDynArray);}
  else
    raise EUnsupportedTypeKind.Create('GetTypeSize ' + GetTypeKindEnumName(tk));
  end;
  Result := r;
end;

function ClassWritePropsToStream(c: TObject; FromPropIndex: integer; AStream: TStream): integer;
var
  ti: PTypeInfo;
  td, ttd: PTypeData;
  tk: TTypeKind;

  pl: TPropList;
  pi: PPropInfo;

  j : integer;
  size, startpos: integer;

  {b: byte;
  w: word;}
  l: longint;

  e: extended;
  s: Single absolute e;
  d: double absolute e;
  com: comp absolute e;
  cur: currency absolute e;

  ss: shortstring;

  st: string;
  strm: TStringStream;
  {v0.22}
  m: TMethod;
  {/v0.22}
begin
  Result := 0;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  if (FromPropIndex < 0) or (FromPropIndex >= td^.PropCount) then
    exit;
  j := FromPropIndex;
  startpos := AStream.Position;
  while j < td^.PropCount do begin
    pi := pl[j];
    ttd := PTypeData(GetTypeData(pi^.PropType^));
   {AName := pi^.Name;
    AValue := '';}
    tk := pi^.PropType^^.Kind;
    size := GetTypeSize(tk, ttd^);
    case tk of
      tkInteger, tkChar, tkEnumeration, tkWChar: begin
        l := GetOrdProp(c, pi);
        AStream.WriteBuffer(l, size);
      end;
      {v0.22}
      tkMethod: begin
        fillchar(m, size, 0);
        {size := 4;}
        AStream.WriteBuffer(m, size);
      end;
      {/v0.22}
      tkFloat: begin
        e := GetFloatProp(c, pi);
        case ttd^.FloatType of
          ftSingle: s := e;
          ftDouble: d := e;
          {ftExtended }
          ftComp: com := e;
          ftCurr: cur := e;
        end;
        AStream.WriteBuffer(e, size);
      end;
      tkString: begin
        ss := GetStrProp(c, pi);
        AStream.WriteBuffer(ss, size);
      end;
      {tkEnumeration: AValue := GetEnumPropStr(c, pi);}
      tkLString{, tkWString}: begin
        st := GetStrProp(c, pi);
        l := length(st);
        AStream.WriteBuffer(l, sizeof(l));
        if l > 0 then begin
          strm := TStringStream.Create(st);
          AStream.CopyFrom(strm, 0);
          strm.Free;
        end;
      end;
    else
      raise EUnsupportedTypeKind.Create('ClassWritePropsToStream ' + GetTypeKindEnumName(tk));
    end;
    inc(j);
  end;
  Result := AStream.Position - startpos;
end;

function ClassSumStringLength(c: TObject): integer;
  { return sum of all lengths of all c's properties of type = tkLString }
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  j : integer;
  l: longint;
begin
  l := 0;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  for j := 0 to td^.PropCount - 1 do begin
    if pl[j]^.PropType^^.Kind = tkLString then begin
      inc(l, length(GetStrProp(c, pl[j])));
    end;
  end;
  Result := l;
end;


function ClassReadPropsFromStream(c: TObject; FromPropIndex: integer; MaxSize: integer; AStream: TStream): integer;
var
  ti: PTypeInfo;
  td: PTypeData;
  tk: tTypeKind;
  ttd: PTypeData;

  pl: TPropList;
  pi: PPropInfo;

  j : integer;
  size, startpos: integer;

  {b: byte;
  w: word;}
  l: longint;

  e: extended;
  s: Single absolute e;
  d: double absolute e;
  com: comp absolute e;
  cur: currency absolute e;

  ss: shortstring;

  st: string;
  strm: TStringStream;
  {v0.22}
  m: TMethod;
  {/v0.22}
begin
  Result := 0;
  {v0.24}
  if MaxSize = 0 then
    exit;
  {/v0.24}
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  if (FromPropIndex < 0) or (FromPropIndex >= td^.PropCount) then
    exit;
  j := FromPropIndex;
  startpos := AStream.Position;
  while j < td^.PropCount do begin
    pi := pl[j];
    ttd := PTypeData(GetTypeData(pi^.PropType^));
    {AName := pi^.Name;
    AValue := '';}
    tk := pi^.PropType^^.Kind;
    size := GetTypeSize(tk, ttd^);
    case tk of
      tkInteger, tkChar, tkEnumeration, tkWChar: begin
        l := 0;
        AStream.ReadBuffer(l, size);
        SetOrdProp(c, pi, l);
      end;
      {v0.22}
      tkMethod: begin
        AStream.ReadBuffer(m, size);
        fillchar(m, size, 0);
      end;
      {/v0.22}

      tkFloat: begin
        AStream.ReadBuffer(e, size);
        case ttd^.FloatType of
          ftSingle: e := s;
          ftDouble: e := d;
          {ftExtended }
          ftComp: e := com;
          ftCurr: e := cur;
        end;
        SetFloatProp(c, pi, e);
      end;
      tkString: begin
        AStream.ReadBuffer(ss, size);
        SetStrProp(c, pi, ss);
      end;
      {tkEnumeration: AValue := GetEnumPropStr(c, pi);}
      tkLString, tkWString: begin
        size := sizeof(l);
        AStream.ReadBuffer(l, size);
        if l > 0 then begin
          strm := TStringStream.Create('');
          strm.CopyFrom(AStream, l);
          st := strm.DataString;
          SetStrProp(c, pi, strm.DataString);
          strm.Free;
        end else begin
          SetStrProp(c, pi, '');
        end;
        {v0.14}
        size := l + size;
        {/v0.14}
      end;
    else
      raise EUnsupportedTypeKind.Create('ClassReadPropsFromStream ' + GetTypeKindEnumName(tk));
    end;
    inc(j);
    {v0.06}
    if MaxSize > 0 then begin
      dec(MaxSize, size);
      if MaxSize <= 0 then
        break;
    end;
    {/v0.06}
  end;
  Result := AStream.Position - startpos;
end;

function ClassGetPropStr(c: TObject; j: integer;
  var AValue: AnsiString): boolean;
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  pi: PPropInfo;
begin
  ClassGetPropStr := false;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  if (j < 0) or (j >= td^.PropCount) then
    exit;
  pi := pl[j];
  AValue := '';
  case pi^.PropType^^.Kind of
    tkInteger: AValue := IntToStr(GetOrdProp(c, pi));
    tkFloat: AValue := FloatToRoundStr(GetFloatProp(c, pi), 4, 0);
    tkString, tkLString: AValue := GetStrProp(c, pi);
    tkEnumeration: AValue := GetEnumPropStr(c, pi);
  end;
  ClassGetPropStr := true;
end;

{v0.22}
{function ClassGetPropInt(c: TObject; j: integer;
  var AValue: integer): boolean;
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  pi: PPropInfo;
begin
  Result := false;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  if (j < 0) or (j >= td^.PropCount) then
    exit;
  pi := pl[j];
  if pi^.PropType^^.Kind = tkInteger then begin
    AValue := GetOrdProp(c, pi);
    Result := true;
  end;
end;
}
{/v0.22}

function ClassGetPropNameAndValue(c: TObject; j: integer;
  var AName: shortstring; var AValue: AnsiString): boolean;
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  pi: PPropInfo;
begin
  Result := false;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  if (j < 0) or (j >= td^.PropCount) then
    exit;
  pi := pl[j];
  {
  case pi^.PropType^^.Kind of
    tkInteger: SetOrdProp(c, pi, StrToInt(AValue));
    tkFloat: SetFloatProp(c, pi, StrToFloat());
    tkString: SetStrProp(c, pi, vs);
  end;
  }
  AName := pi^.Name;
  AValue := '';
  case pi^.PropType^^.Kind of
    tkInteger: AValue := IntToStr(GetOrdProp(c, pi));
    tkFloat: AValue := FloatToRoundStr(GetFloatProp(c, pi), 4, 0);
      {FloatToStr(GetFloatProp(c, pi));}
    tkString, tkLString: AValue := GetStrProp(c, pi);
    tkEnumeration: AValue := GetEnumPropStr(c, pi);
  end;
  Result := true;
end;

function ClassSetPropStr(c: TObject; i: integer; const AValue: AnsiString): integer;
var
{  j: integer;}
  ti: PTypeInfo;
  td, ttd: PTypeData;
  tk: TTypeKind;
  pl: TPropList;
  pi: PPropInfo;
  l: integer;
begin
  Result := 0;
  l := 0;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  if (i < 0) or (i >= td.PropCount) then
    exit;
  GetPropInfos(ti, @pl);
{  for j := 0 to td^.PropCount - 1 do begin}
    pi := pl[i];
    {if pi^.Name = AName then begin}
      tk := pi^.PropType^^.Kind;
      case tk of
        tkInteger: SetOrdProp(c, pi, StrToInt(AValue));
        tkFloat: SetFloatProp(c, pi, StrToFloat(AValue));
        tkString: SetStrProp(c, pi, AValue);
        tkLString: begin SetStrProp(c, pi, AValue); inc(l, 4);end;
        tkEnumeration: SetEnumPropStr(c, pi, AValue);
      end;
      ttd := PTypeData(GetTypeData(pi^.PropType^));
      Result := GetTypeSize(tk, ttd^) + l;
      exit;
    {end;}
{  end;}
end;

function ClassSetPropStr(c: TObject; const AName: shortstring;
  const AValue: AnsiString): integer;
var
  j: integer;
  ti: PTypeInfo;
  td, ttd: PTypeData;
  tk: TTypeKind;
  pl: TPropList;
  pi: PPropInfo;
  l: integer;
begin
  Result := 0;
  l := 0;
  ti := PTypeInfo(c.ClassInfo);
  td := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  for j := 0 to td^.PropCount - 1 do begin
    pi := pl[j];
    if pi^.Name = AName then begin
      tk := pi^.PropType^^.Kind;
      case tk of
        tkInteger: SetOrdProp(c, pi, StrToInt(AValue));
        tkFloat: SetFloatProp(c, pi, StrToFloat(AValue));
        tkString: SetStrProp(c, pi, AValue);
        tkLString: begin SetStrProp(c, pi, AValue); inc(l, 4);end;
        tkEnumeration: SetEnumPropStr(c, pi, AValue);
      end;
      ttd := PTypeData(GetTypeData(pi^.PropType^));
      Result := GetTypeSize(tk, ttd^) + l;
      exit;
    end;
  end;
end;

{v0.21}
{function GetClass(const AClassTypeName: string): TClass;
var ti:TTypeInfo;
begin
  ti.tkClass;
  ti.Name := AClassTypeName;
end;}{tmethod}
{/v0.21}

{v0.22}
function ClassGetMethod(c: TObject; const AMethodName: shortstring;
  var AMethod: TMethod): boolean;
var
  ti: PTypeInfo;
  ttd: PTypeData;
{  tk: TTypeKind;}
  pl: TPropList;
  pi: PPropInfo;
  i: integer;
begin
  Result := false;
  ti := PTypeInfo(c.ClassInfo);
  ttd := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  for i := 0 to ttd^.PropCount - 1 do begin
    pi := pl[i];
    if pi^.Name = AMethodName then begin
      if pi^.PropType^^.Kind = tkMethod then begin
        AMethod := GetMethodProp(c, pi);
        Result := true;
        exit;
      end;
    end;
  end;
end;

function ClassGetMethod(c: TObject; i: integer; var AMethod: TMethod): boolean;
var
  ti: PTypeInfo;
{  ttd: PTypeData;
  tk: TTypeKind;}
  pl: TPropList;
  pi: PPropInfo;
begin
  Result := false;
  ti := PTypeInfo(c.ClassInfo);
  GetPropInfos(ti, @pl);
  pi := pl[i];
  if pi^.PropType^^.Kind = tkMethod then begin
    AMethod := GetMethodProp(c, pi);
    Result := true;
  end;
end;

function ClassSetMethod(c: TObject; const AMethodName: shortstring;
  const AMethod: TMethod): boolean;
var
  ti: PTypeInfo;
  ttd: PTypeData;
{  tk: TTypeKind;}
  pl: TPropList;
  pi: PPropInfo;
  i: integer;
begin
  Result := false;
  ti := PTypeInfo(c.ClassInfo);
  ttd := PTypeData(GetTypeData(ti));
  GetPropInfos(ti, @pl);
  for i := 0 to ttd^.PropCount - 1 do begin
    pi := pl[i];
    if pi^.Name = AMethodName then begin
      if pi^.PropType^^.Kind = tkMethod then begin
        SetMethodProp(c, pi, AMethod);
        Result := true;
        exit;
      end;
    end;
  end;
end;

function ClassSetMethod(c: TObject; i: integer; const AMethod: TMethod): boolean;
var
  ti: PTypeInfo;
{  ttd: PTypeData;
  tk: TTypeKind;  }
  pl: TPropList;
  pi: PPropInfo;
begin
  Result := false;
  ti := PTypeInfo(c.ClassInfo);
  GetPropInfos(ti, @pl);
  pi := pl[i];
  if pi^.PropType^^.Kind = tkMethod then begin
    SetMethodProp(c, pi, AMethod);
    Result := true;
  end;
end;
{/v0.22}

end.
