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}

{$IF FPC_FULLVERSION >= 20700 }
{$codepage UTF8}
{$ENDIF}

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