完成端口的问题(copy_paste或完成端口高手,请进来)(200分)

在http://www.tomore.com/1/6272.html下了你的源码来看,但是我在调试时发现服务器端无法接收到客户端用socket.sendtext()传过来的数据.OnClientRead事件无效.

我也有这样的问题~~

我也急需要一个完成端口的实例~~>

哎。真希望有人给一个正确的答案~.

帮你顶~~~~~~~~~

怎么就没人来回答呢？？？

高手都看世界杯去了？？

如果解决了。再多送300分。

unit SocketServerInterface;

interface

uses Windows, Classes, SysUtils, FileCtrl, SyncObjs, Variants, WinSock2, Forms, SocketDefine, StreamManagerInterface,
BuffManagerInterface, Messages, DataManagerInterface, ADODB, IniFiles;

Const
WM_CLIENTCONNECT=WM_USER+1001;
WM_CLIENTDISCONNECT=WM_USER+1002;
WM_CLIENTDISCONNECTS=WM_USER+1003;
Type
PClientInfo=^TClientInfo;
TClientInfo=record
Socket:TSocket;
Host:String;
Port:Integer;
end;

PSocket=^TSocket;
TServer=Class;
TAcceptThread=Class;

TWorkThread=Class(TThread)
private
Server:TServer;
hCompletion:THandle;

MsgParam, ClientHost, Err:String;
MsgID,TypeID:Integer;

//局部变量
OpOVERLAPPED;
OpExWSAOVERLAPPEDEx;
TransBytes,CompletionKey:Cardinal;
MsgHandle:THandle;
AcceptThread:TAcceptThread;
SendDataByte;
SendLen:Integer;

function GetPeerHost(hSock:TSocket):String;
procedure DoMsg;
procedure DoCustomMsg;
procedure DoRecv(OPWSAOVERLAPPEDEx);
procedure InternalClose;

procedure OnData(Socket:TSocket; Bufointer; Len:Integer; UserData:TUserData; var IsSucc:Boolean);
function SendToClient(Socket: TSocket; var Buf; Len: Integer): Boolean;

protected
procedure Execute;override;
public
Constructor Create(hCompletion: THandle; Param: Pointer);
Destructor Destroy;override;
end;

TAcceptThread=Class(TThread)
private
Server:TServer;
WorkThread:TWorkThread;
Socket:TSocket;
hCompletion:THandle;

SysInfo:SYSTEM_INFO;
DataBuffManager:TBuffManager;
OPBuffManager:TBuffManager;

MsgParam,ClientHost:String;
MsgID,TypeID:Integer;

MsgHandle:THandle;
ClientRecvBuffSize:Integer;

//局部变量
Bufs:TWSABUF;
RecvBytes:Cardinal;
OpWSAOVERLAPPEDEx;
NewSocket:TSocket;

ppp:TStringList;
procedure InternalClose(OpWSAOVERLAPPEDEx);
procedure DoMsg;
procedure DoRecv;
function CheckConnect(p:Integer):Integer;
protected
procedure Execute;override;
public
Constructor Create(Paramointer; DataPoolSize,OPDataPoolSize:Integer);
Destructor Destroy;override;
end;

TServer=Class
private
FOnRecv: TOnRecv;
FActive: Boolean;
FPort: Integer;
Socket:TSocket;
FOnMsg: TOnMsg;
Lock,ClientLock:TCriticalSection;
FPause: Boolean;
ClientList:TList;
FHandle:THandle;
hCompletion:THandle;
FAcceptDataPoolSize: Integer;
FAcceptOPDataPoolSize: Integer;
WorkLock:TCriticalSection;
FDebug: Boolean;

procedure CloseClients;
procedure OnWndProc(Var Msg:TMessage);
procedure SetActive(const Value: Boolean);
procedure SetOnRecv(const Value: TOnRecv);
procedure SetPort(const Value: Integer);
procedure SetOnMsg(const Value: TOnMsg);
procedure SetPause(const Value: Boolean);
function GetPause: Boolean;
function GetPeerHost(hSock: TSocket; Var Port:Integer): String;
procedure SetAcceptDataPoolSize(const Value: Integer);
procedure SetAcceptOPDataPoolSize(const Value: Integer);

