ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/runtime/IBCustomDataSet.pas

Comparing ibx/trunk/runtime/IBCustomDataSet.pas (file contents):
Revision 101 by tony, Thu Jan 18 14:37:18 2018 UTC vs.
Revision 139 by tony, Wed Jan 24 16:16:29 2018 UTC

#	Line 27 | Line 27
27		{    IBX For Lazarus (Firebird Express)                                  }
28		{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29		{    Portions created by MWA Software are copyright McCallum Whyman      }
30	<	{    Associates Ltd 2011 - 2015                                                }
30	>	{    Associates Ltd 2011 - 2015                                          }
31		{                                                                        }
32		{************************************************************************}
33
#	Line 76 | Line 76 | type
76		function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract;
77		procedure InternalSetParams(Params: ISQLParams; buff: PChar); overload;
78		procedure InternalSetParams(Query: TIBSQL; buff: PChar); overload;
79	<	procedure UpdateRecordFromQuery(QryResults: IResults; Buffer: PChar);
79	>	procedure UpdateRecordFromQuery(UpdateKind: TUpdateKind; QryResults: IResults; Buffer: PChar);
80		property DataSet: TIBCustomDataSet read GetDataSet write SetDataSet;
81		public
82		constructor Create(AOwner: TComponent); override;
#	Line 315 | Line 315 | type
315		FFieldName: string;
316		FGeneratorName: string;
317		FIncrement: integer;
318	+	FQuery: TIBSQL;
319	+	function GetDatabase: TIBDatabase;
320	+	function GetTransaction: TIBTransaction;
321	+	procedure SetDatabase(AValue: TIBDatabase);
322	+	procedure SetGeneratorName(AValue: string);
323		procedure SetIncrement(const AValue: integer);
324	+	procedure SetTransaction(AValue: TIBTransaction);
325	+	procedure SetQuerySQL;
326		protected
327	<	function GetNextValue(ADatabase: TIBDatabase; ATransaction: TIBTransaction): integer;
327	>	function GetNextValue: integer;
328		public
329		constructor Create(Owner: TIBCustomDataSet);
330	+	destructor Destroy; override;
331		procedure Apply;
332		property Owner: TIBCustomDataSet read FOwner;
333	+	property Database: TIBDatabase read GetDatabase write SetDatabase;
334	+	property Transaction: TIBTransaction read GetTransaction write SetTransaction;
335		published
336	<	property Generator: string read FGeneratorName write FGeneratorName;
336	>	property Generator: string read FGeneratorName write SetGeneratorName;
337		property Field: string read FFieldName write FFieldName;
338		property Increment: integer read FIncrement write SetIncrement default 1;
339		property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent;
#	Line 361 | Line 371 | type
371
372		TOnValidatePost = procedure (Sender: TObject; var CancelPost: boolean) of object;
373
374	+	TOnDeleteReturning = procedure (Sender: TObject; QryResults: IResults) of object;
375	+
376		TIBCustomDataSet = class(TDataset)
377		private
378		FAllowAutoActivateTransaction: Boolean;
#	Line 393 | Line 405 | type
405		FDeletedRecords: Long;
406		FModelBuffer,
407		FOldBuffer: PChar;
408	+	FOnDeleteReturning: TOnDeleteReturning;
409		FOnValidatePost: TOnValidatePost;
410		FOpen: Boolean;
411		FInternalPrepared: Boolean;
#	Line 431 | Line 444 | type
444		FInTransactionEnd: boolean;
445		FIBLinks: TList;
446		FFieldColumns: PFieldColumns;
447	+	FBufferUpdatedOnQryReturn: boolean;
448		procedure ColumnDataToBuffer(QryResults: IResults; ColumnIndex,
449		FieldIndex: integer; Buffer: PChar);
450		procedure InitModelBuffer(Qry: TIBSQL; Buffer: PChar);
#	Line 455 | Line 469 | type
469		procedure DoBeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
470		procedure DoAfterTransactionEnd(Sender: TObject);
471		procedure DoTransactionFree(Sender: TObject);
472	+	procedure DoDeleteReturning(QryResults: IResults);
473		procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
474		Buffer: PChar);
475		function GetDatabase: TIBDatabase;
#	Line 675 | Line 690 | type
690		procedure Post; override;
691		function ParamByName(ParamName: String): ISQLParam;
692		property ArrayFieldCount: integer read FArrayFieldCount;
693	+	property DatabaseInfo: TIBDatabaseInfo read FDatabaseInfo;
694		property UpdateObject: TIBDataSetUpdateObject read FUpdateObject write SetUpdateObject;
695		property UpdatesPending: Boolean read FUpdatesPending;
696		property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes
#	Line 719 | Line 735 | type
735		write FOnUpdateError;
736		property OnUpdateRecord: TIBUpdateRecordEvent read FOnUpdateRecord
737		write FOnUpdateRecord;
738	+	property OnDeleteReturning: TOnDeleteReturning read FOnDeleteReturning
739	+	write FOnDeleteReturning;
740		end;
741
742		TIBParserDataSet = class(TIBCustomDataSet)
#	Line 805 | Line 823 | type
823		property OnNewRecord;
824		property OnPostError;
825		property OnValidatePost;
826	+	property OnDeleteReturning;
827		end;
828
829		{ TIBDSBlobStream }
#	Line 1112 | Line 1131 | begin
1131		3, {Assume UNICODE_FSS is really UTF8}
1132		4: {Include GB18030 - assuming UTF8 routines work for this codeset}
1133		if DisplayWidth = 0 then
1134	<	Result := ValidUTF8String(TextToSingleLine(Result))
1134	>	Result := Utf8EscapeControlChars(TextToSingleLine(Result))
1135		else
1136		if UTF8Length(Result) > DisplayWidth then {Show truncation with elipses}
1137	<	Result := ValidUTF8String(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
1137	>	Result := Utf8EscapeControlChars(TextToSingleLine(UTF8Copy(Result,1,DisplayWidth-3))) + '...';
1138		end;
1139		end
1140		end;
#	Line 1954 | Line 1973 | begin
1973		FTransactionFree(Sender);
1974		end;
1975
1976	+	procedure TIBCustomDataSet.DoDeleteReturning(QryResults: IResults);
1977	+	begin
1978	+	if assigned(FOnDeleteReturning) then
1979	+	OnDeleteReturning(self,QryResults);
1980	+	end;
1981	+
1982		procedure TIBCustomDataSet.InitModelBuffer(Qry: TIBSQL; Buffer: PChar);
1983		var i, j: Integer;
1984		FieldsLoaded: integer;
#	Line 2053 | Line 2078 | begin
2078		begin
2079		j := GetFieldPosition(QryResults[i].GetAliasName);
2080		if j > 0 then
2081	+	begin
2082		ColumnDataToBuffer(QryResults,i,j,Buffer);
2083	+	FBufferUpdatedOnQryReturn := true;
2084	+	end;
2085		end;
2086		end;
2087
#	Line 2064 | Line 2092 | procedure TIBCustomDataSet.ColumnDataToB
2092		ColumnIndex, FieldIndex: integer; Buffer: PChar);
2093		var
2094		LocalData: PByte;
2095	<	LocalDate, LocalDouble: Double;
2095	>	LocalDate: TDateTime;
2096	>	LocalDouble: Double;
2097		LocalInt: Integer;
2098		LocalBool: wordBool;
2099		LocalInt64: Int64;
2100		LocalCurrency: Currency;
2072	–	p: PRecordData;
2101		ColData: ISQLData;
2102		begin
2075	–	p := PRecordData(Buffer);
2103		LocalData := nil;
2104	<	with p^.rdFields[FieldIndex], FFieldColumns^[FieldIndex] do
2104	>	with PRecordData(Buffer)^.rdFields[FieldIndex], FFieldColumns^[FieldIndex] do
2105		begin
2106		QryResults.GetData(ColumnIndex,fdIsNull,fdDataLength,LocalData);
2107		if not fdIsNull then
2108		begin
2109		ColData := QryResults[ColumnIndex];
2110		case fdDataType of  {Get Formatted data for column types that need formatting}
2111	+	SQL_TYPE_DATE,
2112	+	SQL_TYPE_TIME,
2113		SQL_TIMESTAMP:
2114		begin
2115	<	LocalDate := TimeStampToMSecs(DateTimeToTimeStamp(ColData.AsDateTime));
2115	>	{This is an IBX native format and not the TDataset approach. See also GetFieldData}
2116	>	LocalDate := ColData.AsDateTime;
2117		LocalData := PByte(@LocalDate);
2118		end;
2089	–	SQL_TYPE_DATE:
2090	–	begin
2091	–	LocalInt := DateTimeToTimeStamp(ColData.AsDateTime).Date;
2092	–	LocalData := PByte(@LocalInt);
2093	–	end;
2094	–	SQL_TYPE_TIME:
2095	–	begin
2096	–	LocalInt := DateTimeToTimeStamp(ColData.AsDateTime).Time;
2097	–	LocalData := PByte(@LocalInt);
2098	–	end;
2119		SQL_SHORT, SQL_LONG:
2120		begin
2121		if (fdDataScale = 0) then
#	Line 2314 | Line 2334 | begin
2334		begin
2335		SetInternalSQLParams(FQDelete.Params, Buff);
2336		FQDelete.ExecQuery;
2337	+	if (FQDelete.FieldCount > 0)  then
2338	+	DoDeleteReturning(FQDelete.Current);
2339		end;
2340		with PRecordData(Buff)^ do
2341		begin
#	Line 2451 | Line 2473 | begin
2473		end;
2474		Inc(arr);
2475		end;
2476	+	FBufferUpdatedOnQryReturn := false;
2477		if Assigned(FUpdateObject) then
2478		begin
2479		if (Qry = FQDelete) then
#	Line 2463 | Line 2486 | begin
2486		else begin
2487		SetInternalSQLParams(Qry.Params, Buff);
2488		Qry.ExecQuery;
2489	+	if Qry.FieldCount > 0 then {Has RETURNING Clause}
2490	+	UpdateRecordFromQuery(Qry.Current,Buff);
2491		end;
2467	–	if Qry.FieldCount > 0 then {Has RETURNING Clause}
2468	–	UpdateRecordFromQuery(Qry.Current,Buff);
2492		PRecordData(Buff)^.rdUpdateStatus := usUnmodified;
2493		PRecordData(Buff)^.rdCachedUpdateStatus := cusUnmodified;
2494		SetModified(False);
2495		WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
2496	<	if (FForcedRefresh or FNeedsRefresh) and CanRefresh then
2496	>	if (FForcedRefresh or (FNeedsRefresh and not FBufferUpdatedOnQryReturn)) and CanRefresh then
2497		InternalRefreshRow;
2498		end;
2499
#	Line 2706 | Line 2729 | end;
2729
2730		procedure TIBCustomDataSet.SetDatabase(Value: TIBDatabase);
2731		begin
2732	<	if (FBase.Database <> Value) then
2732	>	if (csLoading in ComponentState) or (FBase.Database <> Value) then
2733		begin
2734		CheckDatasetClosed;
2735		InternalUnPrepare;
#	Line 2717 | Line 2740 | begin
2740		FQSelect.Database := Value;
2741		FQModify.Database := Value;
2742		FDatabaseInfo.Database := Value;
2743	+	FGeneratorField.Database := Value;
2744		end;
2745		end;
2746
#	Line 2745 | Line 2769 | var
2769		fn: string;
2770		st: RawByteString;
2771		OldBuffer: Pointer;
2748	–	ts: TTimeStamp;
2772		Param: ISQLParam;
2773		begin
2774		if (Buffer = nil) then
#	Line 2820 | Line 2843 | begin
2843		end;
2844		SQL_BLOB, SQL_ARRAY, SQL_QUAD:
2845		Param.AsQuad := PISC_QUAD(data)^;
2846	<	SQL_TYPE_DATE:
2847	<	begin
2825	<	ts.Date := PInt(data)^;
2826	<	ts.Time := 0;
2827	<	Param.AsDate := TimeStampToDateTime(ts);
2828	<	end;
2829	<	SQL_TYPE_TIME:
2830	<	begin
2831	<	ts.Date := 0;
2832	<	ts.Time := PInt(data)^;
2833	<	Param.AsTime := TimeStampToDateTime(ts);
2834	<	end;
2846	>	SQL_TYPE_DATE,
2847	>	SQL_TYPE_TIME,
2848		SQL_TIMESTAMP:
2849	<	Param.AsDateTime :=
2850	<	TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^)));
2849	>	{This is an IBX native format and not the TDataset approach. See also SetFieldData}
2850	>	Param.AsDateTime := PDateTime(data)^;
2851		SQL_BOOLEAN:
2852		Param.AsBoolean := PWordBool(data)^;
2853		end;
#	Line 2885 | Line 2898 | begin
2898		FQRefresh.Transaction := Value;
2899		FQSelect.Transaction := Value;
2900		FQModify.Transaction := Value;
2901	+	FGeneratorField.Transaction := Value;
2902		end;
2903		end;
2904
#	Line 3800 | Line 3814 | var
3814		FieldType: TFieldType;
3815		FieldSize: Word;
3816		FieldDataSize: integer;
3803	–	charSetID: short;
3817		CharSetSize: integer;
3818		CharSetName: RawByteString;
3819		FieldCodePage: TSystemCodePage;
#	Line 4160 | Line 4173 | begin
4173		for i := 0 to SQLParams.GetCount - 1 do
4174		begin
4175		cur_field := DataSource.DataSet.FindField(SQLParams[i].Name);
4176	<	cur_param := SQLParams[i];
4177	<	if (cur_field <> nil) then begin
4176	>	if (cur_field <> nil) then
4177	>	begin
4178	>	cur_param := SQLParams[i];
4179		if (cur_field.IsNull) then
4180		cur_param.IsNull := True
4181	<	else case cur_field.DataType of
4181	>	else
4182	>	case cur_field.DataType of
4183		ftString:
4184		cur_param.AsString := cur_field.AsString;
4185		ftBoolean:
#	Line 4174 | Line 4189 | begin
4189		ftInteger:
4190		cur_param.AsLong := cur_field.AsInteger;
4191		ftLargeInt:
4192	<	cur_param.AsInt64 := TLargeIntField(cur_field).AsLargeInt;
4192	>	cur_param.AsInt64 := cur_field.AsLargeInt;
4193		ftFloat, ftCurrency:
4194		cur_param.AsDouble := cur_field.AsFloat;
4195		ftBCD:
#	Line 4928 | Line 4943 | end;
4943		function TIBCustomDataSet.GetFieldData(Field: TField; Buffer: Pointer;
4944		NativeFormat: Boolean): Boolean;
4945		begin
4946	<	if (Field.DataType = ftBCD) and not NativeFormat then
4946	>	{These datatypes use IBX conventions and not TDataset conventions}
4947	>	if (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) and not NativeFormat then
4948		Result := InternalGetFieldData(Field, Buffer)
4949		else
4950		Result := inherited GetFieldData(Field, Buffer, NativeFormat);
#	Line 4954 | Line 4970 | end;
4970		procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer;
4971		NativeFormat: Boolean);
4972		begin
4973	<	if (not NativeFormat) and (Field.DataType = ftBCD) then
4973	>	{These datatypes use IBX conventions and not TDataset conventions}
4974	>	if (not NativeFormat) and (Field.DataType in [ftBCD,ftDateTime,ftDate,ftTime]) then
4975		InternalSetfieldData(Field, Buffer)
4976		else
4977		inherited SetFieldData(Field, buffer, NativeFormat);
#	Line 4991 | Line 5008 | begin
5008		InternalSetParams(Query.Params,buff);
5009		end;
5010
5011	<	procedure TIBDataSetUpdateObject.UpdateRecordFromQuery(QryResults: IResults;
5012	<	Buffer: PChar);
5011	>	procedure TIBDataSetUpdateObject.UpdateRecordFromQuery(UpdateKind: TUpdateKind;
5012	>	QryResults: IResults; Buffer: PChar);
5013		begin
5014		if not Assigned(DataSet) then Exit;
5015	<	DataSet.UpdateRecordFromQuery(QryResults, Buffer);
5015	>	case UpdateKind of
5016	>	ukModify, ukInsert:
5017	>	DataSet.UpdateRecordFromQuery(QryResults, Buffer);
5018	>	ukDelete:
5019	>	DataSet.DoDeleteReturning(QryResults);
5020	>	end;
5021		end;
5022
5023		function TIBDSBlobStream.GetSize: Int64;
#	Line 5058 | Line 5080 | end;
5080
5081		procedure TIBGenerator.SetIncrement(const AValue: integer);
5082		begin
5083	+	if FIncrement = AValue then Exit;
5084		if AValue < 0 then
5085	<	raise Exception.Create('A Generator Increment cannot be negative');
5086	<	FIncrement := AValue
5085	>	IBError(ibxeNegativeGenerator,[]);
5086	>	FIncrement := AValue;
5087	>	SetQuerySQL;
5088		end;
5089
5090	<	function TIBGenerator.GetNextValue(ADatabase: TIBDatabase;
5067	<	ATransaction: TIBTransaction): integer;
5090	>	procedure TIBGenerator.SetTransaction(AValue: TIBTransaction);
5091		begin
5092	<	with TIBSQL.Create(nil) do
5093	<	try
5094	<	Database := ADatabase;
5095	<	Transaction := ATransaction;
5096	<	if not assigned(Database) then
5097	<	IBError(ibxeCannotSetDatabase,[]);
5098	<	if not assigned(Transaction) then
5099	<	IBError(ibxeCannotSetTransaction,[]);
5100	<	with Transaction do
5101	<	if not InTransaction then StartTransaction;
5102	<	SQL.Text := Format('Select Gen_ID(%s,%d) as ID From RDB$Database',[FGeneratorName,Increment]);
5103	<	Prepare;
5092	>	FQuery.Transaction := AValue;
5093	>	end;
5094	>
5095	>	procedure TIBGenerator.SetQuerySQL;
5096	>	begin
5097	>	FQuery.SQL.Text := Format('Select Gen_ID(%s,%d) From RDB$Database',[FGeneratorName,Increment]);
5098	>	end;
5099	>
5100	>	function TIBGenerator.GetDatabase: TIBDatabase;
5101	>	begin
5102	>	Result := FQuery.Database;
5103	>	end;
5104	>
5105	>	function TIBGenerator.GetTransaction: TIBTransaction;
5106	>	begin
5107	>	Result := FQuery.Transaction;
5108	>	end;
5109	>
5110	>	procedure TIBGenerator.SetDatabase(AValue: TIBDatabase);
5111	>	begin
5112	>	FQuery.Database := AValue;
5113	>	end;
5114	>
5115	>	procedure TIBGenerator.SetGeneratorName(AValue: string);
5116	>	begin
5117	>	if FGeneratorName = AValue then Exit;
5118	>	FGeneratorName := AValue;
5119	>	SetQuerySQL;
5120	>	end;
5121	>
5122	>	function TIBGenerator.GetNextValue: integer;
5123	>	begin
5124	>	with FQuery do
5125	>	begin
5126	>	Transaction.Active := true;
5127		ExecQuery;
5128		try
5129	<	Result := FieldByName('ID').AsInteger
5129	>	Result := Fields[0].AsInteger
5130		finally
5131		Close
5132		end;
5087	–	finally
5088	–	Free
5133		end;
5134		end;
5135
#	Line 5093 | Line 5137 | constructor TIBGenerator.Create(Owner: T
5137		begin
5138		FOwner := Owner;
5139		FIncrement := 1;
5140	+	FQuery := TIBSQL.Create(nil);
5141	+	end;
5142	+
5143	+	destructor TIBGenerator.Destroy;
5144	+	begin
5145	+	if assigned(FQuery) then FQuery.Free;
5146	+	inherited Destroy;
5147		end;
5148
5149
5150		procedure TIBGenerator.Apply;
5151		begin
5152	<	if (FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
5153	<	Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
5152	>	if assigned(Database) and assigned(Transaction) and
5153	>	(FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
5154	>	Owner.FieldByName(FFieldName).AsInteger := GetNextValue;
5155		end;
5156
5157

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines