一个快速网络连接检测单元

项目需要, 快速检测SQLServer数据库能否连接

一般的连接无论是ADO还是FD, 在connection阶段都没办法控制超时时间, 如果连不上都是15秒左右提示连接失败, 不符合快速检测需要

所以写了下面的代码, 通过Socke异步连接来进行某IP和端口的快速连接测试

 

2016-10-09 1.1 版本去掉了ping, 如果想用ping测试单独调用ICMP单元类, ICMP单元看这里: http://www.cnblogs.com/lzl_17948876/p/3332866.html

 

注:

　　代码支持版本最低为D2010

　　经测试, 超时时间不要设置的太短, 如果低于1秒, 很可能经常性的出现连接/断开状态切换

 

unit PortCheck;

//  ***************************************************************************
//
//  PortCheck
//
//  版本: 1.1
//  作者: 刘志林
//  修改日期: 2016-10-09
//  QQ: 17948876
//  E-mail: lzl_17948876@hotmail.com
//  博客: http://www.cnblogs.com/lzl_17948876/
//
//  !!! 若有修改,请通知作者,谢谢合作 !!!
//
//  ---------------------------------------------------------------------------
//
//  修改历史:
//    1.1
//      去掉了ping的测试支持, 原因意义不大, 需要的时候单独用ICMP去做, 单元改名为PortCheck
//      去掉了单独检测, 只保留批量检测, 增加了2个同步检测的函数
//      规范一些命名
//
//  ***************************************************************************

interface


uses
  Types, Classes, SyncObjs, Generics.Collections;

type
  /// <summary>
  ///   检测状态
  /// <para>
  ///   PS_UNCHECK: 未检测
  /// </para>
  /// <para>
  ///   PS_OK: 检测成功
  /// </para>
  /// <para>
  ///   PS_UNCONNECTED: 无法连接
  /// </para>
  /// <para>
  ///   PS_UNKNOW: 未知
  /// </para>
  /// </summary>
  TPortState = (PS_UNCHECK, PS_OK, PS_UNCONNECTED, PS_UNKNOW);

  /// <summary>
  ///   检测状态改变时通知
  /// </summary>
  TPortStateChangeEvent = procedure(Sender: TObject; AAddress: string; APort: UInt32;
    AState: TPortState) of object;

  TPortCheck = class(TThread)
  private type
    TCheckItem = record
      State: TPortState;
      Address: string;
      Port: UInt16;
      NAddress: UInt32;
      NPort: UInt16;
      TimeOut: UInt16;
      NextCheckTC: UInt32;
    end;
    PCheckItem = ^TCheckItem;
  private
    FItems: TDictionary<string, PCheckItem>;
    FSCItem: TCriticalSection;
    FOnChange: TPortStateChangeEvent;
    function GetKey(const AItem: TCheckItem): string; overload;
    function GetKey(ANAddress: UInt32; ANPort: UInt16): string; overload;
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
    /// <summary>
    ///   添加一个检测
    /// </summary>
    procedure Add(AAddress: string; APort: UInt16; ATimeOut: UInt16 = 2000);
    /// <summary>
    ///   移除一个检测
    /// </summary>
    procedure Remove(AAddress: string; APort: UInt16);
    function PortState(AAddress: string; APort: UInt16): TPortState;
    property OnChange: TPortStateChangeEvent read FOnChange write FOnChange;
  end;

  function Check(AAddress: string; APort: UInt16; ATimeOut: UInt16; AWSAInited: Boolean): TPortState; overload;
  function Check(ANAddress: UInt32; ANPort: UInt16; ATimeOut: UInt16; AWSAInited: Boolean): TPortState; overload;

implementation

uses
  SysUtils, WinSock;

type
  EUnconnected = class(Exception);

function A2NA(AAddress: string): UInt32;
var
  nHostName: string;
  nPHE: PHostEnt;
begin
  Result := inet_addr(PAnsiChar(AnsiString(AAddress)));
  if Result = INADDR_NONE then
  begin
    nPHE := GetHostByName(PAnsiChar(AnsiString(AAddress)));
    if nPHE <> nil then
      Result := DWORD(PLongWord(nPHE^.h_addr_list^)^);
  end;
end;

function P2NP(APort: UInt16): UInt16;
begin
  Result := htons(APort);
end;

function Check(AAddress: string; APort: UInt16; ATimeOut: UInt16; AWSAInited: Boolean): TPortState;
var
  nWSAData: TWSAData;
  nNAddress: UInt32;
  nNPort: UInt16;
begin
  if not AWSAInited then
    WSAStartup($0101, nWSAData);
  try
    nNAddress := A2NA(AAddress);
    nNPort := P2NP(APort);
    Result := Check(nNAddress, nNPort, ATimeOut, True);
  finally
    if not AWSAInited then
      WSACleanup;
  end;
end;

function Check(ANAddress: UInt32; ANPort: UInt16; ATimeOut: UInt16; AWSAInited: Boolean): TPortState;
var
  nWSAData: TWSAData;
  nFDSet: TFDSet;
  nTimeVal: TTimeVal;
  nSocket: TSocket;
  nAddr: TSockAddrIn;
  nLen: integer;
