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                                       }
{                                                                        }
{************************************************************************}

unit IBStoredProc;

interface

uses Windows, SysUtils, Graphics, Classes, Controls, Db, StdVCL, 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
    { IProviderSupport }
    procedure PSExecute; override;
    function PSGetTableName: string; override;
    function PSGetParams: TParams; override;
    procedure PSSetCommandText(const CommandText: string); override;
    procedure PSSetParams(AParams: TParams); override;

    procedure DefineProperties(Filer: TFiler); override;
    procedure SetFiltered(Value: Boolean); 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.GenerateSQL;
var
  Query : TIBSQL;
  input : string;
begin
  ActivateConnection;
  Database.InternalTransaction.StartTransaction;
  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 + ', :' +
            FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
          input := ':' +
            FormatIdentifier(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
      end
    end;
    SelectSQL.Text := 'Execute Procedure ' + {do not localize}
                FormatIdentifier(Database.SQLDialect, FProcName) + ' ' + input;
  finally
    Query.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_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_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;
        ftBoolean, ftSmallint, ftWord:
          SQLParams[i].AsShort := Params[j].AsSmallInt;
        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;

{ TIBStoredProc IProviderSupport }

function TIBStoredProc.PSGetParams: TParams;
begin
  Result := Params;
end;

procedure TIBStoredProc.PSSetParams(AParams: TParams);
begin
  if AParams.Count > 0 then
    Params.Assign(AParams);
  Close;
end;

function TIBStoredProc.PSGetTableName: string;
begin
  { ! }
end;

procedure TIBStoredProc.PSExecute;
begin
  ExecProc;
end;

procedure TIBStoredProc.PSSetCommandText(const CommandText: string);
begin
  if CommandText <> '' then
    StoredProcName := CommandText;
end;

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