〖分享〗一个基于ADO存储过程的池化处理

Question

依据工作的需要而开发，所以这里只选择了MSSQL和Oracle两个数据库。通过相对固定的调用方式，可以很好地让同一个程序在兼容Oracle和MSSQL。
1.约定都采用过程（不是函数）
2.第一个参数为整形，用于存储过程的返回值，即MSSQL存储过程当中的return
3.存储过程都通过记录集返回结果：
Oracle演示存储过程
create or replace procedure Simple_Procedure_Test
(  Result out Integer,
  --...--其它参数
  PRetCursor out sys_refcursor
)
is
begin
  open PRetCursor for select '名称' as "TestName",'值' as "TestValue" from dual; --返回一个结果集
  Result := 1;  --MSSQL 的return值
  return;
end;
MSSQL演示存储过程
create procedure Simple_Procedure_Test
As
begin
  select '名称' as [TestName],'值' as [TestValue] --返回一个结果集
  return 1  --MSSQL 的return值
end
Oracle演示代码
procedure TestOracle;
var
  ADOPoolMan: TADOConnPoolMan;
  ProcObj: TADOConnPoolObject;
  Proc: TADOStoredProc;
begin
  ADOPoolMan := TADOConnPoolMan.Create(Alias,dbUser,DbPass,DBName,true,ado_dtOracle);
  try
    ProcObj := ADOPoolMan.CreateSP('Simple_Procedure_Test');
    if ProcObj = Nil then Exit;//错误处理
     try
      Proc := ProcObj.ExecObject as TADOStoredProc;
      Proc.Close;
      //参数填充
       //...
      Proc.Open;
      ShowMessage('Result = ' +Proc.Parameters.ParamByName('Result'));
      ShowMessage(Proc.Fields[0].FieldName + '=' + Proc.Fields[0].Value + #13#10 + Proc.Fields[1].FieldName + '=' + Proc.Fields[1].Value);
    finally
      ADOPoolMan.FreeObject(ProcObj);
    end;
  finally
    ADOPoolMan.Free;
  end;
end;
MSSQL演示代码
procedure TestMSSQLServer;
var
  ADOPoolMan: TADOConnPoolMan;
  ProcObj: TADOConnPoolObject;
  Proc: TADOStoredProc;
begin
  ADOPoolMan := TADOConnPoolMan.Create(Alias,dbUser,DbPass,DBName,true,ado_dtMSSQL);
  try
    ProcObj := ADOPoolMan.CreateSP('Simple_Procedure_Test');
    if ProcObj = Nil then Exit;//错误处理
     try
      Proc := ProcObj.ExecObject as TADOStoredProc;
      Proc.Close;
      //参数填充
       //...
      Proc.Open;
      ShowMessage('Result = ' +Proc.Parameters.ParamByName('Result'));
      ShowMessage(Proc.Fields[0].FieldName + '=' + Proc.Fields[0].Value + #13#10 + Proc.Fields[1].FieldName + '=' + Proc.Fields[1].Value);
    finally
      ADOPoolMan.FreeObject(ProcObj);
    end;
  finally
    ADOPoolMan.Free;
  end;
end;下面是模块代码，仅供参考，如果有觉得不够完善，并且愿意完善的同仁欢迎完善，比如这里只做了存储过程，但是TADOConnPoolObject.ExecObject返回的是基类TCustomADODataSet，因此可以支持ADOQuery,ADOCommand等作为“池”元素。PS:分数不多，发到技术区主要是为了可能的奖励^_^

Answer 1

unit UnitADOConnectionPool;interface
uses
    Classes
  , SysUtils
  , Windows
  , uHSStringList
  , ADODB
  , DB
  , UnitManagedObject
  , StringHelperUnit
  , FMTBcd
  , DBConsts
  , SqlTimSt
  , WideStrUtils
  , ADOInt
  ;
type
  TADODatabaseType = (ado_dtMSSQL,  ado_dtOracle);
  TADOConnPoolMan = class;  //连接池
  TExecuteObject = class;
  TExecuteObjectManager = class; //数据集池  {TADOConnPoolObject}{$region}
  TADOConnPoolObject = class(TObject)
    private
      FOwner  : TADOConnPoolMan; //连接池
    private
      FConn   : TADOConnection;  //连接
      FTag    : Integer;         //标识
      FNeedRefresh:Boolean;
      FUsing  : Boolean;         //
      FWhereXY: Integer;
    private
      FExecObjMan: TExecuteObject; //数据集池
    private
      function GetExecObject: TCustomADODataSet;     //数据集
    public
      property Owner:TADOConnPoolMan read FOwner;
      property Connection:TADOConnection read FConn;
      property Tag:Integer read FTag write FTag;
      property Using:Boolean read FUsing write FUsing;
      property WhereXY:Integer read FWhereXY write FWhereXY;
      property ExecObject:TCustomADODataSet read GetExecObject;
      property NeedRefresh:Boolean read FNeedRefresh write FNeedRefresh;
    public
      constructor Create(AOwner:TADOConnPoolMan);
      destructor Destroy;override;
      procedure Free;
      function LoadExecuteObject(AExecObjectMan:TExecuteObjectManager):TADOConnPoolObject;
      function TestConnection:Boolean;
      function Reconnect:Boolean;
  end;
  {$endRegion}  {TADOConnPoolMan}{$region}
  TADOConnPoolMan = class(TManagedObject)
    const FFirstMember  : Integer = -1;
    strict private
      FConnectionPool   : TList;  //线程安全的存储过程列表
      FLastUsing        : Integer;      //最后使用指针
      FLastMember       : Integer;      //最后指针
    strict private
      FDBServer       : String;
      FDBUser         : String;
      FDBPass         : String;
      FDBName         : String;
      FKeepConnection : Boolean;
      FADODBType      : TADODatabaseType;
      FSPPoolList     : {$ifndef NOSTORE_OBJECT_WITH_STRINGS}THSStringList{$else}TStringList{$endif};
      FLock           : TRTLCriticalSection;
      FConcurrent     : Integer;
      FMaxConcurrent  : Integer;
      FTag            : Integer;
    private
      procedure SetDBServer(const Value:String);
      procedure SetDBName(const Value:String);
      function NewConnection:TADOConnPoolObject;
      procedure FreeConnection(ConnPoolObject:TADOConnPoolObject);
    protected
      function Lock:BOOL;
      procedure Unlock;
    public
      property DBServer : String read FDBServer write SetDBServer;
      property DBUser   : String read FDBUSer;
      property DBName   : String read FDBName Write SetDBName;
      property Concurrent : Integer read FConcurrent;
      property MaxConcurrent:Integer read FMaxConcurrent;
      property ADODBType: TADODatabaseType read FADODBType;
      property Tag:Integer read FTag;
      procedure SetLogin(const ADBUser,ADBPass:String);
    public
      function CreateSP(    const ProcName        : String): TADOConnPoolObject;
      procedure FreeObject(ConnPoolObject:TADOConnPoolObject);
      function Reconnect(AConnection:TADOConnection):Boolean;
      class Function ConnectADO(  const sServerip
                                ,       sUser
                                ,       sPass
                                ,       sDbName   : String
                                ; const bKeep     : Boolean
                                ; Var   ADOConn   : TADOConnection
                                ;       ADODBType: TADODatabaseType = ado_dtMSSQL
                                ): Boolean;
    public
      constructor Create(   const ADBServer       : String
                          ; const ADBUser         : String
                          ; const ADBPass         : String
                          ; const ADBName         : String
                          ; const AKeepConnection : Boolean
                          ;       AADODBType: TADODatabaseType = ado_dtMSSQL
                          );
      destructor Destroy;override;  end;
  {$endRegion}
  {TExecuteObject}{$region}
  TExecuteObject = class(TObject)
    private
      FOwner:TExecuteObjectManager;
      FWhereXY:Integer;
      FUSing:BOOL;
      FExecuteObject:TADOStoredProc;
    private
      function GetSPName:String;
    public
      property Owner:TExecuteObjectManager read FOwner;
      property WhereXY:Integer read FWhereXY write FWhereXY;
      property Using:BOOL read FUSing write FUSing;
      property ProcedureName:String read GetSPName;
      property ExecuteObject:TADOStoredProc read FExecuteObject;
    public
      constructor Create(AOwner:TExecuteObjectManager;ASPName:String);
      Destructor Destroy;override;
  end;
  {$endRegion}
  {TExecuteObjectManager}{$region}
  TExecuteObjectManager = class(TManagedObject)
    const FFirstMember  : Integer = -1;
    strict private
      FExecuteObjectPool   : TList;  //线程安全的存储过程列表
      FLastUsing        : Integer;      //最后使用指针
      FLastMember       : Integer;      //最后指针
    private
      FSPName         : String;
      FADODBType      : TADODatabaseType;
    private
      FLock           : TRTLCriticalSection;
    private
      function CreateNewSP(AConnection:TADOConnection):TExecuteObject;
    protected
      function Lock:BOOL;
      procedure Unlock;
    public
      property StoredProcName:String read FSPName;
    public
      procedure FreeExecuteObject(ExecuteObject:TExecuteObject);
      function CreateExecObject(AConnection:TADOConnection;var IsNewObject:Boolean):TExecuteObject;
      class function RefreshParam(ExecuteObject:TCustomADODataSet; AADODBType: TADODatabaseType):Boolean;
      class procedure CreateOracleParameter(Parameters:TParameters; AFieldName, AFieldType, AFieldDirection: AnsiString);
    public
      constructor Create(const ASPName:String;AADODBType      : TADODatabaseType);
      destructor Destroy;override;
  end;
  {$endRegion}

Answer 2

var
    ADORunsPerSec                         : Integer = 0;
implementation
uses
    Variants
  , ActiveX
  , ADOConst
  ;
procedure WriteLog( const   s: string);
begin
  ...
end;{TADOConnPoolObject}{$region}
constructor TADOConnPoolObject.Create(AOwner: TADOConnPoolMan);
begin
  inherited Create;
  FOwner := AOwner;
  FConn := TADOConnection.Create(Nil);
  FTag := -1;
  FExecObjMan := Nil;
  FUsing := False;
  NeedRefresh := True;
end;destructor TADOConnPoolObject.Destroy;
var
  tmpConn:TADOConnection;
begin
  FExecObjMan := Nil;
  tmpConn := FConn;
  FConn := Nil;
  tmpConn.Close;
  tmpConn.Free;
  Inherited;
end;procedure TADOConnPoolObject.free;
begin
  if Using then
    begin      if Assigned(FExecObjMan) then
        begin
          FExecObjMan.Owner.FreeExecuteObject(FExecObjMan);
        end;
      FExecObjMan := Nil;      Owner.FreeObject(self);
      FUsing := false;
      Exit;
    end;
  inherited;
end;function TADOConnPoolObject.LoadExecuteObject(AExecObjectMan:TExecuteObjectManager):TADOConnPoolObject;
var
  LExecObject:TExecuteObject;
  LTag:Integer;
  LIsNewObject:Boolean;
begin
  Result := Nil;
  try
    LTag := Owner.Tag;
    if (FTag <> LTag)  then
      begin
        if Not Reconnect then Exit;
        FTag := LTag;
        FNeedRefresh := True;
      end
    else
      if FNeedRefresh then
        begin
          if Not TestConnection then
            begin
              if Not Reconnect then Exit;
            end;
        end;
    LIsNewObject := False;
    LExecObject := AExecObjectMan.CreateExecObject( FConn,LIsNewObject);
    if LExecObject = Nil then Exit;
    if Not LIsNewObject then
      begin
        if LExecObject.FExecuteObject.Connection<>Nil then
            WriteLog(' Assert: TADOConnPoolObject.LoadExecuteObject with Connection Not be Cleared.');
        LExecObject.ExecuteObject.Connection := FConn;
      end;
    if FNeedRefresh then
      begin
        FNeedRefresh := Not AExecObjectMan.RefreshParam(LExecObject.FExecuteObject, Owner.ADODBType) ;//TADOStoredProc(LExecObject).Parameters.Refresh;
      end;
    FExecObjMan := LExecObject;
    FUsing := True;
    Result := self;
  Except
    On E:Exception do
      begin
        WriteLog('连接串:['+FConn.ConnectionString+']'+' Exception: TADOConnPoolObject.LoadExecuteObject with Error:'+E.Message);
      end;
  end;
end;function TADOConnPoolObject.TestConnection:Boolean;
begin
  Result := true;
  try
    case FOwner.ADODBType of
      ado_dtMSSQL: FConn.Execute('select ''Test Connect...''');
      ado_dtOracle: FConn.Execute('select ''Test Connect...'' "NoName" from dual');
    end;  except
    On E:Exception do
      begin
        if Reconnect then
          Exit;
        Result := false;
        WriteLog(FormatDateTime('yyyy-mm-dd hh:nn:ss.ns',Now) + ' 连接串:['+FConn.ConnectionString+']'+' Exception: TADOConnPoolObject.TestConnection with Error:'+E.Message);
      end;
  end;
end;function TADOConnPoolObject.Reconnect:Boolean;
begin
  Result := Owner.ReConnect(FConn);
end;function TADOConnPoolObject.GetExecObject: TCustomADODataSet;
begin
  Result := Nil;
  if Not Assigned(FExecObjMan) then
    Exit;
  Result := FExecObjMan.ExecuteObject;
end;{$endRegion}

Answer 3

{TADOConnPoolMan}{$region}
constructor TADOConnPoolMan.Create(   const ADBServer: string
                                    ; const ADBUser: string
                                    ; const ADBPass: string
                                    ; const ADBName: string
                                    ; const AKeepConnection: Boolean
                                    ;       AADODBType: TADODatabaseType = ado_dtMSSQL
                                    );
begin
  Inherited create;
  FConnectionPool := TList.Create;
  FLastUsing := FFirstMember;
  FLastMember := FFirstMember;
  FSPPoolList := {$ifndef NOSTORE_OBJECT_WITH_STRINGS}THSStringList{$else}TStringList{$endif}.Create;
  FDBServer := ADBServer;
  FDBUser := ADBUser;
  FDBPass := ADBPass;
  FDBName := ADBName;
  FADODBType := AADODBType;
  FKeepConnection := AKeepConnection;
  InitializeCriticalSection(FLock);
  FConcurrent := 0;
  FMaxConcurrent := 0;
  FTag := 0;
end;destructor TADOConnPoolMan.Destroy;
var
  I: Integer;
  LConnPoolObject:TADOConnPoolObject;
  LExecuteObjectMan:TExecuteObjectManager;
begin
  try
    for I := FConnectionPool.Count - 1 downto 0 do
      begin
        LConnPoolObject := TADOConnPoolObject(FConnectionPool.Items[I]);
        if Assigned(LConnPoolObject) then
          FreeConnection(LConnPoolObject);
      end;
    FConnectionPool.Clear;
    FConnectionPool.Free;    for I := FSPPoolList.Count - 1 downto 0 do
      begin
        LExecuteObjectMan := FSPPoolList.Objects[I] as TExecuteObjectManager;
        FSPPoolList.Delete(I);
        if Assigned(LExecuteObjectMan) then
          LExecuteObjectMan.Free;
      end;
    FSPPoolList.Free;
  finally
    DeleteCriticalSection(FLock);
  end;
  Inherited;
end;function TADOConnPoolMan.Lock:BOOL;
var
  LocalConcurrent:Integer;
begin
  Result := False;
  if self.Attach = Nil then
    Exit;
  LocalConcurrent := InterlockedIncrement(FConcurrent);
  EnterCriticalSection(FLock);
  Result := True;
  if LocalConcurrent>FMaxConcurrent then
    FMaxConcurrent := LocalConcurrent;
end;procedure TADOConnPoolMan.Unlock;
begin
  LeaveCriticalSection(FLock);
  InterlockedDecrement(FConcurrent);  
  Free;
end;procedure TADOConnPoolMan.SetDBServer(const Value:String);
var
  LTag:Integer;
begin
  if IsSameText(FDBServer,Value) then
    Exit;
  LTag := InterlockedCompareExchange(FTag,0,MaxInt );
  if LTag <> MaxInt then
    InterlockedIncrement(FTag);
end;procedure TADOConnPoolMan.SetDBName(const Value:String);
var
  LTag:Integer;
begin
  if IsSameText(FDBName,Value) then
    Exit;
  LTag := InterlockedCompareExchange(FTag,0,MaxInt );
  if LTag <> MaxInt then
    InterlockedIncrement(FTag);
end;procedure TADOConnPoolMan.SetLogin(const ADBUser,ADBPass:String);
var
  LTag:Integer;
begin
  if IsSameText( ADBUser,FDBUser) and IsSameText(ADBPass,FDBPass) then
    Exit;
  LTag := InterlockedCompareExchange(FTag,0,MaxInt );
  if LTag <> MaxInt then
    InterlockedIncrement(FTag);
end;function TADOConnPoolMan.NewConnection:TADOConnPoolObject;
var
  LConnPoolObject:TADOConnPoolObject;
begin
  Result := Nil;
  LConnPoolObject:=TADOConnPoolObject.Create(self);
  if Assigned(LConnPoolObject) then
    Result := LConnPoolObject;
end;procedure TADOConnPoolMan.FreeConnection(ConnPoolObject:TADOConnPoolObject);
begin
  ConnPoolObject.Free;
end;function TADOConnPoolMan.CreateSP(    const ProcName        : String): TADOConnPoolObject;
var
  IsLocked    : Boolean;
  LConnPoolObject:TADOConnPoolObject;
  LExecuteObjectMan:TExecuteObjectManager;
    iIndex      : Integer;
    sParamName
  , sProcOwner
  , sPoolName   : String;
    bNeedExecuteObject   : Boolean;
begin
  result := Nil;
  if Attach=Nil then
    Exit;
  try
    bNeedExecuteObject := false;
    if ProcName <> '' then begin
      bNeedExecuteObject := true;
      sParamName := ProcName;
      iIndex := Pos('.', sParamName);
      if iIndex <> 0 then
        sProcOwner := Copy(sParamName, 1,  iIndex-1)
      else
        sProcOwner := '';
      If sProcOwner = '' Then
        Begin
          if FADODBType =  ado_dtMSSQL then begin
            sProcOwner := 'dbo';
            sPoolName := sParamName;
            sParamName := 'dbo.' + sParamName;
          end else begin
            sProcOwner := '';
            sPoolName := sParamName;
            sParamName := sParamName;
          end;
        End
      else
        sPoolName := Copy(sParamName, iIndex + 1, 50);
    end;    IsLocked := Lock;
    if Not IsLocked then
      Exit;
    try
      LConnPoolObject := Nil;
      if (FLastMember<>FFirstMember) and (FLastUsing<>FLastMember) then
        begin
          Inc(FLastUsing);
          LConnPoolObject  :=  TADOConnPoolObject(FConnectionPool.Items[FLastUsing]);
        end;      if LConnPoolObject = Nil then
        begin
          LConnPoolObject := NewConnection;
          if Not Assigned(LConnPoolObject) then
            Exit;
          LConnPoolObject.WhereXY := FConnectionPool.Add(Pointer(LConnPoolObject));
          Inc(FLastMember);
          FLastUsing        :=  FLastMember;
        end;      if Not bNeedExecuteObject then begin
        LConnPoolObject.FExecObjMan := Nil;
        LConnPoolObject.Reconnect ;
        Result := LConnPoolObject ;        Exit;
      end;
      
      iIndex := FSPPoolList.IndexOf(sPoolName);
        if iIndex<>-1 then
          begin
            LExecuteObjectMan := FSPPoolList.Objects[iIndex] as TExecuteObjectManager;
          end
        else
          begin
            LExecuteObjectMan := TExecuteObjectManager.Create(sParamName, FADODBType);
            if Not Assigned(LExecuteObjectMan) then
              Exit;
            iIndex := FSPPoolList.AddObject(sPoolName,LExecuteObjectMan);
            if iIndex=-1 then
              begin
                LExecuteObjectMan.Free;
                Exit;
              end;
          end;
      Unlock;
      IsLocked := False;
      Result := LConnPoolObject.LoadExecuteObject(LExecuteObjectMan);
      if Result = Nil then
        begin
          IsLocked := Lock;
          if IsLocked then
            begin
              if LConnPoolObject.WhereXY <> FLastUsing then
                begin
                  Result := FConnectionPool.Items[FLastUsing];
                  FConnectionPool.Items[LConnPoolObject.WhereXY] := Result;                  Result.WhereXY := LConnPoolObject.WhereXY;
                  Result := Nil;
                  FConnectionPool.Items[FLastUsing] := LConnPoolObject;
                  LConnPoolObject.WhereXY := FLastUsing;
                end;
              Dec(FLastUsing);
            end;
          Exit;
        end;
      if Not (Attach <> Nil) then
         begin
           //FreeObject(Result);
           Result.Free;
           Result := Nil;
           Exit;
         end;
      InterlockedIncrement(ADORunsPerSec);
    finally
      if IsLocked then
        Unlock;
    end;
  finally
    Free;
  end;
end;

Answer 4

procedure TADOConnPoolMan.FreeObject(ConnPoolObject:TADOConnPoolObject);
var
  LConnPoolObject:TADOConnPoolObject;
begin
  if Not (ConnPoolObject <> nil) then
    Exit;
  if Not Assigned(ConnPoolObject.Owner) then
    Exit;
  if ConnPoolObject.Owner <> self then
    begin
      ConnPoolObject.Owner.FreeObject(ConnPoolObject);
      Exit;
    end;
  if Not Lock then
    Exit;
  try
      if FLastUsing >= 0 then
      begin
        LConnPoolObject  :=  TADOConnPoolObject(FConnectionPool.Items[FLastUsing]);
        if LConnPoolObject <> ConnPoolObject then
          begin
            LConnPoolObject.WhereXY         :=  ConnPoolObject.WhereXY;
            ConnPoolObject.WhereXY             :=  FLastUsing;
            FConnectionPool.Items[FLastUsing]             :=  Pointer(ConnPoolObject);
            FConnectionPool.Items[LConnPoolObject.WhereXY]  :=  Pointer(LConnPoolObject);
          end;
        Dec(FLastUsing);
        self.Free;
      end;
  finally
    Unlock;
  end;
end;function TADOConnPoolMan.Reconnect(AConnection:TADOConnection):Boolean;
begin
  Result := True;
  try
      If AConnection.Connected Then
        begin
          AConnection.Close;
          Sleep(50);
        end;
      AConnection.CommandTimeout := 15;
      AConnection.ConnectionTimeout := 15;
      AConnection.KeepConnection := FKeepConnection;
      AConnection.LoginPrompt := false;
      case FADODBType of
        ado_dtMSSQL: begin
          AConnection.ConnectionString := 'DistribTX=0;Provider=SQLOLEDB.1;'
                                        + 'Persist Security Info=True;'
                                        + 'User ID=' + FDBUser + ';'
                                        + 'Initial Catalog=' + FDbName + ';'
                                        + 'Data Source=' + FDBServer + ';';
        end;
        ado_dtOracle: begin
          AConnection.ConnectionString :=   'PLSQLRSet=1;DistribTX=0;Provider=OraOLEDB.Oracle.1;'
                                          + 'Persist Security Info = True;'
                                          + 'Data Source=' + FDBServer + ';'
                                          + 'User ID=' + FDBUser + ';'
                                          + 'Password =''' + Trim(FDBPass) + '''';
        end
        else
          Exit;
      end;
      AConnection.Open(FDBUser, FDBPass);
  except
    Result := False;
  end;
end;class Function TADOConnPoolMan.ConnectADO(   const sServerip
                                              ,       sUser
                                              ,       sPass
                                              ,       sDbName   : String
                                              ; const bKeep     : Boolean
                                              ; Var   ADOConn   : TADOConnection
                                              ;       ADODBType: TADODatabaseType = ado_dtMSSQL
                                              ): Boolean;
Begin
  Result := False;
  Try
    Try
      If ADOConn = Nil Then ADOConn := TADOConnection.Create(Nil)
      Else ADOConn.Close;
      ADOConn.CommandTimeout := 3;
      ADOConn.ConnectionTimeout := 3;
      ADOConn.KeepConnection := bKeep;
      ADOConn.LoginPrompt := false;
      case ADODBType of
        ado_dtMSSQL: begin
          ADOConn.ConnectionString := 'DistribTX=0;Provider=SQLOLEDB.1;'
                                    + 'Persist Security Info=True;'
                                    + 'User ID=' + sUser + ';'
                                    + 'Initial Catalog=' + sDbName + ';'
                                    + 'Data Source=' + sServerip + ';';
        end;
        ado_dtOracle: begin
          ADOConn.ConnectionString :=   'PLSQLRSet=1;DistribTX=0;Provider=OraOLEDB.Oracle.1;'
                                      + 'Persist Security Info = True;'
                                      + 'Data Source=' + sServerip + ';'
                                      + 'User ID=' + sUser + ';'
                                      + 'Password =''' + Trim(sPass) + '''';
        end
        else
          Exit;
      end;      ADOConn.Open(sUser, sPass);
      result := True;
    Except
      Result := False;
    End;
  Finally
  End;
End;
{$endregion}

Answer 5

{TExecuteObject}{$region}
constructor TExecuteObject.Create(AOwner:TExecuteObjectManager;ASPName:String);
begin
  inherited Create;
  FOwner := AOwner;
  FWhereXY := -1;
  FUSing := False;
  FExecuteObject := TADOStoredProc.Create(Nil);
  FExecuteObject.ProcedureName := ASPName;
end;Destructor TExecuteObject.Destroy;
begin
  FExecuteObject.Free;
end;function TExecuteObject.GetSPName:String;
begin
  Result := '';
  if Not Assigned(FExecuteObject) then
    Exit;
  if Not (FExecuteObject is TADOStoredProc) then
    Exit;
  Result := FExecuteObject.ProcedureName;
end;
  {$endRegion}{TExecuteObjectManager}{$region}
constructor TExecuteObjectManager.Create(const ASPName:String;AADODBType      : TADODatabaseType);
begin
  Inherited Create;
  FLastUsing := FFirstMember;
  FLastMember := FFirstMember;
  FExecuteObjectPool := TList.Create;
  FSPName := ASPName;
  FADODBType := AADODBType;
  InitializeCriticalSection(FLock);
end;function TExecuteObjectManager.Lock:Bool;
begin
  Result := False;
  if Not (Attach<> Nil) then
    Exit;
  EnterCriticalSection(FLock);
  Result := True;
end;procedure TExecuteObjectManager.Unlock;
begin
  LeaveCriticalSection(FLock);
  Free;
end;destructor TExecuteObjectManager.Destroy;
var
  I: Integer;
  LExecObject:TExecuteObject;
begin
  for I := FExecuteObjectPool.Count - 1 downto 0 do
    begin
      LExecObject := TExecuteObject(FExecuteObjectPool.Items[I]);
      if Assigned(LExecObject) then
        LExecObject.Free;
    end;
  FExecuteObjectPool.Clear;
  FExecuteObjectPool.Free;
  DeleteCriticalSection(FLock);
  Inherited;
end;function TExecuteObjectManager.CreateNewSP(AConnection:TADOConnection):TExecuteObject;
var
  LExecuteObject:TExecuteObject;
begin
  Result := Nil;
  LExecuteObject := TExecuteObject.Create(self,FSPName);
  if Assigned(LExecuteObject) then
    begin
      Result := LExecuteObject;
      Result.ExecuteObject.Connection := AConnection;
      RefreshParam(Result.ExecuteObject, FADODBType);
    end;
end;procedure TExecuteObjectManager.FreeExecuteObject(ExecuteObject:TExecuteObject);
var
  LExecuteObject:TExecuteObject;
begin
  if Not Assigned(ExecuteObject) then
    Exit;
  if ExecuteObject.Owner = Nil then
    Exit;
  if (ExecuteObject.Owner <> self ) then
    begin
      ExecuteObject.Owner.FreeExecuteObject(ExecuteObject);
      Exit;
    end;
  if Not Lock then
    Exit;
  try
    if FLastUsing>=0 then
      begin
        ExecuteObject.ExecuteObject.Connection := Nil;
        LExecuteObject := TExecuteObject(FExecuteObjectPool.Items[FLastUsing]);
        if LExecuteObject <> ExecuteObject then
          begin
            FExecuteObjectPool.Items[ExecuteObject.WhereXY] := LExecuteObject;
            LExecuteObject.WhereXY := ExecuteObject.WhereXY;
            FExecuteObjectPool.Items[FLastUsing] := ExecuteObject;
            ExecuteObject.WhereXY := FLastUsing;
          end;
        Dec(FLastUsing);
      end
    else
      begin
        WriteLog(' Assert: TExecuteObjectManager.FreeExecuteObject with Invalid Connection  .');
      end;
  finally
    Unlock;
  end;
  
end;function TExecuteObjectManager.CreateExecObject(      AConnection:  TADOConnection
                                                ; var IsNewObject:  Boolean
                                                ):  TExecuteObject;
var
  LExecuteObject:TExecuteObject;
begin
  Result := Nil;
  if Not (Attach<>Nil) then
    Exit;
  try
    if Not Lock then
      Exit;
    try
      LExecuteObject := Nil;
      if (FLastMember<>FFirstMember) and (FLastUsing<>FLastMember) then
        begin
          Inc(FLastUsing);
          LExecuteObject  :=  TExecuteObject(FExecuteObjectPool.Items[FLastUsing]);
        end;
      if LExecuteObject = nil then
        begin
          LExecuteObject  :=  CreateNewSP(AConnection);
          if LExecuteObject = nil then
            Exit;
          LExecuteObject.WhereXY := FExecuteObjectPool.Add(Pointer(LExecuteObject));
          IsNewObject := True;
          Inc(FLastMember);
          FLastUsing        :=  FLastMember;
        end;
      if Not (Attach<>Nil) then
        begin
          Dec(FLastUsing);
          Exit;
        end;
      if LExecuteObject.ExecuteObject.State = dsOpening then
        begin
          Sleep(5);
          LExecuteObject.ExecuteObject.Close;
        end;
      Result := LExecuteObject;
    finally
      Unlock;
    end;
  finally
    Free;
  end;
end;

Answer 6

class procedure TExecuteObjectManager.CreateOracleParameter(
                                                              Parameters: TParameters
                                                            ; AFieldName
                                                            , AFieldType
                                                            , AFieldDirection: AnsiString
                                                            );
var
  Direction: TParameterDirection;
  DataType: TFieldType;
  DataSize: Integer;
  DataDefault: Variant;
  pdIn_Pos,pdOut_Pos: Integer;
begin
  pdIn_Pos := Pos('IN',AFieldDirection);
  pdOut_Pos := Pos('OUT',AFieldDirection);
  if (pdIn_Pos > 0) and (pdOut_Pos > 0) then Direction := pdInputOutput
  else if pdIn_Pos > 0 then Direction := pdInput
  else if pdOut_Pos > 0 then Direction := pdOutput
  else Direction := pdUnknown;  if Pos('NUMBER',AFieldType) > 0 then begin
    DataType := ftInteger;
    DataSize := sizeof(Integer);
    DataDefault := 0;
  end else if Pos('VARCHAR', AFieldType) > 0 then begin
    DataType := ftString;
    DataSize := 65536;
    DataDefault := '';
  end else if Pos('BOOLEAN', AFieldType) > 0 then begin
    DataType := ftBoolean;
    DataSize := sizeof(boolean);
    DataDefault := false;
  end else if Pos('CURSOR', AFieldType) > 0 then begin
    Exit;
  end;  Parameters.CreateParameter(AFieldName, DataType, Direction, DataSize, DataDefault);       
  
end;class function TExecuteObjectManager.RefreshParam(  ExecuteObject:  TCustomADODataSet
                                                  ; AADODBType: TADODatabaseType
                                                  ): Boolean;
var
  Qry: TADOQuery;
  Proc: TADOStoredProc;
begin
  Result := False;
  try
    if Not Assigned(ExecuteObject) then Exit;
    if Not (ExecuteObject is TADOStoredProc) then Exit;
    case AADODBType of
      ado_dtMSSQL: begin
        Result := TADOStoredProc(ExecuteObject).Parameters.Refresh;
        if Result then TADOStoredProc(ExecuteObject).Parameters.ParamByName('@RETURN_VALUE').Name:='Result';
      end;
      ado_dtOracle: begin
        Result := true;
        if ExecuteObject is TADOStoredProc then begin
          Proc := ExecuteObject as TADOStoredProc;
          Qry := TADOQuery.Create(Nil);
          try
            Qry.Connection := ExecuteObject.Connection;
            Qry.SQL.Text := 'SELECT OBJECT_NAME,PACKAGE_NAME,ARGUMENT_NAME,DATA_TYPE,IN_OUT from user_arguments where OBJECT_NAME = '''+UpperCase(Proc.ProcedureName)+'''';
            try
              Qry.Open;
              Proc.Parameters.Clear;
              while Not Qry.Eof do begin
                CreateOracleParameter(  Proc.Parameters
                                      , Qry.FieldByName('ARGUMENT_NAME').AsString
                                      , Qry.FieldByName('DATA_TYPE').AsString
                                      , Qry.FieldByName('IN_OUT').AsString
                                      );
                Qry.Next;
              end;
            except
              Result := false;
            end;
          finally
            Qry.Free;
          end;
        end;
      end;
    end;  except
    On E:Exception do
      begin
        Result := false;
        WriteLog(' 连接串:['+ExecuteObject.Connection.ConnectionString+']'+' Exception: TExecuteObjectManager.RefreshParam with Error:'+E.Message);
      end;
  end;
end;{$endregion}
end.

Answer 7

僵哥，使用Delphi的数据库组件如ADOConnection如何连接到远程数据库呢？？

Answer 8

完了，沒注意，跑偏了，越權了。回頭liangpei, 阿三不會收拾我吧？？？

Answer 9

create procedure Simple_Procedure_Test
As
begin
  select '名称' as [TestName],'值' as [TestValue] --返回一个结果集

Answer 10

MARK!!在MARK

Answer 11

更正一下，查询oracle存储过程参数的时候须加上"Order By Position"，否则在Oracle 10当中可能不会保证顺序。Qry.SQL.Text := 'SELECT OBJECT_NAME,PACKAGE_NAME,ARGUMENT_NAME,DATA_TYPE,IN_OUT from user_arguments where OBJECT_NAME = '''+UpperCase(Proc.ProcedureName)+''' order by position';
            

Answer 12

增加对DB2的支持
...
type
  TADODatabaseType = (ado_dtMSSQL,  ado_dtOracle, ado_dtDB2);
  ...
  TExecuteObjectManager = class(TManagedObject)
  ...
    public
      ...
      class procedure CreateDB2Parameter(   Parameters: TParameters
                                          ; AFieldName
                                          , AFieldType: AnsiString
                                          ; AFieldLength: Integer
                                          ; AFieldDirection: AnsiString
                                          );
      ...
  end;
  ...
function TADOConnPoolObject.TestConnection: Boolean;
begin
  Result := true;
  try
    case FOwner.ADODBType of
      ado_dtMSSQL: FConn.Execute('select ''Test Connect...'' [NoName]');
      ado_dtOracle: FConn.Execute('select ''Test Connect...'' "NoName" from dual');
      ado_dtDB2: FConn.Execute('select ''Test Connect...'' "NoName" from sysibm.dual');
    end;  except
    On E:Exception do begin
      if Reconnect then Exit;
      Result := false;
      WriteLog(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz ',Now) + ' 连接串:['+FConn.ConnectionString+']'+' Exception: TADOConnPoolObject.TestConnection with Error:'+E.Message);
    end;
  end;
end;
...
function TADOConnPoolMan.Reconnect(AConnection: TADOConnection): Boolean;
begin
  Result := True;
  try
    If AConnection.Connected Then begin
      AConnection.Close;
      Sleep(15);
    end;
    AConnection.CommandTimeout := 15;
    AConnection.ConnectionTimeout := 15;
    AConnection.KeepConnection := FKeepConnection;
    AConnection.LoginPrompt := false;
    case FADODBType of
      ado_dtMSSQL: begin
        AConnection.ConnectionString := 'DistribTX=0;Provider=SQLOLEDB.1;'
                                      + 'Persist Security Info=True;'
                                      + 'User ID=' + FDBUser + ';'
                                      + 'Initial Catalog=' + FDbName + ';'
                                      + 'Data Source=' + FDBServer + ';';
      end;
      ado_dtOracle: begin
        AConnection.ConnectionString :=   'PLSQLRSet=1;DistribTX=0;Provider=OraOLEDB.Oracle.1;'
                                        + 'Persist Security Info = True;'
                                        + 'Data Source=' + FDBServer + ';'
                                        + 'User ID=' + FDBUser + ';'
                                        + 'Password =''' + Trim(FDBPass) + '''';
      end;
      ado_dtDB2: begin
        AConnection.ConnectionString :=   'Provider=IBMDADB2;'
                                        + 'Persist Security Info=True;'
                                        + 'Location=' + FDBServer + ';'
                                        + 'User ID=' + FDBUser + ';'
                                        + 'Data Source=' + FDBName + ';'
                                        + 'Password=' +FDBPass
                                        ;
      end
      else
        Exit;
    end;
    AConnection.Open(FDBUser, FDBPass);
  except
    Result := False;
  end;
end;class Function TADOConnPoolMan.ConnectADO(  const sServerip
                                          ,       sUser
                                          ,       sPass
                                          ,       sDbName   : AnsiString
                                          ;       bKeep     : Boolean
                                          ; Var   ADOConn   : TADOConnection
                                          ;       ADODBType: TADODatabaseType = ado_dtMSSQL
                                          ): Boolean;
Begin
  Result := False;
  Try
    Try
      If ADOConn = Nil Then ADOConn := TADOConnection.Create(Nil)
      Else ADOConn.Close;
      ADOConn.CommandTimeout := 3;
      ADOConn.ConnectionTimeout := 3;
      ADOConn.KeepConnection := bKeep;
      ADOConn.LoginPrompt := false;
      case ADODBType of
        ado_dtMSSQL: begin
          ADOConn.ConnectionString := 'DistribTX=0;Provider=SQLOLEDB.1;'
                                    + 'Persist Security Info=True;'
                                    + 'User ID=' + sUser + ';'
                                    + 'Initial Catalog=' + sDbName + ';'
                                    + 'Data Source=' + sServerip + ';';
        end;
        ado_dtOracle: begin
          ADOConn.ConnectionString :=   'PLSQLRSet=1;DistribTX=0;Provider=OraOLEDB.Oracle.1;'
                                      + 'Persist Security Info = True;'
                                      + 'Data Source=' + sServerip + ';'
                                      + 'User ID=' + sUser + ';'
                                      + 'Password =''' + Trim(sPass) + '''';
        end;
        ado_dtDB2: begin
          ADOConn.ConnectionString :=   'Provider=IBMDADB2;'
                                      + 'Persist Security Info=True;'
                                      + 'Location=' + sServerip + ';'
                                      + 'User ID=' + sUser + ';'
                                      + 'Data Source=' + sDbName + ';'
                                      + 'Password=' +sPass
                                      ;
        end
        else
          Exit;
      end;      ADOConn.Open(sUser, sPass);
      result := True;
    Except
      Result := False;
    End;
  Finally
  End;
End;

Answer 13

...
class procedure TExecuteObjectManager.CreateDB2Parameter(   Parameters: TParameters
                                                          ; AFieldName
                                                          , AFieldType: AnsiString
                                                          ; AFieldLength: Integer
                                                          ; AFieldDirection: AnsiString
                                                          );
var
  Direction: TParameterDirection;
  DataType: TFieldType;
  DataSize: Integer;
  DataDefault: Variant;
  pdIn_Pos, pdOut_Pos: Integer;
  param: TParameter;
begin
  pdIn_Pos := Pos('IN',AFieldDirection);
  pdOut_Pos := Pos('OUT',AFieldDirection);
  if (pdIn_Pos > 0) and (pdOut_Pos > 0) then Direction := pdInputOutput
  else if pdIn_Pos > 0 then Direction := pdInput
  else if pdOut_Pos > 0 then Direction := pdOutput
  else Direction := pdUnknown;  IF AFieldType = 'INTEGER' then begin
    DataType := ftInteger;
    DataDefault := 0;
  end else IF AFieldType = 'SMALLINT' then begin
    DataType := ftSmallint;
    DataDefault := 0;
  end else IF AFieldType = 'BIGINT' then begin
    DataType := ftBCD;
    DataDefault := 0;
  end else if AFieldType = 'REAL' then begin
    DataType := ftFloat;
    DataDefault := 0.0;
  end else if AFieldType = 'DOUBLE' then begin
    DataType := ftFloat;
    DataDefault := 0.0;
  end else if AFieldType = 'CHAR' then begin
    DataType := ftFixedChar;
    DataDefault := #0;
  end else if AFieldType = 'VARCHAR' then begin
    DataType := ftString;
    DataDefault := '';
  end else if AFieldType = 'DECIMAL' then begin
    DataType := ftBCD;
    DataDefault := 0;  end else if AFieldType = 'DATE' then begin
    DataType := ftDate;
    DataDefault := 0;
  end else if AFieldType = 'TIME' then begin
    DataType := ftTime;
    DataDefault := 0;
  end else if AFieldType = 'TIMESTAMP' then begin
    DataType := ftTimeStamp;
    DataDefault := 0;
  end else Exit; Parameters.CreateParameter(AFieldName, DataType, Direction, AFieldLength, DataDefault);
end;
...
class function TExecuteObjectManager.RefreshParam(  ExecuteObject:  TCustomADODataSet
                                                  ; AADODBType: TADODatabaseType
                                                  ; const ADBUser: AnsiString
                                                  ): Boolean;
var
  Qry: TADOQuery;
  Proc: TADOStoredProc;
  iPos: Integer;
    sParamName
  , sProcOwner   : AnsiString;
begin
  Result := False;
  try
    if Not Assigned(ExecuteObject) then Exit;
    if Not (ExecuteObject is TADOStoredProc) then Exit;
    case AADODBType of
      ado_dtMSSQL: begin
        Result := TADOStoredProc(ExecuteObject).Parameters.Refresh;
        if Result then TADOStoredProc(ExecuteObject).Parameters.ParamByName('@RETURN_VALUE').Name:='Result';
      end;
      ado_dtOracle: begin
        Result := true;
        if ExecuteObject is TADOStoredProc then begin
          Proc := ExecuteObject as TADOStoredProc;
          Qry := TADOQuery.Create(Nil);
          try
            Qry.Connection := ExecuteObject.Connection;            Qry.SQL.Text := 'SELECT OBJECT_NAME,PACKAGE_NAME,ARGUMENT_NAME,DATA_TYPE,IN_OUT '+
                            'from user_arguments '+
                            'where OBJECT_NAME = ''' + UpperCase(Proc.ProcedureName) + ''' '+
                            'order by position';
            try
              Qry.Open;
              Proc.Parameters.Clear;              while Not Qry.eof do begin
                CreateOracleParameter(  Proc.Parameters
                                      , Qry.FieldByName('ARGUMENT_NAME').AsString
                                      , Qry.FieldByName('DATA_TYPE').AsString
                                      , Qry.FieldByName('IN_OUT').AsString
                                      );
                Qry.Next;
              end;
            except
              Result := false;
            end;
          finally
            Qry.Free;
          end;
        end;
      end;
      ado_dtDB2: begin
        Result := true;
        if ExecuteObject is TADOStoredProc then begin
          Proc := ExecuteObject as TADOStoredProc;
          Proc.LockType := ltUnspecified;
          sParamName := Proc.ProcedureName;
          iPos := Pos('.',sParamName);
          if iPos > 0 then begin
            sProcOwner := Copy(sParamName, 1, iPos - 1);
            sParamName := Copy(sParamName, iPos + 1, Length(sParamName) - iPos);
          end else begin
            sProcOwner := ADBUser;
          end;
          Qry := TADOQuery.Create(Nil);
          try
            Qry.Connection := ExecuteObject.Connection;
            Qry.SQL.Text := 'SELECT PARMNAME,TYPENAME,LENGTH,PARM_MODE  '+
                            'FROM SYSIBM.SYSPROCPARMS '+
                            'WHERE PROCNAME='''+UpperCase(sParamName)+'''  '+
                            'AND PROCSCHEMA = '''+UpperCase(sProcOwner)+''' '+
                            ' order by ordinal';
            try
              Qry.Open;
              Proc.Parameters.Clear;              while Not Qry.eof do begin
                CreateDB2Parameter(   Proc.Parameters
                                    , Qry.FieldByName('PARMNAME').AsString
                                    , Qry.FieldByName('TYPENAME').AsString
                                    , Qry.FieldByName('LENGTH').AsInteger
                                    , Qry.FieldByName('PARM_MODE').AsString
                                    );
                Qry.Next;
              end;
            except
              Result := false;
            end;
          finally
            Qry.Free;
          end;
        end;
      end;
    end;  except
    On E:Exception do
      begin
        Result := false;
        WriteLog(' 连接串:['+ExecuteObject.Connection.ConnectionString+']'+' Exception: TExecuteObjectManager.RefreshParam with Error:'+E.Message);
      end;
  end;
end;