找ｂｕｇ

unit chinterface;
interface
uses
  SysUtils,
  Classes,
  DBXpress,
  DB,
  SqlExpr,
  SyncObjs, 
  Windows, Variants, ADOInt, DBClient, Provider,
  DateUtils, ADODB;typeIConnection = Interface(IInterface)
    function Connection: TADOConnection;
    function GetRefCount: Integer;
    function GetLastAccess: TDateTime;
    property LastAccess: TDateTime read GetLastAccess;
    property RefCount: Integer read GetRefCount;
    procedure BeginTrans;
    procedure RollbackTrans;
    function CommitTrans: Boolean;
    function ExecSQL(SQL: WideString): Boolean;
    function GetRowCount(SQL: WideString): Integer;
  end;IcardConnection = Interface(IInterface)
    function Connection: TADOConnection;
    //function cardConnection: TADOConnection;
    function GetRefCount: Integer;
    function GetLastAccess: TDateTime;
    property LastAccess: TDateTime read GetLastAccess;
    property RefCount: Integer read GetRefCount;
    procedure BeginTrans;
    procedure RollbackTrans;
    function CommitTrans: Boolean;
    function ExecSQL(SQL: WideString): Boolean;
    function GetRowCount(SQL: WideString): Integer;
  end;EConnPoolException = class (Exception);
implementationend.

