runtime/nongui/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 SetFilterText(const Value: string); 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 Filter;

    property BeforeDatabaseDisconnect;
    property AfterDatabaseDisconnect;
    property DatabaseFree;
    property BeforeTransactionEnd;
    property AfterTransactionEnd;
    property TransactionFree;
    property OnFilterRecord;
  end;

implementation

 uses  IBMessages;

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