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 17 by tony, Sat Dec 28 19:22:24 2013 UTC vs.
Revision 27 by tony, Tue Apr 14 13:10:23 2015 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                                                 }
30	>	{    Associates Ltd 2011 - 2015                                                }
31		{                                                                        }
32		{************************************************************************}
33
34		unit IBCustomDataSet;
35
36	+	{$R-}
37	+
38		{$Mode Delphi}
39
40		{$IFDEF DELPHI}
#	Line 49 | Line 51 | uses
51		{$ENDIF}
52		SysUtils, Classes, Forms, Controls, IBDatabase,
53		IBExternals, IB, IBHeader,  IBSQL, Db,
54	<	IBUtils, IBBlob;
54	>	IBUtils, IBBlob, IBSQLParser;
55
56		const
57		BufferCacheSize    =  1000;  { Allocate cache in this many record chunks}
#	Line 118 | Line 120 | type
120		{ TIBStringField allows us to have strings longer than 8196 }
121
122		TIBStringField = class(TStringField)
123	+	private
124	+	FInitialised: boolean;
125	+	protected
126	+	procedure SetSize(AValue: Integer); override;
127		public
128		constructor create(AOwner: TComponent); override;
129		class procedure CheckTypeSize(Value: Integer); override;
#	Line 185 | Line 191 | type
191		property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent;
192		end;
193
194	+	{TIBControlLink - Allows IB Aware controls to react to dataset state changes}
195	+
196	+	TIBControlLink = class
197	+	private
198	+	FTIBDataSet: TIBCustomDataSet;
199	+	procedure SetIBDataSet(AValue: TIBCustomDataSet);
200	+	protected
201	+	procedure UpdateSQL(Sender: TObject); virtual;
202	+	procedure UpdateParams(Sender: TObject); virtual;
203	+	public
204	+	destructor Destroy; override;
205	+	property IBDataSet: TIBCustomDataSet read FTIBDataSet write SetIBDataSet;
206	+	end;
207	+
208	+	TIBAutoCommit = (acDisabled, acCommitRetaining);
209	+
210		{ TIBCustomDataSet }
211		TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);
212
213		TIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
214	<	UpdateKind: TUpdateKind; var UpdateAction: TIBUpdateAction)
214	>	UpdateKind: TUpdateKind; var TheUpdateAction: TIBUpdateAction)
215		of object;
216		TIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
217		var UpdateAction: TIBUpdateAction) of object;
218
219		TIBUpdateRecordTypes = set of TCachedUpdateStatus;
220
221	+	TDataSetCloseAction = (dcDiscardChanges, dcSaveChanges);
222	+
223	+	TOnValidatePost = procedure (Sender: TObject; var CancelPost: boolean) of object;
224	+
225		TIBCustomDataSet = class(TDataset)
226		private
227	+	FAutoCommit: TIBAutoCommit;
228	+	FGenerateParamNames: Boolean;
229		FGeneratorField: TIBGenerator;
230		FNeedsRefresh: Boolean;
231		FForcedRefresh: Boolean;
#	Line 223 | Line 251 | type
251		FDeletedRecords: Long;
252		FModelBuffer,
253		FOldBuffer: PChar;
254	+	FOnValidatePost: TOnValidatePost;
255		FOpen: Boolean;
256		FInternalPrepared: Boolean;
257		FQDelete,
#	Line 233 | Line 262 | type
262		FRecordBufferSize: Integer;
263		FRecordCount: Integer;
264		FRecordSize: Integer;
265	+	FDataSetCloseAction: TDataSetCloseAction;
266		FUniDirectional: Boolean;
267		FUpdateMode: TUpdateMode;
268		FUpdateObject: TIBDataSetUpdateObject;
#	Line 250 | Line 280 | type
280		FBeforeTransactionEnd,
281		FAfterTransactionEnd,
282		FTransactionFree: TNotifyEvent;
283	<
283	>	FAliasNameMap: array of string;
284	>	FAliasNameList: array of string;
285	>	FBaseSQLSelect: TStrings;
286	>	FParser: TSelectSQLParser;
287	>	FCloseAction: TTransactionAction;
288	>	FInTransactionEnd: boolean;
289	>	FIBLinks: TList;
290		function GetSelectStmtHandle: TISC_STMT_HANDLE;
291		procedure SetUpdateMode(const Value: TUpdateMode);
292		procedure SetUpdateObject(Value: TIBDataSetUpdateObject);
#	Line 263 | Line 299 | type
299		function CanRefresh: Boolean;
300		procedure CheckEditState;
301		procedure ClearBlobCache;
302	+	procedure ClearIBLinks;
303		procedure CopyRecordBuffer(Source, Dest: Pointer);
304		procedure DoBeforeDatabaseDisconnect(Sender: TObject);
305		procedure DoAfterDatabaseDisconnect(Sender: TObject);
306		procedure DoDatabaseFree(Sender: TObject);
307	<	procedure DoBeforeTransactionEnd(Sender: TObject);
307	>	procedure DoBeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
308		procedure DoAfterTransactionEnd(Sender: TObject);
309		procedure DoTransactionFree(Sender: TObject);
310		procedure FetchCurrentRecordToBuffer(Qry: TIBSQL; RecordNumber: Integer;
#	Line 283 | Line 320 | type
320		function GetModifySQL: TStrings;
321		function GetTransaction: TIBTransaction;
322		function GetTRHandle: PISC_TR_HANDLE;
323	+	function GetParser: TSelectSQLParser;
324		procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); virtual;
325		function InternalLocate(const KeyFields: string; const KeyValues: Variant;
326		Options: TLocateOptions): Boolean; virtual;
327		procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer); virtual;
328		procedure InternalRevertRecord(RecordNumber: Integer); virtual;
329		function IsVisible(Buffer: PChar): Boolean;
330	+	procedure RegisterIBLink(Sender: TIBControlLink);
331	+	procedure UnRegisterIBLink(Sender: TIBControlLink);
332		procedure SaveOldBuffer(Buffer: PChar);
333		procedure SetBufferChunks(Value: Integer);
334		procedure SetDatabase(Value: TIBDatabase);
#	Line 321 | Line 361 | type
361		procedure DeactivateTransaction;
362		procedure CheckDatasetClosed;
363		procedure CheckDatasetOpen;
364	+	function CreateParser: TSelectSQLParser; virtual;
365	+	procedure FieldDefsFromQuery(SourceQuery: TIBSQL);
366		function GetActiveBuf: PChar;
367		procedure InternalBatchInput(InputObject: TIBBatchInput); virtual;
368		procedure InternalBatchOutput(OutputObject: TIBBatchOutput); virtual;
#	Line 353 | Line 395 | type
395		procedure ClearCalcFields(Buffer: PChar); override;
396		function AllocRecordBuffer: PChar; override;
397		procedure DoBeforeDelete; override;
398	+	procedure DoAfterDelete; override;
399		procedure DoBeforeEdit; override;
400	+	procedure DoAfterEdit; override;
401		procedure DoBeforeInsert; override;
402		procedure DoAfterInsert; override;
403	+	procedure DoBeforeClose; override;
404	+	procedure DoBeforeOpen; override;
405		procedure DoBeforePost; override;
406	+	procedure DoAfterPost; override;
407		procedure FreeRecordBuffer(var Buffer: PChar); override;
408		procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
409		function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
410		function GetCanModify: Boolean; override;
411		function GetDataSource: TDataSource; override;
412	+	function GetDBAliasName(FieldNo: integer): string;
413	+	function GetFieldDefFromAlias(aliasName: string): TFieldDef;
414		function GetFieldClass(FieldType: TFieldType): TFieldClass; override;
415		function GetRecNo: Integer; override;
416		function GetRecord(Buffer: PChar; GetMode: TGetMode;
417		DoCheck: Boolean): TGetResult; override;
418		function GetRecordCount: Integer; override;
419		function GetRecordSize: Word; override;
420	+	procedure InternalAutoCommit;
421		procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
422		procedure InternalCancel; override;
423		procedure InternalClose; override;
#	Line 385 | Line 435 | type
435		procedure InternalSetFieldData(Field: TField; Buffer: Pointer); virtual;
436		procedure InternalSetToRecord(Buffer: PChar); override;
437		function IsCursorOpen: Boolean; override;
438	+	procedure Loaded; override;
439		procedure ReQuery;
440		procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
441		procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
442		procedure SetCachedUpdates(Value: Boolean);
443		procedure SetDataSource(Value: TDataSource);
444	+	procedure SetGenerateParamNames(AValue: Boolean); virtual;
445		procedure SetFieldData(Field : TField; Buffer : Pointer); override;
446		procedure SetFieldData(Field : TField; Buffer : Pointer;
447		NativeFormat : Boolean); overload; override;
#	Line 397 | Line 449 | type
449
450		protected
451		{Likely to be made public by descendant classes}
452	+	property AutoCommit: TIBAutoCommit read FAutoCommit write FAutoCommit default acDisabled;
453		property SQLParams: TIBXSQLDA read GetSQLParams;
454		property Params: TIBXSQLDA read GetSQLParams;
455		property InternalPrepared: Boolean read FInternalPrepared;
#	Line 420 | Line 473 | type
473		property ModifySQL: TStrings read GetModifySQL write SetModifySQL;
474		property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
475		property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
476	+	property Parser: TSelectSQLParser read GetParser;
477	+	property BaseSQLSelect: TStrings read FBaseSQLSelect;
478
479		property BeforeDatabaseDisconnect: TNotifyEvent read FBeforeDatabaseDisconnect
480		write FBeforeDatabaseDisconnect;
#	Line 433 | Line 488 | type
488		write FAfterTransactionEnd;
489		property TransactionFree: TNotifyEvent read FTransactionFree
490		write FTransactionFree;
491	+	property OnValidatePost: TOnValidatePost read FOnValidatePost write FOnValidatePost;
492
493		public
494		constructor Create(AOwner: TComponent); override;
#	Line 440 | Line 496 | type
496		procedure ApplyUpdates;
497		function CachedUpdateStatus: TCachedUpdateStatus;
498		procedure CancelUpdates;
499	+	function GetFieldPosition(AliasName: string): integer;
500		procedure FetchAll;
501		function LocateNext(const KeyFields: string; const KeyValues: Variant;
502		Options: TLocateOptions): Boolean;
503		procedure RecordModified(Value: Boolean);
504		procedure RevertRecord;
505		procedure Undelete;
506	+	procedure ResetParser;
507	+	function HasParser: boolean;
508
509		{ TDataSet support methods }
510		function BookmarkValid(Bookmark: TBookmark): Boolean; override;
#	Line 456 | Line 515 | type
515		function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; (*override;*)
516		function GetFieldData(Field : TField; Buffer : Pointer;
517		NativeFormat : Boolean) : Boolean; overload; override;
518	+	property GenerateParamNames: Boolean read FGenerateParamNames write SetGenerateParamNames;
519		function Locate(const KeyFields: string; const KeyValues: Variant;
520		Options: TLocateOptions): Boolean; override;
521		function Lookup(const KeyFields: string; const KeyValues: Variant;
522		const ResultFields: string): Variant; override;
523		function UpdateStatus: TUpdateStatus; override;
524		function IsSequenced: Boolean; override;
525	+	procedure Post; override;
526		function ParamByName(ParamName: String): TIBXSQLVAR;
527		property DBHandle: PISC_DB_HANDLE read GetDBHandle;
528		property TRHandle: PISC_TR_HANDLE read GetTRHandle;
#	Line 469 | Line 530 | type
530		property UpdatesPending: Boolean read FUpdatesPending;
531		property UpdateRecordTypes: TIBUpdateRecordTypes read FUpdateRecordTypes
532		write SetUpdateRecordTypes;
533	+	property DataSetCloseAction: TDataSetCloseAction
534	+	read FDataSetCloseAction write FDataSetCloseAction;
535
536		published
537		property Database: TIBDatabase read GetDatabase write SetDatabase;
#	Line 507 | Line 570 | type
570		write FOnUpdateRecord;
571		end;
572
573	<	TIBDataSet = class(TIBCustomDataSet)
573	>	TIBParserDataSet = class(TIBCustomDataSet)
574	>	public
575	>	property Parser;
576	>	end;
577	>
578	>	TIBDataSet = class(TIBParserDataSet)
579		private
580		function GetPrepared: Boolean;
581
#	Line 532 | Line 600 | type
600		property QModify;
601		property StatementType;
602		property SelectStmtHandle;
603	+	property BaseSQLSelect;
604
605		published
606		{ TIBCustomDataSet }
607	+	property AutoCommit;
608		property BufferChunks;
609		property CachedUpdates;
610		property DeleteSQL;
#	Line 543 | Line 613 | type
613		property SelectSQL;
614		property ModifySQL;
615		property GeneratorField;
616	+	property GenerateParamNames;
617		property ParamCheck;
618		property UniDirectional;
619		property Filtered;
620	+	property DataSetCloseAction;
621
622		property BeforeDatabaseDisconnect;
623		property AfterDatabaseDisconnect;
#	Line 581 | Line 653 | type
653		property OnFilterRecord;
654		property OnNewRecord;
655		property OnPostError;
656	+	property OnValidatePost;
657		end;
658
659		{ TIBDSBlobStream }
#	Line 678 | Line 751 | type
751		NextRelation : TRelationNode;
752		end;
753
754	+	{ TIBControlLink }
755	+
756	+	destructor TIBControlLink.Destroy;
757	+	begin
758	+	IBDataSet := nil;
759	+	inherited Destroy;
760	+	end;
761	+
762	+	procedure TIBControlLink.UpdateParams(Sender: TObject);
763	+	begin
764	+
765	+	end;
766	+
767	+	procedure TIBControlLink.UpdateSQL(Sender: TObject);
768	+	begin
769	+
770	+	end;
771	+
772	+	procedure TIBControlLink.SetIBDataSet(AValue: TIBCustomDataSet);
773	+	begin
774	+	if FTIBDataSet = AValue then Exit;
775	+	if IBDataSet <> nil then
776	+	IBDataSet.UnRegisterIBLink(self);
777	+	FTIBDataSet := AValue;
778	+	if IBDataSet <> nil then
779	+	IBDataSet.RegisterIBLink(self);
780	+	end;
781	+
782
783		{ TIBStringField}
784
785	<	constructor TIBStringField.Create(AOwner: TComponent);
785	>	constructor TIBStringField.create(AOwner: TComponent);
786		begin
787		inherited Create(AOwner);
788		end;
#	Line 738 | Line 839 | begin
839		end;
840		end;
841
842	+	procedure TIBStringField.SetSize(AValue: Integer);
843	+	var FieldSize: integer;
844	+	begin
845	+	if csLoading in ComponentState then
846	+	FInitialised := true;
847	+	if FInitialised then
848	+	inherited SetSize(AValue)
849	+	else
850	+	begin
851	+	{IBCustomDataSet encodes the CharWidth size in the size}
852	+	FieldSize := AValue div 4;
853	+	inherited SetSize(FieldSize);
854	+	DisplayWidth := FieldSize div ((AValue mod 4) + 1);
855	+	FInitialised := true;
856	+	end;
857	+	end;
858	+
859		{ TIBBCDField }
860
861		constructor TIBBCDField.Create(AOwner: TComponent);
#	Line 835 | Line 953 | begin
953		CheckIBLoaded;
954		FIBLoaded := True;
955		FBase := TIBBase.Create(Self);
956	+	FIBLinks := TList.Create;
957		FCurrentRecord := -1;
958		FDeletedRecords := 0;
959		FUniDirectional := False;
#	Line 859 | Line 978 | begin
978		FQModify.GoToFirstRecordOnExecute := False;
979		FUpdateRecordTypes := [cusUnmodified, cusModified, cusInserted];
980		FParamCheck := True;
981	+	FGenerateParamNames := False;
982		FForcedRefresh := False;
983	+	FAutoCommit:= acDisabled;
984	+	FDataSetCloseAction := dcDiscardChanges;
985		{Bookmark Size is Integer for IBX}
986		BookmarkSize := SizeOf(Integer);
987		FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
#	Line 873 | Line 995 | begin
995		else
996		if AOwner is TIBTransaction then
997		Transaction := TIBTransaction(AOwner);
998	+	FBaseSQLSelect := TStringList.Create;
999		end;
1000
1001		destructor TIBCustomDataSet.Destroy;
#	Line 884 | Line 1007 | begin
1007		FDataLink.Free;
1008		FBase.Free;
1009		ClearBlobCache;
1010	+	ClearIBLinks;
1011	+	FIBLinks.Free;
1012		FBlobStreamList.Free;
1013		FreeMem(FBufferCache);
1014		FBufferCache := nil;
#	Line 893 | Line 1018 | begin
1018		FOldCacheSize := 0;
1019		FMappedFieldPosition := nil;
1020		end;
1021	+	if assigned(FBaseSQLSelect) then FBaseSQLSelect.Free;
1022	+	if assigned(FParser) then FParser.Free;
1023		inherited Destroy;
1024		end;
1025
#	Line 1136 | Line 1263 | begin
1263		end;
1264		end;
1265
1266	+	function TIBCustomDataSet.GetFieldPosition(AliasName: string): integer;
1267	+	var i: integer;
1268	+	Prepared: boolean;
1269	+	begin
1270	+	Result := 0;
1271	+	Prepared := FInternalPrepared;
1272	+	if not Prepared then
1273	+	InternalPrepare;
1274	+	try
1275	+	for i := 0 to Length(FAliasNameList) - 1 do
1276	+	if FAliasNameList[i] = AliasName then
1277	+	begin
1278	+	Result := i + 1;
1279	+	Exit
1280	+	end;
1281	+	finally
1282	+	if not Prepared then
1283	+	InternalUnPrepare;
1284	+	end;
1285	+	end;
1286	+
1287		procedure TIBCustomDataSet.ActivateConnection;
1288		begin
1289		if not Assigned(Database) then
#	Line 1196 | Line 1344 | begin
1344		IBError(ibxeDatasetClosed, [nil]);
1345		end;
1346
1347	+	function TIBCustomDataSet.CreateParser: TSelectSQLParser;
1348	+	begin
1349	+	Result := TSelectSQLParser.Create(self,FBaseSQLSelect);
1350	+	Result.OnSQLChanging := SQLChanging
1351	+	end;
1352	+
1353		procedure TIBCustomDataSet.CheckNotUniDirectional;
1354		begin
1355		if UniDirectional then
#	Line 1299 | Line 1453 | begin
1453		FDatabaseFree(Sender);
1454		end;
1455
1456	<	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject);
1456	>	procedure TIBCustomDataSet.DoBeforeTransactionEnd(Sender: TObject;
1457	>	Action: TTransactionAction);
1458		begin
1459	<	if Active then
1460	<	Active := False;
1459	>	FCloseAction := Action;
1460	>	FInTransactionEnd := true;
1461	>	try
1462	>	if Active then
1463	>	Active := False;
1464	>	finally
1465	>	FInTransactionEnd := false;
1466	>	end;
1467		if FQSelect <> nil then
1468		FQSelect.FreeHandle;
1469		if FQDelete <> nil then
#	Line 1340 | Line 1501 | var
1501		LocalData: Pointer;
1502		LocalDate, LocalDouble: Double;
1503		LocalInt: Integer;
1504	+	LocalBool: wordBool;
1505		LocalInt64: Int64;
1506		LocalCurrency: Currency;
1507		FieldsLoaded: Integer;
#	Line 1484 | Line 1646 | begin
1646		end;
1647		end;
1648		end;
1649	+	SQL_BOOLEAN:
1650	+	begin
1651	+	LocalBool:= false;
1652	+	rdFields[j].fdDataSize := SizeOf(wordBool);
1653	+	if RecordNumber >= 0 then
1654	+	LocalBool := Qry.Current[i].AsBoolean;
1655	+	LocalData := PChar(@LocalBool);
1656	+	end;
1657		else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD }
1658		begin
1659		rdFields[j].fdDataSize := Qry.Current[i].Data^.sqllen;
#	Line 1759 | Line 1929 | var
1929		ofs: DWORD;
1930		Qry: TIBSQL;
1931		begin
1932	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1932	>	if Assigned(Database) and not Database.SQLHourGlass then
1933	>	SetCursor := False
1934	>	else
1935	>	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
1936		if SetCursor then
1937		Screen.Cursor := crHourGlass;
1938		try
#	Line 1883 | Line 2056 | begin
2056		if FInternalPrepared then
2057		Exit;
2058		DidActivate := False;
2059	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2059	>	if Assigned(Database) and not Database.SQLHourGlass then
2060	>	SetCursor := False
2061	>	else
2062	>	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2063		if SetCursor then
2064		Screen.Cursor := crHourGlass;
2065		try
#	Line 1891 | Line 2067 | begin
2067		DidActivate := ActivateTransaction;
2068		FBase.CheckDatabase;
2069		FBase.CheckTransaction;
2070	+	if HasParser and (FParser.SQLText <> FQSelect.SQL.Text) then
2071	+	FQSelect.SQL.Text := FParser.SQLText;
2072	+	//   writeln( FQSelect.SQL.Text);
2073		if FQSelect.SQL.Text <> '' then
2074		begin
2075		if not FQSelect.Prepared then
2076		begin
2077	+	FQSelect.GenerateParamNames := FGenerateParamNames;
2078		FQSelect.ParamCheck := ParamCheck;
2079		FQSelect.Prepare;
2080		end;
2081	+	FQDelete.GenerateParamNames := FGenerateParamNames;
2082		if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
2083		FQDelete.Prepare;
2084	+	FQInsert.GenerateParamNames := FGenerateParamNames;
2085		if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
2086		FQInsert.Prepare;
2087	+	FQRefresh.GenerateParamNames := FGenerateParamNames;
2088		if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
2089		FQRefresh.Prepare;
2090	+	FQModify.GenerateParamNames := FGenerateParamNames;
2091		if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
2092		FQModify.Prepare;
2093		FInternalPrepared := True;
#	Line 2105 | Line 2289 | begin
2289		SQL_TIMESTAMP:
2290		Qry.Params[i].AsDateTime :=
2291		TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^)));
2292	+	SQL_BOOLEAN:
2293	+	Qry.Params[i].AsBoolean := PWordBool(data)^;
2294		end;
2295		end;
2296		end;
#	Line 2130 | Line 2316 | begin
2316		begin
2317		Disconnect;
2318		FQSelect.SQL.Assign(Value);
2319	+	FBaseSQLSelect.assign(Value);
2320		end;
2321		end;
2322
#	Line 2190 | Line 2377 | begin
2377		end;
2378		end;
2379
2380	+	procedure TIBCustomDataSet.RegisterIBLink(Sender: TIBControlLink);
2381	+	begin
2382	+	if FIBLinks.IndexOf(Sender) = -1 then
2383	+	FIBLinks.Add(Sender);
2384	+	end;
2385	+
2386
2387		procedure TIBCustomDataSet.SQLChanging(Sender: TObject);
2388		begin
2389	<	if FOpen then
2390	<	InternalClose;
2389	>	Active := false;
2390	>	{  if FOpen then
2391	>	InternalClose;}
2392		if FInternalPrepared then
2393		InternalUnPrepare;
2394	+	FieldDefs.Clear;
2395	+	FieldDefs.Updated := false;
2396		end;
2397
2398		{ I can "undelete" uninserted records (make them "inserted" again).
#	Line 2225 | Line 2421 | begin
2421		end;
2422		end;
2423
2424	+	procedure TIBCustomDataSet.UnRegisterIBLink(Sender: TIBControlLink);
2425	+	begin
2426	+	FIBLinks.Remove(Sender);
2427	+	end;
2428	+
2429		function TIBCustomDataSet.UpdateStatus: TUpdateStatus;
2430		begin
2431		if Active then
#	Line 2454 | Line 2655 | begin
2655		inherited DoBeforeDelete;
2656		end;
2657
2658	+	procedure TIBCustomDataSet.DoAfterDelete;
2659	+	begin
2660	+	inherited DoAfterDelete;
2661	+	FBase.DoAfterDelete(self);
2662	+	InternalAutoCommit;
2663	+	end;
2664	+
2665		procedure TIBCustomDataSet.DoBeforeEdit;
2666		var
2667		Buff: PRecordData;
#	Line 2468 | Line 2676 | begin
2676		inherited DoBeforeEdit;
2677		end;
2678
2679	+	procedure TIBCustomDataSet.DoAfterEdit;
2680	+	begin
2681	+	inherited DoAfterEdit;
2682	+	FBase.DoAfterEdit(self);
2683	+	end;
2684	+
2685		procedure TIBCustomDataSet.DoBeforeInsert;
2686		begin
2687		if not CanInsert then
#	Line 2480 | Line 2694 | begin
2694		if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
2695		GeneratorField.Apply;
2696		inherited DoAfterInsert;
2697	+	FBase.DoAfterInsert(self);
2698	+	end;
2699	+
2700	+	procedure TIBCustomDataSet.DoBeforeClose;
2701	+	begin
2702	+	inherited DoBeforeClose;
2703	+	if State in [dsInsert,dsEdit] then
2704	+	begin
2705	+	if FInTransactionEnd and (FCloseAction = TARollback) then
2706	+	Exit;
2707	+
2708	+	if DataSetCloseAction = dcSaveChanges then
2709	+	Post;
2710	+	{Note this can fail with an exception e.g. due to
2711	+	database validation error. In which case the dataset remains open }
2712	+	end;
2713	+	end;
2714	+
2715	+	procedure TIBCustomDataSet.DoBeforeOpen;
2716	+	var i: integer;
2717	+	begin
2718	+	if assigned(FParser) then
2719	+	FParser.Reset;
2720	+	for i := 0 to FIBLinks.Count - 1 do
2721	+	TIBControlLink(FIBLinks[i]).UpdateSQL(self);
2722	+	inherited DoBeforeOpen;
2723	+	for i := 0 to FIBLinks.Count - 1 do
2724	+	TIBControlLink(FIBLinks[i]).UpdateParams(self);
2725		end;
2726
2727		procedure TIBCustomDataSet.DoBeforePost;
#	Line 2490 | Line 2732 | begin
2732		GeneratorField.Apply
2733		end;
2734
2735	+	procedure TIBCustomDataSet.DoAfterPost;
2736	+	begin
2737	+	inherited DoAfterPost;
2738	+	FBase.DoAfterPost(self);
2739	+	InternalAutoCommit;
2740	+	end;
2741	+
2742		procedure TIBCustomDataSet.FetchAll;
2743		var
2744		SetCursor: Boolean;
#	Line 2499 | Line 2748 | var
2748		CurBookmark: string;
2749		{$ENDIF}
2750		begin
2751	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2751	>	if Assigned(Database) and not Database.SQLHourGlass then
2752	>	SetCursor := False
2753	>	else
2754	>	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2755		if SetCursor then
2756		Screen.Cursor := crHourGlass;
2757		try
#	Line 2563 | Line 2815 | begin
2815		result := FDataLink.DataSource;
2816		end;
2817
2818	+	function TIBCustomDataSet.GetDBAliasName(FieldNo: integer): string;
2819	+	begin
2820	+	Result := FAliasNameMap[FieldNo-1]
2821	+	end;
2822	+
2823	+	function TIBCustomDataSet.GetFieldDefFromAlias(aliasName: string): TFieldDef;
2824	+	var
2825	+	i: integer;
2826	+	begin
2827	+	Result := nil;
2828	+	for i := 0 to Length(FAliasNameMap) - 1 do
2829	+	if FAliasNameMap[i] = aliasName then
2830	+	begin
2831	+	Result := FieldDefs[i+1];
2832	+	Exit
2833	+	end;
2834	+	end;
2835	+
2836		function TIBCustomDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
2837		begin
2838		Result := DefaultFieldClasses[FieldType];
#	Line 2603 | Line 2873 | begin
2873		Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs;
2874		if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
2875		begin
2876	<	if fdDataLength <= Field.Size then
2876	>	if fdDataLength < Field.DataSize then
2877		begin
2878		Move(Data^, Buffer^, fdDataLength);
2879		PChar(Buffer)[fdDataLength] := #0;
#	Line 2746 | Line 3016 | begin
3016		result := FRecordBufferSize;
3017		end;
3018
3019	+	procedure TIBCustomDataSet.InternalAutoCommit;
3020	+	begin
3021	+	with Transaction do
3022	+	if InTransaction and (FAutoCommit = acCommitRetaining) then
3023	+	begin
3024	+	if CachedUpdates then ApplyUpdates;
3025	+	CommitRetaining;
3026	+	end;
3027	+	end;
3028	+
3029		procedure TIBCustomDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
3030		begin
3031		CheckEditState;
#	Line 2825 | Line 3105 | var
3105		Buff: PChar;
3106		SetCursor: Boolean;
3107		begin
3108	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3108	>	if Assigned(Database) and not Database.SQLHourGlass then
3109	>	SetCursor := False
3110	>	else
3111	>	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3112		if SetCursor then
3113		Screen.Cursor := crHourGlass;
3114		try
#	Line 2873 | Line 3156 | begin
3156		end;
3157
3158		procedure TIBCustomDataSet.InternalInitFieldDefs;
3159	+	begin
3160	+	if not InternalPrepared then
3161	+	begin
3162	+	InternalPrepare;
3163	+	exit;
3164	+	end;
3165	+	FieldDefsFromQuery(FQSelect);
3166	+	end;
3167	+
3168	+	procedure TIBCustomDataSet.FieldDefsFromQuery(SourceQuery: TIBSQL);
3169		const
3170		DefaultSQL = 'Select F.RDB$COMPUTED_BLR, ' + {do not localize}
3171		'F.RDB$DEFAULT_VALUE, R.RDB$FIELD_NAME ' + {do not localize}
#	Line 2884 | Line 3177 | const
3177		var
3178		FieldType: TFieldType;
3179		FieldSize: Word;
3180	+	CharSetSize: integer;
3181		FieldNullable : Boolean;
3182		i, FieldPosition, FieldPrecision: Integer;
3183	<	FieldAliasName: string;
3183	>	FieldAliasName, DBAliasName: string;
3184		RelationName, FieldName: string;
3185		Query : TIBSQL;
3186		FieldIndex: Integer;
#	Line 2986 | Line 3280 | var
3280		end;
3281
3282		begin
2989	–	if not InternalPrepared then
2990	–	begin
2991	–	InternalPrepare;
2992	–	exit;
2993	–	end;
3283		FRelationNodes := TRelationNode.Create;
3284		FNeedsRefresh := False;
3285		Database.InternalTransaction.StartTransaction;
#	Line 3001 | Line 3290 | begin
3290		FieldDefs.BeginUpdate;
3291		FieldDefs.Clear;
3292		FieldIndex := 0;
3293	<	if (Length(FMappedFieldPosition) < FQSelect.Current.Count) then
3294	<	SetLength(FMappedFieldPosition, FQSelect.Current.Count);
3293	>	if (Length(FMappedFieldPosition) < SourceQuery.Current.Count) then
3294	>	SetLength(FMappedFieldPosition, SourceQuery.Current.Count);
3295		Query.SQL.Text := DefaultSQL;
3296		Query.Prepare;
3297	<	for i := 0 to FQSelect.Current.Count - 1 do
3298	<	with FQSelect.Current[i].Data^ do
3297	>	SetLength(FAliasNameMap, SourceQuery.Current.Count);
3298	>	SetLength(FAliasNameList, SourceQuery.Current.Count);
3299	>	for i := 0 to SourceQuery.Current.Count - 1 do
3300	>	with SourceQuery.Current[i].Data^ do
3301		begin
3302		{ Get the field name }
3303	<	SetString(FieldAliasName, aliasname, aliasname_length);
3303	>	FieldAliasName := SourceQuery.Current[i].Name;
3304	>	SetString(DBAliasName, aliasname, aliasname_length);
3305		SetString(RelationName, relname, relname_length);
3306		SetString(FieldName, sqlname, sqlname_length);
3307	+	FAliasNameList[i] := DBAliasName;
3308		FieldSize := 0;
3309		FieldPrecision := 0;
3310	<	FieldNullable := FQSelect.Current[i].IsNullable;
3310	>	FieldNullable := SourceQuery.Current[i].IsNullable;
3311		case sqltype and not 1 of
3312		{ All VARCHAR's must be converted to strings before recording
3313		their values }
3314		SQL_VARYING, SQL_TEXT:
3315		begin
3316	<	FieldSize := sqllen;
3316	>	CharSetSize := FBase.GetCharSetSize(sqlsubtype and $FF);
3317	>	{FieldSize is encoded for strings - see TIBStringField.SetSize for decode}
3318	>	FieldSize := sqllen * 4 + (CharSetSize - 1);
3319		FieldType := ftString;
3320		end;
3321		{ All Doubles/Floats should be cast to doubles }
#	Line 3089 | Line 3384 | begin
3384		FieldSize := sizeof (TISC_QUAD);
3385		FieldType := ftUnknown;
3386		end;
3387	+	SQL_BOOLEAN:
3388	+	FieldType:= ftBoolean;
3389		else
3390		FieldType := ftUnknown;
3391		end;
#	Line 3100 | Line 3397 | begin
3397		with FieldDefs.AddFieldDef do
3398		begin
3399		Name := FieldAliasName;
3400	<	(*           FieldNo := FieldPosition;*)
3400	>	FAliasNameMap[FieldNo-1] := DBAliasName;
3401		DataType := FieldType;
3402		Size := FieldSize;
3403		Precision := FieldPrecision;
#	Line 3185 | Line 3482 | begin
3482		else case cur_field.DataType of
3483		ftString:
3484		cur_param.AsString := cur_field.AsString;
3485	<	ftBoolean, ftSmallint, ftWord:
3485	>	ftBoolean:
3486	>	cur_param.AsBoolean := cur_field.AsBoolean;
3487	>	ftSmallint, ftWord:
3488		cur_param.AsShort := cur_field.AsInteger;
3489		ftInteger:
3490		cur_param.AsLong := cur_field.AsInteger;
#	Line 3247 | Line 3546 | var
3546		end;
3547
3548		begin
3549	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3549	>	if Assigned(Database) and not Database.SQLHourGlass then
3550	>	SetCursor := False
3551	>	else
3552	>	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3553		if SetCursor then
3554		Screen.Cursor := crHourGlass;
3555		try
#	Line 3322 | Line 3624 | var
3624		SetCursor: Boolean;
3625		bInserting: Boolean;
3626		begin
3627	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3627	>	if Assigned(Database) and not Database.SQLHourGlass then
3628	>	SetCursor := False
3629	>	else
3630	>	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3631		if SetCursor then
3632		Screen.Cursor := crHourGlass;
3633		try
#	Line 3383 | Line 3688 | begin
3688		result := FOpen;
3689		end;
3690
3691	+	procedure TIBCustomDataSet.Loaded;
3692	+	begin
3693	+	if assigned(FQSelect) then
3694	+	FBaseSQLSelect.assign(FQSelect.SQL);
3695	+	inherited Loaded;
3696	+	end;
3697	+
3698	+	procedure TIBCustomDataSet.Post;
3699	+	var CancelPost: boolean;
3700	+	begin
3701	+	CancelPost := false;
3702	+	if assigned(FOnValidatePost) then
3703	+	OnValidatePost(self,CancelPost);
3704	+	if CancelPost then
3705	+	Cancel
3706	+	else
3707	+	inherited Post;
3708	+	end;
3709	+
3710		function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
3711		Options: TLocateOptions): Boolean;
3712		var
#	Line 3465 | Line 3789 | end;
3789		procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
3790		var
3791		Buff, TmpBuff: PChar;
3792	+	MappedFieldPos: integer;
3793		begin
3794		Buff := GetActiveBuf;
3795		if Field.FieldNo < 0 then
#	Line 3481 | Line 3806 | begin
3806		begin
3807		{ If inserting, Adjust record position }
3808		AdjustRecordOnInsert(Buff);
3809	<	if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
3810	<	(FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
3809	>	MappedFieldPos := FMappedFieldPosition[Field.FieldNo - 1];
3810	>	if (MappedFieldPos > 0) and
3811	>	(MappedFieldPos <= rdFieldCount) then
3812		begin
3813		Field.Validate(Buffer);
3814		if (Buffer = nil) or
3815		(Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
3816	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
3816	>	rdFields[MappedFieldPos].fdIsNull := True
3817		else begin
3818	<	Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
3819	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
3820	<	if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
3821	<	(rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
3822	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer));
3823	<	rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
3818	>	Move(Buffer^, Buff[rdFields[MappedFieldPos].fdDataOfs],
3819	>	rdFields[MappedFieldPos].fdDataSize);
3820	>	if (rdFields[MappedFieldPos].fdDataType = SQL_TEXT) or
3821	>	(rdFields[MappedFieldPos].fdDataType = SQL_VARYING) then
3822	>	rdFields[MappedFieldPos].fdDataLength := StrLen(PChar(Buffer));
3823	>	rdFields[MappedFieldPos].fdIsNull := False;
3824		if rdUpdateStatus = usUnmodified then
3825		begin
3826		if CachedUpdates then
#	Line 3582 | Line 3908 | begin
3908		FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);
3909		end;
3910
3911	+	procedure TIBCustomDataSet.ClearIBLinks;
3912	+	var i: integer;
3913	+	begin
3914	+	for i := FIBLinks.Count - 1 downto 0 do
3915	+	TIBControlLink(FIBLinks[i]).IBDataSet := nil;
3916	+	end;
3917	+
3918
3919		procedure TIBCustomDataSet.InternalUnPrepare;
3920		begin
#	Line 3589 | Line 3922 | begin
3922		begin
3923		CheckDatasetClosed;
3924		FieldDefs.Clear;
3925	+	FieldDefs.Updated := false;
3926		FInternalPrepared := False;
3927	+	Setlength(FAliasNameList,0);
3928		end;
3929		end;
3930
#	Line 3599 | Line 3934 | var
3934		SetCursor: Boolean;
3935		begin
3936		DidActivate := False;
3937	<	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3937	>	if Assigned(Database) and not Database.SQLHourGlass then
3938	>	SetCursor := False
3939	>	else
3940	>	SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
3941		if SetCursor then
3942		Screen.Cursor := crHourGlass;
3943		try
#	Line 3628 | Line 3966 | begin
3966		Result := FQSelect.Handle;
3967		end;
3968
3969	+	function TIBCustomDataSet.GetParser: TSelectSQLParser;
3970	+	begin
3971	+	if not assigned(FParser) then
3972	+	FParser := CreateParser;
3973	+	Result := FParser
3974	+	end;
3975	+
3976	+	procedure TIBCustomDataSet.ResetParser;
3977	+	begin
3978	+	if assigned(FParser) then
3979	+	begin
3980	+	FParser.Free;
3981	+	FParser := nil;
3982	+	SQLChanging(nil)
3983	+	end;
3984	+	end;
3985	+
3986	+	function TIBCustomDataSet.HasParser: boolean;
3987	+	begin
3988	+	Result := not (csDesigning in ComponentState) and (FParser <> nil)
3989	+	end;
3990	+
3991	+	procedure TIBCustomDataSet.SetGenerateParamNames(AValue: Boolean);
3992	+	begin
3993	+	if FGenerateParamNames = AValue then Exit;
3994	+	FGenerateParamNames := AValue;
3995	+	Disconnect
3996	+	end;
3997	+
3998		procedure TIBCustomDataSet.InitRecord(Buffer: PChar);
3999		begin
4000		inherited InitRecord(Buffer);

Diff Legend

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