procedure DoRecv(Socket:TSocket; Dataointer; Len:Integer);
procedure SetDebug(const Value: Boolean);


public

Constructor Create(ServerDataPoolSize:Integer);
Destructor Destroy;override;

FUNCTION Send(Socket:TSocket; Var Buf; Len:Integer):Boolean;

property Port:Integer read FPort write SetPort;
property OnRecv:TOnRecv read FOnRecv write SetOnRecv;
property OnMsg:TOnMsg read FOnMsg write SetOnMsg;
property Active:Boolean read FActive write SetActive;
property Pause:Boolean read GetPause write SetPause;
property Handle:THandle read FHandle;
property AcceptDataPoolSize:Integer read FAcceptDataPoolSize write SetAcceptDataPoolSize;
property AcceptOPDataPoolSize:Integer read FAcceptOPDataPoolSize write SetAcceptOPDataPoolSize;

property Debug:Boolean read FDebug write SetDebug;
end;

procedure InitDataManagers(Connection:TADOConnection; Count:Integer; DataPoolSize:Integer);
procedure InitStreamManagers(Count:Integer; DataPoolSize:Integer);

implementation

uses MsgDefine, DES32, Cryptogram;


Type
PDataManagerInfo=^TDataManagerInfo;
TDataManagerInfo=record
IsUse:Boolean;
DataManager:TDataManager;
end;

PStreamManagerInfo=^TStreamManagerInfo;
TStreamManagerInfo=record
IsUse:Boolean;
StreamManager:TStreamManager;
end;
Var
List:TList;
Lock:TCriticalSection;
DebugMode:Boolean;
DefaultDataPoolSize:Integer;
DefaultConnection:TADOConnection;

StreamList:TList;
StreamLock:TCriticalSection;
DefaultStreamPoolSize:Integer;


procedure InitStreamManagers(Count:Integer; DataPoolSize:Integer);
Var
Ini:TIniFile;
i:Integer;
InfoStreamManagerInfo;
begin
StreamLock.Acquire;
Try
DefaultStreamPoolSize:=DataPoolSize;
For i:=1 to Count do
begin
New(Info);
Info.StreamManager:=TStreamManager.Create(DataPoolSize);
Info.IsUse:=false;
StreamList.Add(Info);
end;
Finally
StreamLock.Release;
end;
end;

procedure FreeStreamManager(StreamManager:TStreamManager);
Var
i:Integer;
InfoStreamManagerInfo;
begin
StreamLock.Acquire;
Try
For i:=0 to StreamList.Count-1 do
begin
Info:=StreamList.Items;
if Info.StreamManager=StreamManager then
begin
Info.IsUse:=false;
break;
end;
end;
Finally
StreamLock.Release;
end;
end;

function GetStreamManager:TStreamManager;
Var
i:Integer;
InfoStreamManagerInfo;
begin
StreamLock.Acquire;
Try
Result:=nil;
For i:=0 to StreamList.Count-1 do
begin
Info:=StreamList.Items;
if Not Info.IsUse then
begin
Info.IsUse:=true;
Result:=Info.StreamManager;
Exit;
end;
end;
if Result=nil then
begin
New(Info);
Info.IsUse:=true;
Info.StreamManager:=TStreamManager.Create(DefaultStreamPoolSize);
Result:=Info.StreamManager;
StreamList.Add(Info);
end;
Finally
StreamLock.Release;
end;
end;

procedure InitDataManagers(Connection:TADOConnection; Count:Integer; DataPoolSize:Integer);
Var
i:Integer;
InfoDataManagerInfo;
begin
Lock.Acquire;
Try
DefaultConnection:=Connection;
DefaultDataPoolSize:=DataPoolSize;
For i:=1 to Count do
begin
New(Info);
Info.DataManager:=TDataManager.Create(mtServer,Connection,DataPoolSize);
Info.IsUse:=false;
List.Add(Info);
end;
Finally
Lock.Release;
end;
end;

