ViewVC Help

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

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

Comparing ibx/trunk/runtime/IBStoredProc.pas (file contents):
Revision 27 by tony, Tue Apr 14 13:10:23 2015 UTC vs.
Revision 107 by tony, Thu Jan 18 14:37:40 2018 UTC

#	Line 1 | Line 1
1	<	{************************************************************************}
2	<	{                                                                        }
3	<	{       Borland Delphi Visual Component Library                          }
4	<	{       InterBase Express core components                                }
5	<	{                                                                        }
6	<	{       Copyright (c) 1998-2000 Inprise Corporation                      }
7	<	{                                                                        }
8	<	{    InterBase Express is based in part on the product                   }
9	<	{    Free IB Components, written by Gregory H. Deatz for                 }
10	<	{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11	<	{    Free IB Components is used under license.                           }
12	<	{                                                                        }
13	<	{    The contents of this file are subject to the InterBase              }
14	<	{    Public License Version 1.0 (the "License"); you may not             }
15	<	{    use this file except in compliance with the License. You            }
16	<	{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	<	{    Software distributed under the License is distributed on            }
18	<	{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19	<	{    express or implied. See the License for the specific language       }
20	<	{    governing rights and limitations under the License.                 }
21	<	{    The Original Code was created by InterBase Software Corporation     }
22	<	{       and its successors.                                              }
23	<	{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
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 IBStoredProc;
35	<
36	<	{$Mode Delphi}
37	<
38	<	interface
39	<
40	<	uses SysUtils, Classes, DB, IB, IBDatabase, IBCustomDataSet,
41	<	IBHeader, IBSQL, IBUtils;
42	<
43	<	{ TIBStoredProc }
44	<	type
45	<
46	<	TIBStoredProc = class(TIBCustomDataSet)
47	<	private
48	<	FIBLoaded: Boolean;
49	<	FStmtHandle: TISC_STMT_HANDLE;
50	<	FProcName: string;
51	<	FParams: TParams;
52	<	FPrepared: Boolean;
53	<	FNameList: TStrings;
54	<	procedure SetParamsList(Value: TParams);
55	<	procedure FreeStatement;
56	<	function GetStoredProcedureNames: TStrings;
57	<	procedure GetStoredProcedureNamesFromServer;
58	<	procedure CreateParamDesc;
59	<	procedure SetParams;
60	<	procedure SetParamsFromCursor;
61	<	procedure GenerateSQL;
62	<	procedure FetchDataIntoOutputParams;
63	<	procedure ReadParamData(Reader: TReader);
64	<	procedure WriteParamData(Writer: TWriter);
65	<
66	<	protected
67	<
68	<	procedure DefineProperties(Filer: TFiler); override;
69	<	procedure SetFiltered(Value: Boolean); override;
70	<	procedure InitFieldDefs; override;
71	<	function GetParamsCount: Word;
72	<	procedure SetPrepared(Value: Boolean);
73	<	procedure SetPrepare(Value: Boolean);
74	<	procedure SetProcName(Value: string);
75	<	procedure Disconnect; override;
76	<	procedure InternalOpen; override;
77	<
78	<	public
79	<	constructor Create(AOwner: TComponent); override;
80	<	destructor Destroy; override;
81	<	procedure CopyParams(Value: TParams);
82	<	procedure ExecProc;
83	<	function ParamByName(const Value: string): TParam;
84	<	procedure Prepare;
85	<	procedure UnPrepare;
86	<	property ParamCount: Word read GetParamsCount;
87	<	property StmtHandle: TISC_STMT_HANDLE read FStmtHandle;
88	<	property Prepared: Boolean read FPrepared write SetPrepare;
89	<	property StoredProcedureNames: TStrings read GetStoredProcedureNames;
90	<
91	<	published
92	<	property StoredProcName: string read FProcName write SetProcName;
93	<	property Params: TParams read FParams write SetParamsList;
94	<	property Filtered;
95	<
96	<	property BeforeDatabaseDisconnect;
97	<	property AfterDatabaseDisconnect;
98	<	property DatabaseFree;
99	<	property BeforeTransactionEnd;
100	<	property AfterTransactionEnd;
101	<	property TransactionFree;
102	<	property OnFilterRecord;
103	<	end;
104	<
105	<	implementation
106	<
107	<	uses
108	<	IBIntf;
109	<
110	<	{ TIBStoredProc }
111	<
112	<	constructor TIBStoredProc.Create(AOwner: TComponent);
113	<	begin
114	<	inherited Create(AOwner);
115	<	FIBLoaded := False;
116	<	CheckIBLoaded;
117	<	FIBLoaded := True;
118	<	FParams := TParams.Create (self);
119	<	FNameList := TStringList.Create;
120	<	end;
121	<
122	<	destructor TIBStoredProc.Destroy;
123	<	begin
124	<	if FIBLoaded then
125	<	begin
126	<	Destroying;
127	<	Disconnect;
128	<	FParams.Free;
129	<	FNameList.Destroy;
130	<	end;
131	<	inherited Destroy;
132	<	end;
133	<
134	<	procedure TIBStoredProc.Disconnect;
135	<	begin
136	<	Close;
137	<	UnPrepare;
138	<	end;
139	<
140	<	procedure TIBStoredProc.ExecProc;
141	<	var
142	<	DidActivate: Boolean;
143	<	begin
144	<	CheckInActive;
145	<	if StoredProcName = '' then
146	<	IBError(ibxeNoStoredProcName, [nil]);
147	<	ActivateConnection;
148	<	DidActivate := ActivateTransaction;
149	<	try
150	<	SetPrepared(True);
151	<	if DataSource <> nil then SetParamsFromCursor;
152	<	if FParams.Count > 0 then SetParams;
153	<	InternalExecQuery;
154	<	FetchDataIntoOutputParams;
155	<	finally
156	<	if DidActivate then
157	<	DeactivateTransaction;
158	<	end;
159	<	end;
160	<
161	<	procedure TIBStoredProc.SetProcName(Value: string);
162	<	begin
163	<	if not (csReading in ComponentState) then
164	<	begin
165	<	CheckInactive;
166	<	if Value <> FProcName then
167	<	begin
168	<	FProcName := Value;
169	<	FreeStatement;
170	<	FParams.Clear;
171	<	if (Value <> '') and
172	<	(Database <> nil) then
173	<	GenerateSQL;
174	<	end;
175	<	end else begin
176	<	FProcName := Value;
177	<	if (Value <> '') and
178	<	(Database <> nil) then
179	<	GenerateSQL;
180	<	end;
181	<	end;
182	<
183	<	function TIBStoredProc.GetParamsCount: Word;
184	<	begin
185	<	Result := FParams.Count;
186	<	end;
187	<
188	<	procedure TIBStoredProc.SetFiltered(Value: Boolean);
189	<	begin
190	<	if(Filtered <> Value) then
191	<	begin
192	<	inherited SetFiltered(value);
193	<	if Active then
194	<	begin
195	<	Close;
196	<	Open;
197	<	end;
198	<	end
199	<	else
200	<	inherited SetFiltered(value);
201	<	end;
202	<
203	<	procedure TIBStoredProc.InitFieldDefs;
204	<	begin
205	<	if SelectSQL.Text = '' then
206	<	GenerateSQL;
207	<	inherited InitFieldDefs;
208	<	end;
209	<
210	<	procedure TIBStoredProc.GenerateSQL;
211	<
212	<	var Params: TStringList;
213	<
214	<	function FormatParameter(Dialect: Integer; Value: String): String;
215	<	var j: integer;
216	<	begin
217	<	Value := Trim(Value);
218	<	if Dialect = 1 then
219	<	Result := AnsiUpperCase(Value)
220	<	else
221	<	begin
222	<	j := 1;
223	<	Value := Space2Underscore(AnsiUpperCase(Value));
224	<	Result := Value;
225	<	while Params.IndexOf(Result) <> -1 do
226	<	begin
227	<	Result := Value + IntToStr(j);
228	<	Inc(j)
229	<	end;
230	<	Params.Add(Result)
231	<	end;
232	<	end;
233	<
234	<	var
235	<	Query : TIBSQL;
236	<	input : string;
237	<	begin
238	<	input := '';
239	<	if FProcName = '' then
240	<	IBError(ibxeNoStoredProcName,[nil]);
241	<	ActivateConnection;
242	<	Database.InternalTransaction.StartTransaction;
243	<	Params := TStringList.Create;
244	<	Query := TIBSQL.Create(self);
245	<	try
246	<	Query.Database := DataBase;
247	<	Query.Transaction := Database.InternalTransaction;
248	<	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
249	<	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
250	<	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
251	<	'''' + FormatIdentifierValue(Database.SQLDialect, FProcName) + '''' +
252	<	' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
253	<	Query.Prepare;
254	<	Query.GoToFirstRecordOnExecute := False;
255	<	Query.ExecQuery;
256	<	while (not Query.EOF) and (Query.Next <> nil) do begin
257	<	if (Query.Current.ByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
258	<	if (input <> '') then
259	<	input := input + ', :' +
260	<	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
261	<	input := ':' +
262	<	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
263	<	end
264	<	end;
265	<	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
266	<	FormatParameter(Database.SQLDialect, FProcName) + ' ' + input;
267	<	{   writeln(SelectSQL.Text);}
268	<	finally
269	<	Query.Free;
270	<	Params.Free;
271	<	Database.InternalTransaction.Commit;
272	<	end;
273	<	end;
274	<
275	<	procedure TIBStoredProc.CreateParamDesc;
276	<	var
277	<	i : integer;
278	<	DataType : TFieldType;
279	<	begin
280	<	DataType := ftUnknown;
281	<	for i := 0 to QSelect.Current.Count - 1 do begin
282	<	case QSelect.Fields[i].SQLtype of
283	<	SQL_TYPE_DATE: DataType := ftDate;
284	<	SQL_TYPE_TIME: DataType := ftTime;
285	<	SQL_TIMESTAMP: DataType := ftDateTime;
286	<	SQL_SHORT:
287	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
288	<	DataType := ftSmallInt
289	<	else
290	<	DataType := ftBCD;
291	<	SQL_LONG:
292	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
293	<	DataType := ftInteger
294	<	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
295	<	DataType := ftBCD
296	<	else
297	<	DataType := ftFloat;
298	<	SQL_INT64:
299	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
300	<	DataType := ftLargeInt
301	<	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
302	<	DataType := ftBCD
303	<	else
304	<	DataType := ftFloat;
305	<	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
306	<	SQL_BOOLEAN:
307	<	DataType := ftBoolean;
308	<	SQL_TEXT: DataType := ftString;
309	<	SQL_VARYING:
310	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqllen < 1024) then
311	<	DataType := ftString
312	<	else DataType := ftBlob;
313	<	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
314	<	end;
315	<	FParams.CreateParam(DataType, Trim(QSelect.Fields[i].Name), ptOutput);
316	<	end;
317	<
318	<	DataType := ftUnknown;
319	<	for i := 0 to QSelect.Params.Count - 1 do begin
320	<	case QSelect.Params[i].SQLtype of
321	<	SQL_TYPE_DATE: DataType := ftDate;
322	<	SQL_TYPE_TIME: DataType := ftTime;
323	<	SQL_TIMESTAMP: DataType := ftDateTime;
324	<	SQL_SHORT:
325	<	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
326	<	DataType := ftSmallInt
327	<	else
328	<	DataType := ftBCD;
329	<	SQL_LONG:
330	<	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
331	<	DataType := ftInteger
332	<	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
333	<	DataType := ftBCD
334	<	else DataType := ftFloat;
335	<	SQL_INT64:
336	<	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
337	<	DataType := ftLargeInt
338	<	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
339	<	DataType := ftBCD
340	<	else DataType := ftFloat;
341	<	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
342	<	SQL_BOOLEAN:
343	<	DataType := ftBoolean;
344	<	SQL_TEXT: DataType := ftString;
345	<	SQL_VARYING:
346	<	if ((QSelect.Params[i].AsXSQLVar)^.sqllen < 1024) then
347	<	DataType := ftString
348	<	else DataType := ftBlob;
349	<	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
350	<	end;
351	<	FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
352	<	end;
353	<	end;
354	<
355	<	procedure TIBStoredProc.SetPrepared(Value: Boolean);
356	<	begin
357	<	if Prepared <> Value then
358	<	begin
359	<	if Value then
360	<	try
361	<	if SelectSQL.Text = '' then GenerateSQL;
362	<	InternalPrepare;
363	<	if FParams.Count = 0 then CreateParamDesc;
364	<	FPrepared := True;
365	<	except
366	<	FreeStatement;
367	<	raise;
368	<	end
369	<	else FreeStatement;
370	<	end;
371	<
372	<	end;
373	<
374	<	procedure TIBStoredProc.Prepare;
375	<	begin
376	<	SetPrepared(True);
377	<	end;
378	<
379	<	procedure TIBStoredProc.UnPrepare;
380	<	begin
381	<	SetPrepared(False);
382	<	end;
383	<
384	<	procedure TIBStoredProc.FreeStatement;
385	<	begin
386	<	InternalUnPrepare;
387	<	FPrepared := False;
388	<	end;
389	<
390	<	procedure TIBStoredProc.SetPrepare(Value: Boolean);
391	<	begin
392	<	if Value then Prepare
393	<	else UnPrepare;
394	<	end;
395	<
396	<	procedure TIBStoredProc.CopyParams(Value: TParams);
397	<	begin
398	<	if not Prepared and (FParams.Count = 0) then
399	<	try
400	<	Prepare;
401	<	Value.Assign(FParams);
402	<	finally
403	<	UnPrepare;
404	<	end else
405	<	Value.Assign(FParams);
406	<	end;
407	<
408	<	procedure TIBStoredProc.SetParamsList(Value: TParams);
409	<	begin
410	<	CheckInactive;
411	<	if Prepared then
412	<	begin
413	<	SetPrepared(False);
414	<	FParams.Assign(Value);
415	<	SetPrepared(True);
416	<	end else
417	<	FParams.Assign(Value);
418	<	end;
419	<
420	<	function TIBStoredProc.ParamByName(const Value: string): TParam;
421	<	begin
422	<	Prepare;
423	<	Result := FParams.ParamByName(Value);
424	<	end;
425	<
426	<	function TIBStoredProc.GetStoredProcedureNames: TStrings;
427	<	begin
428	<	FNameList.clear;
429	<	GetStoredProcedureNamesFromServer;
430	<	Result := FNameList;
431	<	end;
432	<
433	<	procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
434	<	var
435	<	Query : TIBSQL;
436	<	begin
437	<	if not (csReading in ComponentState) then begin
438	<	ActivateConnection;
439	<	Database.InternalTransaction.StartTransaction;
440	<	Query := TIBSQL.Create(self);
441	<	try
442	<	Query.GoToFirstRecordOnExecute := False;
443	<	Query.Database := DataBase;
444	<	Query.Transaction := Database.InternalTransaction;
445	<	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES'; {do not localize}
446	<	Query.Prepare;
447	<	Query.ExecQuery;
448	<	while (not Query.EOF) and (Query.Next <> nil) do
449	<	FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
450	<	finally
451	<	Query.Free;
452	<	Database.InternalTransaction.Commit;
453	<	end;
454	<	end;
455	<	end;
456	<
457	<	procedure TIBStoredProc.SetParams;
458	<	var
459	<	i : integer;
460	<	j: integer;
461	<	begin
462	<	i := 0;
463	<	for j := 0 to FParams.Count - 1 do
464	<	begin
465	<	if (Params[j].ParamType <> ptInput) then
466	<	continue;
467	<	if not Params[j].Bound then
468	<	IBError(ibxeRequiredParamNotSet, [Params[j].Name]);
469	<	if Params[j].IsNull then
470	<	SQLParams[i].IsNull := True
471	<	else begin
472	<	SQLParams[i].IsNull := False;
473	<	case Params[j].DataType of
474	<	ftString:
475	<	SQLParams[i].AsString := Params[j].AsString;
476	<	ftSmallint, ftWord:
477	<	SQLParams[i].AsShort := Params[j].AsSmallInt;
478	<	ftBoolean:
479	<	SQLParams[i].AsBoolean := Params[j].AsBoolean;
480	<	ftInteger:
481	<	SQLParams[i].AsLong := Params[j].AsInteger;
482	<	ftLargeInt:
483	<	SQLParams[i].AsInt64 := Params[j].AsLargeInt;
484	<	ftFloat, ftCurrency:
485	<	SQLParams[i].AsDouble := Params[j].AsFloat;
486	<	ftBCD:
487	<	SQLParams[i].AsCurrency := Params[j].AsCurrency;
488	<	ftDate:
489	<	SQLParams[i].AsDate := Params[j].AsDateTime;
490	<	ftTime:
491	<	SQLParams[i].AsTime := Params[j].AsDateTime;
492	<	ftDateTime:
493	<	SQLParams[i].AsDateTime := Params[j].AsDateTime;
494	<	ftBlob, ftMemo:
495	<	SQLParams[i].AsString := Params[j].AsString;
496	<	else
497	<	IBError(ibxeNotSupported, [nil]);
498	<	end;
499	<	end;
500	<	Inc(i);
501	<	end;
502	<	end;
503	<
504	<	procedure TIBStoredProc.SetParamsFromCursor;
505	<	var
506	<	I: Integer;
507	<	DataSet: TDataSet;
508	<	begin
509	<	if DataSource <> nil then
510	<	begin
511	<	DataSet := DataSource.DataSet;
512	<	if DataSet <> nil then
513	<	begin
514	<	DataSet.FieldDefs.Update;
515	<	for I := 0 to FParams.Count - 1 do
516	<	with FParams[I] do
517	<	if (not Bound) and
518	<	((ParamType = ptInput) or (ParamType =  ptInputOutput)) then
519	<	AssignField(DataSet.FieldByName(Name));
520	<	end;
521	<	end;
522	<	end;
523	<
524	<	procedure TIBStoredProc.FetchDataIntoOutputParams;
525	<	var
526	<	i,j : Integer;
527	<	begin
528	<	j := 0;
529	<	for i := 0 to FParams.Count - 1 do
530	<	with Params[I] do
531	<	if ParamType = ptOutput then begin
532	<	Value := QSelect.Fields[j].Value;
533	<	Inc(j);
534	<	end;
535	<	end;
536	<
537	<	procedure TIBStoredProc.InternalOpen;
538	<	begin
539	<	IBError(ibxeIsAExecuteProcedure,[nil]);
540	<	end;
541	<
542	<	procedure TIBStoredProc.DefineProperties(Filer: TFiler);
543	<
544	<	function WriteData: Boolean;
545	<	begin
546	<	if Filer.Ancestor <> nil then
547	<	Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
548	<	Result := FParams.Count > 0;
549	<	end;
550	<
551	<	begin
552	<	inherited DefineProperties(Filer);
553	<	Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
554	<	end;
555	<
556	<	procedure TIBStoredProc.WriteParamData(Writer: TWriter);
557	<	begin
558	<	Writer.WriteCollection(Params);
559	<	end;
560	<
561	<	procedure TIBStoredProc.ReadParamData(Reader: TReader);
562	<	begin
563	<	Reader.ReadValue;
564	<	Reader.ReadCollection(Params);
565	<	end;
566	<
567	<	end.
1	>	{************************************************************************}
2	>	{                                                                        }
3	>	{       Borland Delphi Visual Component Library                          }
4	>	{       InterBase Express core components                                }
5	>	{                                                                        }
6	>	{       Copyright (c) 1998-2000 Inprise Corporation                      }
7	>	{                                                                        }
8	>	{    InterBase Express is based in part on the product                   }
9	>	{    Free IB Components, written by Gregory H. Deatz for                 }
10	>	{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11	>	{    Free IB Components is used under license.                           }
12	>	{                                                                        }
13	>	{    The contents of this file are subject to the InterBase              }
14	>	{    Public License Version 1.0 (the "License"); you may not             }
15	>	{    use this file except in compliance with the License. You            }
16	>	{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	>	{    Software distributed under the License is distributed on            }
18	>	{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19	>	{    express or implied. See the License for the specific language       }
20	>	{    governing rights and limitations under the License.                 }
21	>	{    The Original Code was created by InterBase Software Corporation     }
22	>	{       and its successors.                                              }
23	>	{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
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 IBStoredProc;
35	>
36	>	{$Mode Delphi}
37	>
38	>	{$codepage UTF8}
39	>
40	>	interface
41	>
42	>	uses SysUtils, Classes, DB, IB, IBDatabase, IBCustomDataSet,
43	>	IBSQL, IBUtils;
44	>
45	>	{ TIBStoredProc }
46	>	type
47	>
48	>	TIBStoredProc = class(TIBCustomDataSet)
49	>	private
50	>	FPackageName: string;
51	>	FStmtHandle: IStatement;
52	>	FProcName: string;
53	>	FParams: TParams;
54	>	FPrepared: Boolean;
55	>	FNameList: TStrings;
56	>	FPackageNameList: TStrings;
57	>	function GetPackageNames: TStrings;
58	>	procedure GetPackageNamesFromServer;
59	>	procedure SetPackageName(AValue: string);
60	>	procedure SetParamsList(Value: TParams);
61	>	procedure FreeStatement;
62	>	function GetStoredProcedureNames: TStrings;
63	>	procedure GetStoredProcedureNamesFromServer;
64	>	procedure CreateParamDesc;
65	>	procedure SetParams;
66	>	procedure SetParamsFromCursor;
67	>	procedure GenerateSQL;
68	>	procedure FetchDataIntoOutputParams;
69	>	procedure ReadParamData(Reader: TReader);
70	>	procedure WriteParamData(Writer: TWriter);
71	>	procedure UpdateQuery;
72	>	protected
73	>
74	>	procedure DefineProperties(Filer: TFiler); override;
75	>	procedure SetFiltered(Value: Boolean); override;
76	>	procedure InitFieldDefs; override;
77	>	function GetParamsCount: Word;
78	>	procedure SetPrepared(Value: Boolean);
79	>	procedure SetPrepare(Value: Boolean);
80	>	procedure SetProcName(Value: string);
81	>	procedure Disconnect; override;
82	>	procedure InternalOpen; override;
83	>
84	>	public
85	>	constructor Create(AOwner: TComponent); override;
86	>	destructor Destroy; override;
87	>	procedure CopyParams(Value: TParams);
88	>	procedure ExecProc;
89	>	function ParamByName(const Value: string): TParam;
90	>	procedure Prepare;
91	>	procedure UnPrepare;
92	>	property ParamCount: Word read GetParamsCount;
93	>	property StmtHandle: IStatement read FStmtHandle;
94	>	property Prepared: Boolean read FPrepared write SetPrepare;
95	>	property StoredProcedureNames: TStrings read GetStoredProcedureNames;
96	>	property PackageNames: TStrings read GetPackageNames;
97	>
98	>	published
99	>	property PackageName: string read FPackageName write SetPackageName;
100	>	property StoredProcName: string read FProcName write SetProcName;
101	>	property Params: TParams read FParams write SetParamsList;
102	>	property Filtered;
103	>
104	>	property BeforeDatabaseDisconnect;
105	>	property AfterDatabaseDisconnect;
106	>	property DatabaseFree;
107	>	property BeforeTransactionEnd;
108	>	property AfterTransactionEnd;
109	>	property TransactionFree;
110	>	property OnFilterRecord;
111	>	end;
112	>
113	>	implementation
114	>
115	>	uses  FBMessages;
116	>
117	>	{ TIBStoredProc }
118	>
119	>	constructor TIBStoredProc.Create(AOwner: TComponent);
120	>	begin
121	>	inherited Create(AOwner);
122	>	FParams := TParams.Create (self);
123	>	FNameList := TStringList.Create;
124	>	FPackageNameList := TStringList.Create;
125	>	end;
126	>
127	>	destructor TIBStoredProc.Destroy;
128	>	begin
129	>	Destroying;
130	>	Disconnect;
131	>	if assigned (FParams) then FParams.Free;
132	>	if assigned(FNameList) then FNameList.Free;
133	>	if assigned(FPackageNameList) then FPackageNameList.Free;
134	>	inherited Destroy;
135	>	end;
136	>
137	>	procedure TIBStoredProc.Disconnect;
138	>	begin
139	>	Close;
140	>	UnPrepare;
141	>	end;
142	>
143	>	procedure TIBStoredProc.ExecProc;
144	>	var
145	>	DidActivate: Boolean;
146	>	begin
147	>	CheckInActive;
148	>	if StoredProcName = '' then
149	>	IBError(ibxeNoStoredProcName, [nil]);
150	>	ActivateConnection;
151	>	DidActivate := ActivateTransaction;
152	>	try
153	>	SetPrepared(True);
154	>	if DataSource <> nil then SetParamsFromCursor;
155	>	if FParams.Count > 0 then SetParams;
156	>	InternalExecQuery;
157	>	FetchDataIntoOutputParams;
158	>	finally
159	>	if DidActivate then
160	>	DeactivateTransaction;
161	>	end;
162	>	end;
163	>
164	>	procedure TIBStoredProc.SetProcName(Value: string);
165	>	begin
166	>	if Value = FProcName then Exit;
167	>	CheckInactive;
168	>	FProcName := Value;
169	>	UpdateQuery;
170	>	end;
171	>
172	>	function TIBStoredProc.GetParamsCount: Word;
173	>	begin
174	>	Result := FParams.Count;
175	>	end;
176	>
177	>	procedure TIBStoredProc.SetFiltered(Value: Boolean);
178	>	begin
179	>	if(Filtered <> Value) then
180	>	begin
181	>	inherited SetFiltered(value);
182	>	if Active then
183	>	begin
184	>	Close;
185	>	Open;
186	>	end;
187	>	end
188	>	else
189	>	inherited SetFiltered(value);
190	>	end;
191	>
192	>	procedure TIBStoredProc.InitFieldDefs;
193	>	begin
194	>	if (SelectSQL.Text = '') and (FProcName <> '') and (Database <> nil) then
195	>	GenerateSQL;
196	>	inherited InitFieldDefs;
197	>	end;
198	>
199	>	procedure TIBStoredProc.GenerateSQL;
200	>
201	>	var Params: TStringList;
202	>
203	>	function FormatParameter(Dialect: Integer; Value: String): String;
204	>	var j: integer;
205	>	begin
206	>	Value := Trim(Value);
207	>	if Dialect = 1 then
208	>	Result := AnsiUpperCase(Value)
209	>	else
210	>	begin
211	>	j := 1;
212	>	Value := Space2Underscore(AnsiUpperCase(Value));
213	>	Result := Value;
214	>	while Params.IndexOf(Result) <> -1 do
215	>	begin
216	>	Result := Value + IntToStr(j);
217	>	Inc(j)
218	>	end;
219	>	Params.Add(Result)
220	>	end;
221	>	end;
222	>
223	>	{Trim and make uppercase unless not an SQL Identifier when leave as it is}
224	>	function FormatProcName(Dialect: Integer; Value: String): String;
225	>	begin
226	>	Value := Trim(Value);
227	>	if (Dialect = 1) or IsSQLIdentifier(Value) then
228	>	Result := AnsiUpperCase(Value)
229	>	else
230	>	Result := SQLSafeString(Value);
231	>	end;
232	>
233	>	var
234	>	Query : TIBSQL;
235	>	input : string;
236	>	begin
237	>	input := '';
238	>	if FProcName = '' then
239	>	IBError(ibxeNoStoredProcName,[nil]);
240	>	ActivateConnection;
241	>	Database.InternalTransaction.StartTransaction;
242	>	Params := TStringList.Create;
243	>	Query := TIBSQL.Create(self);
244	>	try
245	>	Query.Database := DataBase;
246	>	Query.Transaction := Database.InternalTransaction;
247	>	if DatabaseInfo.ODSMajorVersion < 12 then
248	>	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
249	>	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
250	>	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
251	>	'''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
252	>	' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
253	>	else
254	>	if FPackageName = '' then
255	>	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
256	>	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
257	>	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
258	>	'''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
259	>	'AND RDB$PACKAGE_NAME IS NULL' + {do not localize}
260	>	' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
261	>	else
262	>	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
263	>	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
264	>	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
265	>	'''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
266	>	'AND RDB$PACKAGE_NAME = ' + {do not localize}
267	>	'''' + FormatProcName(Database.SQLDialect, FPackageName) + '''' +
268	>	' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
269	>	Query.Prepare;
270	>	Query.GoToFirstRecordOnExecute := False;
271	>	Query.ExecQuery;
272	>	while (not Query.EOF) and Query.Next do begin
273	>	if (Query.FieldByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
274	>	if (input <> '') then
275	>	input := input + ', :' +
276	>	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
277	>	input := ':' +
278	>	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
279	>	end
280	>	end;
281	>	if FPackageName = '' then
282	>	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
283	>	QuoteIdentifierIfNeeded(Database.SQLDialect, FProcName) + ' ' + input
284	>	else
285	>	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
286	>	QuoteIdentifierIfNeeded(Database.SQLDialect,FPackageName) + '.' +
287	>	QuoteIdentifierIfNeeded(Database.SQLDialect, FProcName) + ' ' + input;
288	>	//    writeln(SelectSQL.Text);
289	>	finally
290	>	Query.Free;
291	>	Params.Free;
292	>	Database.InternalTransaction.Commit;
293	>	end;
294	>	end;
295	>
296	>	procedure TIBStoredProc.CreateParamDesc;
297	>	var
298	>	i : integer;
299	>	DataType : TFieldType;
300	>	begin
301	>	DataType := ftUnknown;
302	>	for i := 0 to QSelect.MetaData.Count - 1 do begin
303	>	case QSelect.MetaData[i].SQLtype of
304	>	SQL_TYPE_DATE: DataType := ftDate;
305	>	SQL_TYPE_TIME: DataType := ftTime;
306	>	SQL_TIMESTAMP: DataType := ftDateTime;
307	>	SQL_SHORT:
308	>	if QSelect.MetaData[i].getScale = 0 then
309	>	DataType := ftSmallInt
310	>	else
311	>	DataType := ftBCD;
312	>	SQL_LONG:
313	>	if QSelect.MetaData[i].getScale = 0 then
314	>	DataType := ftInteger
315	>	else if QSelect.MetaData[i].getScale >= -4 then
316	>	DataType := ftBCD
317	>	else
318	>	DataType := ftFloat;
319	>	SQL_INT64:
320	>	if QSelect.MetaData[i].getScale = 0 then
321	>	DataType := ftLargeInt
322	>	else if QSelect.MetaData[i].getScale >= -4 then
323	>	DataType := ftBCD
324	>	else
325	>	DataType := ftFloat;
326	>	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
327	>	SQL_BOOLEAN:
328	>	DataType := ftBoolean;
329	>	SQL_TEXT: DataType := ftString;
330	>	SQL_VARYING:
331	>	if QSelect.MetaData[i].GetSize < 1024 then
332	>	DataType := ftString
333	>	else DataType := ftBlob;
334	>	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
335	>	end;
336	>	FParams.CreateParam(DataType, Trim(QSelect.MetaData[i].Name), ptOutput);
337	>	end;
338	>
339	>	DataType := ftUnknown;
340	>	for i := 0 to QSelect.Params.Count - 1 do begin
341	>	case QSelect.Params[i].GetSQLtype of
342	>	SQL_TYPE_DATE: DataType := ftDate;
343	>	SQL_TYPE_TIME: DataType := ftTime;
344	>	SQL_TIMESTAMP: DataType := ftDateTime;
345	>	SQL_SHORT:
346	>	if QSelect.Params[i].getScale = 0 then
347	>	DataType := ftSmallInt
348	>	else
349	>	DataType := ftBCD;
350	>	SQL_LONG:
351	>	if QSelect.Params[i].getScale = 0 then
352	>	DataType := ftInteger
353	>	else if QSelect.Params[i].getScale >= -4 then
354	>	DataType := ftBCD
355	>	else DataType := ftFloat;
356	>	SQL_INT64:
357	>	if QSelect.Params[i].getScale = 0 then
358	>	DataType := ftLargeInt
359	>	else if QSelect.Params[i].getScale >= -4 then
360	>	DataType := ftBCD
361	>	else DataType := ftFloat;
362	>	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
363	>	SQL_BOOLEAN:
364	>	DataType := ftBoolean;
365	>	SQL_TEXT: DataType := ftString;
366	>	SQL_VARYING:
367	>	if QSelect.Params[i].GetSize < 1024 then
368	>	DataType := ftString
369	>	else DataType := ftBlob;
370	>	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
371	>	end;
372	>	FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
373	>	end;
374	>	end;
375	>
376	>	procedure TIBStoredProc.SetPrepared(Value: Boolean);
377	>	begin
378	>	if Prepared <> Value then
379	>	begin
380	>	if Value then
381	>	try
382	>	if SelectSQL.Text = '' then GenerateSQL;
383	>	InternalPrepare;
384	>	if FParams.Count = 0 then CreateParamDesc;
385	>	FPrepared := True;
386	>	except
387	>	FreeStatement;
388	>	raise;
389	>	end
390	>	else FreeStatement;
391	>	end;
392	>
393	>	end;
394	>
395	>	procedure TIBStoredProc.Prepare;
396	>	begin
397	>	SetPrepared(True);
398	>	end;
399	>
400	>	procedure TIBStoredProc.UnPrepare;
401	>	begin
402	>	SetPrepared(False);
403	>	end;
404	>
405	>	procedure TIBStoredProc.FreeStatement;
406	>	begin
407	>	InternalUnPrepare;
408	>	FPrepared := False;
409	>	end;
410	>
411	>	procedure TIBStoredProc.SetPrepare(Value: Boolean);
412	>	begin
413	>	if Value then Prepare
414	>	else UnPrepare;
415	>	end;
416	>
417	>	procedure TIBStoredProc.CopyParams(Value: TParams);
418	>	begin
419	>	if not Prepared and (FParams.Count = 0) then
420	>	try
421	>	Prepare;
422	>	Value.Assign(FParams);
423	>	finally
424	>	UnPrepare;
425	>	end else
426	>	Value.Assign(FParams);
427	>	end;
428	>
429	>	procedure TIBStoredProc.SetParamsList(Value: TParams);
430	>	begin
431	>	CheckInactive;
432	>	if Prepared then
433	>	begin
434	>	SetPrepared(False);
435	>	FParams.Assign(Value);
436	>	SetPrepared(True);
437	>	end else
438	>	FParams.Assign(Value);
439	>	end;
440	>
441	>	procedure TIBStoredProc.SetPackageName(AValue: string);
442	>	begin
443	>	if FPackageName = AValue then Exit;
444	>	CheckInactive;
445	>	FPackageName := AValue;
446	>	FProcName := '';
447	>	UpdateQuery;
448	>	end;
449	>
450	>	procedure TIBStoredProc.GetPackageNamesFromServer;
451	>	var
452	>	Query : TIBSQL;
453	>	begin
454	>	ActivateConnection;
455	>	if (csReading in ComponentState) or (DatabaseInfo.ODSMajorVersion < 12) then Exit;
456	>	Database.InternalTransaction.StartTransaction;
457	>	Query := TIBSQL.Create(self);
458	>	try
459	>	Query.GoToFirstRecordOnExecute := False;
460	>	Query.Database := DataBase;
461	>	Query.Transaction := Database.InternalTransaction;
462	>	Query.SQL.Text := 'Select distinct RDB$PACKAGE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is not null'; {do not localize}
463	>	Query.Prepare;
464	>	Query.ExecQuery;
465	>	while (not Query.EOF) and Query.Next do
466	>	FPackageNameList.Add(TrimRight(Query.Current.ByName('RDB$PACKAGE_NAME').AsString)); {do not localize}
467	>	finally
468	>	Query.Free;
469	>	Database.InternalTransaction.Commit;
470	>	end;
471	>	end;
472	>
473	>	function TIBStoredProc.GetPackageNames: TStrings;
474	>	begin
475	>	FPackageNameList.Clear;
476	>	GetPackageNamesFromServer;
477	>	Result := FPackageNameList;
478	>	end;
479	>
480	>	function TIBStoredProc.ParamByName(const Value: string): TParam;
481	>	begin
482	>	Prepare;
483	>	Result := FParams.ParamByName(Value);
484	>	end;
485	>
486	>	function TIBStoredProc.GetStoredProcedureNames: TStrings;
487	>	begin
488	>	FNameList.clear;
489	>	GetStoredProcedureNamesFromServer;
490	>	Result := FNameList;
491	>	end;
492	>
493	>	procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
494	>	var
495	>	Query : TIBSQL;
496	>	begin
497	>	if not (csReading in ComponentState) then begin
498	>	ActivateConnection;
499	>	Database.InternalTransaction.StartTransaction;
500	>	Query := TIBSQL.Create(self);
501	>	try
502	>	Query.GoToFirstRecordOnExecute := False;
503	>	Query.Database := DataBase;
504	>	Query.Transaction := Database.InternalTransaction;
505	>	if DatabaseInfo.ODSMajorVersion < 12 then
506	>	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES' {do not localize}
507	>	else
508	>	if FPackageName = '' then
509	>	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is NULL' {do not localize}
510	>	else
511	>	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME = ''' + {do not localize}
512	>	SQLSafeString(FPackageName) + '''';
513	>	Query.Prepare;
514	>	Query.ExecQuery;
515	>	while (not Query.EOF) and Query.Next do
516	>	FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
517	>	finally
518	>	Query.Free;
519	>	Database.InternalTransaction.Commit;
520	>	end;
521	>	end;
522	>	end;
523	>
524	>	procedure TIBStoredProc.SetParams;
525	>	var
526	>	i : integer;
527	>	j: integer;
528	>	begin
529	>	i := 0;
530	>	for j := 0 to FParams.Count - 1 do
531	>	begin
532	>	if (Params[j].ParamType <> ptInput) then
533	>	continue;
534	>	if not Params[j].Bound then
535	>	IBError(ibxeRequiredParamNotSet, [Params[j].Name]);
536	>	if Params[j].IsNull then
537	>	SQLParams[i].IsNull := True
538	>	else begin
539	>	SQLParams[i].IsNull := False;
540	>	case Params[j].DataType of
541	>	ftString:
542	>	SQLParams[i].AsString := Params[j].AsString;
543	>	ftSmallint, ftWord:
544	>	SQLParams[i].AsShort := Params[j].AsSmallInt;
545	>	ftBoolean:
546	>	SQLParams[i].AsBoolean := Params[j].AsBoolean;
547	>	ftInteger:
548	>	SQLParams[i].AsLong := Params[j].AsInteger;
549	>	ftLargeInt:
550	>	SQLParams[i].AsInt64 := Params[j].AsLargeInt;
551	>	ftFloat, ftCurrency:
552	>	SQLParams[i].AsDouble := Params[j].AsFloat;
553	>	ftBCD:
554	>	SQLParams[i].AsCurrency := Params[j].AsCurrency;
555	>	ftDate:
556	>	SQLParams[i].AsDate := Params[j].AsDateTime;
557	>	ftTime:
558	>	SQLParams[i].AsTime := Params[j].AsDateTime;
559	>	ftDateTime:
560	>	SQLParams[i].AsDateTime := Params[j].AsDateTime;
561	>	ftBlob, ftMemo:
562	>	SQLParams[i].AsString := Params[j].AsString;
563	>	else
564	>	IBError(ibxeNotSupported, [nil]);
565	>	end;
566	>	end;
567	>	Inc(i);
568	>	end;
569	>	end;
570	>
571	>	procedure TIBStoredProc.SetParamsFromCursor;
572	>	var
573	>	I: Integer;
574	>	DataSet: TDataSet;
575	>	begin
576	>	if DataSource <> nil then
577	>	begin
578	>	DataSet := DataSource.DataSet;
579	>	if DataSet <> nil then
580	>	begin
581	>	DataSet.FieldDefs.Update;
582	>	for I := 0 to FParams.Count - 1 do
583	>	with FParams[I] do
584	>	if (not Bound) and
585	>	((ParamType = ptInput) or (ParamType =  ptInputOutput)) then
586	>	AssignField(DataSet.FieldByName(Name));
587	>	end;
588	>	end;
589	>	end;
590	>
591	>	procedure TIBStoredProc.FetchDataIntoOutputParams;
592	>	var
593	>	i,j : Integer;
594	>	begin
595	>	j := 0;
596	>	for i := 0 to FParams.Count - 1 do
597	>	with Params[I] do
598	>	if ParamType = ptOutput then begin
599	>	Value := QSelect.Fields[j].Value;
600	>	Inc(j);
601	>	end;
602	>	end;
603	>
604	>	procedure TIBStoredProc.InternalOpen;
605	>	begin
606	>	IBError(ibxeIsAExecuteProcedure,[nil]);
607	>	end;
608	>
609	>	procedure TIBStoredProc.DefineProperties(Filer: TFiler);
610	>
611	>	function WriteData: Boolean;
612	>	begin
613	>	if Filer.Ancestor <> nil then
614	>	Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
615	>	Result := FParams.Count > 0;
616	>	end;
617	>
618	>	begin
619	>	inherited DefineProperties(Filer);
620	>	Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
621	>	end;
622	>
623	>	procedure TIBStoredProc.WriteParamData(Writer: TWriter);
624	>	begin
625	>	Writer.WriteCollection(Params);
626	>	end;
627	>
628	>	procedure TIBStoredProc.UpdateQuery;
629	>	begin
630	>	if not (csReading in ComponentState) then
631	>	begin
632	>	FreeStatement;
633	>	FParams.Clear;
634	>	if (FProcName <> '') and (Database <> nil) then
635	>	begin
636	>	GenerateSQL;
637	>	if csDesigning in ComponentState then
638	>	begin
639	>	Prepare;  {Fills the Params collection}
640	>	UnPrepare;
641	>	end;
642	>	end;
643	>	end
644	>	else
645	>	begin
646	>	if (FProcName <> '') and (Database <> nil) then
647	>	GenerateSQL;
648	>	end;
649	>	end;
650	>
651	>	procedure TIBStoredProc.ReadParamData(Reader: TReader);
652	>	begin
653	>	Reader.ReadValue;
654	>	Reader.ReadCollection(Params);
655	>	end;
656	>
657	>	end.

Diff Legend

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