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 1 by tony, Mon Jul 31 16:43:00 2000 UTC vs.
Revision 15 by tony, Thu Feb 28 16:56:14 2013 UTC

#	Line 24 | Line 24
24		{       Corporation. All Rights Reserved.                                }
25		{    Contributor(s): Jeff Overcash                                       }
26		{                                                                        }
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                                                 }
31	+	{                                                                        }
32		{************************************************************************}
33
34		unit IBCustomDataSet;
35
36	+	{$Mode Delphi}
37	+
38	+	{$IFDEF DELPHI}
39	+	{$DEFINE TDBDFIELD_IS_BCD}
40	+	{$ENDIF}
41	+
42		interface
43
44		uses
45	<	Windows, SysUtils, Classes, Forms, Controls, StdVCL,
46	<	IBExternals, IB, IBHeader, IBDatabase, IBSQL, Db,
45	>	{$IFDEF WINDOWS }
46	>	Windows,
47	>	{$ELSE}
48	>	unix,
49	>	{$ENDIF}
50	>	SysUtils, Classes, Forms, Controls, IBDatabase,
51	>	IBExternals, IB, IBHeader,  IBSQL, Db,
52		IBUtils, IBBlob;
53
54		const
#	Line 43 | Line 59 | type
59		TIBCustomDataSet = class;
60		TIBDataSet = class;
61
62	+	{ TIBDataSetUpdateObject }
63	+
64		TIBDataSetUpdateObject = class(TComponent)
65		private
66		FRefreshSQL: TStrings;
#	Line 50 | Line 68 | type
68		protected
69		function GetDataSet: TIBCustomDataSet; virtual; abstract;
70		procedure SetDataSet(ADataSet: TIBCustomDataSet); virtual; abstract;
71	<	procedure Apply(UpdateKind: TUpdateKind); virtual; abstract;
71	>	procedure Apply(UpdateKind: TUpdateKind; buff: PChar); virtual; abstract;
72		function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract;
73	+	procedure InternalSetParams(Query: TIBSQL; buff: PChar);
74		property DataSet: TIBCustomDataSet read GetDataSet write SetDataSet;
75		public
76		constructor Create(AOwner: TComponent); override;
#	Line 60 | Line 79 | type
79		property RefreshSQL: TStrings read FRefreshSQL write SetRefreshSQL;
80		end;
81
63	–	PDateTime = ^TDateTime;
82		TBlobDataArray = array[0..0] of TIBBlobStream;
83		PBlobDataArray = ^TBlobDataArray;
84
#	Line 88 | Line 106 | type
106		TRecordData = record
107		rdBookmarkFlag: TBookmarkFlag;
108		rdFieldCount: Short;
109	<	rdRecordNumber: Long;
109	>	rdRecordNumber: Integer;
110		rdCachedUpdateStatus: TCachedUpdateStatus;
111		rdUpdateStatus: TUpdateStatus;
112		rdSavedOffset: DWORD;
#	Line 142 | Line 160 | type
160		destructor Destroy; override;
161		end;
162
163	+	TIBGeneratorApplyOnEvent = (gaeOnNewRecord,gaeOnPostRecord);
164	+
165	+	{ TIBGenerator }
166	+
167	+	TIBGenerator = class(TPersistent)
168	+	private
169	+	FOwner: TIBCustomDataSet;
170	+	FApplyOnEvent: TIBGeneratorApplyOnEvent;
171	+	FFieldName: string;
172	+	FGeneratorName: string;
173	+	FIncrement: integer;
174	+	procedure SetIncrement(const AValue: integer);
175	+	protected
176	+	function GetNextValue(ADatabase: TIBDatabase; ATransaction: TIBTransaction): integer;
177	+	public
178	+	constructor Create(Owner: TIBCustomDataSet);
179	+	procedure Apply;
180	+	property Owner: TIBCustomDataSet read FOwner;
181	+	published
182	+	property Generator: string read FGeneratorName write FGeneratorName;
183	+	property Field: string read FFieldName write FFieldName;
184	+	property Increment: integer read FIncrement write SetIncrement default 1;
185	+	property ApplyOnEvent: TIBGeneratorApplyOnEvent read FApplyOnEvent write FApplyOnEvent;
186	+	end;
187	+
188		{ TIBCustomDataSet }
189		TIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);
190
#	Line 155 | Line 198 | type
198
199		TIBCustomDataSet = class(TDataset)
200		private
201	+	FGeneratorField: TIBGenerator;
202		FNeedsRefresh: Boolean;
203		FForcedRefresh: Boolean;
204		FDidActivate: Boolean;
#	Line 239 | Line 283 | type
283		function GetModifySQL: TStrings;
284		function GetTransaction: TIBTransaction;
285		function GetTRHandle: PISC_TR_HANDLE;
286	<	procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
286	>	procedure InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer); virtual;
287		function InternalLocate(const KeyFields: string; const KeyValues: Variant;
288		Options: TLocateOptions): Boolean; virtual;
289	<	procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer);
290	<	procedure InternalRevertRecord(RecordNumber: Integer);
289	>	procedure InternalPostRecord(Qry: TIBSQL; Buff: Pointer); virtual;
290	>	procedure InternalRevertRecord(RecordNumber: Integer); virtual;
291		function IsVisible(Buffer: PChar): Boolean;
292		procedure SaveOldBuffer(Buffer: PChar);
293		procedure SetBufferChunks(Value: Integer);
#	Line 260 | Line 304 | type
304		procedure RefreshParams;
305		procedure SQLChanging(Sender: TObject); virtual;
306		function AdjustPosition(FCache: PChar; Offset: DWORD;
307	<	Origin: Integer): Integer;
307	>	Origin: Integer): DWORD;
308		procedure ReadCache(FCache: PChar; Offset: DWORD; Origin: Integer;
309		Buffer: PChar);
310		procedure ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
#	Line 269 | Line 313 | type
313		Buffer: PChar);
314		procedure WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
315		function InternalGetRecord(Buffer: PChar; GetMode: TGetMode;
316	<	DoCheck: Boolean): TGetResult;
316	>	DoCheck: Boolean): TGetResult; virtual;
317
318		protected
319		procedure ActivateConnection;
#	Line 278 | Line 322 | type
322		procedure CheckDatasetClosed;
323		procedure CheckDatasetOpen;
324		function GetActiveBuf: PChar;
325	<	procedure InternalBatchInput(InputObject: TIBBatchInput);
326	<	procedure InternalBatchOutput(OutputObject: TIBBatchOutput);
325	>	procedure InternalBatchInput(InputObject: TIBBatchInput); virtual;
326	>	procedure InternalBatchOutput(OutputObject: TIBBatchOutput); virtual;
327		procedure InternalPrepare; virtual;
328		procedure InternalUnPrepare; virtual;
329		procedure InternalExecQuery; virtual;
330		procedure InternalRefreshRow; virtual;
331	<	procedure InternalSetParamsFromCursor;
331	>	procedure InternalSetParamsFromCursor; virtual;
332		procedure CheckNotUniDirectional;
333
334	<	{ IProviderSupport }
334	>	(*    { IProviderSupport }
335		procedure PSEndTransaction(Commit: Boolean); override;
336		function PSExecuteStatement(const ASQL: string; AParams: TParams;
337		ResultSet: Pointer = nil): Integer; override;
#	Line 300 | Line 344 | type
344		procedure PSStartTransaction; override;
345		procedure PSReset; override;
346		function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
347	<
347	>	*)
348		{ TDataSet support }
349		procedure InternalInsert; override;
350		procedure InitRecord(Buffer: PChar); override;
#	Line 311 | Line 355 | type
355		procedure DoBeforeDelete; override;
356		procedure DoBeforeEdit; override;
357		procedure DoBeforeInsert; override;
358	+	procedure DoAfterInsert; override;
359	+	procedure DoBeforePost; override;
360		procedure FreeRecordBuffer(var Buffer: PChar); override;
361		procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
362		function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
#	Line 327 | Line 373 | type
373		procedure InternalClose; override;
374		procedure InternalDelete; override;
375		procedure InternalFirst; override;
376	<	function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean;
376	>	function InternalGetFieldData(Field: TField; Buffer: Pointer): Boolean; virtual;
377		procedure InternalGotoBookmark(Bookmark: Pointer); override;
378		procedure InternalHandleException; override;
379		procedure InternalInitFieldDefs; override;
#	Line 336 | Line 382 | type
382		procedure InternalOpen; override;
383		procedure InternalPost; override;
384		procedure InternalRefresh; override;
385	<	procedure InternalSetFieldData(Field: TField; Buffer: Pointer);
385	>	procedure InternalSetFieldData(Field: TField; Buffer: Pointer); virtual;
386		procedure InternalSetToRecord(Buffer: PChar); override;
387		function IsCursorOpen: Boolean; override;
388		procedure ReQuery;
#	Line 366 | Line 412 | type
412		property BufferChunks: Integer read FBufferChunks write SetBufferChunks;
413		property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
414		property UniDirectional: Boolean read FUniDirectional write SetUniDirectional default False;
415	+	property GeneratorField: TIBGenerator read FGeneratorField write FGeneratorField;
416		property DeleteSQL: TStrings read GetDeleteSQL write SetDeleteSQL;
417		property InsertSQL: TStrings read GetInsertSQL write SetInsertSQL;
418		property RefreshSQL: TStrings read GetRefreshSQL write SetRefreshSQL;
#	Line 406 | Line 453 | type
453		function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
454		function GetCurrentRecord(Buffer: PChar): Boolean; override;
455		function GetFieldData(Field : TField; Buffer : Pointer) : Boolean; overload; override;
456	<	function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; override;
456	>	function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; (*override;*)
457		function GetFieldData(Field : TField; Buffer : Pointer;
458		NativeFormat : Boolean) : Boolean; overload; override;
459		function Locate(const KeyFields: string; const KeyValues: Variant;
#	Line 415 | Line 462 | type
462		const ResultFields: string): Variant; override;
463		function UpdateStatus: TUpdateStatus; override;
464		function IsSequenced: Boolean; override;
465	<
465	>	function ParamByName(ParamName: String): TIBXSQLVAR;
466		property DBHandle: PISC_DB_HANDLE read GetDBHandle;
467		property TRHandle: PISC_TR_HANDLE read GetTRHandle;
468		property UpdateObject: TIBDataSetUpdateObject read FUpdateObject write SetUpdateObject;
#	Line 430 | Line 477 | type
477		property ForcedRefresh: Boolean read FForcedRefresh
478		write FForcedRefresh default False;
479		property AutoCalcFields;
433	–	property ObjectView default False;
480
481		property AfterCancel;
482		property AfterClose;
#	Line 496 | Line 542 | type
542		property RefreshSQL;
543		property SelectSQL;
544		property ModifySQL;
545	+	property GeneratorField;
546		property ParamCheck;
547		property UniDirectional;
548		property Filtered;
#	Line 576 | Line 623 | DefaultFieldClasses: array[TFieldType] o
623		TBlobField,         { ftTypedBinary }
624		nil,                { ftCursor }
625		TStringField,       { ftFixedChar }
626	<	nil, {TWideStringField } { ftWideString }
626	>	TWideStringField,    { ftWideString }
627		TLargeIntField,     { ftLargeInt }
628	+	nil,          { ftADT }
629	+	nil,        { ftArray }
630	+	nil,    { ftReference }
631	+	nil,     { ftDataSet }
632	+	TBlobField,         { ftOraBlob }
633	+	TMemoField,         { ftOraClob }
634	+	TVariantField,      { ftVariant }
635	+	nil,    { ftInterface }
636	+	nil,     { ftIDispatch }
637	+	TGuidField,        { ftGuid }
638	+	TDateTimeField,    {ftTimestamp}
639	+	TIBBCDField,       {ftFMTBcd}
640	+	nil,  {ftFixedWideChar}
641	+	TWideMemoField);   {ftWideMemo}
642	+	(*
643		TADTField,          { ftADT }
644		TArrayField,        { ftArray }
645		TReferenceField,    { ftReference }
#	Line 587 | Line 649 | DefaultFieldClasses: array[TFieldType] o
649		TVariantField,      { ftVariant }
650		TInterfaceField,    { ftInterface }
651		TIDispatchField,     { ftIDispatch }
652	<	TGuidField);        { ftGuid }
653	<	var
654	<	CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;
652	>	TGuidField);        { ftGuid } *)
653	>	(*var
654	>	CreateProviderProc: function(DataSet: TIBCustomDataSet): IProvider = nil;*)
655
656		implementation
657
658	<	uses IBIntf, IBQuery;
658	>	uses IBIntf, Variants, FmtBCD;
659	>
660	>	const FILE_BEGIN = 0;
661	>	FILE_CURRENT = 1;
662	>	FILE_END = 2;
663
664		type
665
#	Line 617 | Line 683 | type
683
684		constructor TIBStringField.Create(AOwner: TComponent);
685		begin
686	<	inherited;
686	>	inherited Create(AOwner);
687		end;
688
689		class procedure TIBStringField.CheckTypeSize(Value: Integer);
#	Line 714 | Line 780 | end;
780
781		function TIBBCDField.GetDataSize: Integer;
782		begin
783	+	{$IFDEF TBCDFIELD_IS_BCD}
784		Result := 8;
785	+	{$ELSE}
786	+	Result := inherited GetDataSize
787	+	{$ENDIF}
788		end;
789
790		{ TIBDataLink }
#	Line 728 | Line 798 | end;
798		destructor TIBDataLink.Destroy;
799		begin
800		FDataSet.FDataLink := nil;
801	<	inherited;
801	>	inherited Destroy;
802		end;
803
804
#	Line 760 | Line 830 | end;
830
831		constructor TIBCustomDataSet.Create(AOwner: TComponent);
832		begin
833	<	inherited;
833	>	inherited Create(AOwner);
834		FIBLoaded := False;
835		CheckIBLoaded;
836		FIBLoaded := True;
#	Line 770 | Line 840 | begin
840		FUniDirectional := False;
841		FBufferChunks := BufferCacheSize;
842		FBlobStreamList := TList.Create;
843	+	FGeneratorField := TIBGenerator.Create(self);
844		FDataLink := TIBDataLink.Create(Self);
845		FQDelete := TIBSQL.Create(Self);
846		FQDelete.OnSQLChanging := SQLChanging;
#	Line 806 | Line 877 | end;
877
878		destructor TIBCustomDataSet.Destroy;
879		begin
880	<	inherited;
880	>	if Active then Active := false;
881		if FIBLoaded then
882		begin
883	+	if assigned(FGeneratorField) then FGeneratorField.Free;
884		FDataLink.Free;
885		FBase.Free;
886		ClearBlobCache;
#	Line 821 | Line 893 | begin
893		FOldCacheSize := 0;
894		FMappedFieldPosition := nil;
895		end;
896	+	inherited Destroy;
897		end;
898
899		function TIBCustomDataSet.AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode):
#	Line 861 | Line 934 | end;
934
935		procedure TIBCustomDataSet.ApplyUpdates;
936		var
937	+	{$IF FPC_FULLVERSION > 20602 }
938	+	CurBookmark: TBookmark;
939	+	{$ELSE}
940		CurBookmark: string;
941	+	{$ENDIF}
942		Buffer: PRecordData;
943		CurUpdateTypes: TIBUpdateRecordTypes;
944		UpdateAction: TIBUpdateAction;
#	Line 921 | Line 998 | var
998		procedure UpdateUsingUpdateObject;
999		begin
1000		try
1001	<	FUpdateObject.Apply(UpdateKind);
1001	>	FUpdateObject.Apply(UpdateKind,PChar(Buffer));
1002		ResetBufferUpdateStatus;
1003		except
1004		on E: Exception do
#	Line 1266 | Line 1343 | var
1343		LocalInt64: Int64;
1344		LocalCurrency: Currency;
1345		FieldsLoaded: Integer;
1346	+	temp: TIBXSQLVAR;
1347		begin
1348		p := PRecordData(Buffer);
1349		{ Make sure blob cache is empty }
#	Line 1399 | Line 1477 | begin
1477		if (rdFields[j].fdDataLength = 0) then
1478		LocalData := nil
1479		else
1480	<	LocalData := @Qry.Current[i].Data^.sqldata[2];
1480	>	begin
1481	>	temp :=  Qry.Current[i];
1482	>	LocalData := @temp.Data^.sqldata[2];
1483	>	(*              LocalData := @Qry.Current[i].Data^.sqldata[2];*)
1484	>	end;
1485		end;
1486		end;
1487		else { SQL_TEXT, SQL_BLOB, SQL_ARRAY, SQL_QUAD }
#	Line 1526 | Line 1608 | end;
1608		procedure TIBCustomDataSet.InternalDeleteRecord(Qry: TIBSQL; Buff: Pointer);
1609		begin
1610		if (Assigned(FUpdateObject) and (FUpdateObject.GetSQL(ukDelete).Text <> '')) then
1611	<	FUpdateObject.Apply(ukDelete)
1611	>	FUpdateObject.Apply(ukDelete,Buff)
1612		else
1613		begin
1614		SetInternalSQLParams(FQDelete, Buff);
#	Line 1543 | Line 1625 | end;
1625		function TIBCustomDataSet.InternalLocate(const KeyFields: string;
1626		const KeyValues: Variant; Options: TLocateOptions): Boolean;
1627		var
1628	<	fl: TList;
1628	>	keyFieldList: TList;
1629	>	{$IF FPC_FULLVERSION >  20602 }
1630	>	CurBookmark: TBookmark;
1631	>	{$ELSE}
1632		CurBookmark: string;
1633	<	fld, val: Variant;
1634	<	i, fld_cnt: Integer;
1633	>	{$ENDIF}
1634	>	fieldValue: Variant;
1635	>	lookupValues: array of variant;
1636	>	i, fieldCount: Integer;
1637	>	fieldValueAsString: string;
1638	>	lookupValueAsString: string;
1639		begin
1640	<	fl := TList.Create;
1640	>	keyFieldList := TList.Create;
1641		try
1642	<	GetFieldList(fl, KeyFields);
1643	<	fld_cnt := fl.Count;
1642	>	GetFieldList(keyFieldList, KeyFields);
1643	>	fieldCount := keyFieldList.Count;
1644		CurBookmark := Bookmark;
1645	<	result := False;
1646	<	while ((not result) and (not EOF)) do
1645	>	result := false;
1646	>	SetLength(lookupValues, fieldCount);
1647	>	if not EOF then
1648		begin
1649	<	i := 0;
1560	<	result := True;
1561	<	while (result and (i < fld_cnt)) do
1649	>	for i := 0 to fieldCount - 1 do  {expand key values into lookupValues array}
1650		begin
1651	<	if fld_cnt > 1 then
1652	<	val := KeyValues[i]
1651	>	if VarIsArray(KeyValues) then
1652	>	lookupValues[i] := KeyValues[i]
1653		else
1654	<	val := KeyValues;
1655	<	fld := TField(fl[i]).Value;
1656	<	result := not (VarIsNull(val) xor VarIsNull(fld));
1657	<	if result and not VarIsNull(val) then
1654	>	if i > 0 then
1655	>	lookupValues[i] := NULL
1656	>	else
1657	>	lookupValues[0] := KeyValues;
1658	>
1659	>	{convert to upper case is case insensitive search}
1660	>	if (TField(keyFieldList[i]).DataType = ftString) and
1661	>	not VarIsNull(lookupValues[i]) and (loCaseInsensitive in Options) then
1662	>	lookupValues[i] := UpperCase(lookupValues[i]);
1663	>	end;
1664	>	end;
1665	>	while not result and not EOF do   {search for a matching record}
1666	>	begin
1667	>	i := 0;
1668	>	result := true;
1669	>	while result and (i < fieldCount) do
1670	>	{see if all of the key fields matches}
1671	>	begin
1672	>	fieldValue := TField(keyFieldList[i]).Value;
1673	>	result := not (VarIsNull(fieldValue) xor VarIsNull(lookupValues[i]));
1674	>	if result and not VarIsNull(fieldValue) then
1675		begin
1676		try
1677	<	fld := VarAsType(fld, VarType(val));
1573	<	except
1574	<	on E: EVariantError do result := False;
1575	<	end;
1576	<	if Result then
1577	<	if TField(fl[i]).DataType = ftString then
1677	>	if TField(keyFieldList[i]).DataType = ftString then
1678		begin
1679	+	{strings need special handling because of the locate options that
1680	+	apply to them}
1681	+	fieldValueAsString := TField(keyFieldList[i]).AsString;
1682	+	lookupValueAsString := lookupValues[i];
1683		if (loCaseInsensitive in Options) then
1684	<	begin
1685	<	fld := AnsiUpperCase(fld);
1582	<	val := AnsiUpperCase(val);
1583	<	end;
1584	<	fld := TrimRight(fld);
1585	<	val := TrimRight(val);
1684	>	fieldValueAsString := UpperCase(fieldValueAsString);
1685	>
1686		if (loPartialKey in Options) then
1687	<	result := result and (AnsiPos(val, fld) = 1)
1687	>	result := result and (Pos(lookupValueAsString, fieldValueAsString) = 1)
1688		else
1689	<	result := result and (val = fld);
1690	<	end else
1691	<	result := result and (val = fld);
1689	>	result := result and (fieldValueAsString = lookupValueAsString);
1690	>	end
1691	>	else
1692	>	result := result and (lookupValues[i] =
1693	>	VarAsType(fieldValue, VarType(lookupValues[i])));
1694	>	except on EVariantError do
1695	>	result := False;
1696	>	end;
1697		end;
1698		Inc(i);
1699		end;
1700		if not result then
1701	<	Next;
1701	>	Next;
1702		end;
1703		if not result then
1704		Bookmark := CurBookmark
1705		else
1706		CursorPosChanged;
1707		finally
1708	<	fl.Free;
1708	>	keyFieldList.Free;
1709	>	SetLength(lookupValues,0)
1710		end;
1711		end;
1712
#	Line 1628 | Line 1734 | begin
1734		if Assigned(FUpdateObject) then
1735		begin
1736		if (Qry = FQDelete) then
1737	<	FUpdateObject.Apply(ukDelete)
1737	>	FUpdateObject.Apply(ukDelete,Buff)
1738		else if (Qry = FQInsert) then
1739	<	FUpdateObject.Apply(ukInsert)
1739	>	FUpdateObject.Apply(ukInsert,Buff)
1740		else
1741	<	FUpdateObject.Apply(ukModify);
1741	>	FUpdateObject.Apply(ukModify,Buff);
1742		end
1743		else begin
1744		SetInternalSQLParams(Qry, Buff);
#	Line 1792 | Line 1898 | begin
1898		FQSelect.ParamCheck := ParamCheck;
1899		FQSelect.Prepare;
1900		end;
1901	<	if (FQDelete.SQL.Text <> '') and (not FQDelete.Prepared) then
1901	>	if (Trim(FQDelete.SQL.Text) <> '') and (not FQDelete.Prepared) then
1902		FQDelete.Prepare;
1903	<	if (FQInsert.SQL.Text <> '') and (not FQInsert.Prepared) then
1903	>	if (Trim(FQInsert.SQL.Text) <> '') and (not FQInsert.Prepared) then
1904		FQInsert.Prepare;
1905	<	if (FQRefresh.SQL.Text <> '') and (not FQRefresh.Prepared) then
1905	>	if (Trim(FQRefresh.SQL.Text) <> '') and (not FQRefresh.Prepared) then
1906		FQRefresh.Prepare;
1907	<	if (FQModify.SQL.Text <> '') and (not FQModify.Prepared) then
1907	>	if (Trim(FQModify.SQL.Text) <> '') and (not FQModify.Prepared) then
1908		FQModify.Prepare;
1909		FInternalPrepared := True;
1910		InternalInitFieldDefs;
#	Line 1998 | Line 2104 | begin
2104		end;
2105		SQL_TIMESTAMP:
2106		Qry.Params[i].AsDateTime :=
2107	<	TimeStampToDateTime(
2002	<	MSecsToTimeStamp(PDouble(data)^));
2107	>	TimeStampToDateTime(MSecsToTimeStamp(trunc(PDouble(data)^)));
2108		end;
2109		end;
2110		end;
#	Line 2136 | Line 2241 | begin
2241		Result := Assigned( FQSelect ) and FQSelect.EOF;
2242		end;
2243
2244	+	function TIBCustomDataSet.ParamByName(ParamName: String): TIBXSQLVAR;
2245	+	begin
2246	+	ActivateConnection;
2247	+	ActivateTransaction;
2248	+	if not FInternalPrepared then
2249	+	InternalPrepare;
2250	+	Result := Params.ByName(ParamName);
2251	+	end;
2252	+
2253	+	{Beware: the parameter FCache is used as an identifier to determine which
2254	+	cache is being operated on and is not referenced in the computation.
2255	+	The result is an adjusted offset into the identified cache, either the
2256	+	Buffer Cache or the old Buffer Cache.}
2257	+
2258		function TIBCustomDataSet.AdjustPosition(FCache: PChar; Offset: DWORD;
2259	<	Origin: Integer): Integer;
2259	>	Origin: Integer): DWORD;
2260		var
2261		OldCacheSize: Integer;
2262		begin
#	Line 2174 | Line 2293 | procedure TIBCustomDataSet.ReadCache(FCa
2293		Buffer: PChar);
2294		var
2295		pCache: PChar;
2296	+	AdjustedOffset: DWORD;
2297		bOld: Boolean;
2298		begin
2299		bOld := (FCache = FOldBufferCache);
2300	<	pCache := PChar(AdjustPosition(FCache, Offset, Origin));
2300	>	AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
2301		if not bOld then
2302	<	pCache := FBufferCache + Integer(pCache)
2302	>	pCache := FBufferCache + AdjustedOffset
2303		else
2304	<	pCache := FOldBufferCache + Integer(pCache);
2304	>	pCache := FOldBufferCache + AdjustedOffset;
2305		Move(pCache^, Buffer^, DWORD(FRecordBufferSize));
2306		AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2307		end;
#	Line 2211 | Line 2331 | procedure TIBCustomDataSet.WriteCache(FC
2331		Buffer: PChar);
2332		var
2333		pCache: PChar;
2334	+	AdjustedOffset: DWORD;
2335		bOld: Boolean;
2336		dwEnd: DWORD;
2337		begin
2338		bOld := (FCache = FOldBufferCache);
2339	<	pCache := PChar(AdjustPosition(FCache, Offset, Origin));
2339	>	AdjustedOffset := AdjustPosition(FCache, Offset, Origin);
2340		if not bOld then
2341	<	pCache := FBufferCache + Integer(pCache)
2341	>	pCache := FBufferCache + AdjustedOffset
2342		else
2343	<	pCache := FOldBufferCache + Integer(pCache);
2343	>	pCache := FOldBufferCache + AdjustedOffset;
2344		Move(Buffer^, pCache^, FRecordBufferSize);
2345		dwEnd := AdjustPosition(FCache, FRecordBufferSize, FILE_CURRENT);
2346		if not bOld then
#	Line 2330 | Line 2451 | begin
2451		if FCachedUpdates and
2452		(Buff^.rdCachedUpdateStatus in [cusUnmodified]) then
2453		SaveOldBuffer(PChar(Buff));
2454	<	inherited;
2454	>	inherited DoBeforeDelete;
2455		end;
2456
2457		procedure TIBCustomDataSet.DoBeforeEdit;
#	Line 2344 | Line 2465 | begin
2465		if FCachedUpdates and (Buff^.rdCachedUpdateStatus in [cusUnmodified, cusInserted]) then
2466		SaveOldBuffer(PChar(Buff));
2467		CopyRecordBuffer(GetActiveBuf, FOldBuffer);
2468	<	inherited;
2468	>	inherited DoBeforeEdit;
2469		end;
2470
2471		procedure TIBCustomDataSet.DoBeforeInsert;
2472		begin
2473		if not CanInsert then
2474		IBError(ibxeCannotInsert, [nil]);
2475	<	inherited;
2475	>	inherited DoBeforeInsert;
2476	>	end;
2477	>
2478	>	procedure TIBCustomDataSet.DoAfterInsert;
2479	>	begin
2480	>	if GeneratorField.ApplyOnEvent = gaeOnNewRecord then
2481	>	GeneratorField.Apply;
2482	>	inherited DoAfterInsert;
2483	>	end;
2484	>
2485	>	procedure TIBCustomDataSet.DoBeforePost;
2486	>	begin
2487	>	inherited DoBeforePost;
2488	>	if (State = dsInsert) and
2489	>	(GeneratorField.ApplyOnEvent = gaeOnPostRecord) then
2490	>	GeneratorField.Apply
2491		end;
2492
2493		procedure TIBCustomDataSet.FetchAll;
2494		var
2495		SetCursor: Boolean;
2496	+	{$IF FPC_FULLVERSION >  20602 }
2497	+	CurBookmark: TBookmark;
2498	+	{$ELSE}
2499		CurBookmark: string;
2500	+	{$ENDIF}
2501		begin
2502		SetCursor := (GetCurrentThreadID = MainThreadID) and (Screen.Cursor = crDefault);
2503		if SetCursor then
#	Line 2441 | Line 2581 | begin
2581		result := False;
2582		Buff := GetActiveBuf;
2583		if (Buff = nil) or
2584	<	(not IsVisible(Buff)) then
2584	>	(not IsVisible(Buff)) or not assigned(Field.DataSet) then
2585		exit;
2586		{ The intention here is to stuff the buffer with the data for the
2587		referenced field for the current record }
#	Line 2463 | Line 2603 | begin
2603		Data := Buff + CurrentRecord^.rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs;
2604		if (fdDataType = SQL_VARYING) or (fdDataType = SQL_TEXT) then
2605		begin
2606	<	Move(Data^, Buffer^, fdDataLength);
2607	<	PChar(Buffer)[fdDataLength] := #0;
2606	>	if fdDataLength <= Field.Size then
2607	>	begin
2608	>	Move(Data^, Buffer^, fdDataLength);
2609	>	PChar(Buffer)[fdDataLength] := #0;
2610	>	end
2611	>	else
2612	>	IBError(ibxeFieldSizeError,[Field.FieldName])
2613		end
2614		else
2615		Move(Data^, Buffer^, Field.DataSize);
#	Line 2629 | Line 2774 | var
2774		Buff: PChar;
2775		CurRec: Integer;
2776		begin
2777	<	inherited;
2777	>	inherited InternalCancel;
2778		Buff := GetActiveBuf;
2779		if Buff <> nil then begin
2780		CurRec := FCurrentRecord;
#	Line 2902 | Line 3047 | begin
3047		FieldSize := -sqlscale;
3048		end
3049		else
3050	<	FieldType := ftFloat;
3050	>	if Database.SQLDialect = 1 then
3051	>	FieldType := ftFloat
3052	>	else
3053	>	if (FieldCount > i) and (Fields[i] is TFloatField) then
3054	>	FieldType := ftFloat
3055	>	else
3056	>	begin
3057	>	FieldType := ftFMTBCD;
3058	>	FieldPrecision := 9;
3059	>	FieldSize := -sqlscale;
3060		end;
3061	+	end;
3062	+
3063		SQL_INT64:
3064		begin
3065		if (sqlscale = 0) then
#	Line 2915 | Line 3071 | begin
3071		FieldSize := -sqlscale;
3072		end
3073		else
3074	<	FieldType := ftFloat;
3075	<	end;
3074	>	FieldType := ftFloat
3075	>	end;
3076		SQL_TIMESTAMP: FieldType := ftDateTime;
3077		SQL_TYPE_TIME: FieldType := ftTime;
3078		SQL_TYPE_DATE: FieldType := ftDate;
#	Line 2943 | Line 3099 | begin
3099		Inc(FieldIndex);
3100		with FieldDefs.AddFieldDef do
3101		begin
3102	<	Name := string( FieldAliasName );
3103	<	FieldNo := FieldPosition;
3102	>	Name := FieldAliasName;
3103	>	(*           FieldNo := FieldPosition;*)
3104		DataType := FieldType;
3105		Size := FieldSize;
3106		Precision := FieldPrecision;
3107	<	Required := False;
3107	>	Required := not FieldNullable;
3108		InternalCalcField := False;
3109		if (FieldName <> '') and (RelationName <> '') then
3110		begin
#	Line 3213 | Line 3369 | end;
3369
3370		procedure TIBCustomDataSet.InternalRefresh;
3371		begin
3372	<	inherited;
3372	>	inherited InternalRefresh;
3373		InternalRefreshRow;
3374		end;
3375
#	Line 3230 | Line 3386 | end;
3386		function TIBCustomDataSet.Locate(const KeyFields: string; const KeyValues: Variant;
3387		Options: TLocateOptions): Boolean;
3388		var
3389	+	{$IF FPC_FULLVERSION >  20602 }
3390	+	CurBookmark: TBookmark;
3391	+	{$ELSE}
3392		CurBookmark: string;
3393	+	{$ENDIF}
3394		begin
3395		DisableControls;
3396		try
#	Line 3248 | Line 3408 | function TIBCustomDataSet.Lookup(const K
3408		const ResultFields: string): Variant;
3409		var
3410		fl: TList;
3411	+	{$IF FPC_FULLVERSION >  20602 }
3412	+	CurBookmark: TBookmark;
3413	+	{$ELSE}
3414		CurBookmark: string;
3415	+	{$ENDIF}
3416		begin
3417		DisableControls;
3418		fl := TList.Create;
#	Line 3354 | Line 3518 | begin
3518		end;
3519		end;
3520		if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
3521	<	DataEvent(deFieldChange, Longint(Field));
3521	>	DataEvent(deFieldChange, PtrInt(Field));
3522		end;
3523
3524		procedure TIBCustomDataSet.SetRecNo(Value: Integer);
#	Line 3482 | Line 3646 | end;
3646
3647		{ TIBDataSet IProviderSupport }
3648
3649	<	procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
3649	>	(*procedure TIBCustomDataSet.PSEndTransaction(Commit: Boolean);
3650		begin
3651		if Commit then
3652		Transaction.Commit else
#	Line 3645 | Line 3809 | begin
3809		if not FQSelect.Prepared then
3810		FQSelect.Prepare;
3811		Result := FQSelect.UniqueRelationName;
3812	<	end;
3812	>	end;*)
3813
3814		procedure TIBDataSet.BatchInput(InputObject: TIBBatchInput);
3815		begin
#	Line 3682 | Line 3846 | begin
3846		ActivateConnection;
3847		ActivateTransaction;
3848		InternalSetParamsFromCursor;
3849	<	Inherited;
3849	>	Inherited InternalOpen;
3850		end;
3851
3852		procedure TIBDataSet.SetFiltered(Value: Boolean);
#	Line 3710 | Line 3874 | end;
3874
3875		function TIBCustomDataSet.GetFieldData(Field: TField;
3876		Buffer: Pointer): Boolean;
3877	+	{$IFDEF TBCDFIELD_IS_BCD}
3878		var
3879		lTempCurr : System.Currency;
3880		begin
#	Line 3720 | Line 3885 | begin
3885		CurrToBCD(lTempCurr, TBCD(Buffer^), 32, Field.Size);
3886		end
3887		else
3888	+	{$ELSE}
3889	+	begin
3890	+	{$ENDIF}
3891		Result := InternalGetFieldData(Field, Buffer);
3892		end;
3893
#	Line 3733 | Line 3901 | begin
3901		end;
3902
3903		procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
3904	+	{$IFDEF TDBDFIELD_IS_BCD}
3905		var
3906		lTempCurr : System.Currency;
3907		begin
3908	<	if Field.DataType = ftBCD then
3908	>	if (Field.DataType = ftBCD) and (Buffer <> nil) then
3909		begin
3910		BCDToCurr(TBCD(Buffer^), lTempCurr);
3911		InternalSetFieldData(Field, @lTempCurr);
3912		end
3913		else
3914	+	{$ELSE}
3915	+	begin
3916	+	{$ENDIF}
3917		InternalSetFieldData(Field, Buffer);
3918		end;
3919
#	Line 3765 | Line 3937 | end;
3937		destructor TIBDataSetUpdateObject.Destroy;
3938		begin
3939		FRefreshSQL.Free;
3940	<	inherited destroy;
3940	>	inherited Destroy;
3941		end;
3942
3943		procedure TIBDataSetUpdateObject.SetRefreshSQL(Value: TStrings);
#	Line 3773 | Line 3945 | begin
3945		FRefreshSQL.Assign(Value);
3946		end;
3947
3948	+	procedure TIBDataSetUpdateObject.InternalSetParams(Query: TIBSQL; buff: PChar);
3949	+	begin
3950	+	if not Assigned(DataSet) then Exit;
3951	+	DataSet.SetInternalSQLParams(Query, buff);
3952	+	end;
3953	+
3954		{ TIBDSBlobStream }
3955		constructor TIBDSBlobStream.Create(AField: TField; ABlobStream: TIBBlobStream;
3956		Mode: TBlobStreamMode);
#	Line 3804 | Line 3982 | begin
3982		if not (FField.DataSet.State in [dsEdit, dsInsert]) then
3983		IBError(ibxeNotEditing, [nil]);
3984		TIBCustomDataSet(FField.DataSet).RecordModified(True);
3985	+	TBlobField(FField).Modified := true;
3986		result := FBlobStream.Write(Buffer, Count);
3987	<	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, Longint(FField));
3987	>	TIBCustomDataSet(FField.DataSet).DataEvent(deFieldChange, PtrInt(FField));
3988	>	end;
3989	>
3990	>	{ TIBGenerator }
3991	>
3992	>	procedure TIBGenerator.SetIncrement(const AValue: integer);
3993	>	begin
3994	>	if AValue < 0 then
3995	>	raise Exception.Create('A Generator Increment cannot be negative');
3996	>	FIncrement := AValue
3997	>	end;
3998	>
3999	>	function TIBGenerator.GetNextValue(ADatabase: TIBDatabase;
4000	>	ATransaction: TIBTransaction): integer;
4001	>	begin
4002	>	with TIBSQL.Create(nil) do
4003	>	try
4004	>	Database := ADatabase;
4005	>	Transaction := ATransaction;
4006	>	if not assigned(Database) then
4007	>	IBError(ibxeCannotSetDatabase,[]);
4008	>	if not assigned(Transaction) then
4009	>	IBError(ibxeCannotSetTransaction,[]);
4010	>	with Transaction do
4011	>	if not InTransaction then StartTransaction;
4012	>	SQL.Text := Format('Select Gen_ID(%s,%d) as ID From RDB$Database',[FGeneratorName,Increment]);
4013	>	Prepare;
4014	>	ExecQuery;
4015	>	try
4016	>	Result := FieldByName('ID').AsInteger
4017	>	finally
4018	>	Close
4019	>	end;
4020	>	finally
4021	>	Free
4022	>	end;
4023	>	end;
4024	>
4025	>	constructor TIBGenerator.Create(Owner: TIBCustomDataSet);
4026	>	begin
4027	>	FOwner := Owner;
4028	>	FIncrement := 1;
4029	>	end;
4030	>
4031	>
4032	>	procedure TIBGenerator.Apply;
4033	>	begin
4034	>	if (FGeneratorName <> '') and (FFieldName <> '') and Owner.FieldByName(FFieldName).IsNull then
4035	>	Owner.FieldByName(FFieldName).AsInteger := GetNextValue(Owner.Database,Owner.Transaction);
4036		end;
4037
4038		end.

Diff Legend

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