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;

{$Mode Delphi}

interface

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

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

  protected

    procedure DefineProperties(Filer: TFiler); override;
    procedure SetFiltered(Value: Boolean); override;
    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;

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