procedure FreeDataManager(DataManager:TDataManager);
Var
i:Integer;
InfoDataManagerInfo;
begin
Lock.Acquire;
Try
For i:=0 to List.Count-1 do
begin
Info:=List.Items;
if Info.DataManager=DataManager then
begin
Info.IsUse:=false;
break;
end;
end;
Finally
Lock.Release;
end;
end;

function GetDataManager:TDataManager;
Var
i:Integer;
InfoDataManagerInfo;
begin
Lock.Acquire;
Try
Result:=nil;
For i:=0 to List.Count-1 do
begin
Info:=List.Items;
if Not Info.IsUse then
begin
Info.IsUse:=true;
Result:=Info.DataManager;
Exit;
end;
end;
if Result=nil then
begin
New(Info);
Info.IsUse:=true;
Info.DataManager:=TDataManager.Create(mtServer,DefaultConnection,DefaultDataPoolSize);
Result:=Info.DataManager;
List.Add(Info);
end;
Finally
Lock.Release;
end;
end;

{ TServer }

procedure TServer.CloseClients;
Var
i:Integer;
begin
ClientLock.Acquire;
Try
For i:=0 to ClientList.Count-1 do
begin
closesocket(PSocket(ClientList)^);
Dispose(ClientList.Items)
end;
ClientList.Clear;
Finally
ClientLock.Release;
end;
end;

constructor TServer.Create(ServerDataPoolSize:Integer);
begin
FAcceptDataPoolSize:=10*1024*1024;
FAcceptOPDataPoolSize:=10*1024*1024;

hCompletion:=CreateIoCompletionPort(INVALID_HANDLE_VALUE,0,0,0);

WorkLock:=TCriticalSection.Create;
Socket:=INVALID_SOCKET;
Lock:=TCriticalSection.Create;
ClientList:=TList.Create;
ClientLock:=TCriticalSection.Create;
FHandle:=AllocateHwnd(OnWndProc);
FPort:=18016;
end;

destructor TServer.Destroy;
begin
SetActive(false);
ClientLock.Free;
Lock.Free;
WorkLock.Free;
ClientList.Free;
DeAllocateHwnd(FHandle);
inherited;
end;

procedure TServer.DoRecv(Socket: TSocket; Data: Pointer; Len: Integer);
begin
WorkLock.Acquire;
Try
FOnRecv(Socket,Data,Len);
Finally
WorkLock.Release;
end;
end;

function TServer.GetPause: Boolean;
begin
Lock.Acquire;
Try
Result:=FPause;
Finally
Lock.Release;
end;
end;

function TServer.GetPeerHost(hSock: TSocket; Var Port:Integer): String;
Var
Addr:Tsockaddrin;
Len:Integer;
begin
Len:=sizeof(Addr);
getpeername(hSock,Addr,Len);
Port:=Addr.sin_port;
Result:=StrPas(inet_ntoa(Addr.sin_addr));
end;

procedure TServer.OnWndProc(Var Msg: TMessage);
Var
SocketClientInfo;
i:Integer;
begin
Case Msg.Msg of
WM_CLIENTCONNECT:
begin
ClientLock.Acquire;
Try
New(Socket);
Socket.Socket:=Msg.WParam;
Socket.Host:=GetPeerHost(Socket.Socket,Socket^.Port);

ClientList.Add(Socket);
Finally
ClientLock.Release;
end;
end;
WM_CLIENTDISCONNECT:
begin
ClientLock.Acquire;
Try
For i:=0 to ClientList.Count-1 do
begin
Socket:=ClientList.Items;
if Socket.Socket=Msg.WParam then
begin
ClientList.Delete(i);
if Assigned(FOnMsg) then
begin
FOnMsg(Socket.Socket,Msg_ClientDisconnect,Type_Msg,IntToStr(Integer(Socket)),Socket.Host);
end;
Dispose(Socket);
break;
end;
end;
Finally
ClientLock.Release;
end;
end;
WM_CLIENTDISCONNECTS:
begin
Active:=false;
end;
end;
end;

