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