发布一个自己写的 SocketServer 类，Delphi 代码 [绝对原创]

fox1999 2008-07-06 08:44:35
加精 


unit ServerSocketLite;



{******************************************************************************}

{  Unit Name   : ServerSocketLite.pas                                          }

{  Author      : RedFox /Foxbat  CopyRight (c)                                 }

{  E-mail      : foxbat123@126.com                                             }

{  Blog        : redsoft.yculblog.com                                          }

{  Baidu Hi    : redfox_hi                                                     }

{  Datetime    : 2008-05-03                                                    }

{  Version     : v1.1                                                          }

{  Description : ServerSocket Class Lite                                       }

{                                                                              }

{  History List                                                                }

{     1. 2008-05-03  Version 1.0                                               }

{     2. 2008-07-06  Version 1.1                                               }  

{******************************************************************************}



interface



uses

  Windows, Messages, WinSock2, SysUtils, Classes;



type

  {====================== TTcpServerLite forward define ======================}

  TTcpServerLite = class;



  {===================== TTcpClientLite =======================================}

  TTcpClientLite = class

  protected

    m_socket    : TSocket;

    m_saddr     : TSockAddr;

    m_serv      : TTcpServerLite;

    m_csSend    : TRTLCriticalSection;

    m_PeerIp    : string;

    m_PeerPort  : Word;

    m_Closing   : Boolean;

  public

    constructor Create(hsocket : TSocket; saddr : TSockAddr); virtual;

    destructor  Destroy; override;



    procedure Close; virtual;

    property  Server: TTcpServerLite read m_serv;

    

    function  Send(Buf: Pointer; BufLen :Integer): Boolean;

  end;



  {==================== Event Define ==========================================}

  TClientCloseEvent   = procedure(Sender: TObject; Client: TTcpClientLite) of object;

  TClientConnectEvent = procedure(Sender: TObject; Client: TTcpClientLite) of object;

  TClientRecvEvent    = procedure(Sender: TObject; Client: TTcpClientLite) of object;



  TTcpClientLiteClass = class of TTcpClientLite;



  {======================== TTcpServerLite ====================================}

  TTcpServerLite = class

  protected

    m_hWnd           : HWND;

    m_ListenSocket   : TSocket;

    m_Clients        : TList;

    m_ClientLock     : TRTLCriticalSection;

    m_Port           : Word;



    fOnClientClose   : TClientCloseEvent;

    fOnClientConnect : TClientConnectEvent;

    fOnClientRecv    : TClientRecvEvent;

    function getActive: Boolean;

  protected

    TcpClientClass : TTcpClientLiteClass;

    function  NewClient(hClient: TSocket; saddr : TSockAddr):Boolean;

    function  GetClient(hClient: TSocket): TTcpClientLite;

    procedure DelClient(sckt: TTcpClientLite);

    

    procedure DoClientClose(Client: TTcpClientLite); virtual;

    procedure DoClientConnect(Client: TTcpClientLite);    

    procedure DoClientRecv(Client: TTcpClientLite); virtual;



    procedure WndProc(var msg: TMessage);

  public

    constructor Create;

    destructor  Destroy; override;



    function  Open(nPort: Word):Boolean;

    procedure Close();

    property Active :Boolean read getActive;

    property Clients:TList read m_Clients;

     

    property OnClientClose: TClientCloseEvent read fOnClientClose write fOnClientClose;

    property OnClientRecv : TClientRecvEvent read fOnClientRecv write fOnClientRecv;

    property OnClientConnect: TClientConnectEvent read fOnClientConnect write fOnClientConnect;  

  end;  



 



implementation 



const

  WM_SOCKET = WM_APP + 1;



{=========================== TTcpClientLite ==================================}



//--------------------------------------------------------------------------

// Close TcpClientLite Connection 

procedure TTcpClientLite.Close;

begin

  if (not m_Closing) then

  begin

    shutdown(m_socket, SD_BOTH);

    closesocket(m_socket);

    m_Closing := true;

  end;

end;



//-------------------------------------------------------------------------

//  Create New TcpClientLite Object

//     hsocket   : socket handler

//     saddr     : Peer Socket Address