function TServer.Send(Socket:TSocket; var Buf; Len: Integer):Boolean;
Var
wBuf:TWSABUF;
FlagWord;
hRet: Integer;
TransBytesWORD;
OpWSAOVERLAPPEDEx;
begin
Result:=false;
if Len<=0 then
Exit;

wBuf.len:=Len;
wBuf.buf:=@Buf;
Flag:=0;
OP:=AllocMem(sizeof(TWSAOVERLAPPEDEx)+Len);
if Not Assigned(Op) then
Exit;
Op.Buf.len:=Len;
Op.Buf.buf:=PChar(Op)+sizeof(TWSAOVERLAPPEDEx);
CopyMemory(Op.Buf.buf,@Buf,Len);
Op.Socket:=Socket;
Op.DataManager:=nil;
Op.OperType:=otWriteMain;
hRet:=WSASend(Socket,@Op.Buf,1,TransBytes,Flag,POverlapped(Op),nil);
if hRet=SOCKET_ERROR then
begin
hRet:=WSAGetLastError;
if hRet<>SOCKET_ERROR then
begin
Exit;
end;
end
else
begin
if TransBytes<>Len then
Exit;
end;
Result:=true;
end;

procedure TServer.SetAcceptDataPoolSize(const Value: Integer);
begin
FAcceptDataPoolSize := Value;
end;

procedure TServer.SetAcceptOPDataPoolSize(const Value: Integer);
begin
FAcceptOPDataPoolSize := Value;
end;

procedure TServer.SetActive(const Value: Boolean);
begin
if FActive=Value then
Exit;

FActive := Value;
if Value then
begin
With TAcceptThread.Create(Self,FAcceptDataPoolSize,FAcceptOPDataPoolSize) do
begin
Self.Socket:=Socket;
Resume;
end;
end
else
begin
if Socket<>INVALID_SOCKET then
begin
WSACancelBlockingCall;
closesocket(Socket);
Socket:=INVALID_SOCKET;
CloseClients;
end;
end
end;

procedure TServer.SetDebug(const Value: Boolean);
begin
FDebug := Value;
end;

procedure TServer.SetOnMsg(const Value: TOnMsg);
begin
FOnMsg := Value;
end;

procedure TServer.SetOnRecv(const Value: TOnRecv);
begin
FOnRecv := Value;
end;

procedure TServer.SetPause(const Value: Boolean);
begin
Lock.Acquire;
Try
FPause := Value;
if Assigned(FOnMsg) then
begin
if Value then
FOnMsg(Socket,Msg_ServerPause,Type_Msg,IntToStr(Integer(Socket)),'')
else
FOnMsg(Socket,Msg_ServerRestore,Type_Msg,IntToStr(Integer(Socket)),'')
end;

Finally
Lock.Release;
end;
end;

procedure TServer.SetPort(const Value: Integer);
begin
FPort := Value;
end;

{ TWorkThread }

constructor TWorkThread.Create(hCompletion: THandle; Param: Pointer);
begin
Inherited Create(true);
SendData:=AllocMem(1024*1024);
SendLen:=1024*1024;
FreeOnTerminate:=true;
Self.hCompletion:=hCompletion;
Server:=TServer(Param);
MsgHandle:=Server.Handle;
Resume;
end;

destructor TWorkThread.Destroy;
begin
inherited;
end;

procedure TWorkThread.DoCustomMsg;
Var
vLen:Integer;
Host:TSOCKADDRIN;
begin
if Application.Terminated or Terminated then
Exit;
if Not Server.Debug then
Exit;
FillChar(Host,sizeof(Host),0);
vLen:=sizeof(Host);
GetPeerName(OpEx.Socket,Host,vLen);
if Assigned(Server) and Assigned(Server.FOnMsg) then
Server.FOnMsg(OpEx.Socket,Err_Exception,Type_Error,Err,StrPas(inet_ntoa(Host.sin_addr)));
end;

procedure TWorkThread.DoMsg;
begin
if Application.Terminated or Terminated then
Exit;
if Assigned(Server) and Assigned(Server.FOnMsg) then
Server.FOnMsg(OpEx.Socket,MsgID,TypeID,MsgParam,ClientHost);
end;

