IOCP简单例子

Server:

{*******************************************************}
{                                                       }
{       IOCP Server Sample                              }
{       Creation Date 2010.03.22                        }
{       Created By: ming                                }
{                                                       }
{*******************************************************}
unit unitWorkThread;

interface

uses
  Windows, Messages, Forms, SysUtils, Classes, StdCtrls, unitWinsock2;

const
  WM_ACTION = WM_USER + 100;
  DATA_BUFFSIZE = 1024;
  OP_READ = 1;
  OP_WRITE = 2;

type
  TAcceptThread = class(TThread)
  private
    FEvent: HWND;
    FMemo: TMemo;
    FLogMsg: string;
    FProcessorCount: Integer;
  protected
    procedure Execute;override;
  public
    procedure doLogMsg(const msg: String);
    procedure syncLogMsg;
    procedure exitThread;
    constructor Create(Memo: TMemo);
    destructor Destroy; override;
  end;
  //
  TReceiveThread = class(TThread)
  private
    FMemo: TMemo;
    FLogMsg: string;
    FID,FDoCount: Integer;
    FCompletion: THandle;
  protected
    procedure Execute;override;
  public
    procedure doLogMsg(const msg: String);
    procedure syncLogMsg;
    constructor Create(Memo: TMemo; ID: Integer; Completion: THandle);
    destructor Destroy; override;
  end;
  
  PPER_HANDLE_DATA = ^TPER_HANDLE_DATA;
  TPER_HANDLE_DATA = record
    socket: TSocket;
    addr: TSockAddr;
  end;
  PPER_IO_DATA = ^TPER_IO_DATA;
  TPER_IO_DATA = record
    aOverlapper: TOverlapped;
    buf: array [0..DATA_BUFFSIZE-1] of Char;
    opType: Byte;
  end;

var
  gStartupFlag: Integer = -1;
  AcceptThread: TAcceptThread;
  RecvThread: array of TReceiveThread;
  
  p_handle_data: PPER_HANDLE_DATA;
  p_io_data: PPER_IO_DATA;
  WsaBuf: TWSABUF;
  hCompletion: THandle;
  //
  ListenPort: DWORD = 61000;
  ListenSocket: TSocket;
  ServerAddr: TSockAddr;
  ClientAddr: TSockAddr;
  dwRecvBytes,dwSendBytes,dwFlag: DWORD;
  //
  MainForm: HWND;

implementation

function GetProcessorCount:Integer;
var
  sysinfo: SYSTEM_INFO;
begin
  GetSystemInfo(sysinfo);
  Result := sysinfo.dwNumberOfProcessors;
end;

procedure SyncAddLog(const msg:string);
begin
  SendMessage(MainForm,WM_ACTION,WParam(PChar(msg)),0);
end;

function FmtErrMsg(const errMsg:string; const errCode:Integer=0):string;
begin
  Result := Format('ErrMsg:%s,ErrCode:%d',[errMsg,errCode]);
end;

procedure showErrMsg(const errMsg:string; const errCode:Integer=0);
var
  szMsg: string;
begin
  szMsg := Format('ErrMsg:%s,ErrCode:%d',[errMsg,errCode]);
  MessageBox(0,PChar(szMsg),'Error',0);
end;

function StartUpSocket: Integer;
var
  wsaData: TWSAData;
  err: Integer;
begin
  Result := -1;
  err := WSAStartup(MakeWord(2,2),wsaData);
  if err <> 0 then
  begin
    showErrMsg('WSAStartup Error!');
    Exit;
  end;
  if (Lo(wsaData.wVersion)<>2) or (Hi(wsaData.wVersion)<>2) then
  begin
    showErrMsg('Socket Version Error!');
    Exit;
  end;
  Result := 0;
end;

function SocketListen:Integer;
var
  len: Integer;
