paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 10:19:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

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/)

Browse Source 
git-svn-id: trunk@49082 -
This commit is contained in:
lacak 2021-03-30 09:37:30 +00:00
parent 1fe486d8f6
commit f517d21507
2 changed files with 162 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
packages/fcl-db/src/base/db.pas
View File

@ -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;

128
packages/fcl-db/src/base/fields.inc
View File

@ -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;