procedure TWorkThread.DoRecv(OPWSAOVERLAPPEDEx);
Var
IsSucc:Boolean;
StreamState:TStreamState;
UserData:TUserData;
begin
Op.Stream.OnData:=OnData;
IsSucc:=OP.Stream.WriteBuf(OP.Socket,OpEx.Buf.buf^,TransBytes,@UserData,StreamState);
Op.Stream.OnData:=nil;
end;

procedure TWorkThread.Execute;
Label Loop;

Var
hRet:Integer;
Flag:Cardinal;
begin
While Not (Terminated or Application.Terminated) do
begin
if GetQueuedCompletionStatus(hCompletion,TransBytes,CompletionKey,Op,INFINITE) then
begin
Try
if (Op=nil) and (CompletionKey=0) and (TransBytes=0) then
Exit;
OpEx:=PWSAOVERLAPPEDEx(OP);
if TransBytes=0 then
begin
InternalClose;
Continue;
end;
AcceptThread:=Ptr(CompletionKey);
Case OpEx.OperType of
otWrite:
begin

end;
otWriteMain:
begin
FreeMem(OpEx);
end;
otRead:
begin
if TransBytes>0 then
begin
DoRecv(OPEx);
end;
Loop:
TransBytes:=0;
Flag:=0;
hRet:=WSARecv(OpEx.Socket,@OpEx.Buf,1,TransBytes,Flag,Op,nil);
if hRet=SOCKET_ERROR then
begin
hRet:=WSAGetLastError;
if hRet<>WSA_IO_PENDING then
begin
Raise Exception.Create(SysErrorMessage(WSAGetLastError));
end
end
else
begin
DoRecv(OPEx);
Goto Loop;
end
end;
end;
Except
On E:Exception do
begin
InternalClose;
Err:=E.Message;
Synchronize(DoCustomMsg);
end;
end;
end;
end;
end;

function TWorkThread.GetPeerHost(hSock: TSocket): String;
Var
Addr:Tsockaddrin;
Len:Integer;
begin
Len:=sizeof(Addr);
getpeername(hSock,Addr,Len);
Result:=StrPas(inet_ntoa(Addr.sin_addr));
end;

procedure TWorkThread.InternalClose;
begin
if OpEx=nil then
Exit;
closesocket(OpEx.Socket);
FreeStreamManager(OPEx.Stream);
OpEx.DataManager.FreeMemory(OpEx.Buf.buf);
OpEx.OPManager.FreeMemory(OpEx);
PostMessage(MsgHandle,WM_CLIENTDISCONNECT,OpEx.Socket,0);
end;

function TWorkThread.SendToClient(Socket:TSocket; var Buf; Len: Integer):Boolean;
Var
wBuf:TWSABUF;
FlagWord;
hRet: Integer;
TransBytesWORD;
OpWSAOVERLAPPEDEx;
begin
Result:=false;
if Len<=0 then
Exit;

wBuf.len:=Len;
wBuf.buf:=@Buf;
Flag:=0;
if SendLen<sizeof(TWSAOVERLAPPEDEx)+Len then
begin
SendLen:=sizeof(TWSAOVERLAPPEDEx)+Len;
if Assigned(SendData) then
FreeMem(SendData);
SendData:=AllocMem(SendLen);
end
else
ZeroMemory(SendData,SendLen);
OP:=PWSAOVERLAPPEDEx(SendData);
if Not Assigned(Op) then
Exit;
Op.Buf.len:=Len;
Op.Buf.buf:=PChar(Op)+sizeof(TWSAOVERLAPPEDEx);
CopyMemory(Op.Buf.buf,@Buf,Len);
Op.Socket:=Socket;
Op.DataManager:=nil;
Op.OperType:=otWrite;
hRet:=WSASend(Socket,@Op.Buf,1,TransBytes,Flag,POverlapped(Op),nil);
if hRet=SOCKET_ERROR then
begin
hRet:=WSAGetLastError;
if hRet<>SOCKET_ERROR then
begin
Exit;
end;
end
else
begin
if TransBytes<>Len then
Exit;
end;
Result:=true;
end;

