ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBStoredProc.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (6 years, 6 months ago) by tony
File size: 15788 byte(s)
Log Message:
Committing updates for Release R1-0-5
Line File contents
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.