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

unit IBStoredProc;

{$Mode Delphi}

{$codepage UTF8}

interface

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

  TIBStoredProc = class(TIBCustomDataSet)
  private
    FPackageName: string;
    FStmtHandle: IStatement;
    FProcName: string;
    FParams: TParams;
    FPrepared: Boolean;
    FNameList: TStrings;
    FPackageNameList: TStrings;
    function GetPackageNames: TStrings;
    procedure GetPackageNamesFromServer;
    procedure SetPackageName(AValue: string);
    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);
    procedure UpdateQuery;
  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;
    property PackageNames: TStrings read GetPackageNames;

  published
    property PackageName: string read FPackageName write SetPackageName;
    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;
  FPackageNameList := TStringList.Create;
end;

destructor TIBStoredProc.Destroy;
begin
  Destroying;
  Disconnect;
  if assigned (FParams) then FParams.Free;
  if assigned(FNameList) then FNameList.Free;
  if assigned(FPackageNameList) then FPackageNameList.Free;
  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 Value = FProcName then Exit;
  CheckInactive;
  FProcName := Value;
  UpdateQuery;
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 = '') and (FProcName <> '') and (Database <> nil) 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;

  {Trim and make uppercase unless not an SQL Identifier when leave as it is}
  function FormatProcName(Dialect: Integer; Value: String): String;
  begin
    Value := Trim(Value);
    if (Dialect = 1) or IsSQLIdentifier(Value) then
       Result := AnsiUpperCase(Value)
    else
      Result := SQLSafeString(Value);
  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;
    if DatabaseInfo.ODSMajorVersion < 12 then
      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}
                        '''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
                        ' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
    else
    if FPackageName = '' then
      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}
                        '''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
                        'AND RDB$PACKAGE_NAME IS NULL' + {do not localize}
                        ' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
    else
      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}
                        '''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
                        'AND RDB$PACKAGE_NAME = ' + {do not localize}
                        '''' + FormatProcName(Database.SQLDialect, FPackageName) + '''' +
                        ' 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;
    if FPackageName = '' then
      SelectSQL.Text := 'Execute Procedure ' + {do not localize}
                        QuoteIdentifierIfNeeded(Database.SQLDialect, FProcName) + ' ' + input
    else
      SelectSQL.Text := 'Execute Procedure ' + {do not localize}
                        QuoteIdentifierIfNeeded(Database.SQLDialect,FPackageName) + '.' +
                        QuoteIdentifierIfNeeded(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;

procedure TIBStoredProc.SetPackageName(AValue: string);
begin
  if FPackageName = AValue then Exit;
  CheckInactive;
  FPackageName := AValue;
  FProcName := '';
  UpdateQuery;
end;

procedure TIBStoredProc.GetPackageNamesFromServer;
var
  Query : TIBSQL;
begin
  ActivateConnection;
  if (csReading in ComponentState) or (DatabaseInfo.ODSMajorVersion < 12) then Exit;
  Database.InternalTransaction.StartTransaction;
  Query := TIBSQL.Create(self);
  try
    Query.GoToFirstRecordOnExecute := False;
    Query.Database := DataBase;
    Query.Transaction := Database.InternalTransaction;
    Query.SQL.Text := 'Select distinct RDB$PACKAGE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is not null'; {do not localize}
    Query.Prepare;
    Query.ExecQuery;
    while (not Query.EOF) and Query.Next do
      FPackageNameList.Add(TrimRight(Query.Current.ByName('RDB$PACKAGE_NAME').AsString)); {do not localize}
  finally
    Query.Free;
    Database.InternalTransaction.Commit;
  end;
end;

function TIBStoredProc.GetPackageNames: TStrings;
begin
  FPackageNameList.Clear;
  GetPackageNamesFromServer;
  Result := FPackageNameList;
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;
      if DatabaseInfo.ODSMajorVersion < 12 then
        Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES' {do not localize}
      else
      if FPackageName = '' then
        Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is NULL' {do not localize}
      else
        Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME = ''' + {do not localize}
                          SQLSafeString(FPackageName) + '''';
      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.UpdateQuery;
begin
  if not (csReading in ComponentState) then
  begin
      FreeStatement;
      FParams.Clear;
      if (FProcName <> '') and (Database <> nil) then
      begin
        GenerateSQL;
        if csDesigning in ComponentState then
        begin
          Prepare;  {Fills the Params collection}
          UnPrepare;
        end;
      end;
  end
  else
  begin
    if (FProcName <> '') and (Database <> nil) then
    GenerateSQL;
  end;
end;

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

end.
Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	19989 byte(s)
Log Message:	Fixes Merged
#	Content
1	{************************************************************************}
2	{ }
3	{ Borland Delphi Visual Component Library }
4	{ InterBase Express core components }
5	{ }
6	{ Copyright (c) 1998-2000 Inprise Corporation }
7	{ }
8	{ InterBase Express is based in part on the product }
9	{ Free IB Components, written by Gregory H. Deatz for }
10	{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11	{ Free IB Components is used under license. }
12	{ }
13	{ The contents of this file are subject to the InterBase }
14	{ Public License Version 1.0 (the "License"); you may not }
15	{ use this file except in compliance with the License. You }
16	{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	{ Software distributed under the License is distributed on }
18	{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19	{ express or implied. See the License for the specific language }
20	{ governing rights and limitations under the License. }
21	{ The Original Code was created by InterBase Software Corporation }
22	{ and its successors. }
23	{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24	{ Corporation. All Rights Reserved. }
25	{ Contributor(s): Jeff Overcash }
26	{ }
27	{ IBX For Lazarus (Firebird Express) }
28	{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	{ Portions created by MWA Software are copyright McCallum Whyman }
30	{ Associates Ltd 2011 - 2018 }
31	{ }
32	{************************************************************************}
33
34	unit IBStoredProc;
35
36	{$Mode Delphi}
37
38	{$codepage UTF8}
39
40	interface
41
42	uses SysUtils, Classes, DB, IB, IBDatabase, IBCustomDataSet,
43	IBSQL, IBUtils;
44
45	{ TIBStoredProc }
46	type
47
48	TIBStoredProc = class(TIBCustomDataSet)
49	private
50	FPackageName: string;
51	FStmtHandle: IStatement;
52	FProcName: string;
53	FParams: TParams;
54	FPrepared: Boolean;
55	FNameList: TStrings;
56	FPackageNameList: TStrings;
57	function GetPackageNames: TStrings;
58	procedure GetPackageNamesFromServer;
59	procedure SetPackageName(AValue: string);
60	procedure SetParamsList(Value: TParams);
61	procedure FreeStatement;
62	function GetStoredProcedureNames: TStrings;
63	procedure GetStoredProcedureNamesFromServer;
64	procedure CreateParamDesc;
65	procedure SetParams;
66	procedure SetParamsFromCursor;
67	procedure GenerateSQL;
68	procedure FetchDataIntoOutputParams;
69	procedure ReadParamData(Reader: TReader);
70	procedure WriteParamData(Writer: TWriter);
71	procedure UpdateQuery;
72	protected
73
74	procedure DefineProperties(Filer: TFiler); override;
75	procedure SetFiltered(Value: Boolean); override;
76	procedure InitFieldDefs; override;
77	function GetParamsCount: Word;
78	procedure SetPrepared(Value: Boolean);
79	procedure SetPrepare(Value: Boolean);
80	procedure SetProcName(Value: string);
81	procedure Disconnect; override;
82	procedure InternalOpen; override;
83
84	public
85	constructor Create(AOwner: TComponent); override;
86	destructor Destroy; override;
87	procedure CopyParams(Value: TParams);
88	procedure ExecProc;
89	function ParamByName(const Value: string): TParam;
90	procedure Prepare;
91	procedure UnPrepare;
92	property ParamCount: Word read GetParamsCount;
93	property StmtHandle: IStatement read FStmtHandle;
94	property Prepared: Boolean read FPrepared write SetPrepare;
95	property StoredProcedureNames: TStrings read GetStoredProcedureNames;
96	property PackageNames: TStrings read GetPackageNames;
97
98	published
99	property PackageName: string read FPackageName write SetPackageName;
100	property StoredProcName: string read FProcName write SetProcName;
101	property Params: TParams read FParams write SetParamsList;
102	property Filtered;
103
104	property BeforeDatabaseDisconnect;
105	property AfterDatabaseDisconnect;
106	property DatabaseFree;
107	property BeforeTransactionEnd;
108	property AfterTransactionEnd;
109	property TransactionFree;
110	property OnFilterRecord;
111	end;
112
113	implementation
114
115	uses FBMessages;
116
117	{ TIBStoredProc }
118
119	constructor TIBStoredProc.Create(AOwner: TComponent);
120	begin
121	inherited Create(AOwner);
122	FParams := TParams.Create (self);
123	FNameList := TStringList.Create;
124	FPackageNameList := TStringList.Create;
125	end;
126
127	destructor TIBStoredProc.Destroy;
128	begin
129	Destroying;
130	Disconnect;
131	if assigned (FParams) then FParams.Free;
132	if assigned(FNameList) then FNameList.Free;
133	if assigned(FPackageNameList) then FPackageNameList.Free;
134	inherited Destroy;
135	end;
136
137	procedure TIBStoredProc.Disconnect;
138	begin
139	Close;
140	UnPrepare;
141	end;
142
143	procedure TIBStoredProc.ExecProc;
144	var
145	DidActivate: Boolean;
146	begin
147	CheckInActive;
148	if StoredProcName = '' then
149	IBError(ibxeNoStoredProcName, [nil]);
150	ActivateConnection;
151	DidActivate := ActivateTransaction;
152	try
153	SetPrepared(True);
154	if DataSource <> nil then SetParamsFromCursor;
155	if FParams.Count > 0 then SetParams;
156	InternalExecQuery;
157	FetchDataIntoOutputParams;
158	finally
159	if DidActivate then
160	DeactivateTransaction;
161	end;
162	end;
163
164	procedure TIBStoredProc.SetProcName(Value: string);
165	begin
166	if Value = FProcName then Exit;
167	CheckInactive;
168	FProcName := Value;
169	UpdateQuery;
170	end;
171
172	function TIBStoredProc.GetParamsCount: Word;
173	begin
174	Result := FParams.Count;
175	end;
176
177	procedure TIBStoredProc.SetFiltered(Value: Boolean);
178	begin
179	if(Filtered <> Value) then
180	begin
181	inherited SetFiltered(value);
182	if Active then
183	begin
184	Close;
185	Open;
186	end;
187	end
188	else
189	inherited SetFiltered(value);
190	end;
191
192	procedure TIBStoredProc.InitFieldDefs;
193	begin
194	if (SelectSQL.Text = '') and (FProcName <> '') and (Database <> nil) then
195	GenerateSQL;
196	inherited InitFieldDefs;
197	end;
198
199	procedure TIBStoredProc.GenerateSQL;
200
201	var Params: TStringList;
202
203	function FormatParameter(Dialect: Integer; Value: String): String;
204	var j: integer;
205	begin
206	Value := Trim(Value);
207	if Dialect = 1 then
208	Result := AnsiUpperCase(Value)
209	else
210	begin
211	j := 1;
212	Value := Space2Underscore(AnsiUpperCase(Value));
213	Result := Value;
214	while Params.IndexOf(Result) <> -1 do
215	begin
216	Result := Value + IntToStr(j);
217	Inc(j)
218	end;
219	Params.Add(Result)
220	end;
221	end;
222
223	{Trim and make uppercase unless not an SQL Identifier when leave as it is}
224	function FormatProcName(Dialect: Integer; Value: String): String;
225	begin
226	Value := Trim(Value);
227	if (Dialect = 1) or IsSQLIdentifier(Value) then
228	Result := AnsiUpperCase(Value)
229	else
230	Result := SQLSafeString(Value);
231	end;
232
233	var
234	Query : TIBSQL;
235	input : string;
236	begin
237	input := '';
238	if FProcName = '' then
239	IBError(ibxeNoStoredProcName,[nil]);
240	ActivateConnection;
241	Database.InternalTransaction.StartTransaction;
242	Params := TStringList.Create;
243	Query := TIBSQL.Create(self);
244	try
245	Query.Database := DataBase;
246	Query.Transaction := Database.InternalTransaction;
247	if DatabaseInfo.ODSMajorVersion < 12 then
248	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME, RDB$PARAMETER_TYPE ' + {do not localize}
249	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
250	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
251	'''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
252	' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
253	else
254	if FPackageName = '' then
255	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME, RDB$PARAMETER_TYPE ' + {do not localize}
256	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
257	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
258	'''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
259	'AND RDB$PACKAGE_NAME IS NULL' + {do not localize}
260	' ORDER BY RDB$PARAMETER_NUMBER' {do not localize}
261	else
262	Query.SQL.Text := 'SELECT RDB$PARAMETER_NAME, RDB$PARAMETER_TYPE ' + {do not localize}
263	'FROM RDB$PROCEDURE_PARAMETERS ' + {do not localize}
264	'WHERE RDB$PROCEDURE_NAME = ' + {do not localize}
265	'''' + FormatProcName(Database.SQLDialect, FProcName) + '''' +
266	'AND RDB$PACKAGE_NAME = ' + {do not localize}
267	'''' + FormatProcName(Database.SQLDialect, FPackageName) + '''' +
268	' ORDER BY RDB$PARAMETER_NUMBER'; {do not localize}
269	Query.Prepare;
270	Query.GoToFirstRecordOnExecute := False;
271	Query.ExecQuery;
272	while (not Query.EOF) and Query.Next do begin
273	if (Query.FieldByName('RDB$PARAMETER_TYPE').AsInteger = 0) then begin {do not localize}
274	if (input <> '') then
275	input := input + ', :' +
276	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString) else {do not localize}
277	input := ':' +
278	FormatParameter(Database.SQLDialect, Query.Current.ByName('RDB$PARAMETER_NAME').AsString); {do not localize}
279	end
280	end;
281	if FPackageName = '' then
282	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
283	QuoteIdentifierIfNeeded(Database.SQLDialect, FProcName) + ' ' + input
284	else
285	SelectSQL.Text := 'Execute Procedure ' + {do not localize}
286	QuoteIdentifierIfNeeded(Database.SQLDialect,FPackageName) + '.' +
287	QuoteIdentifierIfNeeded(Database.SQLDialect, FProcName) + ' ' + input;
288	// writeln(SelectSQL.Text);
289	finally
290	Query.Free;
291	Params.Free;
292	Database.InternalTransaction.Commit;
293	end;
294	end;
295
296	procedure TIBStoredProc.CreateParamDesc;
297	var
298	i : integer;
299	DataType : TFieldType;
300	begin
301	DataType := ftUnknown;
302	for i := 0 to QSelect.MetaData.Count - 1 do begin
303	case QSelect.MetaData[i].SQLtype of
304	SQL_TYPE_DATE: DataType := ftDate;
305	SQL_TYPE_TIME: DataType := ftTime;
306	SQL_TIMESTAMP: DataType := ftDateTime;
307	SQL_SHORT:
308	if QSelect.MetaData[i].getScale = 0 then
309	DataType := ftSmallInt
310	else
311	DataType := ftBCD;
312	SQL_LONG:
313	if QSelect.MetaData[i].getScale = 0 then
314	DataType := ftInteger
315	else if QSelect.MetaData[i].getScale >= -4 then
316	DataType := ftBCD
317	else
318	DataType := ftFloat;
319	SQL_INT64:
320	if QSelect.MetaData[i].getScale = 0 then
321	DataType := ftLargeInt
322	else if QSelect.MetaData[i].getScale >= -4 then
323	DataType := ftBCD
324	else
325	DataType := ftFloat;
326	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
327	SQL_BOOLEAN:
328	DataType := ftBoolean;
329	SQL_TEXT: DataType := ftString;
330	SQL_VARYING:
331	if QSelect.MetaData[i].GetSize < 1024 then
332	DataType := ftString
333	else DataType := ftBlob;
334	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
335	end;
336	FParams.CreateParam(DataType, Trim(QSelect.MetaData[i].Name), ptOutput);
337	end;
338
339	DataType := ftUnknown;
340	for i := 0 to QSelect.Params.Count - 1 do begin
341	case QSelect.Params[i].GetSQLtype of
342	SQL_TYPE_DATE: DataType := ftDate;
343	SQL_TYPE_TIME: DataType := ftTime;
344	SQL_TIMESTAMP: DataType := ftDateTime;
345	SQL_SHORT:
346	if QSelect.Params[i].getScale = 0 then
347	DataType := ftSmallInt
348	else
349	DataType := ftBCD;
350	SQL_LONG:
351	if QSelect.Params[i].getScale = 0 then
352	DataType := ftInteger
353	else if QSelect.Params[i].getScale >= -4 then
354	DataType := ftBCD
355	else DataType := ftFloat;
356	SQL_INT64:
357	if QSelect.Params[i].getScale = 0 then
358	DataType := ftLargeInt
359	else if QSelect.Params[i].getScale >= -4 then
360	DataType := ftBCD
361	else DataType := ftFloat;
362	SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: DataType := ftFloat;
363	SQL_BOOLEAN:
364	DataType := ftBoolean;
365	SQL_TEXT: DataType := ftString;
366	SQL_VARYING:
367	if QSelect.Params[i].GetSize < 1024 then
368	DataType := ftString
369	else DataType := ftBlob;
370	SQL_BLOB, SQL_ARRAY, SQL_QUAD: DataType := ftBlob;
371	end;
372	FParams.CreateParam(DataType, Trim(QSelect.Params[i].Name), ptInput);
373	end;
374	end;
375
376	procedure TIBStoredProc.SetPrepared(Value: Boolean);
377	begin
378	if Prepared <> Value then
379	begin
380	if Value then
381	try
382	if SelectSQL.Text = '' then GenerateSQL;
383	InternalPrepare;
384	if FParams.Count = 0 then CreateParamDesc;
385	FPrepared := True;
386	except
387	FreeStatement;
388	raise;
389	end
390	else FreeStatement;
391	end;
392
393	end;
394
395	procedure TIBStoredProc.Prepare;
396	begin
397	SetPrepared(True);
398	end;
399
400	procedure TIBStoredProc.UnPrepare;
401	begin
402	SetPrepared(False);
403	end;
404
405	procedure TIBStoredProc.FreeStatement;
406	begin
407	InternalUnPrepare;
408	FPrepared := False;
409	end;
410
411	procedure TIBStoredProc.SetPrepare(Value: Boolean);
412	begin
413	if Value then Prepare
414	else UnPrepare;
415	end;
416
417	procedure TIBStoredProc.CopyParams(Value: TParams);
418	begin
419	if not Prepared and (FParams.Count = 0) then
420	try
421	Prepare;
422	Value.Assign(FParams);
423	finally
424	UnPrepare;
425	end else
426	Value.Assign(FParams);
427	end;
428
429	procedure TIBStoredProc.SetParamsList(Value: TParams);
430	begin
431	CheckInactive;
432	if Prepared then
433	begin
434	SetPrepared(False);
435	FParams.Assign(Value);
436	SetPrepared(True);
437	end else
438	FParams.Assign(Value);
439	end;
440
441	procedure TIBStoredProc.SetPackageName(AValue: string);
442	begin
443	if FPackageName = AValue then Exit;
444	CheckInactive;
445	FPackageName := AValue;
446	FProcName := '';
447	UpdateQuery;
448	end;
449
450	procedure TIBStoredProc.GetPackageNamesFromServer;
451	var
452	Query : TIBSQL;
453	begin
454	ActivateConnection;
455	if (csReading in ComponentState) or (DatabaseInfo.ODSMajorVersion < 12) then Exit;
456	Database.InternalTransaction.StartTransaction;
457	Query := TIBSQL.Create(self);
458	try
459	Query.GoToFirstRecordOnExecute := False;
460	Query.Database := DataBase;
461	Query.Transaction := Database.InternalTransaction;
462	Query.SQL.Text := 'Select distinct RDB$PACKAGE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is not null'; {do not localize}
463	Query.Prepare;
464	Query.ExecQuery;
465	while (not Query.EOF) and Query.Next do
466	FPackageNameList.Add(TrimRight(Query.Current.ByName('RDB$PACKAGE_NAME').AsString)); {do not localize}
467	finally
468	Query.Free;
469	Database.InternalTransaction.Commit;
470	end;
471	end;
472
473	function TIBStoredProc.GetPackageNames: TStrings;
474	begin
475	FPackageNameList.Clear;
476	GetPackageNamesFromServer;
477	Result := FPackageNameList;
478	end;
479
480	function TIBStoredProc.ParamByName(const Value: string): TParam;
481	begin
482	Prepare;
483	Result := FParams.ParamByName(Value);
484	end;
485
486	function TIBStoredProc.GetStoredProcedureNames: TStrings;
487	begin
488	FNameList.clear;
489	GetStoredProcedureNamesFromServer;
490	Result := FNameList;
491	end;
492
493	procedure TIBStoredProc.GetStoredProcedureNamesFromServer;
494	var
495	Query : TIBSQL;
496	begin
497	if not (csReading in ComponentState) then begin
498	ActivateConnection;
499	Database.InternalTransaction.StartTransaction;
500	Query := TIBSQL.Create(self);
501	try
502	Query.GoToFirstRecordOnExecute := False;
503	Query.Database := DataBase;
504	Query.Transaction := Database.InternalTransaction;
505	if DatabaseInfo.ODSMajorVersion < 12 then
506	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES' {do not localize}
507	else
508	if FPackageName = '' then
509	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME is NULL' {do not localize}
510	else
511	Query.SQL.Text := 'Select RDB$PROCEDURE_NAME from RDB$PROCEDURES Where RDB$PACKAGE_NAME = ''' + {do not localize}
512	SQLSafeString(FPackageName) + '''';
513	Query.Prepare;
514	Query.ExecQuery;
515	while (not Query.EOF) and Query.Next do
516	FNameList.Add(TrimRight(Query.Current.ByName('RDB$PROCEDURE_NAME').AsString)); {do not localize}
517	finally
518	Query.Free;
519	Database.InternalTransaction.Commit;
520	end;
521	end;
522	end;
523
524	procedure TIBStoredProc.SetParams;
525	var
526	i : integer;
527	j: integer;
528	begin
529	i := 0;
530	for j := 0 to FParams.Count - 1 do
531	begin
532	if (Params[j].ParamType <> ptInput) then
533	continue;
534	if not Params[j].Bound then
535	IBError(ibxeRequiredParamNotSet, [Params[j].Name]);
536	if Params[j].IsNull then
537	SQLParams[i].IsNull := True
538	else begin
539	SQLParams[i].IsNull := False;
540	case Params[j].DataType of
541	ftString:
542	SQLParams[i].AsString := Params[j].AsString;
543	ftSmallint, ftWord:
544	SQLParams[i].AsShort := Params[j].AsSmallInt;
545	ftBoolean:
546	SQLParams[i].AsBoolean := Params[j].AsBoolean;
547	ftInteger:
548	SQLParams[i].AsLong := Params[j].AsInteger;
549	ftLargeInt:
550	SQLParams[i].AsInt64 := Params[j].AsLargeInt;
551	ftFloat, ftCurrency:
552	SQLParams[i].AsDouble := Params[j].AsFloat;
553	ftBCD:
554	SQLParams[i].AsCurrency := Params[j].AsCurrency;
555	ftDate:
556	SQLParams[i].AsDate := Params[j].AsDateTime;
557	ftTime:
558	SQLParams[i].AsTime := Params[j].AsDateTime;
559	ftDateTime:
560	SQLParams[i].AsDateTime := Params[j].AsDateTime;
561	ftBlob, ftMemo:
562	SQLParams[i].AsString := Params[j].AsString;
563	else
564	IBError(ibxeNotSupported, [nil]);
565	end;
566	end;
567	Inc(i);
568	end;
569	end;
570
571	procedure TIBStoredProc.SetParamsFromCursor;
572	var
573	I: Integer;
574	DataSet: TDataSet;
575	begin
576	if DataSource <> nil then
577	begin
578	DataSet := DataSource.DataSet;
579	if DataSet <> nil then
580	begin
581	DataSet.FieldDefs.Update;
582	for I := 0 to FParams.Count - 1 do
583	with FParams[I] do
584	if (not Bound) and
585	((ParamType = ptInput) or (ParamType = ptInputOutput)) then
586	AssignField(DataSet.FieldByName(Name));
587	end;
588	end;
589	end;
590
591	procedure TIBStoredProc.FetchDataIntoOutputParams;
592	var
593	i,j : Integer;
594	begin
595	j := 0;
596	for i := 0 to FParams.Count - 1 do
597	with Params[I] do
598	if ParamType = ptOutput then begin
599	Value := QSelect.Fields[j].Value;
600	Inc(j);
601	end;
602	end;
603
604	procedure TIBStoredProc.InternalOpen;
605	begin
606	IBError(ibxeIsAExecuteProcedure,[nil]);
607	end;
608
609	procedure TIBStoredProc.DefineProperties(Filer: TFiler);
610
611	function WriteData: Boolean;
612	begin
613	if Filer.Ancestor <> nil then
614	Result := not FParams.IsEqual(TIBStoredProc(Filer.Ancestor).FParams) else
615	Result := FParams.Count > 0;
616	end;
617
618	begin
619	inherited DefineProperties(Filer);
620	Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteData); {do not localize}
621	end;
622
623	procedure TIBStoredProc.WriteParamData(Writer: TWriter);
624	begin
625	Writer.WriteCollection(Params);
626	end;
627
628	procedure TIBStoredProc.UpdateQuery;
629	begin
630	if not (csReading in ComponentState) then
631	begin
632	FreeStatement;
633	FParams.Clear;
634	if (FProcName <> '') and (Database <> nil) then
635	begin
636	GenerateSQL;
637	if csDesigning in ComponentState then
638	begin
639	Prepare; {Fills the Params collection}
640	UnPrepare;
641	end;
642	end;
643	end
644	else
645	begin
646	if (FProcName <> '') and (Database <> nil) then
647	GenerateSQL;
648	end;
649	end;
650
651	procedure TIBStoredProc.ReadParamData(Reader: TReader);
652	begin
653	Reader.ReadValue;
654	Reader.ReadCollection(Params);
655	end;
656
657	end.