begin
  Result := -1;
  if gStartupFlag <> 0 then Exit;

  ListenSocket := WSASocket(AF_INET,SOCK_STREAM,IPPROTO_TCP,nil,0,WSA_FLAG_OVERLAPPED);

  if ListenSocket = INVALID_SOCKET then
  begin
    showErrMsg('Create ListenSocket Error!');
    Exit;
  end;

  ServerAddr.sin_family := AF_INET;
  ServerAddr.sin_addr.S_addr := htonl(INADDR_ANY);
  ServerAddr.sin_port := htons(ListenPort);
  len := SizeOf(ServerAddr);
  
  if bind(ListenSocket,PSockaddr(@ServerAddr),len)=SOCKET_ERROR then
  begin
    showErrMsg('bind Error!',WSAGetLastError);
    Exit;
  end;
  if listen(ListenSocket,5)=SOCKET_ERROR then
  begin
    showErrMsg('listen Error!',WSAGetLastError);
    Exit;
  end;
  Result := 0;
end;

{ TAcceptThread }

constructor TAcceptThread.Create(Memo: TMemo);
var
  i: Integer;
begin
  inherited Create(False);
  FreeOnTerminate := True;
  FMemo := Memo;
  FEvent := CreateEvent(nil,False,False,nil);
  hCompletion := CreateIoCompletionPort(INVALID_HANDLE_VALUE,0,0,0);
  FProcessorCount := GetProcessorCount * 2;
  SetLength(RecvThread,FProcessorCount);
  for i := 0 to FProcessorCount-1 do
  begin
    RecvThread[i] := TReceiveThread.Create(Memo,i,hCompletion);
  end;
end;

destructor TAcceptThread.Destroy;
begin
  SetLength(RecvThread,0);
  CloseHandle(FEvent);
  inherited;
end;

procedure TAcceptThread.Execute;
var
  len,errCode: Integer;
  tempSocket: TSocket;
begin
  inherited;
  len := SizeOf(ClientAddr);
  if SocketListen <> 0 then Exit;
  while not Terminated do
  begin
    if WaitForSingleObject(FEvent,100)=WAIT_OBJECT_0 then
      Break;
    
    tempSocket := accept(ListenSocket,PSockaddr(@ClientAddr),len);
    if tempSocket = INVALID_SOCKET then Continue;

    p_handle_data := PPER_HANDLE_DATA(GlobalAlloc(GPTR,SizeOf(TPER_HANDLE_DATA)));
    p_handle_data^.socket := tempSocket;
    CopyMemory(@p_handle_data^.addr,@ClientAddr,len);

    CreateIoCompletionPort(p_handle_data^.socket,hCompletion,Cardinal(p_handle_data),0);

    p_io_data := PPER_IO_DATA(GlobalAlloc(GPTR,SizeOf(TPER_IO_DATA)));
    p_io_data^.opType := OP_READ;
    WsaBuf.buf := @p_io_data^.buf;
    WsaBuf.len := DATA_BUFFSIZE;

    if (WSARecv(p_handle_data^.socket,@WsaBuf,1,@dwRecvBytes,@dwFlag
      ,@p_io_data^.aOverlapper,nil))=SOCKET_ERROR then
    begin
      errCode := WSAGetLastError;
      if errCode <> WSA_IO_PENDING then
      begin
        closesocket(p_handle_data^.socket);
        GlobalFree(Cardinal(p_io_data));
        GlobalFree(Cardinal(p_handle_data));
        doLogMsg(FmtErrMsg('WSAGetLastError Error!',errCode));
        Continue;
      end;
    end;
  end;
end;

procedure TAcceptThread.exitThread;
var
  dwTrans: DWORD;
  i: Integer;
begin
  dwTrans := 0;
  if ListenSocket <> INVALID_SOCKET then
  begin
    for i := 0 to FProcessorCount-1 do
      PostQueuedCompletionStatus(hCompletion,dwTrans,0,nil);
    shutdown(ListenSocket,SD_BOTH);
    closesocket(ListenSocket);
    CloseHandle(hCompletion);
  end;
  SetEvent(FEvent);
end;

procedure TAcceptThread.doLogMsg(const msg: String);
begin
  FLogMsg := msg;
  Synchronize(syncLogMsg);
end;

procedure TAcceptThread.syncLogMsg;
begin
  FMemo.Lines.Add(FLogMsg);
end;

{ TReceiveThread }

constructor TReceiveThread.Create(Memo: TMemo; ID:Integer; Completion: THandle);
begin
  inherited Create(False);
  FreeOnTerminate := True;
  FMemo := Memo;
  FID := ID;
  FCompletion := Completion;
