iocpcomp.pas

DELPHI编程实现的对端口通讯的封装。比较有参考意义。

unit IOCPComp;

interface

{$IFDEF VER150}
  {$WARN UNSAFE_TYPE OFF}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_CAST OFF}
{$ENDIF}

uses
  Windows, Messages, WinSock2, Classes, ScktComp, SysUtils;

const
  MAX_BUFSIZE = 4096;
  WM_CLIENTSOCKET = WM_USER + $2000;

type
  TCMSocketMessage = packed record
    Msg: Cardinal;
    Socket: TSocket;
    SelectEvent: Word;
    SelectError: Word;
    Result: Longint;
  end;

  TSocketEvent = (seInitIOPort, seInitSocket,  seConnect, seDisconnect,
    seListen, seAccept, seWrite, seRead);
  TErrorEvent = (eeGeneral, eeSend, eeReceive, eeConnect, eeDisconnect, eeAccept);

  PPerHandleData = ^TPerHandleData;
  TPerHandleData = packed record
    Overlapped: OVERLAPPED;
    wsaBuffer: WSABUF;
    Event: TSocketEvent;
    IsUse: Boolean;
    Buffer: array [0..MAX_BUFSIZE - 1] of Char;
  end;

  PBlock = ^TBlock;
  TBlock = packed record
    Data: TPerHandleData;
    IsUse: Boolean;
  end;

  EMemoryBuffer = class(Exception);
  ESocketError = class(Exception);

  TCustomSocket = class;
  TServerClientSocket = class;

  TOnDataEvent = function(Socket: TCustomSocket; Data: Pointer; Count: Integer): Integer of object;
  TSocketErrorEvent = procedure(Socket: TCustomSocket; ErrorEvent: TErrorEvent; var ErrCode: Integer) of object;
  TSocketEventEvent = procedure(Socket: TCustomSocket; SocketEvent: TSocketEvent) of object;


  TMemoryBuffer = class
  private
    FList: TList;
    FSocket: TCustomSocket;
    function GetCount: Integer;
    function GetBlock(const Index: Integer): PBlock;
  protected
    property Count: Integer read GetCount;
    property Blocks[const Index: Integer]: PBlock read GetBlock;
  public
    constructor Create(ASocket: TCustomSocket); overload;
    constructor Create(ASocket: TCustomSocket; BlockCount: Integer); overload;
    destructor Destroy; override;
    function AllocBlock: PBlock;
    procedure RemoveBlock(Block: PBlock);
  end;

  TCustomSocket = class
  private
    FSocket: TSocket;
    FActive: Boolean;
    FInitLock: Boolean;
    FLock: TRTLCriticalSection;
    FOnRead: TOnDataEvent;
    FOnErrorEvent: TSocketErrorEvent;
    FOnEventEvent: TSocketEventEvent;
    function GetRemoteAddress: string;
    function GetRemoteHost: string;
    procedure DoRead(Data: Pointer; Count: Integer);
  protected
    procedure SetActive(Value: Boolean); virtual; abstract;
    procedure Event(SocketEvent: TSocketEvent); virtual;
    procedure Error(ErrorEvent: TErrorEvent; var ErrCode: Integer); virtual;
    property OnRead: TOnDataEvent read FOnRead write FOnRead;
    property OnErrorEvent: TSocketErrorEvent read FOnErrorEvent write FOnErrorEvent;
    property OnEventEvent: TSocketEventEvent read FOnEventEvent write FOnEventEvent;
  public
    constructor Create(ASocket: TSocket);
    destructor Destroy; override;
    procedure Close;
    procedure Open;
    procedure Lock;
    procedure UnLock;
    function Read(var Buf; Count: Integer): Integer; virtual;
    function Write(var Buf; Count: Integer): Integer; virtual;
    property SocketHandle: TSocket read FSocket;
    property Active: Boolean read FActive write SetActive;
    property RemoteHost: string read GetRemoteHost;
    property RemoteAddress: string read GetRemoteAddress;
  end;

  TCustomerServerSocket = class(TCustomSocket)
  private
    FOnClientRead: TOnDataEvent;
    FOnClientError: TSocketErrorEvent;
    FOnClientEvent: TSocketEventEvent;
  protected
    function DoClientRead(ASocket: TCustomSocket; AData: Pointer; ACount: Integer): Integer;
    procedure ClientSocketError(ASocket: TCustomSocket;
      ErrorEvent: TErrorEvent; var ErrCode: Integer);
    procedure ClientSocketEvent(ASocket: TCustomSocket; SocketEvent: TSocketEvent);
  public
    property OnClientRead: TOnDataEvent read FOnClientRead write FOnClientRead;
    property OnClientError: TSocketErrorEvent read FOnClientError write FOnClientError;
    property OnClientEvent: TSocketEventEvent read FOnClientEvent write FOnClientEvent;
    property OnErrorEvent;
    property OnEventEvent;
  end;

  TGetSocketEvent = procedure(Socket: TSocket; var ClientSocket: TServerClientSocket) of object;
  TServerSocket = class(TCustomerServerSocket)
  private
    FPort: Integer;
    FAddr: TSockAddr;
    FAcceptThread: THandle;
    FCompletionPort: THandle;
    FClients: TList;
    FThreads: TList;
    FHandle: THandle;
    FBuffer: TMemoryBuffer;
    FOnGetSocket: TGetSocketEvent;
    procedure SetPort(Value: Integer);
    procedure RegisterClient(ASocket: TCustomSocket);
    procedure RemoveClient(ASocket: TCustomSocket);
    procedure WMClientClose(var Message: TCMSocketMessage); message WM_CLIENTSOCKET;
    procedure WndProc(var Message: TMessage);
    function FindClientSocket(ASocket: TSocket): TCustomSocket;
    function GetClientCount: Integer;
    function GetClients(const Index: Integer): TServerClientSocket;
  protected
    procedure InternalOpen;
    procedure InternalClose;
    procedure SetActive(Value: Boolean); override;
    property AcceptThread: THandle read FAcceptThread;
    property CompletionPort: THandle read FCompletionPort;
    function IsAccept(Socket: TSocket): Boolean; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Accept(ASocket: TSocket; ACompletionPort: THandle);
    property Handle: THandle read FHandle;
    property Port: Integer read FPort write SetPort;
    property ClientCount: Integer read GetClientCount;
    property Clients[const Index: Integer]: TServerClientSocket read GetClients;
    property OnGetSocket: TGetSocketEvent read FOnGetSocket write FOnGetSocket;
  end;

  TServerClientSocket = class(TCustomSocket)
  private
    FBlock: TList;
    FBuffer: TMemoryBuffer;
    FServerSocket: TServerSocket;
    function AllocBlock: PBlock;
    function PrepareRecv(Block: PBlock = nil): Boolean;
    function WorkBlock(var Block: PBlock; Transfered: DWORD): DWORD;
  protected
    procedure SetActive(Value: Boolean); override;
  public
    constructor Create(AServerSocket: TServerSocket; ASocket: TSocket);
    destructor Destroy; override;
    function Read(var Buf; Count: Integer): Integer; override;
    function Write(var Buf; Count: Integer): Integer; override;
  end;

