Socket IO重叠模型(事件通知)

{*******************************************************}
{                                                       }
{       Overlap IO Client                               }
{       Creation Date 2010.03.18                        }
{       Created By: 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;
//
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);
destructor Destroy; override;
end;

const
K_ClientCount = 80;
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('127.0.0.1');
FServerAddr.sin_port := htons(61000);
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);
begin
inherited Create(True);
FreeOnTerminate := True;
FClientID := ID;
FMemo := Memo;
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);
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 Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
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;
ClientArr: array [1..K_ClientCount] of TClientThread;
begin
MainFormHandle := Self.Handle;
if unitWorkThread.gStartupFlag = 0 then
for i := 1 to K_ClientCount do
begin
ClientArr[i] := TClientThread.Create(Memo1,i);
Sleep(1);
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.