//     return    : New TcpClientLite Created

constructor TTcpClientLite.Create(hsocket: TSocket; saddr : TSockAddr);

begin

  m_socket  := hsocket;

  m_saddr   := saddr;

  m_PeerIp  := inet_ntoa(saddr.sin_addr);

  m_PeerPort:= ntohs(saddr.sin_port); 

  m_Closing := False;

  InitializeCriticalSection(m_csSend);

  inherited Create();

end;



destructor TTcpClientLite.Destroy;

begin

  Close;

  DeleteCriticalSection(m_csSend);

  inherited;

end;



//-----------------------------------------------------------------------

// Send Data from TcpClientLite to Peer, Thread safed 

//    Buf     : Data Pointer for send

//    BufLen  : Data length want to send

//    return  : true -- Success 

function TTcpClientLite.Send(Buf: Pointer; BufLen: Integer): Boolean;

var

  nSend : Integer;

  pData : PChar;

begin



  EnterCriticalSection(m_csSend);

  pData := Buf;

  try

    while BufLen > 0 do

    begin

      nSend := WinSock2.send(m_socket, pData^, BufLen, 0);



      if (nSend = SOCKET_ERROR) then

      begin

        if  (WSAGetLastError() = WSAEWOULDBLOCK) then

        begin

          Sleep(5);

          Continue;

        end

        else begin

           Result    := False;

           m_Closing := True; 

           Exit;

        end;

      end;

      Inc(pData, nSend);

      Dec(BufLen, nSend);      

    end;

    Result := true;

  finally

    LeaveCriticalSection(m_csSend);

  end;

end;
...全文
2721 155 打赏 收藏 转发到动态 举报
写回复
用AI写文章
155 条回复
切换为时间正序
请发表友善的回复…
发表回复
wangj_0520 2010-01-10
  • 打赏
  • 举报
 回复
xx
zxf52 2010-01-10
  • 打赏
  • 举报
 回复
很不错，不过用消息来收数据，accept稍微效率有点低了。。。server的模型还可以有多种选择，总结一下，是不错的代码！！！2010年delphi版的精华贴，哈
hjkto 2010-01-01
  • 打赏
  • 举报
 回复
学习一下
ywx2008 2010-01-01
  • 打赏
  • 举报
 回复
学习
sanguomi 2010-01-01
  • 打赏
  • 举报
 回复
另外感觉楼主这封装有点不太好用
呵呵，废话说了这么多
sanguomi 2010-01-01
  • 打赏
  • 举报
 回复
花了半小时看了下源码，没太多东西
标准的SOCKET 异步选择 I/0模型
TTcpClientLite 这个类建议里面自己封装连接，用使用者去使用不太好吧，另外放个连接是否成功属性出来比较好
另外发现你那收包有问题


// 服务端

procedure TForm1.Button1Click(Sender: TObject);

var

  TestServe: TTcpServerLite;

  WsaData: TWSADATA;

begin

  if WSAStartup(MAKEWORD(2, 2), WsaData) <> 0 then

  begin

    WSACleanup;

    Exit;

  end;



  TestServe := TTcpServerLite.Create;

  TestServe.Open(1002);

end;



// 发送端

procedure TForm1.Button2Click(Sender: TObject);

var

  TestClient: TTcpClientLite;

  ListenSocket: TSocket;

  Addr: TSockAddr;

  I, Len: Integer;

  S: array[0..24] of Char;

  WsaData: TWSADATA;

begin

  if WSAStartup(MAKEWORD(2, 2), WsaData) <> 0 then

  begin

    WSACleanup;

    Exit;

  end;



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

  if ListenSocket = INVALID_SOCKET then

  begin

    ShowMessage(SysErrorMessage(WSAGetLastError));

    Exit;

  end;



  addr.sin_family := AF_INET;

  addr.sin_addr.s_addr := inet_addr('127.0.0.1');

  addr.sin_port := htons(1002);

  Len := SizeOf(TSockAddr);



  S := 'Testddd';

  TestClient := TTcpClientLite.Create(ListenSocket, addr);

  connect(ListenSocket, PSockAddr(@addr), len);

  Winsock2.send(ListenSocket, S, Length('Testddd') + 1, 0);

