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

Diff Legend

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