mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-04-21 09:19:27 +02:00
* Merging revisions 1068,1070,1072, from trunk:
------------------------------------------------------------------------
r1068 | michael | 2021-01-23 11:32:10 +0100 (Sat, 23 Jan 2021) | 1 line
* Patch from Henrique Werlang to implement TDatasetField
------------------------------------------------------------------------
r1070 | michael | 2021-01-23 11:45:24 +0100 (Sat, 23 Jan 2021) | 1 line
* Patch from Henrique Werlang to implement getting method parameters info (bug ID 38313)
------------------------------------------------------------------------
r1072 | michael | 2021-02-07 13:20:26 +0100 (Sun, 07 Feb 2021) | 1 line
* Fix in TDataSet.DefaultBytesToBlobData, index out of range
------------------------------------------------------------------------
This commit is contained in:
michael
parent
11c5304c9a
commit
cec79c18cc
@ -23,7 +23,6 @@ interface
|
||||
uses Classes, SysUtils, JS, Types, DateUtils;
|
||||
|
||||
const
|
||||
|
||||
dsMaxBufferCount = MAXINT div 8;
|
||||
dsMaxStringSize = 8192;
|
||||
|
||||
@ -34,7 +33,6 @@ const
|
||||
SQLDelimiterCharacters = [';',',',' ','(',')',#13,#10,#9];
|
||||
|
||||
type
|
||||
|
||||
{ Misc Dataset types }
|
||||
|
||||
TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey,
|
||||
@ -729,6 +727,16 @@ type
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
end;
|
||||
|
||||
TDataSetField = class(TField)
|
||||
private
|
||||
FNestedDataSet: TDataSet;
|
||||
procedure AssignNestedDataSet(Value: TDataSet);
|
||||
protected
|
||||
procedure Bind(Binding: Boolean); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
end;
|
||||
|
||||
{ TIndexDef }
|
||||
|
||||
TIndexDefs = class;
|
||||
@ -1054,6 +1062,8 @@ type
|
||||
TOnRecordResolveEvent = Procedure (Sender : TDataset; info : TResolveInfo) of object;
|
||||
TApplyUpdatesEvent = Procedure (Sender : TDataset; info : TResolveResults) of object;
|
||||
|
||||
TNestedDataSetsList = TFPList;
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
|
||||
TDataSet = class(TComponent)
|
||||
@ -1127,6 +1137,9 @@ type
|
||||
FInApplyupdates : Boolean;
|
||||
FLoadCount : Integer;
|
||||
FMinLoadID : Integer;
|
||||
FDataSetField: TDataSetField;
|
||||
FNestedDataSets: TNestedDataSetsList;
|
||||
FNestedDataSetClass: TDataSetClass;
|
||||
Procedure DoInsertAppend(DoAppend : Boolean);
|
||||
Procedure DoInternalOpen;
|
||||
Function GetBuffer (Index : longint) : TDataRecord;
|
||||
@ -1146,6 +1159,7 @@ type
|
||||
// Callback for Tdataproxy.DoGetData;
|
||||
function ResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
|
||||
procedure HandleRequestResponse(ARequest: TDataRequest);
|
||||
function GetNestedDataSets: TNestedDataSetsList;
|
||||
protected
|
||||
// Proxy methods
|
||||
// Override this to integrate package in local data
|
||||
@ -1283,6 +1297,7 @@ type
|
||||
procedure SetBookmarkData(Var Buffer{%H-}: TDataRecord; Data{%H-}: TBookmark); virtual;
|
||||
procedure SetUniDirectional(const Value: Boolean);
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
procedure SetDataSetField(const Value: TDataSetField); virtual;
|
||||
// These use the active buffer
|
||||
function GetFieldData(Field: TField): JSValue; virtual; overload;
|
||||
procedure SetFieldData(Field: TField; AValue : JSValue); virtual; overload;
|
||||
@ -1290,6 +1305,7 @@ type
|
||||
procedure SetFieldData(Field: TField; var Buffer: TDatarecord; AValue : JSValue); virtual; overload;
|
||||
class function FieldDefsClass : TFieldDefsClass; virtual;
|
||||
class function FieldsClass : TFieldsClass; virtual;
|
||||
property NestedDataSets: TNestedDataSetsList read GetNestedDataSets;
|
||||
protected { abstract methods }
|
||||
function GetRecord(var Buffer: TDataRecord; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
|
||||
procedure InternalClose; virtual; abstract;
|
||||
@ -1360,6 +1376,7 @@ type
|
||||
procedure UpdateCursorPos;
|
||||
procedure UpdateRecord;
|
||||
Function GetPendingUpdates : TResolveInfoArray;
|
||||
property DataSetField: TDataSetField read FDataSetField write SetDataSetField;
|
||||
Property Loading : Boolean Read GetIsLoading;
|
||||
property BlockReadSize: Integer read FBlockReadSize write SetBlockReadSize;
|
||||
property BOF: Boolean read FBOF;
|
||||
@ -2343,10 +2360,9 @@ begin
|
||||
FIsUniDirectional := False;
|
||||
FAutoCalcFields := True;
|
||||
FDataRequestID:=0;
|
||||
FNestedDataSetClass := TDataSetClass(Self.ClassType);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
destructor TDataSet.Destroy;
|
||||
|
||||
var
|
||||
@ -2356,6 +2372,7 @@ begin
|
||||
Active:=False;
|
||||
FFieldDefs.Free;
|
||||
FFieldList.Free;
|
||||
FNestedDataSets.Free;
|
||||
With FDataSources do
|
||||
begin
|
||||
While Count>0 do
|
||||
@ -2544,9 +2561,23 @@ procedure TDataSet.DataEvent(Event: TDataEvent; Info: JSValue);
|
||||
end;
|
||||
|
||||
procedure HandleScrollOrChange;
|
||||
var
|
||||
A: Integer;
|
||||
|
||||
NestedDataSet: TDataSet;
|
||||
|
||||
begin
|
||||
if State <> dsInsert then
|
||||
UpdateCursorPos;
|
||||
|
||||
if Assigned(FNestedDataSets) then
|
||||
for A := 0 to Pred(NestedDataSets.Count) do
|
||||
begin
|
||||
NestedDataSet := TDataSet(NestedDataSets[A]);
|
||||
|
||||
if NestedDataSet.Active then
|
||||
NestedDataSet.DataEvent(deParentScroll, 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
@ -3157,6 +3188,35 @@ begin
|
||||
// empty stub
|
||||
end;
|
||||
|
||||
procedure TDataSet.SetDataSetField(const Value: TDataSetField);
|
||||
begin
|
||||
if Value = FDataSetField then
|
||||
exit;
|
||||
if (Value <> nil) and ((Value.DataSet = Self) or
|
||||
((Value.DataSet.GetDataSource <> nil) and
|
||||
(Value.DataSet.GetDataSource.DataSet = Self))) then
|
||||
DatabaseError(SCircularDataLink, Self);
|
||||
if Assigned(Value) and not InheritsFrom(Value.DataSet.FNestedDataSetClass) then
|
||||
DatabaseErrorFmt(SNestedDataSetClass, [Value.DataSet.FNestedDataSetClass.ClassName], Self);
|
||||
if Active then
|
||||
Close;
|
||||
if Assigned(FDataSetField) then
|
||||
FDataSetField.AssignNestedDataSet(nil);
|
||||
FDataSetField := Value;
|
||||
if Assigned(Value) then
|
||||
begin
|
||||
Value.AssignNestedDataSet(Self);
|
||||
if Value.DataSet.Active then
|
||||
Open;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDataSet.GetNestedDataSets: TNestedDataSetsList;
|
||||
begin
|
||||
if not Assigned(FNestedDataSets) then
|
||||
FNestedDataSets := TNestedDataSetsList.Create;
|
||||
Result := FNestedDataSets;
|
||||
end;
|
||||
|
||||
function TDataSet.GetFieldData(Field: TField; Buffer: TDatarecord): JSValue;
|
||||
|
||||
@ -3998,7 +4058,7 @@ begin
|
||||
else
|
||||
begin
|
||||
S:='';
|
||||
For I:=0 to Length(AValue) do
|
||||
For I:=0 to Length(AValue)-1 do
|
||||
TJSString(S).Concat(IntToHex(aValue[i],2));
|
||||
Result:=S;
|
||||
end;
|
||||
@ -9001,6 +9061,45 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
{ TDataSetField }
|
||||
|
||||
constructor TDataSetField.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
SetDataType(ftDataSet);
|
||||
end;
|
||||
|
||||
procedure TDataSetField.Bind(Binding: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
if Assigned(FNestedDataSet) then
|
||||
if Binding then
|
||||
begin
|
||||
if FNestedDataSet.State = dsInActive then
|
||||
FNestedDataSet.Open;
|
||||
end
|
||||
else
|
||||
FNestedDataSet.Close;
|
||||
end;
|
||||
|
||||
procedure TDataSetField.AssignNestedDataSet(Value: TDataSet);
|
||||
begin
|
||||
if Assigned(FNestedDataSet) then
|
||||
begin
|
||||
FNestedDataSet.Close;
|
||||
FNestedDataSet.FDataSetField := nil;
|
||||
if Assigned(DataSet) then
|
||||
DataSet.NestedDataSets.Remove(FNestedDataSet);
|
||||
end;
|
||||
if Assigned(Value) then
|
||||
begin
|
||||
DataSet.NestedDataSets.Add(Value);
|
||||
FFields := Value.Fields;
|
||||
end
|
||||
else
|
||||
FFields := nil;
|
||||
FNestedDataSet := Value;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -128,6 +128,8 @@ Resourcestring
|
||||
SatEOFInternalOnly = 'loAtEOF is for internal use only.';
|
||||
SErrInsertingSameRecordtwice = 'Attempt to insert the same record twice.';
|
||||
SErrDoApplyUpdatesNeedsProxy = 'Cannot apply updates without Data proxy';
|
||||
SNestedDataSetClass = 'Nested dataset must inherit from %s';
|
||||
SCircularDataLink = 'Circular datalinks are not allowed';
|
||||
|
||||
Implementation
|
||||
|
||||
|
||||
@ -134,12 +134,28 @@ type
|
||||
//procedure SetValue(Instance: Pointer; const AValue: TValue);
|
||||
//function ToString: string; override;
|
||||
end;
|
||||
TRttiFieldArray = array of TRttiField;
|
||||
TRttiFieldArray = specialize TArray<TRttiField>;
|
||||
|
||||
TRttiParameter = class(TRttiNamedObject)
|
||||
private
|
||||
FParamType: TRttiType;
|
||||
FFlags: TParamFlags;
|
||||
FName: String;
|
||||
protected
|
||||
function GetName: string; override;
|
||||
public
|
||||
property Flags: TParamFlags read FFlags;
|
||||
property ParamType: TRttiType read FParamType;
|
||||
end;
|
||||
|
||||
TRttiParameterArray = specialize TArray<TRttiParameter>;
|
||||
|
||||
{ TRttiMethod }
|
||||
|
||||
TRttiMethod = class(TRttiMember)
|
||||
private
|
||||
FParameters: TRttiParameterArray;
|
||||
|
||||
function GetMethodTypeInfo: TTypeMemberMethod;
|
||||
function GetIsClassMethod: boolean;
|
||||
function GetIsConstructor: boolean;
|
||||
@ -149,7 +165,10 @@ type
|
||||
function GetIsVarArgs: boolean;
|
||||
function GetMethodKind: TMethodKind;
|
||||
function GetReturnType: TRttiType;
|
||||
|
||||
procedure LoadParameters;
|
||||
public
|
||||
function GetParameters: TRttiParameterArray;
|
||||
property MethodTypeInfo: TTypeMemberMethod read GetMethodTypeInfo;
|
||||
property ReturnType: TRttiType read GetReturnType;
|
||||
property MethodKind: TMethodKind read GetMethodKind;
|
||||
@ -159,7 +178,6 @@ type
|
||||
property IsExternal: boolean read GetIsExternal;
|
||||
property IsStatic: boolean read GetIsStatic;// true = has Self argument
|
||||
property IsVarArgs: boolean read GetIsVarArgs;
|
||||
//function GetParameters:
|
||||
end;
|
||||
|
||||
TRttiMethodArray = specialize TArray<TRttiMethod>;
|
||||
@ -1065,6 +1083,13 @@ begin
|
||||
Result := GRttiContext.GetType(FTypeInfo);
|
||||
end;
|
||||
|
||||
{ TRttiParameter }
|
||||
|
||||
function TRttiParameter.GetName: String;
|
||||
begin
|
||||
Result := FName;
|
||||
end;
|
||||
|
||||
{ TRttiMethod }
|
||||
|
||||
function TRttiMethod.GetMethodTypeInfo: TTypeMemberMethod;
|
||||
@ -1112,6 +1137,43 @@ begin
|
||||
Result := GRttiContext.GetType(MethodTypeInfo.ProcSig.ResultType);
|
||||
end;
|
||||
|
||||
procedure TRttiMethod.LoadParameters;
|
||||
const
|
||||
FLAGS_CONVERSION: array[TParamFlag] of Integer = (1, 2, 4, 8, 16, 32);
|
||||
|
||||
var
|
||||
A, Flag: Integer;
|
||||
|
||||
Param: TProcedureParam;
|
||||
|
||||
RttiParam: TRttiParameter;
|
||||
|
||||
begin
|
||||
SetLength(FParameters, Length(MethodTypeInfo.ProcSig.Params));
|
||||
|
||||
for A := Low(FParameters) to High(FParameters) do
|
||||
begin
|
||||
Param := MethodTypeInfo.ProcSig.Params[A];
|
||||
RttiParam := TRttiParameter.Create;
|
||||
RttiParam.FName := Param.Name;
|
||||
RttiParam.FParamType := GRttiContext.GetType(Param.TypeInfo);
|
||||
|
||||
for Flag in FLAGS_CONVERSION do
|
||||
if Flag and Param.Flags > 0 then
|
||||
RttiParam.FFlags := RttiParam.FFlags + [TParamFlag(A)];
|
||||
|
||||
FParameters[A] := RttiParam;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TRttiMethod.GetParameters: TRttiParameterArray;
|
||||
begin
|
||||
if not Assigned(FParameters) then
|
||||
LoadParameters;
|
||||
|
||||
Result := FParameters;
|
||||
end;
|
||||
|
||||
{ TRttiProperty }
|
||||
|
||||
constructor TRttiProperty.Create(AParent: TRttiType; ATypeInfo: TTypeMember);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user