procedure TWorkThread.OnData(Socket: TSocket; Buf: Pointer; Len: Integer;
UserData: TUserData; var IsSucc: Boolean);
Var
sql,Key:String;
Data:OleVariant;
vDataointer;
vLen:Integer;
DataManager:TDataManager;
Info:TResultInfo;
Infos:TTransCommandInfos;

procedure SendResult;
Var
dDataointer;
dLen:Integer;
begin
DataManager.ResultToBuff(@Info,dData,dLen,@UserData);
if dData<>nil then
begin
SendToClient(Socket,dData^,dLen);
end;
DataManager.FreeMemory(dData);
end;

begin
DataManager:=GetDataManager;
Try
if DataManager=nil then
begin
Exit;
end;
Err:='';
Info.ID:=UserData[1];
Info.ResultValue:=false;
Info.Error:='';
Info.Param:='';
Case UserData[0] of
Type_Command_Text_Trans:
begin
if DataManager.BufToTCInfos(Infos,Buf,Len) then
begin
if DataManager.ApplyDatas(Infos,Err) then
begin
Info.ResultValue:=true;
Info.Error:='';
end;
end
else
begin
if sql='' then
begin
Info.Error:='获取事务操作指令失败';
end;
end;
SendResult;
end;
Type_Command_Text:
begin
sql:=DataManager.BuffToCommand(Buf,Len);
if sql='' then
begin
Info.Error:='获取数据操作指令失败';
SendResult;
Exit;
end;
Case UserData[2] of
Exec_Type_Execute:
begin
if DataManager.ExecCommand(SQL,Err) then
begin
Info.ResultValue:=true;
end;
SendResult;
end;
Exec_Type_Open:
begin
Data:=DataManager.OpenCommand(SQL,Err);
Info.Error:=Err;
if Not VarIsNull(Data) then
begin
if DataManager.DataToSendBuff(Data,'',vData,vLen,@UserData) then
begin
if SendToClient(Socket,vData^,vLen) then
begin
Info.ResultValue:=true;
Info.Error:='';
end;
DataManager.FreeMemory(vData);
end;
end
else
SendResult;
end;
end;
end;
Type_Command_Dataset:
begin
Data:=DataManager.BuffToApplyData(Buf,Len,SQL,Key);
IsSucc:=DataManager.ApplyData(sql,Data,Err,Key);
if IsSucc then
begin
Info.ResultValue:=true;
end
else
begin
Synchronize(DoCustomMsg);
end;
SendResult;
end
else
SendResult;
end;
Finally
FreeDataManager(DataManager);
if Err<>'' then
Synchronize(DoCustomMsg);
end;
end;

{ TAcceptThread }

function TAcceptThread.CheckConnect(p:Integer): Integer;
Var
Str:String;
Data:Array[0..1024] of Char;
Lock:TXComponent;
FileStream:TFileStream;
begin
Result:=-1;
Try
Str:=ExtractFilePath(Application.ExeName)+'Connect.wh';
if Not FileExists(Str) then
Exit;
FileStream:=TFileStream.Create(Str,fmOpenRead);
Lock:=TXComponent.Create(nil);
Try
FillChar(Data,sizeof(Data),0);
FileStream.Read(Data,FileStream.Size);
Str:=Data;
Str:=VXStr(Str,'{F87BDD45-2CED-4E61-9CC5-33CB3CA43C11}{336E4B29-61A1-4F11-8420-EA6D3CD738B4}');
Lock.AutoSetKey:=false;
Lock.Key:=1985673421;
Str:=Lock.UnLock(Str);
if p<=1000000000-StrToInt(Str) then
Result:=1;
Finally
Lock.Free;
FileStream.Free;
FileStream:=nil;
end;
Except
Result:=-2;
end;
end;

constructor TAcceptThread.Create(Param: Pointer; DataPoolSize,OPDataPoolSize:Integer);
begin
Inherited Create(true);
ppp:=TStringList.Create;
ppp.Duplicates:=dupIgnore;
ppp.Sorted:=true;