begin
  Result := PS_UNCHECK;
  try
    if not AWSAInited then
      WSAStartup($0101, nWSAData);
    try
      with nAddr do
      begin
        sin_family := PF_INET;
        sin_addr.s_addr := ANAddress;
        sin_port := ANPort;
      end;
      with nTimeVal do
      begin
        tv_sec := ATimeOut div 1000; {超时}
        tv_usec := ATimeOut mod 1000;
      end;

      try
        {检测端口能否连通}
        nSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
        try
          {设置Socket为非阻塞}
          nLen := 1;
          ioctlsocket(nSocket, FIONBIO, nLen);

          {测试连接}
          connect(nSocket, nAddr, SizeOf(nAddr));

          FD_ZERO(nFDSet);
          FD_SET(nSocket, nFDSet);
          if select(0, 0, @nFDSet, 0, @nTimeVal) <= 0 then
            raise EUnconnected.Create('');
        finally
          closesocket(nSocket);
        end;

        Result := PS_OK;
      except
        on E: EUnconnected do
          Result := PS_UNCONNECTED;
      end;
    finally
      if not AWSAInited then
        WSACleanup;
    end;
  except
  end;
end;

{ TPortCheck }

procedure TPortCheck.Add(AAddress: string; APort: UInt16; ATimeOut: UInt16);
var
  nPCI: PCheckItem;
  nKey: string;
  nNA: UInt32;
  nNP: UInt16;
begin
  nNA := A2NA(AAddress);
  nNP := P2NP(APort);
  nKey := GetKey(nNA, nNP);

  {如果已经存在监测, 则退出}
  FSCItem.Enter;
  try
    if FItems.ContainsKey(nKey) then
      Exit;
  finally
    FSCItem.Leave;
  end;

  New(nPCI);
  with nPCI^ do
  begin
    State := PS_UNCHECK;
    NAddress := nNA;
    NPort := nNP;
    Address := AAddress;
    Port := APort;
    TimeOut := ATimeOut;
    NextCheckTC := GetTickCount;
  end;

  FSCItem.Enter;
  try
    FItems.Add(nKey, nPCI);
  finally
    FSCItem.Leave;
  end;
end;

function TPortCheck.PortState(AAddress: string;
  APort: UInt16): TPortState;
var
  nPCI: PCheckItem;
begin
  nPCI := FItems.Items[GetKey(A2NA(AAddress), P2NP(APort))];
  if nPCI = nil then
    Result := PS_UNCHECK
  else
    Result := nPCI^.State;
end;

constructor TPortCheck.Create;
begin
  FSCItem := TCriticalSection.Create;
  FItems := TDictionary<string, PCheckItem>.Create;
  FOnChange := nil;
  inherited Create(False);
end;

destructor TPortCheck.Destroy;
var
  nPI: PCheckItem;
begin
  FSCItem.Free;
  for nPI in FItems.Values do
    Dispose(nPI);
  FItems.Free;
  inherited;
end;

procedure TPortCheck.Execute;
var
  nNextCheckTC: UInt32;
  nFDSet: TFDSet;
  nTimeVal: TTimeVal;
  nSocket: TSocket;
  nAddr: TSockAddrIn;
  nLen, i: integer;
  nPCI: PCheckItem;
  nPCIArray: TArray<PCheckItem>;
  nConPortChecked: Boolean;
  nStatus: TPortState;
  nWSAData: TWSAData;
begin
  try
    WSAStartup($0101, nWSAData);
    try
      nNextCheckTC := GetTickCount;
      while not Terminated do
      begin
        Sleep(100);

        if GetTickCount < nNextCheckTC then
          Continue;

        {先定义下次检测时间, 如果检测时间过长则直接进入下轮检测}
        nNextCheckTC := GetTickCount + 2000;

        {每次循环前先吧当前要检测的取出来, 防止长期占用临界区}
        FSCItem.Enter;
        try
          SetLength(nPCIArray, FItems.Count);
          i := 0;
          for nPCI in FItems.Values do
          begin
            nPCIArray[i] := nPCI;
            Inc(i);
          end;
        finally
          FSCItem.Leave;
        end;

        for i := Low(nPCIArray) to High(nPCIArray) do
        begin
          if Terminated then
            Exit;

          Sleep(20);
          nPCI := nPCIArray[i];

          nStatus := Check(nPCI^.NAddress, nPCI^.NPort, nPCI^.TimeOut, True);

          if nPCI^.State <> nStatus then
          begin
            nPCI^.State := nStatus;
            if Assigned(FOnChange) then
              FOnChange(Self, nPCI^.Address, nPCI^.Port, nPCI^.State);
          end;
        end;
      end;
    finally
      WSACleanup;
    end;
  except
  end;
end;

function TPortCheck.GetKey(const AItem: TCheckItem): string;
begin
  Result := GetKey(AItem.NAddress, AItem.NPort);
end;

function TPortCheck.GetKey(ANAddress: UInt32; ANPort: UInt16): string;
begin
  Result := Format('%d:%d', [ANAddress, ANPort]);
end;

procedure TPortCheck.Remove(AAddress: string; APort: UInt16);
var
  nKey: string;
  nNA: UInt32;
  nNP: UInt16;
begin
  nNA := A2NA(AAddress);
  nNP := P2NP(APort);
  nKey := GetKey(nNA, nNP);

  {如果已经存在监测, 则退出}
  FSCItem.Enter;
  try
    FItems.Remove(nKey);
  finally
    FSCItem.Leave;
  end;
end;

end.