end;

destructor TReceiveThread.Destroy;
begin

  inherited;
end;

procedure TReceiveThread.Execute;
var
  dwTrans: DWORD;
  pPerHandle: PPER_HANDLE_DATA;
  pPerIO: PPER_IO_DATA;
  bOK: Boolean;
  szText: string;
begin
  inherited;
  while not Terminated do
  begin
    bOK := GetQueuedCompletionStatus(FCompletion,dwTrans,
      Cardinal(pPerHandle),POverlapped(pPerIO),WSA_INFINITE);
    if not Assigned(pPerIO) then Break;
    if not bOK then
    begin
      closesocket(pPerHandle^.socket);
      GlobalFree(Cardinal(pPerHandle));
      GlobalFree(Cardinal(pPerIO));
      doLogMsg('GlobalFree 1.');
      Continue;
    end
    else if (dwTrans=0) and ((pPerIO^.opType=OP_READ) or (pPerIO^.opType=OP_WRITE)) then
    begin
      closesocket(pPerHandle^.socket);
      GlobalFree(Cardinal(pPerHandle));
      GlobalFree(Cardinal(pPerIO));
      doLogMsg('GlobalFree 2.');
      Continue;
    end;
    
    case pPerIO^.opType of
      OP_READ:
      begin
        Inc(FDoCount);
        doLogMsg(Format('ID:%d DoCount:%d Recv: %s',[FID,FDoCount,pPerIO^.buf]));
        szText := 'Return Msg';

        p_io_data^.opType := OP_WRITE;
        ZeroMemory(@p_io_data^.buf,DATA_BUFFSIZE);
        CopyMemory(@p_io_data^.buf,@szText[1],Length(szText));
        WsaBuf.buf := @p_io_data^.buf;
        WsaBuf.len := Length(szText);

        WSASend(p_handle_data^.socket,@WsaBuf,1,@dwRecvBytes,0
          ,@p_io_data^.aOverlapper,nil);
      end;
      OP_WRITE:
      begin
        //doLogMsg('OP_WRITE');
        closesocket(pPerHandle^.socket);
        GlobalFree(Cardinal(pPerHandle));
        GlobalFree(Cardinal(pPerIO));
        doLogMsg('GlobalFree 3.');
      end; 
    end;
    Sleep(100);
  end;
end;

procedure TReceiveThread.doLogMsg(const msg: String);
begin
  FLogMsg := msg;
  Synchronize(syncLogMsg);
end;

procedure TReceiveThread.syncLogMsg;
begin
  FMemo.Lines.Add(FLogMsg);
end;


initialization
  gStartupFlag := StartupSocket;
finalization
  if gStartupFlag = 0 then
    WSACleanup;

end.

//Main Form
unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, unitWorkThread;

type
  TForm1 = class(TForm)
    mmoLog: TMemo;
    Button1: TButton;
    btnSetPort: TButton;
    lbledtPort: TLabeledEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure mmoLogDblClick(Sender: TObject);
    procedure btnSetPortClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    procedure onMyAction(var msg: TMessage);message WM_ACTION;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnSetPortClick(Sender: TObject);
begin
  ListenPort := StrToInt(lbledtPort.Text);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if gStartupFlag = 0 then
  begin
    AcceptThread := TAcceptThread.Create(mmoLog);
    MainForm := Self.Handle;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Assigned(AcceptThread) then  
    AcceptThread.exitThread;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  //
end;

procedure TForm1.mmoLogDblClick(Sender: TObject);
begin
  TMemo(Sender).Clear;
end;

procedure TForm1.onMyAction(var msg: TMessage);
begin
  mmoLog.Lines.Add(StrPas(PChar(msg.WParam)));
end;

end.

Client:

{*******************************************************}
{                                                       }
{       Overlap IO Client                               }
{       Creation Date 2010.03.18                        }
{       版权所有 (C) 2011 ming                          }
{                                                       }
{*******************************************************}
unit unitWorkThread;

interface

uses
  Windows, Messages, SysUtils, Classes, StdCtrls, unitWinsock2;

const
  WM_ACTION = WM_USER + 100;
  DATA_BUFFSIZE = 1024;