DataBuffManager:=TBuffManager.Create(DataPoolSize);
OPBuffManager:=TBuffManager.Create(OPDataPoolSize);
FreeOnTerminate:=true;
Server:=TServer(Param);
Self.hCompletion:=Server.hCompletion;
MsgHandle:=Server.Handle;
Socket:=WSASocket(AF_INET,SOCK_STREAM,0,nil,0,WSA_FLAG_OVERLAPPED);
end;

destructor TAcceptThread.Destroy;
begin
DataBuffManager.Free;
OPBuffManager.Free;
if Socket<>INVALID_SOCKET then
closesocket(Socket);
ppp.Free;
inherited;
end;

procedure TAcceptThread.DoMsg;
begin
if Application.Terminated or Terminated then
Exit;
if Assigned(Server) and Assigned(Server.FOnMsg) then
Server.FOnMsg(NewSocket,MsgID,TypeID,MsgParam,ClientHost);
end;

procedure TAcceptThread.DoRecv;
begin
if Assigned(Server) then
begin
if Assigned(Server.FOnRecv) then
begin
Server.FOnRecv(NewSocket,Bufs.buf,RecvBytes);
end;
end;
end;

procedure TAcceptThread.Execute;
Label Loop;

Var
hRet,i:Integer;
Len:Integer;
Addr:TSockAddrIn;
ThreadCount:Integer;
Flag:Cardinal;
LocalAddr:TSockAddrIn;
hThreadCompletion:THandle;
begin
FillChar(LocalAddr,sizeof(LocalAddr),0);
LocalAddr.sin_family:=AF_INET;
LocalAddr.sin_port:=htons(Server.Port);
LocalAddr.sin_addr.S_addr:=INADDR_ANY;

hRet:=bind(Socket,@LocalAddr,sizeof(LocalAddr));
if hRet=SOCKET_ERROR then
begin
TypeID:=Type_Error;
MsgID:=Err_Bind;
MsgParam:='';
Synchronize(DoMsg);
Exit;
end;
hRet:=listen(Socket,5);
if hRet=SOCKET_ERROR then
begin
TypeID:=Type_Error;
MsgID:=Err_Listen;
MsgParam:='';
Synchronize(DoMsg);
Exit;
end;
GetSystemInfo(sysInfo);
ThreadCount:=sysInfo.dwNumberOfProcessors*2+1;
if hCompletion=INVALID_HANDLE_VALUE then
begin
TypeID:=Type_Error;
MsgID:=Err_CreateIoCompletionPort;
MsgParam:='';
Synchronize(DoMsg);
Exit;
end;

Len:=sizeof(Addr);

For i:=1 to ThreadCount do
begin
TWorkThread.Create(hCompletion,Server);
end;

TypeID:=Type_Msg;
MsgID:=Msg_ServerOpen;
MsgParam:='';
Synchronize(DoMsg);

While Not (Terminated or Application.Terminated) do
begin
FillChar(Addr,sizeof(Addr),0);
NewSocket:=WSAAccept(Socket,PSockAddr(@Addr),@Len,nil,0);
Try
ClientHost:=StrPas(inet_ntoa(Addr.sin_addr));
ppp.Add(Trim(ClientHost));
if CheckConnect(ppp.Count)<>1-1+1*10-10+1 then
begin
closesocket(NewSocket);
NewSocket:=INVALID_SOCKET;
Continue;
end;
if NewSocket=INVALID_SOCKET then
begin
hRet:=WSAGetLastError;
if (hRet=10004) or (hRet=0) or (hRet=WSAENETDOWN) then
begin
break
end
else
begin
TypeID:=Type_Error;
MsgID:=Err_Socket_Error;
MsgParam:='';
Synchronize(DoMsg);
end;
end;

if Server.Pause then
begin
closesocket(newSocket);
Continue;
end;

TypeID:=Type_Msg;
MsgID:=Msg_ClientConnect;
MsgParam:=ClientHost;
Synchronize(DoMsg);

