ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBStoredProc.pas
Revision: 308
Committed: Sat Jul 18 10:26:30 2020 UTC (3 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 20184 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 - 2018 }
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 SetFilterText(const Value: string); override;
77 procedure InitFieldDefs; override;
78 function GetParamsCount: Word;
79 procedure SetPrepared(Value: Boolean);
80 procedure SetPrepare(Value: Boolean);
81 procedure SetProcName(Value: string);
82 procedure Disconnect; override;
83 procedure InternalOpen; override;
84
85 public
86 constructor Create(AOwner: TComponent); override;
87 destructor Destroy; override;
88 procedure CopyParams(Value: TParams);
89 procedure ExecProc;
90 function ParamByName(const Value: string): TParam;
91 procedure Prepare;
92 procedure UnPrepare;
93 property ParamCount: Word read GetParamsCount;
94 property StmtHandle: IStatement read FStmtHandle;
95 property Prepared: Boolean read FPrepared write SetPrepare;
96 property StoredProcedureNames: TStrings read GetStoredProcedureNames;
97 property PackageNames: TStrings read GetPackageNames;
98
99 published
100 property PackageName: string read FPackageName write SetPackageName;
101 property StoredProcName: string read FProcName write SetProcName;
102 property Params: TParams read FParams write SetParamsList;
103 property Filtered;
104 property Filter;
105
106 property BeforeDatabaseDisconnect;
107 property AfterDatabaseDisconnect;
108 property DatabaseFree;
109 property BeforeTransactionEnd;
110 property AfterTransactionEnd;
111 property TransactionFree;
112 property OnFilterRecord;
113 end;
114
115 implementation
116
117 uses IBMessages;
118
119 { TIBStoredProc }
120
121 constructor TIBStoredProc.Create(AOwner: TComponent);
122 begin
123 inherited Create(AOwner);
124 FParams := TParams.Create (self);
125 FNameList := TStringList.Create;
126 FPackageNameList := TStringList.Create;
127 end;
128
129 destructor TIBStoredProc.Destroy;
130 begin
131 Destroying;
132 Disconnect;
133 if assigned (FParams) then FParams.Free;
134 if assigned(FNameList) then FNameList.Free;
135 if assigned(FPackageNameList) then FPackageNameList.Free;
136 inherited Destroy;
137 end;
138
139 procedure TIBStoredProc.Disconnect;
140 begin
141 Close;
142 UnPrepare;
143 end;
144
145 procedure TIBStoredProc.ExecProc;
146 var
147 DidActivate: Boolean;
148 begin
149 CheckInActive;
150 if StoredProcName = '' then
151 IBError(ibxeNoStoredProcName, [nil]);
152 ActivateConnection;
153 DidActivate := ActivateTransaction;
154 try
155 SetPrepared(True);
156 if DataSource <> nil then SetParamsFromCursor;
157 if FParams.Count > 0 then SetParams;
158 InternalExecQuery;
159 FetchDataIntoOutputParams;
160 finally
161 if DidActivate then
162 DeactivateTransaction;
163 end;
164 end;
165
166 procedure TIBStoredProc.SetProcName(Value: string);
167 begin
168 if Value = FProcName then Exit;
169 CheckInactive;
170 FProcName := Value;
171 UpdateQuery;
172 end;
173
174 function TIBStoredProc.GetParamsCount: Word;
175 begin
176 Result := FParams.Count;
177 end;
178
179 procedure TIBStoredProc.SetFiltered(Value: Boolean);
180 begin
181 if(Filtered <> Value) then
182 begin
183 inherited SetFiltered(value);
184 if Active then
185 begin
186 Close;
187 Open;
188 end;
189 end
190 else
191 inherited SetFiltered(value);
192 end;
193
194 procedure TIBStoredProc.SetFilterText(const Value: string);
195 begin
196 IBError(ibxeIsAExecuteProcedure,[nil]);
197 end;
198
199 procedure TIBStoredProc.InitFieldDefs;
200 begin
201 if (SelectSQL.Text = '') and (FProcName <> '') and (Database <> nil) then
202 GenerateSQL;
203 inherited InitFieldDefs;
204 end;
205
206 procedure TIBStoredProc.GenerateSQL;
207
208 var Params: TStringList;
209
210 function FormatParameter(Dialect: Integer; Value: String): String;
211 var j: integer;
212 begin
213 Value := Trim(Value);
214 if Dialect = 1 then
215 Result := AnsiUpperCase(Value)
216 else
217 begin
218 j := 1;
219 Value := Space2Underscore(AnsiUpperCase(Value));
220 Result := Value;
221 while Params.IndexOf(Result) <> -1 do
222 begin
223 Result := Value + IntToStr(j);
224 Inc(j)
225 end;
226 Params.Add(Result)
227 end;
228 end;
229
230 {Trim and make uppercase unless not an SQL Identifier when leave as it is}
231 function FormatProcName(Dialect: Integer; Value: String): String;
232 begin
233 Value := Trim(Value);
234 if (Dialect = 1) or IsSQLIdentifier(Value) then
235 Result := AnsiUpperCase(Value)
236 else
237 Result := SQLSafeString(Value);
238 end;
239
240 var
241 Query : TIBSQL;
242 input : string;
243 begin
244 input := '';
245 if FProcName = '' then
246 IBError(ibxeNoStoredProcName,[nil]);
247 ActivateConnection;
248 Database.InternalTransaction.StartTransaction;
249 Params := TStringList.Create;
250 Query := TIBSQL.Create(self);
251 try
252 Query.Database := DataBase;
253 Query.Transaction := Database.InternalTransaction;
254 if DatabaseInfo.ODSMajorVersion < 12 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 ' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
260 else
261 if FPackageName = '' then
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 IS NULL' + {do not localize}
267 ' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
268 else
269 Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME, RDB$PARAMETER_TYPE ' + {do not localize}
270 'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
271 'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
272 '''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
273 'AND RDB$PACKAGE_NAME = ' + {do not localize}
274 '''' + FormatProcName(Database.SQLDialect, FPackageName) + '''' +
275 ' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
276 Query.Prepare;
277 Query.GoToFirstRecordOnExecute := False;
278 Query.ExecQuery;
279 while (not Query.EOF) and Query.Next do begin
280 if (Query.FieldByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
281 if (input <> '') then
282 input := input + ', :' +
283 FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
284 input := ':' +
285 FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
286 end
287 end;
288 if FPackageName = '' then
289 SelectSQL.Text := 'Execute Procedure ' + {do not localize}
290 QuoteIdentifierIfNeeded(Database.SQLDialect, FProcName) + ' ' + input
291 else
292 SelectSQL.Text := 'Execute Procedure ' + {do not localize}
293 QuoteIdentifierIfNeeded(Database.SQLDialect,FPackageName) + '.' +
294 QuoteIdentifierIfNeeded(Database.SQLDialect, FProcName) + ' ' + input;
295 // writeln(SelectSQL.Text);
296 finally
297 Query.Free;
298 Params.Free;
299 Database.InternalTransaction.Commit;
300 end;
301 end;
302
303 procedure TIBStoredProc.CreateParamDesc;
304 var
305 i : integer;
306 DataType : TFieldType;
307 begin
308 DataType := ftUnknown;
309 for i := 0 to QSelect.MetaData.Count - 1 do begin
310 case QSelect.MetaData[i].SQLtype of
311 SQL_TYPE_DATE: DataType := ftDate;
312 SQL_TYPE_TIME: DataType := ftTime;
313 SQL_TIMESTAMP: DataType := ftDateTime;
314 SQL_SHORT:
315 if QSelect.MetaData[i].getScale = 0 then
316 DataType := ftSmallInt
317 else
318 DataType := ftBCD;
319 SQL_LONG:
320 if QSelect.MetaData[i].getScale = 0 then
321 DataType := ftInteger
322 else if QSelect.MetaData[i].getScale >= -4 then
323 DataType := ftBCD
324 else
325 DataType := ftFloat;
326 SQL_INT64:
327 if QSelect.MetaData[i].getScale = 0 then
328 DataType := ftLargeInt
329 else if QSelect.MetaData[i].getScale >= -4 then
330 DataType := ftBCD
331 else
332 DataType := ftFloat;
333 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
334 SQL_BOOLEAN:
335 DataType := ftBoolean;
336 SQL_TEXT: DataType := ftString;
337 SQL_VARYING:
338 if QSelect.MetaData[i].GetSize < 1024 then
339 DataType := ftString
340 else DataType := ftBlob;
341 SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
342 end;
343 FParams.CreateParam(DataType, Trim(QSelect.MetaData[i].Name), ptOutput);
344 end;
345
346 DataType := ftUnknown;
347 for i := 0 to QSelect.Params.Count - 1 do begin
348 case QSelect.Params[i].GetSQLtype of
349 SQL_TYPE_DATE: DataType := ftDate;
350 SQL_TYPE_TIME: DataType := ftTime;
351 SQL_TIMESTAMP: DataType := ftDateTime;
352 SQL_SHORT:
353 if QSelect.Params[i].getScale = 0 then
354 DataType := ftSmallInt
355 else
356 DataType := ftBCD;
357 SQL_LONG:
358 if QSelect.Params[i].getScale = 0 then
359 DataType := ftInteger
360 else if QSelect.Params[i].getScale >= -4 then
361 DataType := ftBCD
362 else DataType := ftFloat;
363 SQL_INT64:
364 if QSelect.Params[i].getScale = 0 then
365 DataType := ftLargeInt
366 else if QSelect.Params[i].getScale >= -4 then
367 DataType := ftBCD
368 else DataType := ftFloat;
369 SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
370 SQL_BOOLEAN:
371 DataType := ftBoolean;
372 SQL_TEXT: DataType := ftString;
373 SQL_VARYING:
374 if QSelect.Params[i].GetSize < 1024 then
375 DataType := ftString
376 else DataType := ftBlob;
377 SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
378 end;
379 FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
380 end;
381 end;
382
383 procedure TIBStoredProc.SetPrepared(Value: Boolean);
384 begin
385 if Prepared <> Value then
386 begin
387 if Value then
388 try
389 if SelectSQL.Text = '' then GenerateSQL;
390 InternalPrepare;
391 if FParams.Count = 0 then CreateParamDesc;
392 FPrepared := True;
393 except
394 FreeStatement;
395 raise;
396 end
397 else FreeStatement;
398 end;
399
400 end;
401
402 procedure TIBStoredProc.Prepare;
403 begin
404 SetPrepared(True);
405 end;
406
407 procedure TIBStoredProc.UnPrepare;
408 begin
409 SetPrepared(False);
410 end;
411
412 procedure TIBStoredProc.FreeStatement;
413 begin
414 InternalUnPrepare;
415 FPrepared := False;
416 end;
417
418 procedure TIBStoredProc.SetPrepare(Value: Boolean);
419 begin
420 if Value then Prepare
421 else UnPrepare;
422 end;
423
424 procedure TIBStoredProc.CopyParams(Value: TParams);
425 begin
426 if not Prepared and (FParams.Count = 0) then
427 try
428 Prepare;
429 Value.Assign(FParams);
430 finally
431 UnPrepare;
432 end else
433 Value.Assign(FParams);
434 end;
435
436 procedure TIBStoredProc.SetParamsList(Value: TParams);
437 begin
438 CheckInactive;
439 if Prepared then
440 begin
441 SetPrepared(False);
442 FParams.Assign(Value);
443 SetPrepared(True);
444 end else
445 FParams.Assign(Value);
446 end;
447
448 procedure TIBStoredProc.SetPackageName(AValue: string);
449 begin
450 if FPackageName = AValue then Exit;
451 CheckInactive;
452 FPackageName := AValue;
453 FProcName := '';
454 UpdateQuery;
455 end;
456
457 procedure TIBStoredProc.GetPackageNamesFromServer;
458 var
459 Query : TIBSQL;
460 begin
461 ActivateConnection;
462 if (csReading in ComponentState) or (DatabaseInfo.ODSMajorVersion < 12) then Exit;
463 Database.InternalTransaction.StartTransaction;
464 Query := TIBSQL.Create(self);
465 try
466 Query.GoToFirstRecordOnExecute := False;
467 Query.Database := DataBase;
468 Query.Transaction := Database.InternalTransaction;
469 Query.SQL.Text := 'Select distinct RDB$PACKAGE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is not null'; {do not localize}
470 Query.Prepare;
471 Query.ExecQuery;
472 while (not Query.EOF) and Query.Next do
473 FPackageNameList.Add(TrimRight(Query.Current.ByName('RDB$PACKAGE_NAME').AsString)); {do not localize}
474 finally
475 Query.Free;
476 Database.InternalTransaction.Commit;
477 end;
478 end;
479
480 function TIBStoredProc.GetPackageNames: TStrings;
481 begin
482 FPackageNameList.Clear;
483 GetPackageNamesFromServer;
484 Result := FPackageNameList;
485 end;
486
487 function TIBStoredProc.ParamByName(const Value: string): TParam;
488 begin
489 Prepare;
490 Result := FParams.ParamByName(Value);
491 end;
492
493 function TIBStoredProc.GetStoredProcedureNames: TStrings;
494 begin
495 FNameList.clear;
496 GetStoredProcedureNamesFromServer;
497 Result := FNameList;
498 end;
499
500 procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
501 var
502 Query : TIBSQL;
503 begin
504 if not (csReading in ComponentState) then begin
505 ActivateConnection;
506 Database.InternalTransaction.StartTransaction;
507 Query := TIBSQL.Create(self);
508 try
509 Query.GoToFirstRecordOnExecute := False;
510 Query.Database := DataBase;
511 Query.Transaction := Database.InternalTransaction;
512 if DatabaseInfo.ODSMajorVersion < 12 then
513 Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES' {do not localize}
514 else
515 if FPackageName = '' then
516 Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is NULL' {do not localize}
517 else
518 Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME = ''' + {do not localize}
519 SQLSafeString(FPackageName) + '''';
520 Query.Prepare;
521 Query.ExecQuery;
522 while (not Query.EOF) and Query.Next do
523 FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
524 finally
525 Query.Free;
526 Database.InternalTransaction.Commit;
527 end;
528 end;
529 end;
530
531 procedure TIBStoredProc.SetParams;
532 var
533 i : integer;
534 j: integer;
535 begin
536 i := 0;
537 for j := 0 to FParams.Count - 1 do
538 begin
539 if (Params[j].ParamType <> ptInput) then
540 continue;
541 if not Params[j].Bound then
542 IBError(ibxeRequiredParamNotSet, [Params[j].Name]);
543 if Params[j].IsNull then
544 SQLParams[i].IsNull := True
545 else begin
546 SQLParams[i].IsNull := False;
547 case Params[j].DataType of
548 ftString:
549 SQLParams[i].AsString := Params[j].AsString;
550 ftSmallint, ftWord:
551 SQLParams[i].AsShort := Params[j].AsSmallInt;
552 ftBoolean:
553 SQLParams[i].AsBoolean := Params[j].AsBoolean;
554 ftInteger:
555 SQLParams[i].AsLong := Params[j].AsInteger;
556 ftLargeInt:
557 SQLParams[i].AsInt64 := Params[j].AsLargeInt;
558 ftFloat, ftCurrency:
559 SQLParams[i].AsDouble := Params[j].AsFloat;
560 ftBCD:
561 SQLParams[i].AsCurrency := Params[j].AsCurrency;
562 ftDate:
563 SQLParams[i].AsDate := Params[j].AsDateTime;
564 ftTime:
565 SQLParams[i].AsTime := Params[j].AsDateTime;
566 ftDateTime:
567 SQLParams[i].AsDateTime := Params[j].AsDateTime;
568 ftBlob, ftMemo:
569 SQLParams[i].AsString := Params[j].AsString;
570 else
571 IBError(ibxeNotSupported, [nil]);
572 end;
573 end;
574 Inc(i);
575 end;
576 end;
577
578 procedure TIBStoredProc.SetParamsFromCursor;
579 var
580 I: Integer;
581 DataSet: TDataSet;
582 begin
583 if DataSource <> nil then
584 begin
585 DataSet := DataSource.DataSet;
586 if DataSet <> nil then
587 begin
588 DataSet.FieldDefs.Update;
589 for I := 0 to FParams.Count - 1 do
590 with FParams[I] do
591 if (not Bound) and
592 ((ParamType = ptInput) or (ParamType = ptInputOutput)) then
593 AssignField(DataSet.FieldByName(Name));
594 end;
595 end;
596 end;
597
598 procedure TIBStoredProc.FetchDataIntoOutputParams;
599 var
600 i,j : Integer;
601 begin
602 j := 0;
603 for i := 0 to FParams.Count - 1 do
604 with Params[I] do
605 if ParamType = ptOutput then begin
606 Value := QSelect.Fields[j].Value;
607 Inc(j);
608 end;
609 end;
610
611 procedure TIBStoredProc.InternalOpen;
612 begin
613 IBError(ibxeIsAExecuteProcedure,[nil]);
614 end;
615
616 procedure TIBStoredProc.DefineProperties(Filer: TFiler);
617
618 function WriteData: Boolean;
619 begin
620 if Filer.Ancestor <> nil then
621 Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
622 Result := FParams.Count > 0;
623 end;
624
625 begin
626 inherited DefineProperties(Filer);
627 Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
628 end;
629
630 procedure TIBStoredProc.WriteParamData(Writer: TWriter);
631 begin
632 Writer.WriteCollection(Params);
633 end;
634
635 procedure TIBStoredProc.UpdateQuery;
636 begin
637 if not (csReading in ComponentState) then
638 begin
639 FreeStatement;
640 FParams.Clear;
641 if (FProcName <> '') and (Database <> nil) then
642 begin
643 GenerateSQL;
644 if csDesigning in ComponentState then
645 begin
646 Prepare; {Fills the Params collection}
647 UnPrepare;
648 end;
649 end;
650 end
651 else
652 begin
653 if (FProcName <> '') and (Database <> nil) then
654 GenerateSQL;
655 end;
656 end;
657
658 procedure TIBStoredProc.ReadParamData(Reader: TReader);
659 begin
660 Reader.ReadValue;
661 Reader.ReadCollection(Params);
662 end;
663
664 end.