type
  //
  TClientThread = class(TThread)
  private
    FMemo: TMemo;
    FEvent: HWND;
    FClientID: Integer;
    FLogMsg: String;
    //
    FRemoteIP:string;
    FRemotePort:DWORD;
    //
    FClientSocket: TSocket;
    FServerAddr: TSockAddrIn;
    FOverlapper: TOverlapped;
    FDataBuf: TWSABUF;
    FEventArray: array [0..1] of WSAEVENT;
    FBuf: array [0..DATA_BUFFSIZE-1] of AnsiChar;
    FTransBytes,FTransFlag: DWORD;
    //function StartupSocket: Integer;
    function ConnectServer:Integer;
    procedure doLogMsg(const msg: String);
    procedure syncLogMsg;
  protected
    procedure Execute;override;
  public
    procedure _SetEvent;
    function SendMsg(const msg:string=''):Integer;
    function RecvMsg(const msg:string=''):Integer;
    constructor Create(Memo: TMemo; ID:Integer; const IP:string; port:DWORD);
    destructor Destroy; override;
  end;

const
  K_ClientCount = 100;
var
  MainFormHandle: HWND=0;
  gStartupFlag: Integer = -1;
  ClientThread: TClientThread;
  MsgArr: array [1..K_ClientCount] of string;

implementation

procedure showErrMsg(const errMsg:string; const errCode:Integer=0);
var
  szMsg: string;
begin
  szMsg := Format('ErrMsg:%s,ErrCode:%d',[errMsg,errCode]);
  MessageBox(0,PChar(szMsg),'Error',0);
end;

function StartupSocket: Integer;
var
  wsaData: TWSAData;
  err: Integer;
begin
  Result := -1;
  err := WSAStartup(MakeWord(2,2),wsaData);
  if err <> 0 then
  begin
    showErrMsg('WSAStartup Error!');
    Exit;
  end;
  if (Lo(wsaData.wVersion)<>2) or (Hi(wsaData.wVersion)<>2) then
  begin
    showErrMsg('Socket Version Error!');
    Exit;
  end;
  Result := 0;
end;

{ TClientThread }

function TClientThread.ConnectServer: Integer;
var
  len: Integer;
begin
  Result := -1;
  FClientSocket := WSASocket(AF_INET,SOCK_STREAM,IPPROTO_TCP,nil,0,WSA_FLAG_OVERLAPPED);
  if FClientSocket = INVALID_SOCKET then
    Exit;
  FServerAddr.sin_family := AF_INET;
  FServerAddr.sin_addr.S_addr := inet_addr(PAnsiChar(FRemoteIP));
  FServerAddr.sin_port := htons(FRemotePort);
  len := SizeOf(TSockAddrIn);
  if connect(FClientSocket,PSockAddr(@FServerAddr),len)=SOCKET_ERROR then
    Exit;
  FEventArray[0] := WSACreateEvent;
  FOverlapper.hEvent := FEventArray[0];
  Result := 0;
end;

constructor TClientThread.Create(Memo:TMemo; ID:Integer; const IP:string; port:DWORD);
begin
  inherited Create(True);
  FreeOnTerminate := True;
  FClientID := ID;
  FMemo := Memo;
  FRemoteIP := IP;
  FRemotePort := port;
  FEvent := CreateEvent(nil,False,False,nil);
  if ConnectServer = 0 then
    Resume;
end;

destructor TClientThread.Destroy;
begin
  shutdown(FClientSocket,0);
  closesocket(FClientSocket);
  if FEvent > 0 then
    CloseHandle(FEvent);
  WSACloseEvent(FOverlapper.hEvent);
  inherited;
end;

procedure TClientThread.syncLogMsg;
begin
  FMemo.Lines.Add(FLogMsg);
end;

procedure TClientThread.doLogMsg(const msg: String);
begin
  FLogMsg := msg;
  Synchronize(syncLogMsg);
end;

procedure TClientThread.Execute;
var
  dwFlag,dwIndex,dwBytesTransferred: DWORD;
  szText: string;
