ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBStoredProc.pas
Revision: 107
Committed: Thu Jan 18 14:37:40 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 19984 byte(s)
Log Message:
Fixes merged

File Contents

# Content
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.