解决方案 »

  1.   

    unit chinterface;
    interface
    uses
      SysUtils,
      Classes,
      DBXpress,
      DB,
      SqlExpr,
      SyncObjs, 
      Windows, Variants, ADOInt, DBClient, Provider,
      DateUtils, ADODB;typeIConnection = Interface(IInterface)
        function Connection: TADOConnection;
        function GetRefCount: Integer;
        function GetLastAccess: TDateTime;
        property LastAccess: TDateTime read GetLastAccess;
        property RefCount: Integer read GetRefCount;
        procedure BeginTrans;
        procedure RollbackTrans;
        function CommitTrans: Boolean;
        function ExecSQL(SQL: WideString): Boolean;
        function GetRowCount(SQL: WideString): Integer;
      end;IcardConnection = Interface(IInterface)
        function Connection: TADOConnection;
        //function cardConnection: TADOConnection;
        function GetRefCount: Integer;
        function GetLastAccess: TDateTime;
        property LastAccess: TDateTime read GetLastAccess;
        property RefCount: Integer read GetRefCount;
        procedure BeginTrans;
        procedure RollbackTrans;
        function CommitTrans: Boolean;
        function ExecSQL(SQL: WideString): Boolean;
        function GetRowCount(SQL: WideString): Integer;
      end;EConnPoolException = class (Exception);
    implementationend.
      

  2.   

    unit duConnPool;
    interfaceuses
      SysUtils,
      Classes,
      DBXpress,
      DB,
      SqlExpr,
      SyncObjs, 
      Windows, Variants, ADOInt, DBClient, Provider,
      DateUtils, ADODB,
      chinterface,chServerClasses;type  TCleanupThread = class; //forward declaration  //This is the class that manages the connection pool
      TADOConnectionPool = class(TObject)
      private
        FPool: array of IConnection;
        FConnectionString : string;
        FPoolSize: Integer;
        FTimeout: LargeInt;
        CleanupThread: TCleanupThread;
        Semaphore: THandle;
        CriticalSection: TCriticalSection;
      public    constructor Create(const PoolSize: Integer = 10;const CleanupDelayMinutes: Integer = 5;const Timeoutms: LargeInt = 10000);
        destructor Destroy; override;
        function GetConnection: IConnection;
      end;  TCleanupThread = class(TThread)
      private
        FCleanupDelay: Integer;
      protected
        CriticalSection: TCriticalSection;
        FixedConnectionPool: TADOConnectionPool;
        procedure Execute; override;
        constructor Create(CreateSuspended: Boolean;
          const CleanupDelayMinutes: Integer);
      end;  TConnectionModule = class(TDataModule, IConnection)
        ADOConnection: TADOConnection;
        procedure DataModuleCreate(Sender: TObject);
      private    { Private declarations }
        FErrorMsg: String;
        protected    FRefCount: Integer;
        FLastAccess: TDateTime;
        CriticalSection: TCriticalSection;
        Semaphore: THandle;
        function _AddRef: Integer; stdcall;
        function _Release: Integer; stdcall;
        {IConnection methods}
        function GetLastAccess: TDateTime;
        function GetRefCount: Integer;
      public
        function Connection: TADOConnection;
        procedure BeginTrans;
        procedure RollbackTrans;
        function CommitTrans: Boolean;
        function ExecSQL(SQL: WideString): Boolean;
        function GetRowCount(SQL: WideString): Integer;
      end;var
        ADOConnectionPools:TADOConnectionPool;
    implementation{$R *.dfm}
    var
      InternalEvent: TEvent;{ TADOConnectionPool }
    constructor TADOConnectionPool.Create(const PoolSize: Integer = 10;
          const CleanupDelayMinutes: Integer = 5;
          const Timeoutms: LargeInt = 10000);
    begin
      FPoolSize := PoolSize;
      FConnectionString:='Provider=SQLOLEDB.1;Password='+
      serverobject.MainPassWord +';Persist Security Info=True;User ID='+
      serverobject.mainUserName +';Initial Catalog='+
      serverobject.mainDataBase +';Data Source='+
      serverobject.mainHost;
      
      FTimeout := Timeoutms;
      Semaphore := CreateSemaphore(nil, PoolSize, PoolSize, '');
      CriticalSection := TCriticalSection.Create;
      SetLength(FPool, PoolSize);
      CleanupThread := TCleanupThread.Create(True,
        CleanupDelayMinutes);
      with CleanupThread do
      begin
        FreeOnTerminate := True;
        Priority := tpLower;
        FixedConnectionPool := Self;
        Resume;
      end;
    end;
      

  3.   

    unit duConnPool;
    interfaceuses
      SysUtils,
      Classes,
      DBXpress,
      DB,
      SqlExpr,
      SyncObjs, 
      Windows, Variants, ADOInt, DBClient, Provider,
      DateUtils, ADODB,
      chinterface,chServerClasses;type  TCleanupThread = class; //forward declaration  //This is the class that manages the connection pool
      TADOConnectionPool = class(TObject)
      private
        FPool: array of IConnection;
        FConnectionString : string;
        FPoolSize: Integer;
        FTimeout: LargeInt;
        CleanupThread: TCleanupThread;
        Semaphore: THandle;
        CriticalSection: TCriticalSection;
      public    constructor Create(const PoolSize: Integer = 10;const CleanupDelayMinutes: Integer = 5;const Timeoutms: LargeInt = 10000);
        destructor Destroy; override;
        function GetConnection: IConnection;
      end;  TCleanupThread = class(TThread)
      private
        FCleanupDelay: Integer;
      protected
        CriticalSection: TCriticalSection;
        FixedConnectionPool: TADOConnectionPool;
        procedure Execute; override;
        constructor Create(CreateSuspended: Boolean;
          const CleanupDelayMinutes: Integer);
      end;  TConnectionModule = class(TDataModule, IConnection)
        ADOConnection: TADOConnection;
        procedure DataModuleCreate(Sender: TObject);
      private    { Private declarations }
        FErrorMsg: String;
        protected    FRefCount: Integer;
        FLastAccess: TDateTime;
        CriticalSection: TCriticalSection;
        Semaphore: THandle;
        function _AddRef: Integer; stdcall;
        function _Release: Integer; stdcall;
        {IConnection methods}
        function GetLastAccess: TDateTime;
        function GetRefCount: Integer;
      public
        function Connection: TADOConnection;
        procedure BeginTrans;
        procedure RollbackTrans;
        function CommitTrans: Boolean;
        function ExecSQL(SQL: WideString): Boolean;
        function GetRowCount(SQL: WideString): Integer;
      end;var
        ADOConnectionPools:TADOConnectionPool;
    implementation{$R *.dfm}
    var
      InternalEvent: TEvent;{ TADOConnectionPool }
    constructor TADOConnectionPool.Create(const PoolSize: Integer = 10;
          const CleanupDelayMinutes: Integer = 5;
          const Timeoutms: LargeInt = 10000);
    begin
      FPoolSize := PoolSize;
      FConnectionString:='Provider=SQLOLEDB.1;Password='+
      serverobject.MainPassWord +';Persist Security Info=True;User ID='+
      serverobject.mainUserName +';Initial Catalog='+
      serverobject.mainDataBase +';Data Source='+
      serverobject.mainHost;
      
      FTimeout := Timeoutms;
      Semaphore := CreateSemaphore(nil, PoolSize, PoolSize, '');
      CriticalSection := TCriticalSection.Create;
      SetLength(FPool, PoolSize);
      CleanupThread := TCleanupThread.Create(True,
        CleanupDelayMinutes);
      with CleanupThread do
      begin
        FreeOnTerminate := True;
        Priority := tpLower;
        FixedConnectionPool := Self;
        Resume;
      end;
    end;
      

  4.   


    destructor TADOConnectionPool.Destroy;
    var
      i: Integer;
    begin
      //Terminate the cleanup thread
      CleanupThread.Terminate;
      InternalEvent.SetEvent;
      CriticalSection.Enter;
      try
        for i := Low(FPool) to High(FPool) do
          FPool[i] := nil;
        SetLength(FPool,0);
      finally
        CriticalSection.Leave;
      end;
      CriticalSection.Free;
      //Release the semaphore
      CloseHandle(Semaphore);
      inherited;
    end;function TADOConnectionPool.GetConnection: IConnection;
    var
      i: Integer;
      DM: TConnectionModule;
      WaitResult: Integer;
    begin
    Result := nil;
    WaitResult := WaitForSingleObject(Semaphore, FTimeout);
    if WaitResult <> WAIT_OBJECT_0 then Exit;
    CriticalSection.Enter;
    try
      for i := Low(FPool) to High(FPool) do
        begin
          if FPool[i] = nil then
            begin
              DM := TConnectionModule.Create(nil);
              DM.CriticalSection := Self.CriticalSection;
              DM.Semaphore := Self.Semaphore;
              FPool[i] := DM;
              FPool[i].Connection.ConnectionString := FConnectionString ;
              FPool[i].Connection.Connected := True;
              Result := FPool[i];
              Exit;
            end;
          if FPool[i].RefCount = 1 then
            begin
              Result := FPool[i];
              Exit;
            end;
        end; //for
    finally
      CriticalSection.Leave;
    end;
    end;{ TDataModule1 }function TConnectionModule._AddRef: Integer;
    begin
    //increment the reference count
    CriticalSection.Enter;
    try
      Inc(FRefCount);
      Result := FRefCount;
    finally
      CriticalSection.Leave;
    end;
    end;function TConnectionModule._Release: Integer;
    var
      tmpCriticalSection: TCriticalSection;
      tmpSemaphore: THandle;
    begin
      tmpCriticalSection := CriticalSection;
      tmpSemaphore := Semaphore;//decrement the reference count
      CriticalSection.Enter;
      Result := FRefCount;
      try
        Dec(FRefCount);
        Result := FRefCount;
      //if not more references, call Destroy
        if Result = 0 then
          Destroy
        else
          Self.FLastAccess := Now;
        finally
          tmpCriticalSection.Leave;
          if Result = 1 then
            ReleaseSemaphore(tmpSemaphore, 1, nil);
      end;
    end;{IConnection }//CHANGE
    //To use a connection of another type, change the
    //return type of the Connection function
    procedure TConnectionModule.BeginTrans;
    begin
      if ADOConnection.InTransaction then ADOConnection.RollbackTrans;
      ADOConnection.BeginTrans;
    end;function TConnectionModule.CommitTrans: Boolean;
    begin
      FErrorMsg := '';
      try
        ADOConnection.CommitTrans;
      except
      end;
      if ADOConnection.ConnectionObject.Errors.Count > 0 then
      begin
        if ADOConnection.InTransaction then ADOConnection.RollbackTrans;
        FErrorMsg := ADOConnection.ConnectionObject.Errors[0].Description;
        ADOConnection.ConnectionObject.Errors.Clear;
        Result := False;
      end else
        Result := True;
    end;function TConnectionModule.Connection: TADOConnection;
    begin
      //Return a connection
      Result := ADOConnection;
    end;
    function TConnectionModule.ExecSQL(SQL: WideString): Boolean;
    begin
      Result := True;
      FErrorMsg := '';
      try
        ADOConnection.Execute(SQL);
      except
        Result := False;
        if ADOConnection.InTransaction then ADOConnection.RollbackTrans;
        FErrorMsg := ADOConnection.ConnectionObject.Errors[0].Description;
        ADOConnection.ConnectionObject.Errors.Clear;
        Exit;
      end;
      if ADOConnection.ConnectionObject.Errors.Count > 0 then
      begin
        if ADOConnection.InTransaction then ADOConnection.RollbackTrans;
        FErrorMsg := ADOConnection.ConnectionObject.Errors[0].Description;
        ADOConnection.ConnectionObject.Errors.Clear;
        Result := False;
      end;
    end;function TConnectionModule.GetRefCount: Integer;
    begin
      CriticalSection.Enter;
      Result := FRefCount;
      CriticalSection.Leave;
    end;function TConnectionModule.GetRowCount(SQL: WideString): Integer;
    var
      ADataSet: TADODataSet;
    begin
      ADataSet := TADODataSet.Create(nil);
      ADataSet.Connection := ADOConnection;
      ADataSet.CommandText := SQL;  try
        ADataSet.Open;
        Result := ADataSet.Fields[0].AsInteger;
      except
        Result := -1;
      end;
      ADataSet.Active := False;
      ADataSet.Free;
    end;procedure TConnectionModule.RollbackTrans;
    begin
      if ADOConnection.InTransaction then ADOConnection.RollbackTrans;
    end;function TConnectionModule.GetLastAccess: TDateTime;
    begin
      CriticalSection.Enter;
      Result := FLastAccess;
      CriticalSection.Leave;
    end;{ TCleanupThread }constructor TCleanupThread.Create(CreateSuspended: Boolean;
          const CleanupDelayMinutes: Integer);
    begin
      // always create suspended
      inherited Create(True); // always create suspended
      FCleanupDelay := CleanupDelayMinutes;
      //Resume if not created suspended
      if not CreateSuspended then
        Resume;
    end;procedure TCleanupThread.Execute;
    var
      i: Integer;
      WaitMinutes: Integer;
    begin
      WaitMinutes := FCleanupDelay * 1000 * 60;
      while True do
      begin
        if Terminated then Exit;
      //wait for the FCleanupDelay period
        if  InternalEvent.WaitFor(WaitMinutes) <> wrTimeout then
          Exit;
        if Terminated then Exit;
      //WaitForSingleObject has timed out. Look for connections to clean up
        FixedConnectionPool.CriticalSection.Enter;
        try
          for i := low(FixedConnectionPool.FPool) to
            High(FixedConnectionPool.FPool) do
            //if the connection exists, has no external reference,
            //and has not been used lately, release it
            if (FixedConnectionPool.FPool[i] <> nil) and
              (FixedConnectionPool.FPool[i].RefCount = 1) and
              (MinutesBetween(FixedConnectionPool.FPool[i].LastAccess, Now) > FCleanupDelay) then
              FixedConnectionPool.FPool[i] := nil;
      finally
        FixedConnectionPool.CriticalSection.Leave;
      end;//try
    end;//while
    end;procedure TConnectionModule.DataModuleCreate(Sender: TObject);
    begin
    //
    end;initialization
      ADOConnectionPools := TADOConnectionPool.Create(ServerObject.MaxdatebasePool , 5, 20000);
      InternalEvent := TEvent.Create(nil, False, False, '');finalization
       InternalEvent.Free;end.