begin
  inherited;
  if SendMsg('')=0 then Exit;
  RecvMsg('');
  while not Terminated do
  begin
    dwIndex := WSAWaitForMultipleEvents(1,@FOverlapper.hEvent,FALSE,1000,FALSE);
    if (dwIndex=WSA_WAIT_FAILED) or (dwIndex=WSA_WAIT_TIMEOUT) then
    begin
      Continue;
    end;
    dwIndex := dwIndex - WSA_WAIT_EVENT_0;
    WSAResetEvent(FEventArray[dwIndex]);
    WSAGetOverlappedResult(FClientSocket,@FOverlapper,@dwBytesTransferred,FALSE,@dwFlag);
    //Break;
    if dwBytesTransferred=0 then
    begin
      MsgArr[FClientID] := Format('%d Error,dwBytesTransferred=0.',[FClientID]);
      //doLogMsg(Format('%d Error,dwBytesTransferred=0.',[FClientID]));
    end
    else
    begin
      szText := StrPas(FDataBuf.buf);
      MsgArr[FClientID] := Format('%d Msg: %s',[FClientID,szText]);
      //doLogMsg(Format('%d Msg: %s',[FClientID,szText]));
    end;
    Break;
  end;
end;

function TClientThread.RecvMsg(const msg: string):Integer;
begin
  ZeroMemory(@FBuf,DATA_BUFFSIZE);
  FDataBuf.len := DATA_BUFFSIZE;
  FDataBuf.buf := @FBuf;
  Result := WSARecv(FClientSocket,@FDataBuf,1,@FTransBytes,@FTransFlag,@FOverlapper,nil);
end;

function TClientThread.SendMsg(const msg: string):Integer;
var
  len: Integer;
  szText: AnsiString;
  buf: array [0..100-1] of AnsiChar;
  dwBytes,dwFlag,dwBytesTransferred: DWORD;
  SendOverlapper: TOverlapped;
begin
  ZeroMemory(@SendOverlapper,SizeOf(TOverlapped));
  SendOverlapper.hEvent := WSACreateEvent;
  FillChar(buf,100,0);
  szText := 'Test Message.';
  szText := Format('%d Msg: %s',[FClientID,szText]);
  len := Length(szText);
  CopyMemory(@buf,@szText[1],len);
  FDataBuf.len := len;
  FDataBuf.buf := @buf;
  Result := WSASend(FClientSocket,@FDataBuf,1,@dwBytes,0,@SendOverlapper,nil);
  if Result <> SOCKET_ERROR then
  begin
    WSAGetOverlappedResult(FClientSocket,@SendOverlapper,@dwBytesTransferred,FALSE,@dwFlag);
    Result := dwBytesTransferred;
  end;
  WSACloseEvent(SendOverlapper.hEvent);
end;

procedure TClientThread._SetEvent;
begin

end;

initialization
  gStartupFlag := StartupSocket;
finalization
  if gStartupFlag = 0 then
    WSACleanup;

end.

//Main form
unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, unitWorkThread;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    cbbIP: TComboBox;
    edtPort: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Memo1DblClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure ShowMsg;
    procedure On_WM_Action(var msg:TMessage);message WM_ACTION;
  end;

var
  Form1: TForm1;

implementation

uses unitWinSock2;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
  port: DWORD;
  ClientArr: array [1..K_ClientCount] of TClientThread;
begin
  MainFormHandle := Self.Handle;
  port := StrToInt(edtPort.Text);
  if unitWorkThread.gStartupFlag = 0 then
  for i := 1 to K_ClientCount do
  begin
    ClientArr[i] := TClientThread.Create(Memo1,i,cbbIP.Text,port);
    Sleep(10);
  end;
  WaitForMultipleObjects(K_ClientCount,@ClientArr,True,480000);
  Memo1.Lines.Add('Execute completed------');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMsg;
end;

procedure TForm1.ShowMsg;
var
  i: Integer;
begin
  for i := 1 to K_ClientCount do
  begin
    Memo1.Lines.Add(MsgArr[i]);
  end;
end;

procedure TForm1.On_WM_Action(var msg: TMessage);
begin
  case msg.LParam of
    1: ShowMsg;
  end;
end;

procedure TForm1.Memo1DblClick(Sender: TObject);
begin
  TMemo(Sender).Clear;
end;

end.