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 7 by tony, Sun Aug 5 18:28:19 2012 UTC vs.
Revision 17 by tony, Sat Dec 28 19:22:24 2013 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	<	function GetParamsCount: Word;
71	<	procedure SetPrepared(Value: Boolean);
72	<	procedure SetPrepare(Value: Boolean);
73	<	procedure SetProcName(Value: string);
74	<	procedure Disconnect; override;
75	<	procedure InternalOpen; override;
76	<
77	<	public
78	<	constructor Create(AOwner: TComponent); override;
79	<	destructor Destroy; override;
80	<	procedure CopyParams(Value: TParams);
81	<	procedure ExecProc;
82	<	function ParamByName(const Value: string): TParam;
83	<	procedure Prepare;
84	<	procedure UnPrepare;
85	<	property ParamCount: Word read GetParamsCount;
86	<	property StmtHandle: TISC_STMT_HANDLE read FStmtHandle;
87	<	property Prepared: Boolean read FPrepared write SetPrepare;
88	<	property StoredProcedureNames: TStrings read GetStoredProcedureNames;
89	<
90	<	published
91	<	property StoredProcName: string read FProcName write SetProcName;
92	<	property Params: TParams read FParams write SetParamsList;
93	<	property Filtered;
94	<
95	<	property BeforeDatabaseDisconnect;
96	<	property AfterDatabaseDisconnect;
97	<	property DatabaseFree;
98	<	property BeforeTransactionEnd;
99	<	property AfterTransactionEnd;
100	<	property TransactionFree;
101	<	property OnFilterRecord;
102	<	end;
103	<
104	<	implementation
105	<
106	<	uses
107	<	IBIntf;
108	<
109	<	{ TIBStoredProc }
110	<
111	<	constructor TIBStoredProc.Create(AOwner: TComponent);
112	<	begin
113	<	inherited Create(AOwner);
114	<	FIBLoaded := False;
115	<	CheckIBLoaded;
116	<	FIBLoaded := True;
117	<	FParams := TParams.Create (self);
118	<	FNameList := TStringList.Create;
119	<	end;
120	<
121	<	destructor TIBStoredProc.Destroy;
122	<	begin
123	<	if FIBLoaded then
124	<	begin
125	<	Destroying;
126	<	Disconnect;
127	<	FParams.Free;
128	<	FNameList.Destroy;
129	<	end;
130	<	inherited Destroy;
131	<	end;
132	<
133	<	procedure TIBStoredProc.Disconnect;
134	<	begin
135	<	Close;
136	<	UnPrepare;
137	<	end;
138	<
139	<	procedure TIBStoredProc.ExecProc;
140	<	var
141	<	DidActivate: Boolean;
142	<	begin
143	<	CheckInActive;
144	<	if StoredProcName = '' then
145	<	IBError(ibxeNoStoredProcName, [nil]);
146	<	ActivateConnection;
147	<	DidActivate := ActivateTransaction;
148	<	try
149	<	SetPrepared(True);
150	<	if DataSource <> nil then SetParamsFromCursor;
151	<	if FParams.Count > 0 then SetParams;
152	<	InternalExecQuery;
153	<	FetchDataIntoOutputParams;
154	<	finally
155	<	if DidActivate then
156	<	DeactivateTransaction;
157	<	end;
158	<	end;
159	<
160	<	procedure TIBStoredProc.SetProcName(Value: string);
161	<	begin
162	<	if not (csReading in ComponentState) then
163	<	begin
164	<	CheckInactive;
165	<	if Value <> FProcName then
166	<	begin
167	<	FProcName := Value;
168	<	FreeStatement;
169	<	FParams.Clear;
170	<	if (Value <> '') and
171	<	(Database <> nil) then
172	<	GenerateSQL;
173	<	end;
174	<	end else begin
175	<	FProcName := Value;
176	<	if (Value <> '') and
177	<	(Database <> nil) then
178	<	GenerateSQL;
179	<	end;
180	<	end;
181	<
182	<	function TIBStoredProc.GetParamsCount: Word;
183	<	begin
184	<	Result := FParams.Count;
185	<	end;
186	<
187	<	procedure TIBStoredProc.SetFiltered(Value: Boolean);
188	<	begin
189	<	if(Filtered <> Value) then
190	<	begin
191	<	inherited SetFiltered(value);
192	<	if Active then
193	<	begin
194	<	Close;
195	<	Open;
196	<	end;
197	<	end
198	<	else
199	<	inherited SetFiltered(value);
200	<	end;
201	<
202	<	procedure TIBStoredProc.GenerateSQL;
203	<	var
204	<	Query : TIBSQL;
205	<	input : string;
206	<	begin
207	<	ActivateConnection;
208	<	Database.InternalTransaction.StartTransaction;
209	<	Query := TIBSQL.Create(self);
210	<	try
211	<	Query.Database := DataBase;
212	<	Query.Transaction := Database.InternalTransaction;
213	<	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
214	<	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
215	<	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
216	<	'''' + FormatIdentifierValue(Database.SQLDialect, FProcName) + '''' +
217	<	' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
218	<	Query.Prepare;
219	<	Query.GoToFirstRecordOnExecute := False;
220	<	Query.ExecQuery;
221	<	while (not Query.EOF) and (Query.Next <> nil) do begin
222	<	if (Query.Current.ByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
223	<	if (input <> '') then
224	<	input := input + ', :' +
225	<	FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
226	<	input := ':' +
227	<	FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
228	<	end
229	<	end;
230	<	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
231	<	FormatIdentifier(Database.SQLDialect, FProcName) + ' ' + input;
232	<	finally
233	<	Query.Free;
234	<	Database.InternalTransaction.Commit;
235	<	end;
236	<	end;
237	<
238	<	procedure TIBStoredProc.CreateParamDesc;
239	<	var
240	<	i : integer;
241	<	DataType : TFieldType;
242	<	begin
243	<	DataType := ftUnknown;
244	<	for i := 0 to QSelect.Current.Count - 1 do begin
245	<	case QSelect.Fields[i].SQLtype of
246	<	SQL_TYPE_DATE: DataType := ftDate;
247	<	SQL_TYPE_TIME: DataType := ftTime;
248	<	SQL_TIMESTAMP: DataType := ftDateTime;
249	<	SQL_SHORT:
250	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
251	<	DataType := ftSmallInt
252	<	else
253	<	DataType := ftBCD;
254	<	SQL_LONG:
255	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
256	<	DataType := ftInteger
257	<	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
258	<	DataType := ftBCD
259	<	else
260	<	DataType := ftFloat;
261	<	SQL_INT64:
262	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
263	<	DataType := ftLargeInt
264	<	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
265	<	DataType := ftBCD
266	<	else
267	<	DataType := ftFloat;
268	<	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
269	<	SQL_TEXT: DataType := ftString;
270	<	SQL_VARYING:
271	<	if ((QSelect.Fields[i].AsXSQLVar)^.sqllen < 1024) then
272	<	DataType := ftString
273	<	else DataType := ftBlob;
274	<	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
275	<	end;
276	<	FParams.CreateParam(DataType, Trim(QSelect.Fields[i].Name), ptOutput);
277	<	end;
278	<
279	<	DataType := ftUnknown;
280	<	for i := 0 to QSelect.Params.Count - 1 do begin
281	<	case QSelect.Params[i].SQLtype of
282	<	SQL_TYPE_DATE: DataType := ftDate;
283	<	SQL_TYPE_TIME: DataType := ftTime;
284	<	SQL_TIMESTAMP: DataType := ftDateTime;
285	<	SQL_SHORT:
286	<	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
287	<	DataType := ftSmallInt
288	<	else
289	<	DataType := ftBCD;
290	<	SQL_LONG:
291	<	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
292	<	DataType := ftInteger
293	<	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
294	<	DataType := ftBCD
295	<	else DataType := ftFloat;
296	<	SQL_INT64:
297	<	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
298	<	DataType := ftLargeInt
299	<	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
300	<	DataType := ftBCD
301	<	else DataType := ftFloat;
302	<	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
303	<	SQL_TEXT: DataType := ftString;
304	<	SQL_VARYING:
305	<	if ((QSelect.Params[i].AsXSQLVar)^.sqllen < 1024) then
306	<	DataType := ftString
307	<	else DataType := ftBlob;
308	<	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
309	<	end;
310	<	FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
311	<	end;
312	<	end;
313	<
314	<	procedure TIBStoredProc.SetPrepared(Value: Boolean);
315	<	begin
316	<	if Prepared <> Value then
317	<	begin
318	<	if Value then
319	<	try
320	<	if SelectSQL.Text = '' then GenerateSQL;
321	<	InternalPrepare;
322	<	if FParams.Count = 0 then CreateParamDesc;
323	<	FPrepared := True;
324	<	except
325	<	FreeStatement;
326	<	raise;
327	<	end
328	<	else FreeStatement;
329	<	end;
330	<
331	<	end;
332	<
333	<	procedure TIBStoredProc.Prepare;
334	<	begin
335	<	SetPrepared(True);
336	<	end;
337	<
338	<	procedure TIBStoredProc.UnPrepare;
339	<	begin
340	<	SetPrepared(False);
341	<	end;
342	<
343	<	procedure TIBStoredProc.FreeStatement;
344	<	begin
345	<	InternalUnPrepare;
346	<	FPrepared := False;
347	<	end;
348	<
349	<	procedure TIBStoredProc.SetPrepare(Value: Boolean);
350	<	begin
351	<	if Value then Prepare
352	<	else UnPrepare;
353	<	end;
354	<
355	<	procedure TIBStoredProc.CopyParams(Value: TParams);
356	<	begin
357	<	if not Prepared and (FParams.Count = 0) then
358	<	try
359	<	Prepare;
360	<	Value.Assign(FParams);
361	<	finally
362	<	UnPrepare;
363	<	end else
364	<	Value.Assign(FParams);
365	<	end;
366	<
367	<	procedure TIBStoredProc.SetParamsList(Value: TParams);
368	<	begin
369	<	CheckInactive;
370	<	if Prepared then
371	<	begin
372	<	SetPrepared(False);
373	<	FParams.Assign(Value);
374	<	SetPrepared(True);
375	<	end else
376	<	FParams.Assign(Value);
377	<	end;
378	<
379	<	function TIBStoredProc.ParamByName(const Value: string): TParam;
380	<	begin
381	<	Result := FParams.ParamByName(Value);
382	<	end;
383	<
384	<	function TIBStoredProc.GetStoredProcedureNames: TStrings;
385	<	begin
386	<	FNameList.clear;
387	<	GetStoredProcedureNamesFromServer;
388	<	Result := FNameList;
389	<	end;
390	<
391	<	procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
392	<	var
393	<	Query : TIBSQL;
394	<	begin
395	<	if not (csReading in ComponentState) then begin
396	<	ActivateConnection;
397	<	Database.InternalTransaction.StartTransaction;
398	<	Query := TIBSQL.Create(self);
399	<	try
400	<	Query.GoToFirstRecordOnExecute := False;
401	<	Query.Database := DataBase;
402	<	Query.Transaction := Database.InternalTransaction;
403	<	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES'; {do not localize}
404	<	Query.Prepare;
405	<	Query.ExecQuery;
406	<	while (not Query.EOF) and (Query.Next <> nil) do
407	<	FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
408	<	finally
409	<	Query.Free;
410	<	Database.InternalTransaction.Commit;
411	<	end;
412	<	end;
413	<	end;
414	<
415	<	procedure TIBStoredProc.SetParams;
416	<	var
417	<	i : integer;
418	<	j: integer;
419	<	begin
420	<	i := 0;
421	<	for j := 0 to FParams.Count - 1 do
422	<	begin
423	<	if (Params[j].ParamType <> ptInput) then
424	<	continue;
425	<	if not Params[j].Bound then
426	<	IBError(ibxeRequiredParamNotSet, [nil]);
427	<	if Params[j].IsNull then
428	<	SQLParams[i].IsNull := True
429	<	else begin
430	<	SQLParams[i].IsNull := False;
431	<	case Params[j].DataType of
432	<	ftString:
433	<	SQLParams[i].AsString := Params[j].AsString;
434	<	ftBoolean, ftSmallint, ftWord:
435	<	SQLParams[i].AsShort := Params[j].AsSmallInt;
436	<	ftInteger:
437	<	SQLParams[i].AsLong := Params[j].AsInteger;
438	<	{        ftLargeInt:
439	<	SQLParams[i].AsInt64 := Params[j].AsLargeInt; }
440	<	ftFloat, ftCurrency:
441	<	SQLParams[i].AsDouble := Params[j].AsFloat;
442	<	ftBCD:
443	<	SQLParams[i].AsCurrency := Params[j].AsCurrency;
444	<	ftDate:
445	<	SQLParams[i].AsDate := Params[j].AsDateTime;
446	<	ftTime:
447	<	SQLParams[i].AsTime := Params[j].AsDateTime;
448	<	ftDateTime:
449	<	SQLParams[i].AsDateTime := Params[j].AsDateTime;
450	<	ftBlob, ftMemo:
451	<	SQLParams[i].AsString := Params[j].AsString;
452	<	else
453	<	IBError(ibxeNotSupported, [nil]);
454	<	end;
455	<	end;
456	<	Inc(i);
457	<	end;
458	<	end;
459	<
460	<	procedure TIBStoredProc.SetParamsFromCursor;
461	<	var
462	<	I: Integer;
463	<	DataSet: TDataSet;
464	<	begin
465	<	if DataSource <> nil then
466	<	begin
467	<	DataSet := DataSource.DataSet;
468	<	if DataSet <> nil then
469	<	begin
470	<	DataSet.FieldDefs.Update;
471	<	for I := 0 to FParams.Count - 1 do
472	<	with FParams[I] do
473	<	if (not Bound) and
474	<	((ParamType = ptInput) or (ParamType =  ptInputOutput)) then
475	<	AssignField(DataSet.FieldByName(Name));
476	<	end;
477	<	end;
478	<	end;
479	<
480	<	procedure TIBStoredProc.FetchDataIntoOutputParams;
481	<	var
482	<	i,j : Integer;
483	<	begin
484	<	j := 0;
485	<	for i := 0 to FParams.Count - 1 do
486	<	with Params[I] do
487	<	if ParamType = ptOutput then begin
488	<	Value := QSelect.Fields[j].Value;
489	<	Inc(j);
490	<	end;
491	<	end;
492	<
493	<	procedure TIBStoredProc.InternalOpen;
494	<	begin
495	<	IBError(ibxeIsAExecuteProcedure,[nil]);
496	<	end;
497	<
498	<	procedure TIBStoredProc.DefineProperties(Filer: TFiler);
499	<
500	<	function WriteData: Boolean;
501	<	begin
502	<	if Filer.Ancestor <> nil then
503	<	Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
504	<	Result := FParams.Count > 0;
505	<	end;
506	<
507	<	begin
508	<	inherited DefineProperties(Filer);
509	<	Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
510	<	end;
511	<
512	<	procedure TIBStoredProc.WriteParamData(Writer: TWriter);
513	<	begin
514	<	Writer.WriteCollection(Params);
515	<	end;
516	<
517	<	procedure TIBStoredProc.ReadParamData(Reader: TReader);
518	<	begin
519	<	Reader.ReadValue;
520	<	Reader.ReadCollection(Params);
521	<	end;
522	<
523	<	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	>	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	>	function GetParamsCount: Word;
71	>	procedure SetPrepared(Value: Boolean);
72	>	procedure SetPrepare(Value: Boolean);
73	>	procedure SetProcName(Value: string);
74	>	procedure Disconnect; override;
75	>	procedure InternalOpen; override;
76	>
77	>	public
78	>	constructor Create(AOwner: TComponent); override;
79	>	destructor Destroy; override;
80	>	procedure CopyParams(Value: TParams);
81	>	procedure ExecProc;
82	>	function ParamByName(const Value: string): TParam;
83	>	procedure Prepare;
84	>	procedure UnPrepare;
85	>	property ParamCount: Word read GetParamsCount;
86	>	property StmtHandle: TISC_STMT_HANDLE read FStmtHandle;
87	>	property Prepared: Boolean read FPrepared write SetPrepare;
88	>	property StoredProcedureNames: TStrings read GetStoredProcedureNames;
89	>
90	>	published
91	>	property StoredProcName: string read FProcName write SetProcName;
92	>	property Params: TParams read FParams write SetParamsList;
93	>	property Filtered;
94	>
95	>	property BeforeDatabaseDisconnect;
96	>	property AfterDatabaseDisconnect;
97	>	property DatabaseFree;
98	>	property BeforeTransactionEnd;
99	>	property AfterTransactionEnd;
100	>	property TransactionFree;
101	>	property OnFilterRecord;
102	>	end;
103	>
104	>	implementation
105	>
106	>	uses
107	>	IBIntf;
108	>
109	>	{ TIBStoredProc }
110	>
111	>	constructor TIBStoredProc.Create(AOwner: TComponent);
112	>	begin
113	>	inherited Create(AOwner);
114	>	FIBLoaded := False;
115	>	CheckIBLoaded;
116	>	FIBLoaded := True;
117	>	FParams := TParams.Create (self);
118	>	FNameList := TStringList.Create;
119	>	end;
120	>
121	>	destructor TIBStoredProc.Destroy;
122	>	begin
123	>	if FIBLoaded then
124	>	begin
125	>	Destroying;
126	>	Disconnect;
127	>	FParams.Free;
128	>	FNameList.Destroy;
129	>	end;
130	>	inherited Destroy;
131	>	end;
132	>
133	>	procedure TIBStoredProc.Disconnect;
134	>	begin
135	>	Close;
136	>	UnPrepare;
137	>	end;
138	>
139	>	procedure TIBStoredProc.ExecProc;
140	>	var
141	>	DidActivate: Boolean;
142	>	begin
143	>	CheckInActive;
144	>	if StoredProcName = '' then
145	>	IBError(ibxeNoStoredProcName, [nil]);
146	>	ActivateConnection;
147	>	DidActivate := ActivateTransaction;
148	>	try
149	>	SetPrepared(True);
150	>	if DataSource <> nil then SetParamsFromCursor;
151	>	if FParams.Count > 0 then SetParams;
152	>	InternalExecQuery;
153	>	FetchDataIntoOutputParams;
154	>	finally
155	>	if DidActivate then
156	>	DeactivateTransaction;
157	>	end;
158	>	end;
159	>
160	>	procedure TIBStoredProc.SetProcName(Value: string);
161	>	begin
162	>	if not (csReading in ComponentState) then
163	>	begin
164	>	CheckInactive;
165	>	if Value <> FProcName then
166	>	begin
167	>	FProcName := Value;
168	>	FreeStatement;
169	>	FParams.Clear;
170	>	if (Value <> '') and
171	>	(Database <> nil) then
172	>	GenerateSQL;
173	>	end;
174	>	end else begin
175	>	FProcName := Value;
176	>	if (Value <> '') and
177	>	(Database <> nil) then
178	>	GenerateSQL;
179	>	end;
180	>	end;
181	>
182	>	function TIBStoredProc.GetParamsCount: Word;
183	>	begin
184	>	Result := FParams.Count;
185	>	end;
186	>
187	>	procedure TIBStoredProc.SetFiltered(Value: Boolean);
188	>	begin
189	>	if(Filtered <> Value) then
190	>	begin
191	>	inherited SetFiltered(value);
192	>	if Active then
193	>	begin
194	>	Close;
195	>	Open;
196	>	end;
197	>	end
198	>	else
199	>	inherited SetFiltered(value);
200	>	end;
201	>
202	>	procedure TIBStoredProc.GenerateSQL;
203	>	var
204	>	Query : TIBSQL;
205	>	input : string;
206	>	begin
207	>	ActivateConnection;
208	>	Database.InternalTransaction.StartTransaction;
209	>	Query := TIBSQL.Create(self);
210	>	try
211	>	Query.Database := DataBase;
212	>	Query.Transaction := Database.InternalTransaction;
213	>	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
214	>	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
215	>	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
216	>	'''' + FormatIdentifierValue(Database.SQLDialect, FProcName) + '''' +
217	>	' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
218	>	Query.Prepare;
219	>	Query.GoToFirstRecordOnExecute := False;
220	>	Query.ExecQuery;
221	>	while (not Query.EOF) and (Query.Next <> nil) do begin
222	>	if (Query.Current.ByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
223	>	if (input <> '') then
224	>	input := input + ', :' +
225	>	FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
226	>	input := ':' +
227	>	FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
228	>	end
229	>	end;
230	>	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
231	>	FormatIdentifier(Database.SQLDialect, FProcName) + ' ' + input;
232	>	finally
233	>	Query.Free;
234	>	Database.InternalTransaction.Commit;
235	>	end;
236	>	end;
237	>
238	>	procedure TIBStoredProc.CreateParamDesc;
239	>	var
240	>	i : integer;
241	>	DataType : TFieldType;
242	>	begin
243	>	DataType := ftUnknown;
244	>	for i := 0 to QSelect.Current.Count - 1 do begin
245	>	case QSelect.Fields[i].SQLtype of
246	>	SQL_TYPE_DATE: DataType := ftDate;
247	>	SQL_TYPE_TIME: DataType := ftTime;
248	>	SQL_TIMESTAMP: DataType := ftDateTime;
249	>	SQL_SHORT:
250	>	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
251	>	DataType := ftSmallInt
252	>	else
253	>	DataType := ftBCD;
254	>	SQL_LONG:
255	>	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
256	>	DataType := ftInteger
257	>	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
258	>	DataType := ftBCD
259	>	else
260	>	DataType := ftFloat;
261	>	SQL_INT64:
262	>	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
263	>	DataType := ftLargeInt
264	>	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
265	>	DataType := ftBCD
266	>	else
267	>	DataType := ftFloat;
268	>	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
269	>	SQL_TEXT: DataType := ftString;
270	>	SQL_VARYING:
271	>	if ((QSelect.Fields[i].AsXSQLVar)^.sqllen < 1024) then
272	>	DataType := ftString
273	>	else DataType := ftBlob;
274	>	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
275	>	end;
276	>	FParams.CreateParam(DataType, Trim(QSelect.Fields[i].Name), ptOutput);
277	>	end;
278	>
279	>	DataType := ftUnknown;
280	>	for i := 0 to QSelect.Params.Count - 1 do begin
281	>	case QSelect.Params[i].SQLtype of
282	>	SQL_TYPE_DATE: DataType := ftDate;
283	>	SQL_TYPE_TIME: DataType := ftTime;
284	>	SQL_TIMESTAMP: DataType := ftDateTime;
285	>	SQL_SHORT:
286	>	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
287	>	DataType := ftSmallInt
288	>	else
289	>	DataType := ftBCD;
290	>	SQL_LONG:
291	>	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
292	>	DataType := ftInteger
293	>	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
294	>	DataType := ftBCD
295	>	else DataType := ftFloat;
296	>	SQL_INT64:
297	>	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
298	>	DataType := ftLargeInt
299	>	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
300	>	DataType := ftBCD
301	>	else DataType := ftFloat;
302	>	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
303	>	SQL_TEXT: DataType := ftString;
304	>	SQL_VARYING:
305	>	if ((QSelect.Params[i].AsXSQLVar)^.sqllen < 1024) then
306	>	DataType := ftString
307	>	else DataType := ftBlob;
308	>	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
309	>	end;
310	>	FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
311	>	end;
312	>	end;
313	>
314	>	procedure TIBStoredProc.SetPrepared(Value: Boolean);
315	>	begin
316	>	if Prepared <> Value then
317	>	begin
318	>	if Value then
319	>	try
320	>	if SelectSQL.Text = '' then GenerateSQL;
321	>	InternalPrepare;
322	>	if FParams.Count = 0 then CreateParamDesc;
323	>	FPrepared := True;
324	>	except
325	>	FreeStatement;
326	>	raise;
327	>	end
328	>	else FreeStatement;
329	>	end;
330	>
331	>	end;
332	>
333	>	procedure TIBStoredProc.Prepare;
334	>	begin
335	>	SetPrepared(True);
336	>	end;
337	>
338	>	procedure TIBStoredProc.UnPrepare;
339	>	begin
340	>	SetPrepared(False);
341	>	end;
342	>
343	>	procedure TIBStoredProc.FreeStatement;
344	>	begin
345	>	InternalUnPrepare;
346	>	FPrepared := False;
347	>	end;
348	>
349	>	procedure TIBStoredProc.SetPrepare(Value: Boolean);
350	>	begin
351	>	if Value then Prepare
352	>	else UnPrepare;
353	>	end;
354	>
355	>	procedure TIBStoredProc.CopyParams(Value: TParams);
356	>	begin
357	>	if not Prepared and (FParams.Count = 0) then
358	>	try
359	>	Prepare;
360	>	Value.Assign(FParams);
361	>	finally
362	>	UnPrepare;
363	>	end else
364	>	Value.Assign(FParams);
365	>	end;
366	>
367	>	procedure TIBStoredProc.SetParamsList(Value: TParams);
368	>	begin
369	>	CheckInactive;
370	>	if Prepared then
371	>	begin
372	>	SetPrepared(False);
373	>	FParams.Assign(Value);
374	>	SetPrepared(True);
375	>	end else
376	>	FParams.Assign(Value);
377	>	end;
378	>
379	>	function TIBStoredProc.ParamByName(const Value: string): TParam;
380	>	begin
381	>	Result := FParams.ParamByName(Value);
382	>	end;
383	>
384	>	function TIBStoredProc.GetStoredProcedureNames: TStrings;
385	>	begin
386	>	FNameList.clear;
387	>	GetStoredProcedureNamesFromServer;
388	>	Result := FNameList;
389	>	end;
390	>
391	>	procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
392	>	var
393	>	Query : TIBSQL;
394	>	begin
395	>	if not (csReading in ComponentState) then begin
396	>	ActivateConnection;
397	>	Database.InternalTransaction.StartTransaction;
398	>	Query := TIBSQL.Create(self);
399	>	try
400	>	Query.GoToFirstRecordOnExecute := False;
401	>	Query.Database := DataBase;
402	>	Query.Transaction := Database.InternalTransaction;
403	>	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES'; {do not localize}
404	>	Query.Prepare;
405	>	Query.ExecQuery;
406	>	while (not Query.EOF) and (Query.Next <> nil) do
407	>	FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
408	>	finally
409	>	Query.Free;
410	>	Database.InternalTransaction.Commit;
411	>	end;
412	>	end;
413	>	end;
414	>
415	>	procedure TIBStoredProc.SetParams;
416	>	var
417	>	i : integer;
418	>	j: integer;
419	>	begin
420	>	i := 0;
421	>	for j := 0 to FParams.Count - 1 do
422	>	begin
423	>	if (Params[j].ParamType <> ptInput) then
424	>	continue;
425	>	if not Params[j].Bound then
426	>	IBError(ibxeRequiredParamNotSet, [nil]);
427	>	if Params[j].IsNull then
428	>	SQLParams[i].IsNull := True
429	>	else begin
430	>	SQLParams[i].IsNull := False;
431	>	case Params[j].DataType of
432	>	ftString:
433	>	SQLParams[i].AsString := Params[j].AsString;
434	>	ftBoolean, ftSmallint, ftWord:
435	>	SQLParams[i].AsShort := Params[j].AsSmallInt;
436	>	ftInteger:
437	>	SQLParams[i].AsLong := Params[j].AsInteger;
438	>	{        ftLargeInt:
439	>	SQLParams[i].AsInt64 := Params[j].AsLargeInt; }
440	>	ftFloat, ftCurrency:
441	>	SQLParams[i].AsDouble := Params[j].AsFloat;
442	>	ftBCD:
443	>	SQLParams[i].AsCurrency := Params[j].AsCurrency;
444	>	ftDate:
445	>	SQLParams[i].AsDate := Params[j].AsDateTime;
446	>	ftTime:
447	>	SQLParams[i].AsTime := Params[j].AsDateTime;
448	>	ftDateTime:
449	>	SQLParams[i].AsDateTime := Params[j].AsDateTime;
450	>	ftBlob, ftMemo:
451	>	SQLParams[i].AsString := Params[j].AsString;
452	>	else
453	>	IBError(ibxeNotSupported, [nil]);
454	>	end;
455	>	end;
456	>	Inc(i);
457	>	end;
458	>	end;
459	>
460	>	procedure TIBStoredProc.SetParamsFromCursor;
461	>	var
462	>	I: Integer;
463	>	DataSet: TDataSet;
464	>	begin
465	>	if DataSource <> nil then
466	>	begin
467	>	DataSet := DataSource.DataSet;
468	>	if DataSet <> nil then
469	>	begin
470	>	DataSet.FieldDefs.Update;
471	>	for I := 0 to FParams.Count - 1 do
472	>	with FParams[I] do
473	>	if (not Bound) and
474	>	((ParamType = ptInput) or (ParamType =  ptInputOutput)) then
475	>	AssignField(DataSet.FieldByName(Name));
476	>	end;
477	>	end;
478	>	end;
479	>
480	>	procedure TIBStoredProc.FetchDataIntoOutputParams;
481	>	var
482	>	i,j : Integer;
483	>	begin
484	>	j := 0;
485	>	for i := 0 to FParams.Count - 1 do
486	>	with Params[I] do
487	>	if ParamType = ptOutput then begin
488	>	Value := QSelect.Fields[j].Value;
489	>	Inc(j);
490	>	end;
491	>	end;
492	>
493	>	procedure TIBStoredProc.InternalOpen;
494	>	begin
495	>	IBError(ibxeIsAExecuteProcedure,[nil]);
496	>	end;
497	>
498	>	procedure TIBStoredProc.DefineProperties(Filer: TFiler);
499	>
500	>	function WriteData: Boolean;
501	>	begin
502	>	if Filer.Ancestor <> nil then
503	>	Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
504	>	Result := FParams.Count > 0;
505	>	end;
506	>
507	>	begin
508	>	inherited DefineProperties(Filer);
509	>	Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
510	>	end;
511	>
512	>	procedure TIBStoredProc.WriteParamData(Writer: TWriter);
513	>	begin
514	>	Writer.WriteCollection(Params);
515	>	end;
516	>
517	>	procedure TIBStoredProc.ReadParamData(Reader: TReader);
518	>	begin
519	>	Reader.ReadValue;
520	>	Reader.ReadCollection(Params);
521	>	end;
522	>
523	>	end.

Diff Legend

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