unit ULObjDes;

interface
uses
  SysUtils, Math, Classes,
  {$IFNDEF CONSOLE}
  Messages, Dialogs, Controls, Forms,
  {$ENDIF}
  TypInfo,
  PropUtl, Fileu, Stru, UlanType, ULRecTyp, ULRecUtl, MyType,
  WinUtl, BinHex;

type
  TOnGetSetUsrValue = function(const AValue: string):string of object;

  TULObjFldDescs = class;
  TULObjDesc = class;

  TULObjFldDesc = class(TObject)
    { encapsulates RTTI property information, plus uses eventual
      ULFldDesc information }
  private
    FPropInfo: PPropInfo;
    FRTIndex: integer;{ in RTTI array of objects' properties }
    FFldDescs: TULObjFldDescs;
    {FOnGetUsrValue: TOnGetSetUsrValue;
    FOnSetUsrValue: TOnGetSetUsrValue; moved to TULObjField}
    {v0.14}
    FValuesSource: TObject;{=TULObj;}
    {/v0.14}
  protected
    function GetName: shortstring;
    function GetCaption: string;
    function GetHint: string;
    function GetEditWidth: integer;
    function GetBrowseWidth: integer;
    function GetULIndex: integer;
    {v0.09}
    function GetUserCoef: TUserCoef;
    function GetNumDec: integer;
    {/0.09}
    {v0.13}
    function GetTypeKind: TTypeKind;
    function GetIsFileName: boolean;
    function GetIsFileDateTime: boolean;
    {/v0.13}
    {v0.14}
    function GetIsULEnum: boolean;
    function GetValuesSourceRecID: TULRecID;
    procedure SetValuesSource(AObject: TObject);
    {/v0.14}
  public
    FldDesc: PULFldDesc;
    constructor Create(AFldDescs: TULObjFldDescs; APropInfo: PPropInfo; ARTIndex: integer); reintroduce;
      { this object describes RTTI property with APropInfo }
    {v0.14}
    procedure SetResult(AObjResult: TULObjResult; const msg: string);
    {/v0.14}
    property RTIndex: integer read FRTIndex;
    property ULIndex: integer read GetULIndex;
    property Name: shortstring read GetName;
    property Caption: string read GetCaption;
    property Hint: string read GetHint;
    property EditWidth: integer read GetEditWidth;
    property BrowseWidth: integer read GetBrowseWidth;
    property UserCoef: TUserCoef read GetUserCoef;
    property NumDec: integer read GetNumDec;
    {property OnGetUsrValue: TOnGetSetUsrValue read FOnGetUsrValue write FOnGetUsrValue;
    property OnSetUsrValue: TOnGetSetUsrValue read FOnSetUsrValue write FOnSetUsrValue;}
    {v0.13}
    property TypeKind: TTypeKind read GetTypeKind;
    property IsFileName: boolean read GetIsFileName;
    property IsFileDateTime: boolean read GetIsFileDateTime;
    {/v0.13}
    {v0.14}
    property ValuesSource: TObject read FValuesSource write SetValuesSource;
    property ValuesSourceRecID: TULRecID read GetValuesSourceRecID;
    property IsULEnum: boolean read GetIsULEnum;
    {/v0.14}
  end;

  TULObjFldDescs = class(TList)
  private
    FObjDesc: TULObjDesc;
    FFirstPropIndex: integer;
  protected
    function GetFldDesc(Index: integer): TULObjFldDesc;
    function AddFldDesc(APropInfo:PPropInfo; ARTIndex: integer): TULObjFldDesc;
    procedure SetResult(AObjResult: TULObjResult; const msg: string);
  public
    constructor Create(AObjDesc: TULObjDesc; const AFieldNameList: string);
    destructor Destroy;override;
    procedure ClearFldDescs;
    procedure Fill(const AFieldNameList: string);
    property FldDescs[Index: integer]: TULObjFldDesc read GetFldDesc;default;
    property FirstPropIndex:integer read FFirstPropIndex;
  end;

  TULObjDesc = class(TObject)
  private
    FObj: TObject;
      { RTTI for this objects is used. }
    FFields: TULObjFldDescs;{TStringList;}
      { List of all fields (String=FldName, Object=TULObjFldDesc) in TULxxRec
        order; owns the objects. }
    FEditFields: TULObjFldDescs;
      { List of the those fields (TULObjFldDesc), that should appear in
        EditWindow. }
    FBrowseFields: TULObjFldDescs;
      { List of the those fields (TULObjFldDesc), that should appear in
        EditWindow. }
    FBrowseMode: TULBrowseMode;
      { Specifies what values should return BrowseFields and BrowseFieldCount
        properties }
  protected
    function GetChildRecIDCount:integer;
    function GetChildRecID(Index: integer): TULRecID;
    function GetCaption: string;
    function GetFlags: TULRecFlags;
    function GetFieldCount: integer;
    function GetEditFieldCount: integer;
    function GetBrowseFieldCount: integer;
    function GetField(Index: integer): TULObjFldDesc;
    function GetEditField(Index: integer): TULObjFldDesc;
    function GetBrowseField(Index: integer): TULObjFldDesc;
    function GetFirstPropIndex: integer;
  public
    { Common info for all instances of TULxxObj }
    RecID: TULRecID;
    RefCount: longint;
      { How many instances of this RecID exist (created but not destroyed yet) }
    {FirstPropIndex: integer;
      { What is the index of the first property listed in PropNames in
        object's published RTTI properties list. I.e. index that will
        be used to access fields will have value=0 for this property/field.

       = Index of the first objects' published property, that is not common
         to all ULObj objects }
    ULRecDesc: PULRecDesc;
      { Static record with additional info, see ULRecTyp.PAS }
    constructor Create(AObj: TObject); reintroduce;
    destructor Destroy; override;
    procedure IncRefCount;
    procedure DecRefCount;
    function FindFldDesc(const AName:string):TULObjFldDesc;
      { raises exception if the field with AName not found }
    property ChildRecIDCount: integer read GetChildRecIDCount;
    property ChildRecIDs[Index: integer]: TULRecID read GetChildRecID;
    property Caption: string read GetCaption;
    property Flags: TULRecFlags read GetFlags;
    property FieldCount: integer read GetFieldCount;
    property Fields[Index: integer]: TULObjFldDesc read GetField;
    property EditFieldCount: integer read GetEditFieldCount;
    property EditFields[Index: integer]: TULObjFldDesc read GetEditField;
    property BrowseFieldCount: integer read GetBrowseFieldCount;
    property BrowseFields[Index: integer]: TULObjFldDesc read GetBrowseField;
    property Obj: TObject read FObj;
    property FirstPropIndex: integer read GetFirstPropIndex;
    property BrowseMode: TULBrowseMode read FBrowseMode write FBrowseMode;
  end;

  TULObjDescs = class(TList)
    function FindInfo(ARecID: TULRecID; var AInfo: TULObjDesc):boolean;
  end;

const
  ObjDescs: TULObjDescs = nil;
    { List of TULObjDesc }
(*
function FillFields(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. }
*)
implementation
uses
  ulobju;
(*
function FillFields(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.AddObject(pi^.Name, TULObjFldDesc.Create(pi));
    end;
  end;
  Result := true;
end;
*)
{TULObjFldDesc}
function TULObjFldDesc.GetName: shortstring;
begin
  GetName := FPropInfo^.Name;
end;

function TULObjFldDesc.GetCaption: string;
begin
  Result := FPropInfo^.Name;
  if (FldDesc <> nil) and (FldDesc^.Caption <> '') then
    Result := FldDesc^.Caption;
end;

function TULObjFldDesc.GetHint: string;
begin
  if FldDesc = nil then
    Result := ''
  else
    Result := FldDesc^.Hint;
end;

function TULObjFldDesc.GetEditWidth: integer;
begin
  if FldDesc = nil then
    Result := 0
  else
    Result := FldDesc^.EditWidth;
end;

function TULObjFldDesc.GetBrowseWidth: integer;
begin
  if FldDesc = nil then
    Result := 0
  else
    Result := FldDesc^.BrowseWidth;
end;


constructor TULObjFldDesc.Create(AFldDescs: TULObjFldDescs;
  APropInfo: PPropInfo; ARTIndex: integer);
begin
  inherited Create;
  if AFldDescs = nil then
    raise EEmptyFldDescs.Create('EEmptyFldDescs');
  FFldDescs := AFldDescs;
  if APropInfo = nil then
    FFldDescs.SetResult(orEmptyPropInfo, '');
  FPropInfo := APropInfo;
  FRTIndex := ARTIndex;
end;

function TULObjFldDesc.GetULIndex: integer;
begin
  Result := FRTIndex - FFldDescs.FirstPropIndex;
end;

{v0.09}
function TULObjFldDesc.GetUserCoef: TUserCoef;
begin
  if FldDesc = nil then
    Result := 0
  else
    Result := FldDesc^.UserCoef;
end;

function TULObjFldDesc.GetNumDec: integer;
begin
  if FldDesc = nil then
    Result := 0
  else
    Result := FldDesc^.NumDec;
end;
{/0.09}

{v0.13}
function TULObjFldDesc.GetTypeKind: TTypeKind;
begin
  Result := FPropInfo^.PropType^^.Kind;
end;

function TULObjFldDesc.GetIsFileName: boolean;
begin
  Result := (FldDesc <> nil) and ((FldDesc^.Flags and ffFileName) <> 0);
end;

function TULObjFldDesc.GetIsFileDateTime: boolean;
begin
  Result := (FldDesc <> nil) and ((FldDesc^.Flags and ffFileDateTime) <> 0);
end;
{/v0.13}

{v0.14}
function TULObjFldDesc.GetIsULEnum: boolean;
begin
  Result := (FldDesc <> nil) and ((FldDesc^.Flags and ffULEnum) <> 0);
end;

function TULObjFldDesc.GetValuesSourceRecID: TULRecID;
begin
  Result := 0;
  if FldDesc <> nil then
    Result := FldDesc^.ValuesSourceRecID;
end;

procedure TULObjFldDesc.SetValuesSource(AObject: TObject);
begin
  if not (AObject is TULObj) then
    SetResult(orNotULObject, 'TULObjFldDesc.SetValuesSource');
  with AObject as TULObj do begin
    if (ValuesSourceRecID <> 0) and (RecID <> ValuesSourceRecID) then
      SetResult(orInvalidValuesSourceRecID, RecIDStr);
    FValuesSource := AObject;
  end;
end;

procedure TULObjFldDesc.SetResult(AObjResult: TULObjResult; const msg: string);
begin
  FFldDescs.SetResult(AObjResult, msg);
end;
{/v0.14}
{/TULObjFldDesc}

{TULObjFldDescs}
constructor TULObjFldDescs.Create(AObjDesc: TULObjDesc; const AFieldNameList: string);
begin
  inherited Create;
  FObjDesc := AObjDesc;
  Fill(AFieldNameList);
end;

procedure TULObjFldDescs.Fill(const AFieldNameList: string);
{ Fill Items with TULObjFldDesc of properties published in given object
  FULObjDesc.FObj (if AFieldNameList <> '' then only with fields/properties
  the names of which are specified in the list)
  Fills only with names of those properties that are defined
  after property with name = ULRecTyp . ULRecLastCommonProp }
var
  ti: PTypeInfo;
  td: PTypeData;
  pl: TPropList;
  pi: PPropInfo;
  j:integer;
  isAfter:boolean;

  flist:string;
const
  Delim = ',';{delimitor of field names in a FieldNameList}

begin
  ClearFldDescs;
  isAfter := false;
  {(AfterName = '');}
  {FirstPropIndex := 0;}
  if AFieldNameList = '' then
    flist := ''
  else
    flist := Delim + Trim(AFieldNameList) + Delim;
  ti := PTypeInfo(FObjDesc.Obj.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 = ULRecLastCommonProp{AfterName});
      if isAfter then
        FFirstPropIndex := j + 1;
    end else begin
      if (flist = '') or (pos(Delim+pi^.Name+Delim, flist) > 0) then
        AddFldDesc(pi, j);
      {Items.AddObject(pi^.Name, TULObjFldDesc.Create(pi));}
    end;
  end;
{  FObjDesc.FirstPropIndex := FFirstPropIndex;}
end;

function TULObjFldDescs.AddFldDesc(APropInfo:PPropInfo; ARTIndex: integer): TULObjFldDesc;
var
  f: TULObjFldDesc;
begin
  f := TULObjFldDesc.Create(Self, APropInfo, ARTIndex);
  Add(f);
  Result := f;
end;

function TULObjFldDescs.GetFldDesc(Index: integer): TULObjFldDesc;
begin
  Result := TULObjFldDesc(Items[Index]);
end;

procedure TULObjFldDescs.ClearFldDescs;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FldDescs[i].Free;
  Clear;
end;

destructor TULObjFldDescs.Destroy;
begin
  ClearFldDescs;
  inherited;
end;

procedure TULObjFldDescs.SetResult(AObjResult: TULObjResult; const msg: string);
begin
  TULObj(FObjDesc.Obj).SetResult(AObjResult, msg);
end;

{/TULObjFldDescs}

{TULObjDesc}
constructor TULObjDesc.Create(AObj: TObject);
var
  o: TULObj;
  el, bl: string;
  i: integer;

  procedure CopyFldDescs(Src, Dest: TULObjFldDescs);
  var i, j: integer;
  begin
    for i := 0 to Src.Count - 1 do begin
      for j := 0 to Dest.Count - 1 do begin
        if Src[i].Name = Dest[j].Name then
          Dest[j].FldDesc := Src[i].FldDesc;
      end;
    end;
  end;

begin
  o := TULObj(AObj);
  FObj := o;
  RecID := o.RecID;
  ULRecDesc := o.ULRecDesc;
  RefCount := 0;
{ PropNames := TStringList.Create;
  PropHints := TStringList.Create; }
  FFields := TULObjFldDescs.Create(Self, '');
  if (ULRecDesc <> nil) then begin
    if ULRecDesc^.Flds <> nil then begin
      for i := 0 to FFields.Count - 1 do begin
        FFields[i].FldDesc := @ULRecDesc^.Flds^[i];
      end;
    end;
    el := ULRecDesc^.EditFieldList;
    bl := ULRecDesc^.BrowseFieldList;
  end else begin
    el := '';
    bl := '';
  end;
  FEditFields := TULObjFldDescs.Create(Self, el);
  FBrowseFields := TULObjFldDescs.Create(Self, bl);
  CopyFldDescs(FFields, FEditFields);
  CopyFldDescs(FFields, FBrowseFields);
end;

procedure TULObjDesc.IncRefCount;
begin
  inc(RefCount);
end;

procedure TULObjDesc.DecRefCount;
begin
  dec(RefCount);
end;

function TULObjDesc.GetChildRecIDCount:integer;
begin
  if ULRecDesc = nil then
    Result := 0
  else
    Result := ULRecDesc^.ChildRecIDCount;
end;

function TULObjDesc.GetChildRecID(Index: integer): TULRecID;
begin
  if (Index < 0) or (Index >= ChildRecIDCount) then
    raise ERangeError.Create('TULObjDesc.ChildRecID ' + IntToStr(index));
  Result := ULRecDesc^.ChildRecIDs^[Index];
end;

function TULObjDesc.GetCaption: string;
begin
  if ULRecDesc = nil then
    Result := ''
  else
    Result := ULRecDesc^.Caption;
end;

function TULObjDesc.GetFlags: TULRecFlags;
begin
  if ULRecDesc = nil then
    Result := 0
  else
    Result := ULRecDesc^.Flags;
end;

destructor TULObjDesc.Destroy;
var
  i: integer;
  fd: TULObjFldDesc;
begin
  if FFields.Count > 0 then begin
    for i := 0 to FFields.Count - 1 do begin
      fd := FFields[i];
      fd.Free;
    end;
  end;
  FFields.Free;
  FEditFields.Free;
  FBrowseFields.Free;
{  PropNames.Free;
  PropHints.Free;}
end;

function TULObjDesc.GetFieldCount: integer;
begin
  Result := FFields.Count;
end;

function TULObjDesc.GetField(Index: integer): TULObjFldDesc;
begin
  Result := FFields[Index];
end;

function TULObjDesc.GetEditFieldCount: integer;
begin
  Result := FEditFields.Count;
end;

function TULObjDesc.GetEditField(Index: integer): TULObjFldDesc;
begin
  Result := FEditFields[Index];
end;

function TULObjDesc.GetBrowseFieldCount: integer;
begin
  case FBrowseMode of
    bmShort:  Result := FBrowseFields.Count;
  else
    Result := FFields.Count;
  end;
end;

function TULObjDesc.GetBrowseField(Index: integer): TULObjFldDesc;
begin
  case FBrowseMode of
    bmShort: Result := FBrowseFields[Index];
  else
    Result := FFields[Index];
  end;
end;

function TULObjDesc.GetFirstPropIndex: integer;
begin
  Result := FFields.FirstPropIndex;
end;

function TULObjDesc.FindFldDesc(const AName:string):TULObjFldDesc;
  { raises exception if the field with AName not found }
var i: integer;
begin
  Result := nil;
  for i := 0 to FFields.Count - 1 do begin
    if FFields[i].Name = AName then begin
      Result := FFields[i];
      exit;
    end;
  end;
  TULObj(Obj).SetResult(orFieldNotFound, AName);{ulrectyp}
end;
{/TULObjDesc}

{TULObjDescs}
function TULObjDescs.FindInfo(ARecID: TULRecID; var AInfo: TULObjDesc):boolean;
var i:integer; o:TULObjDesc;
begin
  Result := false;
  AInfo := nil;
  if Count = 0 then
    exit;
  for i := 0 to Count - 1 do begin
    o := TULObjDesc(Items[i]);
    if (o <> nil) and (o.RecID = ARecID) then begin
      AInfo := o;
      Result := true;
      exit;
    end;
  end;
end;
{/TULObjDescs}

end.
