fcl-db: Introduce TObjectField. Only essential parts (added new object properties according to Delphi documentation). Some code taken from FreeCLX project (https://sourceforge.net/projects/freeclx/)

git-svn-id: trunk@49082 -

packages/fcl-db/src/base/db.pas

@@ -75,6 +75,7 @@ type
   TDataSource = Class;
   TDataLink = Class;
   TDBTransaction = Class;
+  TObjectField = class;
 
 { Exception classes }
 
@@ -169,14 +170,19 @@ type
     FCodePage : TSystemCodePage;
     FDataType : TFieldType;
     FFieldNo : Longint;
+    FChildDefs : TFieldDefs;
     FInternalCalcField : Boolean;
     FPrecision : Longint;
     FRequired : Boolean;
     FSize : Integer;
     function GetCharSize: Word;
+    function GetChildDefs: TFieldDefs;
     Function GetFieldClass : TFieldClass;
+    function GetParentDef: TFieldDef;
+    function GetSize: Integer;
     procedure SetAttributes(AValue: TFieldAttributes);
     procedure SetDataType(AValue: TFieldType);
+    procedure SetChildDefs(AValue: TFieldDefs);
     procedure SetPrecision(const AValue: Longint);
     procedure SetSize(const AValue: Integer);
     procedure SetRequired(const AValue: Boolean);
@@ -186,19 +192,23 @@ type
       ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint;
       ACodePage: TSystemCodePage = CP_ACP); overload;
     destructor Destroy; override;
+    function AddChild: TFieldDef;
     procedure Assign(APersistent: TPersistent); override;
-    function CreateField(AOwner: TComponent): TField;
+    function CreateField(AOwner: TComponent; ParentField: TObjectField = nil;  const FieldName: string = ''; CreateChildren: Boolean = True): TField;
+    function HasChildDefs: Boolean;
     property FieldClass: TFieldClass read GetFieldClass;
     property FieldNo: Longint read FFieldNo;
     property CharSize: Word read GetCharSize;
     property InternalCalcField: Boolean read FInternalCalcField write FInternalCalcField;
+    property ParentDef: TFieldDef read GetParentDef;
     property Required: Boolean read FRequired write SetRequired;
     Property Codepage : TSystemCodePage Read FCodePage;
   Published
     property Attributes: TFieldAttributes read FAttributes write SetAttributes default [];
     property DataType: TFieldType read FDataType write SetDataType;
+    property ChildDefs: TFieldDefs read GetChildDefs write SetChildDefs stored HasChildDefs;
     property Precision: Longint read FPrecision write SetPrecision default 0;
-    property Size: Integer read FSize write SetSize default 0;
+    property Size: Integer read GetSize write SetSize default 0;
   end;
   TFieldDefClass = Class of TFieldDef;
 
@@ -206,13 +216,14 @@ type
 
   TFieldDefs = class(TDefCollection)
   private
+    FParentDef: TFieldDef;
     FHiddenFields : Boolean;
     function GetItem(Index: Longint): TFieldDef;
     procedure SetItem(Index: Longint; const AValue: TFieldDef);
   Protected
     Class Function FieldDefClass : TFieldDefClass; virtual;
   public
-    constructor Create(ADataSet: TDataSet);
+    constructor Create(AOwner: TPersistent);
 //    destructor Destroy; override;
     Function Add(const AName: string; ADataType: TFieldType; ASize, APrecision: Integer; ARequired, AReadOnly: Boolean; AFieldNo : Integer; ACodePage:TSystemCodePage) : TFieldDef; overload;
     Function Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo : Integer) : TFieldDef; overload;
@@ -228,6 +239,7 @@ type
     Function MakeNameUnique(const AName : String) : string; virtual;
     Property HiddenFields : Boolean Read FHiddenFields Write FHiddenFields;
     property Items[Index: Longint]: TFieldDef read GetItem write SetItem; default;
+    property ParentDef: TFieldDef read FParentDef;
   end;
   TFieldDefsClass = Class of TFieldDefs;
 
@@ -300,6 +312,8 @@ type
     FOnSetText: TFieldSetTextEvent;
     FOnValidate: TFieldNotifyEvent;
     FOrigin : String;
