trunk/runtime/IBStoredProc.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011                                                 }
{                                                                        }
{************************************************************************}

unit IBStoredProc;

{$Mode Delphi}

interface

uses SysUtils, Classes, DB, IB, IBDatabase, IBCustomDataSet,
     IBHeader, IBSQL, IBUtils;
     
{ TIBStoredProc }
type

  TIBStoredProc = class(TIBCustomDataSet)
  private
    FIBLoaded: Boolean;
    FStmtHandle: TISC_STMT_HANDLE;
    FProcName: string;
    FParams: TParams;
    FPrepared: Boolean;
    FNameList: TStrings;
    procedure SetParamsList(Value: TParams);
    procedure FreeStatement;
    function GetStoredProcedureNames: TStrings;
    procedure GetStoredProcedureNamesFromServer;
    procedure CreateParamDesc;
    procedure SetParams;
    procedure SetParamsFromCursor;
    procedure GenerateSQL;
    procedure FetchDataIntoOutputParams;
    procedure ReadParamData(Reader: TReader);
    procedure WriteParamData(Writer: TWriter);

  protected

    procedure DefineProperties(Filer: TFiler); override;
    procedure SetFiltered(Value: Boolean); override;
    procedure InitFieldDefs; override;
    function GetParamsCount: Word;
    procedure SetPrepared(Value: Boolean);
    procedure SetPrepare(Value: Boolean);
    procedure SetProcName(Value: string);
    procedure Disconnect; override;
    procedure InternalOpen; override;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyParams(Value: TParams);
    procedure ExecProc;
    function ParamByName(const Value: string): TParam;
    procedure Prepare;
    procedure UnPrepare;
    property ParamCount: Word read GetParamsCount;
    property StmtHandle: TISC_STMT_HANDLE read FStmtHandle;
    property Prepared: Boolean read FPrepared write SetPrepare;
    property StoredProcedureNames: TStrings read GetStoredProcedureNames;

  published
    property StoredProcName: string read FProcName write SetProcName;
    property Params: TParams read FParams write SetParamsList;
    property Filtered;

    property BeforeDatabaseDisconnect;
    property AfterDatabaseDisconnect;
    property DatabaseFree;
    property BeforeTransactionEnd;
    property AfterTransactionEnd;
    property TransactionFree;
    property OnFilterRecord;
  end;

implementation

 uses
   IBIntf;

{ TIBStoredProc }

constructor TIBStoredProc.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIBLoaded := False;
  CheckIBLoaded;
  FIBLoaded := True;
  FParams := TParams.Create (self);
  FNameList := TStringList.Create;
end;

destructor TIBStoredProc.Destroy;
begin
  if FIBLoaded then
  begin
    Destroying;
    Disconnect;
    FParams.Free;
    FNameList.Destroy;
  end;
  inherited Destroy;
end;

procedure TIBStoredProc.Disconnect;
begin
  Close;
  UnPrepare;
end;

procedure TIBStoredProc.ExecProc;
var
  DidActivate: Boolean;
begin
  CheckInActive;
  if StoredProcName = '' then
    IBError(ibxeNoStoredProcName, [nil]);
  ActivateConnection;
  DidActivate := ActivateTransaction;
  try
    SetPrepared(True);
    if DataSource <> nil then SetParamsFromCursor;
    if FParams.Count > 0 then SetParams;
    InternalExecQuery;
    FetchDataIntoOutputParams;
  finally
    if DidActivate then
      DeactivateTransaction;
  end;
end;

procedure TIBStoredProc.SetProcName(Value: string);
begin
  if not (csReading in ComponentState) then
  begin
    CheckInactive;
    if Value <> FProcName then
    begin
      FProcName := Value;
      FreeStatement;
      FParams.Clear;
      if (Value <> '') and
        (Database <> nil) then
        GenerateSQL;
    end;
  end else begin
    FProcName := Value;
  if (Value <> '') and
    (Database <> nil) then
    GenerateSQL;
  end;
end;

function TIBStoredProc.GetParamsCount: Word;
begin
  Result := FParams.Count;
end;