implementation

uses RTLConsts;

const
  SHUTDOWN_FLAG = $FFFFFFFF;
  BlockSize: Word = SizeOf(TBlock);

var
  WSData: TWSAData;

{ TMemoryBuffer }

constructor TMemoryBuffer.Create(ASocket: TCustomSocket);
begin
  Create(ASocket, 200);
end;

constructor TMemoryBuffer.Create(ASocket: TCustomSocket; BlockCount: Integer);
var
  I: Integer;
  P: PBlock;
begin
  inherited Create;
  FSocket := ASocket;
  FList := TList.Create;
  for I := 0 to BlockCount - 1 do
  begin
    New(P);
    FillChar(P^, BlockSize, 0);
    FList.Add(P);
  end;
end;      

destructor TMemoryBuffer.Destroy;
var
  I: Integer;
begin
  for I := 0 to FList.Count - 1 do
    FreeMem(FList[I]);
  FList.Free;
  inherited Destroy;
end;

function TMemoryBuffer.AllocBlock: PBlock;
var
  I: Integer;
begin
  FSocket.Lock;
  try
    Result := nil;
    for I := 0 to FList.Count - 1 do
    begin
      Result := FList[I];
      if not Result.IsUse then
        break;
    end;
    if not Assigned(Result) or Result.IsUse then
    begin
      New(Result);
      FList.Add(Result);
    end;
    FillChar(Result^.Data, SizeOf(Result^.Data), 0);
    Result^.IsUse := True;
  finally
    FSocket.UnLock;
  end;
end;

procedure TMemoryBuffer.RemoveBlock(Block: PBlock);
begin
  FSocket.Lock;
  try
    Block.IsUse := False;
  finally
    FSocket.UnLock;
  end;
end;

function TMemoryBuffer.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TMemoryBuffer.GetBlock(const Index: Integer): PBlock;
begin
  if (Index >= Count) or (Index <= -1) then
    raise EMemoryBuffer.CreateFmt(SListIndexError, [Index])
  else
    Result := FList[Index];
end;

procedure CheckError(ResultCode: Integer; const OP: string);
var
  ErrCode: Integer;
begin
  if ResultCode <> 0 then
  begin
    ErrCode := WSAGetLastError;
    if (ErrCode <> WSAEWOULDBLOCK) or (ErrCode <> ERROR_IO_PENDING) then
      raise ESocketError.CreateFmt(SWindowsSocketError,
        [SysErrorMessage(ErrCode), ErrCode, Op]);
  end;