end;

楼主的服务端在FD_Read  进入了死循环

不知道是否是我使用有问题

另外TLIST建议换成哈希，

另外还建议发送和收发包加算法，防止粘包


QQ286251099 2009-12-31
  • 打赏
  • 举报
 回复
最恶心 的就是 消息试的垃圾
吊死在 Win
yxhua240 2009-10-11
  • 打赏
  • 举报
 回复
牛。。。逼。。。
zhuang_bx 2009-10-10
  • 打赏
  • 举报
 回复
学习中。。。。。。！
yc_8301 2009-10-10
  • 打赏
  • 举报
 回复
新手，，纯属过来学习！呵呵！
国风 2009-10-10
  • 打赏
  • 举报
 回复
客户端断开后，可以考虑不释放TTcpClientLite,而是初始化TTcpClientLite类，然后放入一个TStack栈中，等待新的客户连接上来时使用，这样可以提高内存使用
shaonew 2009-10-09
  • 打赏
  • 举报
 回复
楼主超强，支持，顶起
simonhehe 2009-10-09
  • 打赏
  • 举报
 回复
学习
sanguomi 2009-10-09
  • 打赏
  • 举报
 回复
先MARK, 哪天有空好好看看
僵哥 2009-10-09
  • 打赏
  • 举报
 回复
[Quote=引用 84 楼 guestcode 的回复:]
对于效率，用途和设计要求不同很难比较。


除了Hash和While遍历，大家可以考虑下面这个方法：
应用程序获得的Socket的数值一般大于等于560，并且连续获得句柄的话，Socket1和Socket2的值相差是4，
如果有个1000个Socket句柄，
Socket最大值在10000范围内。
如果建立一个影射表：Map[10000]，
那么查找ClientLite就是：Map[Socket]。这样比任何都快。

或者：
Socket最大值：10000，
定义映射表：Map[10000 div 4]，
查找ClientLite：Map[Socket div 4]。

以上前提是：在32位机32位OS，IOCP模式Socket重用（事先获得MaxConnection数量的Socket句柄）。
如果是64位可以根据情况来设计。



[/Quote]
在起初Socket资源足够的时候是按照560起始,然后每间隔4的编号规则的,但是当申请到一定数字之后,就会打破这个规则,Socket可以出现1,并且最后的间隔也会是1.
Socket本身是一个32位的值,即不存在最大10000或者65535一类的限制(只有端口因为是双字节,才有65535的限制).
XyRbj 2009-10-09
  • 打赏
  • 举报
 回复
学习了
hupengboy 2009-10-09
  • 打赏
  • 举报
 回复
虽然不是DEPHIL，但还是顶起！
XD王 2009-10-09
  • 打赏
  • 举报
 回复
mark
linghengmao 2009-10-09
  • 打赏
  • 举报
 回复
高手好多啊！
期待僵哥寫一個上來。
qiume 2009-10-09
  • 打赏
  • 举报
 回复
不错，顶！！！
加载更多回复（132）
delphi SocketServer实现远程传输,双向传输
用delphi的SocketServer控件实现远程传输，多个客户端可以连接一个服务器，并且服务器可以选择性地给客户端发数据。 第一次发源代码，写的不好请见谅！
SocketServer/Tcp 源码 基于delphi XE52
SocketServer/Tcp 基于delphi XE5开发，源码，只有Server程序，每一句我都做了详细的注释，我也是初学delphi才一周，所以本例仅供大家学习参考。
SocketServer(API).rar_delphi API
Delphi:API写的SocketServer源码，采用多线程通讯，这是一个框架，可以加入自己的代码使用。
SocketServer(API).rar_API_delphi 线程_sock
API写的SocketServer源码，采用多线程通讯，这是一个框架，可以加入自己的代码使用。
SocketServer
利用AsyncSocket编码进行ios设备间的网络通信
网络通信/分布式开发

1,593

社区成员

32,964

社区内容

发帖
与我相关
我的任务
社区描述
Delphi 网络通信/分布式开发
社区管理员
  • 网络通信/分布式开发社区
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章