Bufs.len:=8192;
Bufs.buf:=DataBuffManager.AllocMemory(Bufs.len);//
if Bufs.buf=nil then
begin
closesocket(NewSocket);
TypeID:=Type_Error;
MsgID:=Err_DataBuffAlloc;
MsgParam:='';
Synchronize(DoMsg);
continue;
end;

Op:=OPBuffManager.AllocMemory(sizeof(Op^));
FillChar(OP^,sizeof(Op),0);
if OP=nil then
begin
closesocket(NewSocket);
TypeID:=Type_Error;
MsgID:=Err_OPBuffAlloc;
MsgParam:='';
Synchronize(DoMsg);
continue;
end;
OP.DataManager:=DataBuffManager;
OP.OPManager:=OPBuffManager;
Op.Stream:=GetStreamManager;
OP.Buf:=Bufs;
OP.OperType:=otRead;
OP.Socket:=newSocket;
hThreadCompletion:=CreateIOCompletionPort(NewSocket,hCompletion,Integer(Self),0);
if hThreadCompletion=INVALID_HANDLE_VALUE then
begin
InternalClose(Op);
TypeID:=Type_Error;
MsgID:=Err_CreateThreadCompletion;
MsgParam:='';
Synchronize(DoMsg);
Continue;
end;
PostMessage(MsgHandle,WM_CLIENTCONNECT,newSocket,0);
Loop:
RecvBytes:=0;
Flag:=0;

hRet:=WSARecv(NewSocket,@Bufs,1,RecvBytes,Flag,POverlapped(Op),nil);
if hRet=SOCKET_ERROR then
begin
hRet:=WSAGetLastError;
if hRet<>WSA_IO_PENDING then
begin
InternalClose(Op);
TypeID:=Type_Error;
MsgID:=Err_ClientConnect;
MsgParam:=SysErrorMessage(hRet);
Synchronize(DoMsg);
end
end
else
begin
if RecvBytes=0 then
begin
closesocket(NewSocket);
DataBuffManager.FreeMemory(Bufs.buf);
OPBuffManager.FreeMemory(Op);
end
else
begin
DoRecv;
Goto Loop;
end;
end;
Except
InternalClose(Op);
end;
end;
PostQueuedCompletionStatus(hCompletion,0,0,nil);
TypeID:=Type_Msg;
MsgID:=Msg_ServerClose;
MsgParam:='';
Synchronize(DoMsg);
PostMessage(MsgHandle,WM_CLIENTDISCONNECTS,0,0);
end;

Var
i:Integer;
InfoDataManagerInfo;
Info1StreamManagerInfo;

procedure TAcceptThread.InternalClose(Op: PWSAOVERLAPPEDEx);
begin
if Op=nil then
Exit;
closesocket(Op.Socket);
FreeStreamManager(OP.Stream);
if Assigned(Op.Buf.buf) then
DataBuffManager.FreeMemory(Op.Buf.buf);
OPBuffManager.FreeMemory(Op);
end;

Initialization
List:=TList.Create;
Lock:=TCriticalSection.Create;

StreamList:=TList.Create;
StreamLock:=TCriticalSection.Create;
Finalization
For i:=0 to List.Count-1 do
begin
Info:=List.Items;
Info.DataManager.Free;
Dispose(Info);
end;
List.Free;
Lock.Free;

For i:=0 to StreamList.Count-1 do
begin
Info1:=StreamList.Items;
Info1.StreamManager.Free;
Dispose(Info1);
end;
StreamList.Free;
StreamLock.Free;


end.

我的一个程序用到的，你可以参考一下。

http://www.delphibbs.com/keylife/iblog_show.asp?xid=19752

to:jfyes
从你提供的链接下载了一个来学习，我先研究一下，如果可以，马上给分给你。

to:appfirst
谢谢～
我看一下，如果同样可以跑动，我另开贴给你分。^_^

没问题的，不过那里少了一个流管理器的代码，不过如果替换为你自己的流管理器就没问题了。

接受答案了.

请jfyes到 http://delphibbs.com/delphibbs/dispq.asp?lid=3504055 接分。

appfirst请到http://delphibbs.com/delphibbs/dispq.asp?lid=3497603接分。