From f517d21507d66cef0b6a1144f41c8359982e9c2e Mon Sep 17 00:00:00 2001
From: lacak <lacak@idefix.freepascal.org>
Date: Tue, 30 Mar 2021 09:37:30 +0000
Subject: [PATCH] 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 | 42 ++++++++-
packages/fcl-db/src/base/fields.inc | 128 +++++++++++++++++++++++++++-
2 files changed, 162 insertions(+), 8 deletions(-)
diff --git a/packages/fcl-db/src/base/db.pas b/packages/fcl-db/src/base/db.pas
index 6997da5f21..1c6fe4e266 100644
--- a/packages/fcl-db/src/base/db.pas
+++ b/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;
diff --git a/packages/fcl-db/src/base/fields.inc b/packages/fcl-db/src/base/fields.inc
index c6c270ce09..cb123815ce 100644
--- a/packages/fcl-db/src/base/fields.inc
+++ b/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;