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}

{$codepage UTF8}

interface

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

  TIBStoredProc = class(TIBCustomDataSet)
  private
    FStmtHandle: IStatement;
    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: IStatement 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  FBMessages;

{ TIBStoredProc }

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

destructor TIBStoredProc.Destroy;
begin
  Destroying;
  Disconnect;
  if assigned (FParams) then FParams.Free;
  if assigned(FNameList) then FNameList.Destroy;
  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 do begin
      if (Query.FieldByName('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.MetaData.Count - 1 do begin
  case QSelect.MetaData[i].SQLtype of
    SQL_TYPE_DATE: DataType := ftDate;
    SQL_TYPE_TIME: DataType := ftTime;
    SQL_TIMESTAMP: DataType := ftDateTime;
    SQL_SHORT:
      if QSelect.MetaData[i].getScale = 0 then
        DataType := ftSmallInt
      else
        DataType := ftBCD;
    SQL_LONG:
      if QSelect.MetaData[i].getScale = 0 then
        DataType := ftInteger
      else if QSelect.MetaData[i].getScale >= -4 then
        DataType := ftBCD
      else
        DataType := ftFloat;
    SQL_INT64:
      if QSelect.MetaData[i].getScale = 0 then
        DataType := ftLargeInt
      else if QSelect.MetaData[i].getScale >= -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.MetaData[i].GetSize < 1024 then
        DataType := ftString
      else DataType := ftBlob;
    SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
    end;
    FParams.CreateParam(DataType, Trim(QSelect.MetaData[i].Name), ptOutput);
  end;

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