ViewVC Help

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

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

Comparing ibx/trunk/runtime/IBSQL.pas (file contents):
Revision 19 by tony, Mon Jul 7 13:00:15 2014 UTC vs.
Revision 43 by tony, Thu Sep 22 17:10:15 2016 UTC

#	Line 35 | Line 35 | unit IBSQL;
35
36		{$Mode Delphi}
37
38	+	{$IF FPC_FULLVERSION >= 20700 }
39	+	{$codepage UTF8}
40	+	{$DEFINE HAS_ANSISTRING_CODEPAGE}
41	+	{$ENDIF}
42	+
43		{ IBSQL param names in dialect 3 quoted format (e.g. :"MyParam") are by default disabled.
44
45		Dialect 3 quoted format parameter names represent a significant overhead and are of
#	Line 76 | Line 81 | uses
81		{$ELSE}
82		baseunix, unix,
83		{$ENDIF}
84	<	SysUtils, Classes, Forms, Controls, IBHeader,
84	>	SysUtils, Classes, IBHeader,
85		IBErrorCodes, IBExternals, DB, IB, IBDatabase, IBUtils, IBXConst;
86
87	+	const
88	+	sSQLErrorSeparator = ' When Executing: ';
89	+
90		type
91		TIBSQL = class;
92		TIBXSQLDA = class;
#	Line 89 | Line 97 | type
97		FParent: TIBXSQLDA;
98		FSQL: TIBSQL;
99		FIndex: Integer;
100	+	FCharSetID: integer;
101		FModified: Boolean;
102		FName: String;
103		FUniqueName: boolean;
#	Line 97 | Line 106 | type
106		function AdjustScale(Value: Int64; Scale: Integer): Double;
107		function AdjustScaleToInt64(Value: Int64; Scale: Integer): Int64;
108		function AdjustScaleToCurrency(Value: Int64; Scale: Integer): Currency;
109	+	function GetAsBoolean: boolean;
110		function GetAsCurrency: Currency;
111		function GetAsInt64: Int64;
112		function GetAsDateTime: TDateTime;
#	Line 113 | Line 123 | type
123		function GetIsNullable: Boolean;
124		function GetSize: Integer;
125		function GetSQLType: Integer;
126	+	procedure SetAsBoolean(AValue: boolean);
127		procedure SetAsCurrency(Value: Currency);
128		procedure SetAsInt64(Value: Int64);
129		procedure SetAsDate(Value: TDateTime);
130	+	procedure SetAsLong(Value: Long);
131		procedure SetAsTime(Value: TDateTime);
132		procedure SetAsDateTime(Value: TDateTime);
133		procedure SetAsDouble(Value: Double);
134		procedure SetAsFloat(Value: Float);
123	–	procedure SetAsLong(Value: Long);
135		procedure SetAsPointer(Value: Pointer);
136		procedure SetAsQuad(Value: TISC_QUAD);
137		procedure SetAsShort(Value: Short);
#	Line 129 | Line 140 | type
140		procedure SetAsXSQLVAR(Value: PXSQLVAR);
141		procedure SetIsNull(Value: Boolean);
142		procedure SetIsNullable(Value: Boolean);
143	+	procedure xSetAsBoolean(AValue: boolean);
144		procedure xSetAsCurrency(Value: Currency);
145		procedure xSetAsInt64(Value: Int64);
146		procedure xSetAsDate(Value: TDateTime);
#	Line 149 | Line 161 | type
161		constructor Create(Parent: TIBXSQLDA; Query: TIBSQL);
162		procedure Assign(Source: TIBXSQLVAR);
163		procedure Clear;
164	+	function GetCharSetID: integer;
165	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
166	+	function GetCodePage: TSystemCodePage;
167	+	{$ENDIF}
168		procedure LoadFromFile(const FileName: String);
169		procedure LoadFromStream(Stream: TStream);
170		procedure SaveToFile(const FileName: String);
171		procedure SaveToStream(Stream: TStream);
172		property AsDate: TDateTime read GetAsDateTime write SetAsDate;
173	+	property AsBoolean:boolean read GetAsBoolean write SetAsBoolean;
174		property AsTime: TDateTime read GetAsDateTime write SetAsTime;
175		property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
176		property AsDouble: Double read GetAsDouble write SetAsDouble;
#	Line 321 | Line 338 | type
338		TIBSQL = class(TComponent)
339		private
340		FIBLoaded: Boolean;
341	+	FOnSQLChanged: TNotifyEvent;
342		FUniqueParamNames: Boolean;
343		function GetFieldCount: integer;
344		procedure SetUniqueParamNames(AValue: Boolean);
#	Line 359 | Line 377 | type
377		procedure SetSQL(Value: TStrings);
378		procedure SetTransaction(Value: TIBTransaction);
379		procedure SQLChanging(Sender: TObject);
380	<	procedure BeforeTransactionEnd(Sender: TObject);
380	>	procedure SQLChanged(Sender: TObject);
381	>	procedure BeforeTransactionEnd(Sender: TObject; Action: TTransactionAction);
382		public
383		constructor Create(AOwner: TComponent); override;
384		destructor Destroy; override;
#	Line 405 | Line 424 | type
424		property SQL: TStrings read FSQL write SetSQL;
425		property Transaction: TIBTransaction read GetTransaction write SetTransaction;
426		property OnSQLChanging: TNotifyEvent read FOnSQLChanging write FOnSQLChanging;
427	+	property OnSQLChanged: TNotifyEvent read FOnSQLChanged write FOnSQLChanged;
428		end;
429
430		implementation
431
432		uses
433	<	IBIntf, IBBlob, Variants , IBSQLMonitor;
433	>	IBIntf, IBBlob, Variants , IBSQLMonitor, IBCodePage;
434
435		{ TIBXSQLVAR }
436		constructor TIBXSQLVAR.Create(Parent: TIBXSQLDA; Query: TIBSQL);
#	Line 585 | Line 605 | begin
605		result := Value;
606		end;
607
608	+	function TIBXSQLVAR.GetAsBoolean: boolean;
609	+	begin
610	+	result := false;
611	+	if not IsNull then
612	+	begin
613	+	if FXSQLVAR^.sqltype and (not 1) = SQL_BOOLEAN then
614	+	result := PByte(FXSQLVAR^.sqldata)^ = ISC_TRUE
615	+	else
616	+	IBError(ibxeInvalidDataConversion, [nil]);
617	+	end
618	+	end;
619	+
620		function TIBXSQLVAR.GetAsCurrency: Currency;
621		begin
622		result := 0;
#	Line 815 | Line 847 | var
847		sz: PChar;
848		str_len: Integer;
849		ss: TStringStream;
850	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
851	+	rs: RawByteString;
852	+	{$ENDIF}
853		begin
854		result := '';
855		{ Check null, if so return a default string }
#	Line 826 | Line 861 | begin
861		ss := TStringStream.Create('');
862		try
863		SaveToStream(ss);
864	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
865	+	rs := ss.DataString;
866	+	SetCodePage(rs,GetCodePage,false);
867	+	result := rs;
868	+	{$ELSE}
869		result := ss.DataString;
870	+	{$ENDIF}
871		finally
872		ss.Free;
873		end;
#	Line 839 | Line 880 | begin
880		str_len := isc_vax_integer(FXSQLVar^.sqldata, 2);
881		Inc(sz, 2);
882		end;
883	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
884	+	SetString(rs, sz, str_len);
885	+	SetCodePage(rs,GetCodePage,false);
886	+	result := rs;
887	+	{$ELSE}
888		SetString(result, sz, str_len);
889	+	{$ENDIF}
890		if ((FXSQLVar^.sqltype and (not 1)) = SQL_TEXT) then
891		result := TrimRight(result);
892		end;
#	Line 896 | Line 943 | begin
943		result := AsDouble;
944		SQL_INT64:
945		if FXSQLVAR^.sqlscale = 0 then
946	<	IBError(ibxeInvalidDataConversion, [nil])
946	>	result := AsInt64
947		else if FXSQLVAR^.sqlscale >= (-4) then
948		result := AsCurrency
949		else
950		result := AsDouble;
951		SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
952		result := AsDouble;
953	+	SQL_BOOLEAN:
954	+	result := AsBoolean;
955		else
956		IBError(ibxeInvalidDataConversion, [nil]);
957		end;
#	Line 991 | Line 1040 | begin
1040		result := FXSQLVAR^.sqltype and (not 1);
1041		end;
1042
1043	+	procedure TIBXSQLVAR.SetAsBoolean(AValue: boolean);
1044	+	var
1045	+	i: Integer;
1046	+	begin
1047	+	if FUniqueName then
1048	+	xSetAsBoolean(AValue)
1049	+	else
1050	+	for i := 0 to FParent.FCount - 1 do
1051	+	if FParent[i].FName = FName then
1052	+	FParent[i].xSetAsBoolean(AValue);
1053	+	end;
1054	+
1055		procedure TIBXSQLVAR.xSetAsCurrency(Value: Currency);
1056		begin
1057		if IsNullable then
#	Line 1341 | Line 1402 | var
1402		end;
1403		FModified := True;
1404		end;
1405	<
1405	>	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1406	>	var rs: RawByteString;
1407	>	codepage: TSystemCodePage;
1408	>	{$ENDIF}
1409		begin
1410		if IsNullable then
1411		IsNull := False;
1412
1413		stype := FXSQLVAR^.sqltype and (not 1);
1414	+
1415	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1416	+	codepage := GetCodePage;
1417	+	if (codepage <> CP_NONE) and (StringCodePage(Value) <> codepage) then
1418	+	begin
1419	+	rs := Value;
1420	+	SetCodePage(rs,codepage,true);
1421	+	Value := rs;
1422	+	end;
1423	+	{$ENDIF}
1424	+
1425		if (stype = SQL_TEXT) or (stype = SQL_VARYING) then
1426		SetStringValue
1427		else begin
#	Line 1398 | Line 1473 | begin
1473		varCurrency:
1474		AsCurrency := Value;
1475		varBoolean:
1476	<	if Value then
1402	<	AsLong := ISC_TRUE
1403	<	else
1404	<	AsLong := ISC_FALSE;
1476	>	AsBoolean := Value;
1477		varDate:
1478		AsDateTime := Value;
1479		varOleStr, varString:
#	Line 1528 | Line 1600 | begin
1600		FParent[i].xSetIsNullable(Value);
1601		end;
1602
1603	+	procedure TIBXSQLVAR.xSetAsBoolean(AValue: boolean);
1604	+	begin
1605	+	if IsNullable then
1606	+	IsNull := False;
1607	+
1608	+	FXSQLVAR^.sqltype := SQL_BOOLEAN;
1609	+	FXSQLVAR^.sqllen := 1;
1610	+	FXSQLVAR^.sqlscale := 0;
1611	+	IBAlloc(FXSQLVAR^.sqldata, 0, FXSQLVAR^.sqllen);
1612	+	if AValue then
1613	+	PByte(FXSQLVAR^.sqldata)^ := ISC_TRUE
1614	+	else
1615	+	PByte(FXSQLVAR^.sqldata)^ := ISC_FALSE;
1616	+	FModified := True;
1617	+	end;
1618	+
1619		procedure TIBXSQLVAR.Clear;
1620		begin
1621		IsNull := true;
1622		end;
1623
1624	+	function TIBXSQLVAR.GetCharSetID: integer;
1625	+	var stype: Integer;
1626	+	begin
1627	+	if FCharSetID = -1 then
1628	+	begin
1629	+	FCharSetID := 0;
1630	+	stype := FXSQLVAR^.sqltype and (not 1);
1631	+	case stype of
1632	+	SQL_TEXT,SQL_VARYING:
1633	+	FCharSetID := FXSQLVAR^.sqlsubtype and $FF;
1634	+
1635	+	SQL_BLOB:
1636	+	if (FXSQLVAR^.sqlsubtype = 1) and (strpas(FXSQLVAR^.relname) <> '') and
1637	+	(strpas(FXSQLVAR^.sqlname) <> '') then
1638	+	FCharSetID := GetBlobCharSetID(FParent.FSQL.Database.Handle,FParent.FSQL.Transaction.Handle,
1639	+	@(FXSQLVAR^.relname),@(FXSQLVAR^.sqlname));
1640	+	end;
1641	+
1642	+	if (FCharSetID > 1) and (FParent.FSQL.Database.DefaultCharSetName <> '')
1643	+	and (FParent.FSQL.Database.DefaultCharSetID > 1) then
1644	+	FCharSetID := FParent.FSQL.Database.DefaultCharSetID;
1645	+	end;
1646	+	Result := FCharSetID;
1647	+	end;
1648	+
1649	+	{$IFDEF HAS_ANSISTRING_CODEPAGE}
1650	+	function TIBXSQLVAR.GetCodePage: TSystemCodePage;
1651	+	begin
1652	+	TFirebirdCharacterSets.CharSetID2CodePage(GetCharSetID,Result);
1653	+	end;
1654	+	{$ENDIF}
1655	+
1656
1657		{ TIBXSQLDA }
1658		constructor TIBXSQLDA.Create(Query: TIBSQL; sqldaType: TIBXSQLDAType);
#	Line 1663 | Line 1783 | begin
1783		begin
1784		for i := 0 to FCount - 1 do
1785		begin
1786	+	FXSQLVARs[i].FCharSetID := -1;
1787		with FXSQLVARs[i].Data^ do
1788		begin
1789
#	Line 1721 | Line 1842 | begin
1842
1843		case sqltype and (not 1) of
1844		SQL_TEXT, SQL_TYPE_DATE, SQL_TYPE_TIME, SQL_TIMESTAMP,
1845	<	SQL_BLOB, SQL_ARRAY, SQL_QUAD, SQL_SHORT,
1845	>	SQL_BLOB, SQL_ARRAY, SQL_QUAD, SQL_SHORT, SQL_BOOLEAN,
1846		SQL_LONG, SQL_INT64, SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: begin
1847		if (sqllen = 0) then
1848		{ Make sure you get a valid pointer anyway
#	Line 2091 | Line 2212 | end;
2212
2213		{ TIBSQL }
2214		constructor TIBSQL.Create(AOwner: TComponent);
2215	+	var  GUID : TGUID;
2216		begin
2217		inherited Create(AOwner);
2218		FIBLoaded := False;
#	Line 2107 | Line 2229 | begin
2229		FRecordCount := 0;
2230		FSQL := TStringList.Create;
2231		TStringList(FSQL).OnChanging := SQLChanging;
2232	+	TStringList(FSQL).OnChange := SQLChanged;
2233		FProcessedSQL := TStringList.Create;
2234		FHandle := nil;
2235		FSQLParams := TIBXSQLDA.Create(self,daInput);
2236		FSQLRecord := TIBXSQLDA.Create(self,daOutput);
2237		FSQLType := SQLUnknown;
2238		FParamCheck := True;
2239	<	FCursor := Name + RandomString(8);
2239	>	CreateGuid(GUID);
2240	>	FCursor := GUIDToString(GUID);
2241		if AOwner is TIBDatabase then
2242		Database := TIBDatabase(AOwner)
2243		else
#	Line 2265 | Line 2389 | begin
2389		FBOF := True;
2390		FEOF := False;
2391		FRecordCount := 0;
2392	+	if not (csDesigning in ComponentState) then
2393	+	MonitorHook.SQLExecute(Self);
2394		if FGoToFirstRecordOnExecute then
2395		Next;
2396		end;
#	Line 2275 | Line 2401 | begin
2401		Database.SQLDialect,
2402		FSQLParams.AsXSQLDA,
2403		FSQLRecord.AsXSQLDA), True);
2404	+	if not (csDesigning in ComponentState) then
2405	+	MonitorHook.SQLExecute(Self);
2406		(*      if (fetch_res <> 0) and (fetch_res <> isc_deadlock) then
2407		begin
2408		{ Sometimes a prepared stored procedure appears to get
#	Line 2297 | Line 2425 | begin
2425		TRHandle,
2426		@FHandle,
2427		Database.SQLDialect,
2428	<	FSQLParams.AsXSQLDA), True)
2428	>	FSQLParams.AsXSQLDA), True);
2429	>	if not (csDesigning in ComponentState) then
2430	>	MonitorHook.SQLExecute(Self);
2431		end;
2432	<	if not (csDesigning in ComponentState) then
2433	<	MonitorHook.SQLExecute(Self);
2432	>	FBase.DoAfterExecQuery(self);
2433	>	//  writeln('Rows Affected = ',RowsAffected);
2434		end;
2435
2436		function TIBSQL.GetEOF: Boolean;
#	Line 2412 | Line 2542 | begin
2542		SQLUpdate, SQLDelete])) then
2543		result := ''
2544		else begin
2545	<	info_request := Char(isc_info_sql_get_plan);
2545	>	info_request := isc_info_sql_get_plan;
2546		Call(isc_dsql_sql_info(StatusVector, @FHandle, 2, @info_request,
2547		SizeOf(result_buffer), result_buffer), True);
2548	<	if (result_buffer[0] <> Char(isc_info_sql_get_plan)) then
2548	>	if (result_buffer[0] <> isc_info_sql_get_plan) then
2549		IBError(ibxeUnknownError, [nil]);
2550		result_length := isc_vax_integer(@result_buffer[1], 2);
2551		SetString(result, nil, result_length);
#	Line 2432 | Line 2562 | end;
2562
2563		function TIBSQL.GetRowsAffected: Integer;
2564		var
2435	–	result_buffer: array[0..1048] of Char;
2565		info_request: Char;
2566	+	RB: TResultBuffer;
2567		begin
2568		if not Prepared then
2569		result := -1
2570		else begin
2571	<	info_request := Char(isc_info_sql_records);
2572	<	if isc_dsql_sql_info(StatusVector, @FHandle, 1, @info_request,
2573	<	SizeOf(result_buffer), result_buffer) > 0 then
2574	<	IBDatabaseError;
2575	<	if (result_buffer[0] <> Char(isc_info_sql_records)) then
2576	<	result := -1
2577	<	else
2578	<	case SQLType of
2579	<	SQLUpdate:   Result := isc_vax_integer(@result_buffer[6], 4);
2580	<	SQLDelete:   Result := isc_vax_integer(@result_buffer[13], 4);
2581	<	SQLInsert:   Result := isc_vax_integer(@result_buffer[27], 4);
2582	<	else         Result := -1 ;
2583	<	end ;
2571	>	RB := TResultBuffer.Create;
2572	>	try
2573	>	info_request := isc_info_sql_records;
2574	>	if isc_dsql_sql_info(StatusVector, @FHandle, 1, @info_request,
2575	>	RB.Size, RB.buffer) > 0 then
2576	>	IBDatabaseError;
2577	>	case SQLType of
2578	>	SQLInsert, SQLUpdate: {Covers Insert or Update as well as individual update}
2579	>	Result := RB.GetValue(isc_info_sql_records, isc_info_req_insert_count)+
2580	>	RB.GetValue(isc_info_sql_records, isc_info_req_update_count);
2581	>	SQLDelete:
2582	>	Result := RB.GetValue(isc_info_sql_records, isc_info_req_delete_count);
2583	>	SQLExecProcedure:
2584	>	Result :=  RB.GetValue(isc_info_sql_records, isc_info_req_insert_count) +
2585	>	RB.GetValue(isc_info_sql_records, isc_info_req_update_count) +
2586	>	RB.GetValue(isc_info_sql_records, isc_info_req_delete_count);
2587	>	else
2588	>	Result := 0;
2589	>	end;
2590	>	finally
2591	>	RB.Free;
2592	>	end;
2593		end;
2594		end;
2595
#	Line 2502 | Line 2641 | const
2641		end;
2642
2643		begin
2644	+	sParamName := '';
2645		slNames := TStringList.Create;
2646		try
2647		{ Do some initializations of variables }
#	Line 2662 | Line 2802 | begin
2802		{ After preparing the statement, query the stmt type and possibly
2803		create a FSQLRecord "holder" }
2804		{ Get the type of the statement }
2805	<	type_item := Char(isc_info_sql_stmt_type);
2805	>	type_item := isc_info_sql_stmt_type;
2806		Call(isc_dsql_sql_info(StatusVector, @FHandle, 1, @type_item,
2807		SizeOf(res_buffer), res_buffer), True);
2808	<	if (res_buffer[0] <> Char(isc_info_sql_stmt_type)) then
2808	>	if (res_buffer[0] <> isc_info_sql_stmt_type) then
2809		IBError(ibxeUnknownError, [nil]);
2810		stmt_len := isc_vax_integer(@res_buffer[1], 2);
2811		FSQLType := TIBSQLTypes(isc_vax_integer(@res_buffer[3], stmt_len));
#	Line 2710 | Line 2850 | begin
2850		on E: Exception do begin
2851		if (FHandle <> nil) then
2852		FreeHandle;
2853	<	raise;
2853	>	if E is EIBInterBaseError then
2854	>	raise EIBInterBaseError.Create(EIBInterBaseError(E).SQLCode,
2855	>	EIBInterBaseError(E).IBErrorCode,
2856	>	EIBInterBaseError(E).Message +
2857	>	sSQLErrorSeparator + FProcessedSQL.Text)
2858	>	else
2859	>	raise;
2860		end;
2861		end;
2862		end;
#	Line 2748 | Line 2894 | begin
2894		if FHandle <> nil then FreeHandle;
2895		end;
2896
2897	<	procedure TIBSQL.BeforeTransactionEnd(Sender: TObject);
2897	>	procedure TIBSQL.SQLChanged(Sender: TObject);
2898	>	begin
2899	>	if assigned(OnSQLChanged) then
2900	>	OnSQLChanged(self);
2901	>	end;
2902	>
2903	>	procedure TIBSQL.BeforeTransactionEnd(Sender: TObject;
2904	>	Action: TTransactionAction);
2905		begin
2906		if (FOpen) then
2907		Close;

Diff Legend

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