procedure TIBStoredProc.SetFiltered(Value: Boolean);
begin
  if(Filtered <> Value) then
  begin
    inherited SetFiltered(value);
    if Active then
    begin
      Close;
      Open;
    end;
  end
  else
    inherited SetFiltered(value);
end;

 procedure TIBStoredProc.InitFieldDefs;
begin
  if SelectSQL.Text = '' then
     GenerateSQL;
  inherited InitFieldDefs;
end;

procedure TIBStoredProc.GenerateSQL;

var Params: TStringList;

  function FormatParameter(Dialect: Integer; Value: String): String;
  var j: integer;
  begin
    Value := Trim(Value);
    if Dialect = 1 then
       Result := AnsiUpperCase(Value)
    else
    begin
      j := 1;
      Value := Space2Underscore(AnsiUpperCase(Value));
      Result := Value;
      while Params.IndexOf(Result) <> -1 do
      begin
        Result := Value + IntToStr(j);
        Inc(j)
      end;
      Params.Add(Result)
    end;
  end;

var
  Query : TIBSQL;
  input : string;
begin
  input := '';
  if FProcName = '' then
     IBError(ibxeNoStoredProcName,[nil]);
  ActivateConnection;
  Database.InternalTransaction.StartTransaction;
  Params := TStringList.Create;
  Query := TIBSQL.Create(self);
  try
    Query.Database := DataBase;
    Query.Transaction := Database.InternalTransaction;
    Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME,  RDB$PARAMETER_TYPE ' + {do not localize}
                       'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
                       'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
                       '''' + FormatIdentifierValue(Database.SQLDialect, FProcName) + '''' +
                       ' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
    Query.Prepare;
    Query.GoToFirstRecordOnExecute := False;
    Query.ExecQuery;
    while (not Query.EOF) and (Query.Next <> nil) do begin
      if (Query.Current.ByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
        if (input <> '') then
          input := input + ', :' +
            FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
          input := ':' +
            FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
      end
    end;
    SelectSQL.Text := 'Execute Procedure ' + {do not localize}
                FormatParameter(Database.SQLDialect, FProcName) + ' ' + input;
 {   writeln(SelectSQL.Text);}
  finally
    Query.Free;
    Params.Free;
    Database.InternalTransaction.Commit;
  end;
end;

procedure TIBStoredProc.CreateParamDesc;
var
  i : integer;
  DataType : TFieldType;
begin
  DataType := ftUnknown;
  for i := 0 to QSelect.Current.Count - 1 do begin
  case QSelect.Fields[i].SQLtype of
    SQL_TYPE_DATE: DataType := ftDate;
    SQL_TYPE_TIME: DataType := ftTime;
    SQL_TIMESTAMP: DataType := ftDateTime;
    SQL_SHORT:
      if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
        DataType := ftSmallInt
      else
        DataType := ftBCD;
    SQL_LONG:
      if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
        DataType := ftInteger
      else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
        DataType := ftBCD
      else
        DataType := ftFloat;
    SQL_INT64:
      if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
        DataType := ftLargeInt
      else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
        DataType := ftBCD
      else
        DataType := ftFloat;
    SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
    SQL_BOOLEAN:
      DataType := ftBoolean;
    SQL_TEXT: DataType := ftString;
    SQL_VARYING:
      if ((QSelect.Fields[i].AsXSQLVar)^.sqllen < 1024) then
        DataType := ftString
      else DataType := ftBlob;
    SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
    end;
    FParams.CreateParam(DataType, Trim(QSelect.Fields[i].Name), ptOutput);
  end;

  DataType := ftUnknown;
  for i := 0 to QSelect.Params.Count - 1 do begin
  case QSelect.Params[i].SQLtype of
    SQL_TYPE_DATE: DataType := ftDate;
    SQL_TYPE_TIME: DataType := ftTime;
    SQL_TIMESTAMP: DataType := ftDateTime;
    SQL_SHORT:
      if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
        DataType := ftSmallInt
      else
        DataType := ftBCD;
    SQL_LONG:
      if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
        DataType := ftInteger
      else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
        DataType := ftBCD
      else DataType := ftFloat;
    SQL_INT64:
      if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
        DataType := ftLargeInt
      else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
        DataType := ftBCD
      else DataType := ftFloat;
    SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
    SQL_BOOLEAN:
      DataType := ftBoolean;
    SQL_TEXT: DataType := ftString;
    SQL_VARYING:
      if ((QSelect.Params[i].AsXSQLVar)^.sqllen < 1024) then
        DataType := ftString
      else DataType := ftBlob;
    SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
    end;
    FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
  end;
end;

procedure TIBStoredProc.SetPrepared(Value: Boolean);
begin
  if Prepared <> Value then
  begin
    if Value then
      try
        if SelectSQL.Text = '' then GenerateSQL;
        InternalPrepare;
        if FParams.Count = 0 then CreateParamDesc;
        FPrepared := True;
      except
        FreeStatement;
        raise;
      end
    else FreeStatement;
  end;

end;

procedure TIBStoredProc.Prepare;
begin
  SetPrepared(True);
end;

procedure TIBStoredProc.UnPrepare;
begin
  SetPrepared(False);
end;

procedure TIBStoredProc.FreeStatement;
begin
  InternalUnPrepare;
  FPrepared := False;
end;

procedure TIBStoredProc.SetPrepare(Value: Boolean);
begin
  if Value then Prepare
  else UnPrepare;
end;

procedure TIBStoredProc.CopyParams(Value: TParams);
begin
  if not Prepared and (FParams.Count = 0) then
  try
    Prepare;
    Value.Assign(FParams);
  finally
    UnPrepare;
  end else
    Value.Assign(FParams);
end;

procedure TIBStoredProc.SetParamsList(Value: TParams);
begin
  CheckInactive;
  if Prepared then
  begin
    SetPrepared(False);
    FParams.Assign(Value);
    SetPrepared(True);
  end else
    FParams.Assign(Value);
end;

function TIBStoredProc.ParamByName(const Value: string): TParam;
begin
  Result := FParams.ParamByName(Value);
end;

function TIBStoredProc.GetStoredProcedureNames: TStrings;
begin
  FNameList.clear;
  GetStoredProcedureNamesFromServer;
  Result := FNameList;
end;

procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
var
  Query : TIBSQL;
begin
  if not (csReading in ComponentState) then begin
    ActivateConnection;
    Database.InternalTransaction.StartTransaction;
    Query := TIBSQL.Create(self);
    try
      Query.GoToFirstRecordOnExecute := False;
      Query.Database := DataBase;
      Query.Transaction := Database.InternalTransaction;
      Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES'; {do not localize}
      Query.Prepare;
      Query.ExecQuery;
      while (not Query.EOF) and (Query.Next <> nil) do
        FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
    finally
      Query.Free;
      Database.InternalTransaction.Commit;
    end;
  end;
end;

procedure TIBStoredProc.SetParams;
var
i : integer;
j: integer;
begin
  i := 0;
  for j := 0 to FParams.Count - 1 do
  begin
    if (Params[j].ParamType <> ptInput) then
      continue;
    if not Params[j].Bound then
      IBError(ibxeRequiredParamNotSet, [nil]);
    if Params[j].IsNull then
      SQLParams[i].IsNull := True
    else begin
      SQLParams[i].IsNull := False;
      case Params[j].DataType of
        ftString:
          SQLParams[i].AsString := Params[j].AsString;
        ftSmallint, ftWord:
          SQLParams[i].AsShort := Params[j].AsSmallInt;
        ftBoolean:
           SQLParams[i].AsBoolean := Params[j].AsBoolean;
        ftInteger:
          SQLParams[i].AsLong := Params[j].AsInteger;
        ftLargeInt:
          SQLParams[i].AsInt64 := Params[j].AsLargeInt;
        ftFloat, ftCurrency:
         SQLParams[i].AsDouble := Params[j].AsFloat;
        ftBCD:
          SQLParams[i].AsCurrency := Params[j].AsCurrency;
        ftDate:
          SQLParams[i].AsDate := Params[j].AsDateTime;
        ftTime:
          SQLParams[i].AsTime := Params[j].AsDateTime;
        ftDateTime:
          SQLParams[i].AsDateTime := Params[j].AsDateTime;
        ftBlob, ftMemo:
          SQLParams[i].AsString := Params[j].AsString;
        else
          IBError(ibxeNotSupported, [nil]);
      end;
    end;
    Inc(i);
  end;
end;

procedure TIBStoredProc.SetParamsFromCursor;
var
  I: Integer;
  DataSet: TDataSet;
begin
  if DataSource <> nil then
  begin
    DataSet := DataSource.DataSet;
    if DataSet <> nil then
    begin
      DataSet.FieldDefs.Update;
      for I := 0 to FParams.Count - 1 do
        with FParams[I] do
          if (not Bound) and
            ((ParamType = ptInput) or (ParamType =  ptInputOutput)) then
            AssignField(DataSet.FieldByName(Name));
    end;
  end;
end;

procedure TIBStoredProc.FetchDataIntoOutputParams;
var
i,j : Integer;
begin
  j := 0;
  for i := 0 to FParams.Count - 1 do
    with Params[I] do
      if ParamType = ptOutput then begin
         Value := QSelect.Fields[j].Value;
         Inc(j);
      end;
end;

procedure TIBStoredProc.InternalOpen;
begin
  IBError(ibxeIsAExecuteProcedure,[nil]);
end;

procedure TIBStoredProc.DefineProperties(Filer: TFiler);

  function WriteData: Boolean;
  begin
    if Filer.Ancestor <> nil then
      Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
      Result := FParams.Count > 0;
  end;

begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
end;

procedure TIBStoredProc.WriteParamData(Writer: TWriter);
begin
  Writer.WriteCollection(Params);
end;

procedure TIBStoredProc.ReadParamData(Reader: TReader);
begin
  Reader.ReadValue;
  Reader.ReadCollection(Params);
end;

end.
Revision:	23
Committed:	Fri Mar 13 10:26:52 2015 UTC (9 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	16795 byte(s)
Log Message:	Committing updates for Release R1-2-1
#	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	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	procedure InitFieldDefs; override;
71	function GetParamsCount: Word;
72	procedure SetPrepared(Value: Boolean);
73	procedure SetPrepare(Value: Boolean);
74	procedure SetProcName(Value: string);
75	procedure Disconnect; override;
76	procedure InternalOpen; override;
77
78	public
79	constructor Create(AOwner: TComponent); override;
80	destructor Destroy; override;
81	procedure CopyParams(Value: TParams);
82	procedure ExecProc;
83	function ParamByName(const Value: string): TParam;
84	procedure Prepare;
85	procedure UnPrepare;
86	property ParamCount: Word read GetParamsCount;
87	property StmtHandle: TISC_STMT_HANDLE read FStmtHandle;
88	property Prepared: Boolean read FPrepared write SetPrepare;
89	property StoredProcedureNames: TStrings read GetStoredProcedureNames;
90
91	published
92	property StoredProcName: string read FProcName write SetProcName;
93	property Params: TParams read FParams write SetParamsList;
94	property Filtered;
95
96	property BeforeDatabaseDisconnect;
97	property AfterDatabaseDisconnect;
98	property DatabaseFree;
99	property BeforeTransactionEnd;
100	property AfterTransactionEnd;
101	property TransactionFree;
102	property OnFilterRecord;
103	end;
104
105	implementation
106
107	uses
108	IBIntf;
109
110	{ TIBStoredProc }
111
112	constructor TIBStoredProc.Create(AOwner: TComponent);
113	begin
114	inherited Create(AOwner);
115	FIBLoaded := False;
116	CheckIBLoaded;
117	FIBLoaded := True;
118	FParams := TParams.Create (self);
119	FNameList := TStringList.Create;
120	end;
121
122	destructor TIBStoredProc.Destroy;
123	begin
124	if FIBLoaded then
125	begin
126	Destroying;
127	Disconnect;
128	FParams.Free;
129	FNameList.Destroy;
130	end;
131	inherited Destroy;
132	end;
133
134	procedure TIBStoredProc.Disconnect;
135	begin
136	Close;
137	UnPrepare;
138	end;
139
140	procedure TIBStoredProc.ExecProc;
141	var
142	DidActivate: Boolean;
143	begin
144	CheckInActive;
145	if StoredProcName = '' then
146	IBError(ibxeNoStoredProcName, [nil]);
147	ActivateConnection;
148	DidActivate := ActivateTransaction;
149	try
150	SetPrepared(True);
151	if DataSource <> nil then SetParamsFromCursor;
152	if FParams.Count > 0 then SetParams;
153	InternalExecQuery;
154	FetchDataIntoOutputParams;
155	finally
156	if DidActivate then
157	DeactivateTransaction;
158	end;
159	end;
160
161	procedure TIBStoredProc.SetProcName(Value: string);
162	begin
163	if not (csReading in ComponentState) then
164	begin
165	CheckInactive;
166	if Value <> FProcName then
167	begin
168	FProcName := Value;
169	FreeStatement;
170	FParams.Clear;
171	if (Value <> '') and
172	(Database <> nil) then
173	GenerateSQL;
174	end;
175	end else begin
176	FProcName := Value;
177	if (Value <> '') and
178	(Database <> nil) then
179	GenerateSQL;
180	end;
181	end;
182
183	function TIBStoredProc.GetParamsCount: Word;
184	begin
185	Result := FParams.Count;
186	end;
187
188	procedure TIBStoredProc.SetFiltered(Value: Boolean);
189	begin
190	if(Filtered <> Value) then
191	begin
192	inherited SetFiltered(value);
193	if Active then
194	begin
195	Close;
196	Open;
197	end;
198	end
199	else
200	inherited SetFiltered(value);
201	end;
202
203	procedure TIBStoredProc.InitFieldDefs;
204	begin
205	if SelectSQL.Text = '' then
206	GenerateSQL;
207	inherited InitFieldDefs;
208	end;
209
210	procedure TIBStoredProc.GenerateSQL;
211
212	var Params: TStringList;
213
214	function FormatParameter(Dialect: Integer; Value: String): String;
215	var j: integer;
216	begin
217	Value := Trim(Value);
218	if Dialect = 1 then
219	Result := AnsiUpperCase(Value)
220	else
221	begin
222	j := 1;
223	Value := Space2Underscore(AnsiUpperCase(Value));
224	Result := Value;
225	while Params.IndexOf(Result) <> -1 do
226	begin
227	Result := Value + IntToStr(j);
228	Inc(j)
229	end;
230	Params.Add(Result)
231	end;
232	end;
233
234	var
235	Query : TIBSQL;
236	input : string;
237	begin
238	input := '';
239	if FProcName = '' then
240	IBError(ibxeNoStoredProcName,[nil]);
241	ActivateConnection;
242	Database.InternalTransaction.StartTransaction;
243	Params := TStringList.Create;
244	Query := TIBSQL.Create(self);
245	try
246	Query.Database := DataBase;
247	Query.Transaction := Database.InternalTransaction;
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	'''' + FormatIdentifierValue(Database.SQLDialect, FProcName) + '''' +
252	' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
253	Query.Prepare;
254	Query.GoToFirstRecordOnExecute := False;
255	Query.ExecQuery;
256	while (not Query.EOF) and (Query.Next <> nil) do begin
257	if (Query.Current.ByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
258	if (input <> '') then
259	input := input + ', :' +
260	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
261	input := ':' +
262	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
263	end
264	end;
265	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
266	FormatParameter(Database.SQLDialect, FProcName) + ' ' + input;
267	{ writeln(SelectSQL.Text);}
268	finally
269	Query.Free;
270	Params.Free;
271	Database.InternalTransaction.Commit;
272	end;
273	end;
274
275	procedure TIBStoredProc.CreateParamDesc;
276	var
277	i : integer;
278	DataType : TFieldType;
279	begin
280	DataType := ftUnknown;
281	for i := 0 to QSelect.Current.Count - 1 do begin
282	case QSelect.Fields[i].SQLtype of
283	SQL_TYPE_DATE: DataType := ftDate;
284	SQL_TYPE_TIME: DataType := ftTime;
285	SQL_TIMESTAMP: DataType := ftDateTime;
286	SQL_SHORT:
287	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
288	DataType := ftSmallInt
289	else
290	DataType := ftBCD;
291	SQL_LONG:
292	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
293	DataType := ftInteger
294	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
295	DataType := ftBCD
296	else
297	DataType := ftFloat;
298	SQL_INT64:
299	if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale = 0) then
300	DataType := ftLargeInt
301	else if ((QSelect.Fields[i].AsXSQLVar)^.sqlscale >= (-4)) then
302	DataType := ftBCD
303	else
304	DataType := ftFloat;
305	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
306	SQL_BOOLEAN:
307	DataType := ftBoolean;
308	SQL_TEXT: DataType := ftString;
309	SQL_VARYING:
310	if ((QSelect.Fields[i].AsXSQLVar)^.sqllen < 1024) then
311	DataType := ftString
312	else DataType := ftBlob;
313	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
314	end;
315	FParams.CreateParam(DataType, Trim(QSelect.Fields[i].Name), ptOutput);
316	end;
317
318	DataType := ftUnknown;
319	for i := 0 to QSelect.Params.Count - 1 do begin
320	case QSelect.Params[i].SQLtype of
321	SQL_TYPE_DATE: DataType := ftDate;
322	SQL_TYPE_TIME: DataType := ftTime;
323	SQL_TIMESTAMP: DataType := ftDateTime;
324	SQL_SHORT:
325	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
326	DataType := ftSmallInt
327	else
328	DataType := ftBCD;
329	SQL_LONG:
330	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
331	DataType := ftInteger
332	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
333	DataType := ftBCD
334	else DataType := ftFloat;
335	SQL_INT64:
336	if ((QSelect.Params[i].AsXSQLVar)^.sqlscale = 0) then
337	DataType := ftLargeInt
338	else if ((QSelect.Params[i].AsXSQLVar)^.sqlscale >= (-4)) then
339	DataType := ftBCD
340	else DataType := ftFloat;
341	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
342	SQL_BOOLEAN:
343	DataType := ftBoolean;
344	SQL_TEXT: DataType := ftString;
345	SQL_VARYING:
346	if ((QSelect.Params[i].AsXSQLVar)^.sqllen < 1024) then
347	DataType := ftString
348	else DataType := ftBlob;
349	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
350	end;
351	FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
352	end;
353	end;
354
355	procedure TIBStoredProc.SetPrepared(Value: Boolean);
356	begin
357	if Prepared <> Value then
358	begin
359	if Value then
360	try
361	if SelectSQL.Text = '' then GenerateSQL;
362	InternalPrepare;
363	if FParams.Count = 0 then CreateParamDesc;
364	FPrepared := True;
365	except
366	FreeStatement;
367	raise;
368	end
369	else FreeStatement;
370	end;
371
372	end;
373
374	procedure TIBStoredProc.Prepare;
375	begin
376	SetPrepared(True);
377	end;
378
379	procedure TIBStoredProc.UnPrepare;
380	begin
381	SetPrepared(False);
382	end;
383
384	procedure TIBStoredProc.FreeStatement;
385	begin
386	InternalUnPrepare;
387	FPrepared := False;
388	end;
389
390	procedure TIBStoredProc.SetPrepare(Value: Boolean);
391	begin
392	if Value then Prepare
393	else UnPrepare;
394	end;
395
396	procedure TIBStoredProc.CopyParams(Value: TParams);
397	begin
398	if not Prepared and (FParams.Count = 0) then
399	try
400	Prepare;
401	Value.Assign(FParams);
402	finally
403	UnPrepare;
404	end else
405	Value.Assign(FParams);
406	end;
407
408	procedure TIBStoredProc.SetParamsList(Value: TParams);
409	begin
410	CheckInactive;
411	if Prepared then
412	begin
413	SetPrepared(False);
414	FParams.Assign(Value);
415	SetPrepared(True);
416	end else
417	FParams.Assign(Value);
418	end;
419
420	function TIBStoredProc.ParamByName(const Value: string): TParam;
421	begin
422	Result := FParams.ParamByName(Value);
423	end;
424
425	function TIBStoredProc.GetStoredProcedureNames: TStrings;
426	begin
427	FNameList.clear;
428	GetStoredProcedureNamesFromServer;
429	Result := FNameList;
430	end;
431
432	procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
433	var
434	Query : TIBSQL;
435	begin
436	if not (csReading in ComponentState) then begin
437	ActivateConnection;
438	Database.InternalTransaction.StartTransaction;
439	Query := TIBSQL.Create(self);
440	try
441	Query.GoToFirstRecordOnExecute := False;
442	Query.Database := DataBase;
443	Query.Transaction := Database.InternalTransaction;
444	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES'; {do not localize}
445	Query.Prepare;
446	Query.ExecQuery;
447	while (not Query.EOF) and (Query.Next <> nil) do
448	FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
449	finally
450	Query.Free;
451	Database.InternalTransaction.Commit;
452	end;
453	end;
454	end;
455
456	procedure TIBStoredProc.SetParams;
457	var
458	i : integer;
459	j: integer;
460	begin
461	i := 0;
462	for j := 0 to FParams.Count - 1 do
463	begin
464	if (Params[j].ParamType <> ptInput) then
465	continue;
466	if not Params[j].Bound then
467	IBError(ibxeRequiredParamNotSet, [nil]);
468	if Params[j].IsNull then
469	SQLParams[i].IsNull := True
470	else begin
471	SQLParams[i].IsNull := False;
472	case Params[j].DataType of
473	ftString:
474	SQLParams[i].AsString := Params[j].AsString;
475	ftSmallint, ftWord:
476	SQLParams[i].AsShort := Params[j].AsSmallInt;
477	ftBoolean:
478	SQLParams[i].AsBoolean := Params[j].AsBoolean;
479	ftInteger:
480	SQLParams[i].AsLong := Params[j].AsInteger;
481	ftLargeInt:
482	SQLParams[i].AsInt64 := Params[j].AsLargeInt;
483	ftFloat, ftCurrency:
484	SQLParams[i].AsDouble := Params[j].AsFloat;
485	ftBCD:
486	SQLParams[i].AsCurrency := Params[j].AsCurrency;
487	ftDate:
488	SQLParams[i].AsDate := Params[j].AsDateTime;
489	ftTime:
490	SQLParams[i].AsTime := Params[j].AsDateTime;
491	ftDateTime:
492	SQLParams[i].AsDateTime := Params[j].AsDateTime;
493	ftBlob, ftMemo:
494	SQLParams[i].AsString := Params[j].AsString;
495	else
496	IBError(ibxeNotSupported, [nil]);
497	end;
498	end;
499	Inc(i);
500	end;
501	end;
502
503	procedure TIBStoredProc.SetParamsFromCursor;
504	var
505	I: Integer;
506	DataSet: TDataSet;
507	begin
508	if DataSource <> nil then
509	begin
510	DataSet := DataSource.DataSet;
511	if DataSet <> nil then
512	begin
513	DataSet.FieldDefs.Update;
514	for I := 0 to FParams.Count - 1 do
515	with FParams[I] do
516	if (not Bound) and
517	((ParamType = ptInput) or (ParamType = ptInputOutput)) then
518	AssignField(DataSet.FieldByName(Name));
519	end;
520	end;
521	end;
522
523	procedure TIBStoredProc.FetchDataIntoOutputParams;
524	var
525	i,j : Integer;
526	begin
527	j := 0;
528	for i := 0 to FParams.Count - 1 do
529	with Params[I] do
530	if ParamType = ptOutput then begin
531	Value := QSelect.Fields[j].Value;
532	Inc(j);
533	end;
534	end;
535
536	procedure TIBStoredProc.InternalOpen;
537	begin
538	IBError(ibxeIsAExecuteProcedure,[nil]);
539	end;
540
541	procedure TIBStoredProc.DefineProperties(Filer: TFiler);
542
543	function WriteData: Boolean;
544	begin
545	if Filer.Ancestor <> nil then
546	Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
547	Result := FParams.Count > 0;
548	end;
549
550	begin
551	inherited DefineProperties(Filer);
552	Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
553	end;
554
555	procedure TIBStoredProc.WriteParamData(Writer: TWriter);
556	begin
557	Writer.WriteCollection(Params);
558	end;
559
560	procedure TIBStoredProc.ReadParamData(Reader: TReader);
561	begin
562	Reader.ReadValue;
563	Reader.ReadCollection(Params);
564	end;
565
566	end.