+    FParentField: TObjectField;
+    FProviderFlags : TProviderFlags;
     FReadOnly : Boolean;
     FRequired : Boolean;
     FSize : integer;
@@ -307,7 +321,6 @@ type
     FValueBuffer : Pointer;
     FValidating : Boolean;
     FVisible : Boolean;
-    FProviderFlags : TProviderFlags;
     function GetIndex : longint;
     function GetLookup: Boolean;
     procedure SetAlignment(const AValue: TAlignMent);
@@ -385,6 +398,7 @@ type
     procedure SetNewValue(const AValue: Variant);
     procedure SetSize(AValue: Integer); virtual;
     procedure SetParentComponent(AParent: TComponent); override;
+    procedure SetParentField(AField: TObjectField); virtual;
     procedure SetText(const AValue: string); virtual;
     procedure SetVarValue(const AValue: Variant); virtual;
   public
@@ -461,6 +475,7 @@ type
     property LookupResultField: string read FLookupResultField write FLookupResultField;
     property Lookup: Boolean read GetLookup write SetLookup stored false; deprecated;
     property Origin: string read FOrigin write FOrigin;
+    property ParentField: TObjectField read FParentField write SetParentField;
     property ProviderFlags : TProviderFlags read FProviderFlags write FProviderFlags;
     property ReadOnly: Boolean read FReadOnly write SetReadOnly;
     property Required: Boolean read FRequired write FRequired;
@@ -1092,6 +1107,25 @@ type
     property AsGuid: TGUID read GetAsGuid write SetAsGuid;
   end;
 
+{ TObjectField }
+
+  TObjectField = class(TField)
+  private
+    FFieldFields: TFields;
+  protected
+    function GetAsVariant: Variant; override;
+    function GetFieldCount: Integer;
+    function GetFields: TFields; virtual;
+    function GetFieldValue(AIndex: Integer): Variant; virtual;
+    procedure SetFieldValue(AIndex: Integer; const AValue: Variant); virtual;
+    procedure SetParentField(AField: TObjectField); override;
+    procedure SetVarValue(const AValue: Variant); override;
+  public
+    property FieldCount: Integer read GetFieldCount;
+    property Fields: TFields read GetFields;
+    property FieldValues[AIndex: Integer]: Variant read GetFieldValue  write SetFieldValue; default;
+  end;
+
 { TIndexDef }
 
   TIndexDefs = class;

packages/fcl-db/src/base/fields.inc

@@ -63,7 +63,35 @@ end;
 destructor TFieldDef.Destroy;
 
 begin
-  Inherited destroy;
+  FChildDefs.Free;
+  Inherited Destroy;
+end;
+
+function TFieldDef.AddChild: TFieldDef;
+begin
+  Result := ChildDefs.AddFieldDef;
+end;
+
+function TFieldDef.GetChildDefs: TFieldDefs;
+begin
+  if FChildDefs = nil then
+    FChildDefs := TFieldDefs.Create(Self);
+  Result := FChildDefs;
+end;
+
+procedure TFieldDef.SetChildDefs(AValue: TFieldDefs);
+begin
+  ChildDefs.Assign(AValue);
+end;
+
+function TFieldDef.HasChildDefs: Boolean;
+begin
+  Result := Assigned(FChildDefs) and (FChildDefs.Count > 0);
+end;
+
+function TFieldDef.GetParentDef: TFieldDef;
+begin
+  Result := TFieldDefs(Collection).ParentDef;
 end;
 
 procedure TFieldDef.Assign(APersistent: TPersistent);
@@ -89,9 +117,10 @@ begin
     inherited Assign(APersistent);
 end;
 
-function TFieldDef.CreateField(AOwner: TComponent): TField;
+function TFieldDef.CreateField(AOwner: TComponent; ParentField: TObjectField = nil; const FieldName: string = ''; CreateChildren: Boolean = True): TField;
 
 var TheField : TFieldClass;
+    i: integer;
 
 begin
 {$ifdef dsdebug}
@@ -125,6 +154,12 @@ begin
       TBCDField(Result).Precision := FPrecision
     else if (Result is TFmtBCDField) then
       TFmtBCDField(Result).Precision := FPrecision;
+
+    if CreateChildren and HasChildDefs then
+    begin
+      for i := 0 to ChildDefs.Count - 1 do
+        ChildDefs[i].CreateField(nil, TObjectField(Result), '');
+    end;
   except
     Result.Free;
     Raise;
@@ -149,8 +184,17 @@ begin
   Changed(False);
 end;
 
+function TFieldDef.GetSize: Integer;
+begin
+  if HasChildDefs and (FSize = 0) then
+    Result := FChildDefs.Count
+  else
+    Result := FSize;
+end;
+
 procedure TFieldDef.SetSize(const AValue: Integer);
 begin
+  if HasChildDefs and (DataType <> ftArray) then Exit;
   FSize := AValue;
   Changed(False);
 end;
@@ -249,9 +293,17 @@ begin
   Result:=TFieldDef;
 end;
 
-constructor TFieldDefs.Create(ADataSet: TDataSet);
+constructor TFieldDefs.Create(AOwner: TPersistent);
+var ADataSet: TDataSet;
 begin
-  Inherited Create(ADataset, Owner, FieldDefClass);
+  if AOwner is TFieldDef then
+  begin
+    FParentDef := TFieldDef(AOwner);
+    ADataSet := TFieldDefs(FParentDef.Collection).DataSet;
+  end
+  else
+    ADataSet := AOwner as TDataSet;
+  Inherited Create(ADataset, AOwner, FieldDefClass);
 end;
 
 function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize, APrecision: Integer;
@@ -1100,6 +1152,25 @@ begin
   FieldKind := ValueToLookupMap[AValue];
 end;
 
+procedure TField.SetParentField(AField: TObjectField);
+begin
+  if AField <> FParentField then
+  begin
+    if FDataSet <> nil then FDataSet.CheckInactive;
+    if AField <> nil then
+    begin
+      if AField.DataSet <> nil then AField.DataSet.CheckInactive;
+      AField.Fields.CheckFieldName(FFieldName);
+      AField.Fields.Add(Self);
+      if FDataSet <> nil then FDataSet.Fields.Remove(Self);
+      FDataSet := AField.DataSet;
+    end
+    else if FDataSet <> nil then FDataSet.Fields.Add(Self);
+    if FParentField <> nil then FParentField.Fields.Remove(Self);
+    FParentField := AField;
+  end;
+end;
+
 procedure TField.SetReadOnly(const AValue: Boolean);
 begin
   if (FReadOnly<>AValue) then
@@ -3663,6 +3734,55 @@ begin
   SetData(@aValue);
 end;
 
+{ TObjectField }
+
+function TObjectField.GetFieldCount: Integer;
+begin
+  Result := Fields.Count;
+end;
+
+function TObjectField.GetFields: TFields;
+begin
+  Result := FFieldFields;
+end;
+
+function TObjectField.GetFieldValue(AIndex: Integer): Variant;
+begin
+  Result := FFieldFields[AIndex].Value;
+end;
+
+procedure TObjectField.SetFieldValue(AIndex: Integer; const AValue: Variant);
+begin
+  FFieldFields[AIndex].Value := AValue;
+end;
+
+procedure TObjectField.SetParentField(AField: TObjectField);
+begin
+  inherited SetParentField(AField);
+end;
+
+function TObjectField.GetAsVariant: Variant;
+var I: integer;
+begin
+  if IsNull then
+    Result := Null
+  else
+  begin
+    Result := VarArrayCreate([0, FieldCount - 1], varVariant);
+    for I := 0 to FieldCount - 1 do
+      Result[I] := GetFieldValue(I);
+  end;
+end;
+
+procedure TObjectField.SetVarValue(const AValue: Variant);
+var N,I: integer;
+begin
+  N := VarArrayHighBound(AValue, 1) + 1;
+  if N > Size then N := Size;
+  for I := 0 to N - 1  do
+    SetFieldValue(I, AValue[I]);
+end;
+
 { TFieldsEnumerator }
 
 function TFieldsEnumerator.GetCurrent: TField;