end;

{ TCustomSocket }

constructor TCustomSocket.Create(ASocket: TSocket);
begin
  inherited Create;
  FInitLock := False;
  if WSAStartup($0202, WSData) <> 0 then
    raise ESocketError.Create(SysErrorMessage(GetLastError));
  FSocket := ASocket;
  FActive := FSocket <> INVALID_SOCKET;
end;

destructor TCustomSocket.Destroy;
begin
  SetActive(False);
  WSACleanup;
  if FInitLock then
    DeleteCriticalSection(FLock);
  inherited Destroy;
end;

procedure TCustomSocket.Lock;
begin
  if not FInitLock then
  begin
    InitializeCriticalSection(FLock);
    FInitLock := True;
  end;
  EnterCriticalSection(FLock);
end;

procedure TCustomSocket.UnLock;
begin
  if FInitLock then
    LeaveCriticalSection(FLock);
end;

procedure TCustomSocket.Close;
begin
  SetActive(False);
end;

procedure TCustomSocket.Open;
begin
  SetActive(True);
end;

procedure TCustomSocket.DoRead(Data: Pointer; Count: Integer);
begin
  if Assigned(FOnRead) then
    FOnRead(Self, Data, Count);
end;

procedure TCustomSocket.Error(ErrorEvent: TErrorEvent; var ErrCode: Integer);
begin
  if Assigned(FOnErrorEvent) then
    FOnErrorEvent(Self, ErrorEvent, ErrCode);
end;

procedure TCustomSocket.Event(SocketEvent: TSocketEvent);
begin
  if Assigned(FOnEventEvent) then
    FOnEventEvent(Self, SocketEvent);
end;

function TCustomSocket.GetRemoteAddress: string;
var
  SockAddrIn: TSockAddrIn;
  Size: Integer;
begin
  Result := '';
  if not FActive then Exit;
  Size := SizeOf(SockAddrIn);
  CheckError(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
  Result := inet_ntoa(SockAddrIn.sin_addr);
end;

function TCustomSocket.GetRemoteHost: string;
var
  SockAddrIn: TSockAddrIn;
  Size: Integer;
  HostEnt: PHostEnt;
begin
  Result := '';
  if not FActive then Exit;
  Size := SizeOf(SockAddrIn);
  CheckError(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
  HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.s_addr, 4, PF_INET);
  if HostEnt <> nil then Result := HostEnt.h_name;
end;

function TCustomSocket.Read(var Buf; Count: Integer): Integer;
begin
  raise ESocketError.Create('Error');
end;

function TCustomSocket.Write(var Buf; Count: Integer): Integer;
begin
  raise ESocketError.Create('Error');
end;

{ TCustomerServerSocket }

function TCustomerServerSocket.DoClientRead(ASocket: TCustomSocket;
  AData: Pointer; ACount: Integer): Integer;
begin
  if not Assigned(FOnClientRead) then
    Result := 0 else
    Result := FOnClientRead(ASocket, AData, ACount);
end;

procedure TCustomerServerSocket.ClientSocketError(ASocket: TCustomSocket;
  ErrorEvent: TErrorEvent; var ErrCode: Integer);
begin
  if Assigned(FOnClientError) then
    FOnClientError(ASocket, ErrorEvent, ErrCode);
end;

procedure TCustomerServerSocket.ClientSocketEvent(ASocket: TCustomSocket;
  SocketEvent: TSocketEvent);
begin
  if Assigned(FOnClientEvent) then
    FOnClientEvent(ASocket, SocketEvent);
end;
{ TServerSocket }

function AcceptThreadProc(AServer: TServerSocket): DWORD; stdcall;
begin
  with AServer do
    while Active do
      Accept(SocketHandle, CompletionPort);
  Result := 0;
end;

procedure TServerSocket.Accept(ASocket: TSocket; ACompletionPort: THandle);
var
  Addr: TSockAddrIn;
  AddrLen, Ret, ErrCode: Integer;
  ClientWinSocket: TSocket;
  ClientSocket: TServerClientSocket;
begin
  AddrLen := SizeOf(Addr);
  ClientWinSocket := WinSock2.accept(ASocket, Addr, AddrLen);
  if ClientWinSocket <> INVALID_SOCKET then
  begin
    if not Active and not IsAccept(ClientWinSocket) then
    begin
      closesocket(ClientWinSocket);
      Exit;
    end;
    try
      Event(seAccept);
      ClientSocket := nil;
      if Assigned(FOnGetSocket) then
        FOnGetSocket(ClientWinSocket, ClientSocket);
      if not Assigned(ClientSocket) then
        ClientSocket := TServerClientSocket.Create(Self, ClientWinSocket);
    except