ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBStoredProc.pas
(Generate patch)

Comparing ibx/trunk/runtime/IBStoredProc.pas (file contents):
Revision 7 by tony, Sun Aug 5 18:28:19 2012 UTC vs.
Revision 17 by tony, Sat Dec 28 19:22:24 2013 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 < {    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.
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.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines