www.pudn.com > IPXControl.rar > IPXCtl.pas

//------------------------------------------------------------------// 
// Copyright (c) 2002, 智能认知工作室. 
// All rights reserved. 
//  
// 文件名称: MainUnit.pas 
// 文件标识: 
// 
// 摘    要: IPX协议通讯控件（Delphi 6） 
// 
// 当前版本: 1.0  
// 作    者: Rain (wangzp.try2it.com) 
// 网    站: http://www.try2it.com 
// 完成日期: 2002年08月20日 
// 
// 取代版本: 这是第一版 
//------------------------------------------------------------------// 
unit IPXCtl; 
 
interface 
uses Windows, Winsock2, Classes, Messages; 
type 
    //出错处理 
    TSockErrEvent = procedure(Sender : TObject; ErrMsg : string) of Object; 
    TSocketEvent = procedure(Sender : TObject; Socket : TSocket) of Object; 
    TSocketArray = array of TSocket; 
    //IPX/SPX客户端类 
    TIPXClientSocket = class(TComponent) 
    private{对外不可见} 
         FActive : Boolean; 
         //保存与服务器相连的套接字 
         FSocket : TSocket; 
         //处理消息的窗口句柄 
         FWnd : HWND; 
         //节点地址 
         Fsa_nodenum : string; 
         //内部网络号 
         Fsa_netnum : string; 
         //内部端口 
         Fsa_socket : string; 
         // 
         FOnRead : TNotifyEvent; 
         FOnWrite : TNotifyEvent; 
         FOnConnected : TNotifyEvent; 
         FOnDisConnect : TNotifyEvent; 
         FOnError : TSockErrEvent; 
    protected{只对子孙可见} 
         procedure WndProc(var Msg : TMessage); 
    public{对外可见，出现在.后} 
         constructor Create(AOwner : TComponent); override; 
         destructor Destroy; override; 
         procedure Open; 
         procedure Close; 
         function SendBuf(var Buf; BufLen : Integer) : Integer; 
         function RecvBuf(var Buf; BufLen : Integer) : Integer; 
         property Handle : HWND read FWnd; 
         property Active : Boolean read FActive; 
    published{出现在Object Inspector中} 
         property sa_nodenum : string read Fsa_NodeNum write Fsa_NodeNum; 
         property sa_netnum : string read Fsa_NetNum write Fsa_NetNum; 
         property sa_socket : string read Fsa_Socket write Fsa_Socket; 
         property OnRead : TNotifyEvent read FOnRead write FOnRead; 
         property OnWrite : TNotifyEvent read FOnWrite write FOnWrite; 
         property OnConnected : TNotifyEvent read FOnConnected write FOnConnected; 
         property OnDisConnect : TNotifyEvent read FOnDisConnect write FOnDisConnect; 
         property OnError : TSockErrEvent read FOnError write FOnError; 
    end; 
 
    //IPXSPX服务器端类 
    TIPXServerSocket = class(TComponent) 
    private 
         FActive : Boolean; 
         //客户端连接过来的套接字 
         FClientSocket : TSocketArray; 
         FListenSocket : TSocket; 
         //当前活动的连接数 
         FActiveClientCount : Integer; 
         //消息窗口句柄 
         FWnd : HWND; 
         //服务器端绑定的端口 
         Fsa_socket : string; 
         //客户端发数据时发生 
         FOnRead : TSocketEvent; 
         //服务器发送数据时发生 
         FOnWrite : TSocketEvent; 
         FOnError : TSockErrEvent; 
         //服务器接受一个客户连接时发生 
         FOnClientConnected : TSocketEvent; 
         //一个客户端断开时发生 
         FOnClientDisconnect : TSocketEvent; 
         //当服务器建立侦听后发生 
         FOnListen : TSocketEvent; 
         function AcceptConnect : Boolean; 
    protected 
         procedure WndProc(var Msg : TMessage); 
    public 
         constructor Create(AOwner : TComponent); override; 
         destructor Destroy; override; 
         procedure Open; 
         procedure Close; 
         function SendBuf(ClientSocket : TSocket; var Buf; BufLen : Integer) : Integer; 
         function RecvBuf(ClientSocket : TSocket; var Buf; BufLen : Integer) : Integer; 
         property Handle : HWND read FWnd; 
         property ActiveClientCount : Integer read FActiveClientCount; 
         property Active : Boolean read FActive; 
         property Connections : TSocketArray read FClientSocket; 
    published 
         property sa_socket : string read Fsa_socket write Fsa_socket; 
         property OnListen : TSocketEvent read FOnListen write FOnListen; 
         property OnRead : TSocketEvent read FOnRead write FOnRead; 
         property OnWrite : TSocketEvent read FOnWrite write FOnWrite; 
         property OnClientConnected : TSocketEvent read FOnClientConnected write FOnClientConnected; 
         property OnClientDisconnect : TSocketEvent read FOnClientDisconnect write FOnClientDisconnect; 
         property OnError : TSockErrEvent read FOnError write FOnError; 
    end; 
 
procedure Register; 
//对在初始化中调用的WSAStartup进行判断是否成功 
function CanUseWinSock : Boolean; 
//字符串转换为IPX地址 
procedure ATOH(Src : string; var Dest : array of Char; DestLen : Integer);overload; 
procedure ATOH(Src : string; var Dest : u_short; DestLen : Integer);overload; 
function BTOH(ch : char) : Char; 
 
var 
     WSAData : TWSAData; 
     WSAStartError : Integer; 
 
implementation 
     uses SysUtils, Forms; 
 
const 
     WM_SOCKET = WM_USER + $0101; //异步消息 
     WM_SOCKET_SERVER = WM_USER + $0102; 
procedure Register; 
begin 
     RegisterComponents('Internet',[TIPXServerSocket, TIPXClientSocket]); 
end; 
 
//对在初始化中调用的WSAStartup进行判断是否成功 
function CanUseWinSock : Boolean; 
begin 
     Result := (WSAStartError = 0) and (WSAData.wVersion = WINSOCK_VERSION); 
end; 
//返回数字或字母的十六进制值 
function BTOH(ch : char) : Char; 
begin 
     if (ch >= '0') and (ch <= '9') then 
     begin 
          Result := Char(Ord(ch)- Ord('0')); 
          Exit; 
     end; 
     if (ch >= 'A') and (ch <= 'Z') then 
     begin 
          Result := Char((Ord(ch) - Ord('A')) + $0A); 
          Exit; 
     end; 
     if (ch >= 'a') and (ch <= 'z') then 
     begin 
          Result := Char((Ord(ch) - Ord('a')) + $0A); 
          Exit; 
     end; 
     Result := Char(255); 
end; 
procedure ATOH(Src : string; var Dest : array of char; DestLen : Integer); 
var 
     srcptr : Char; 
     i, j : Integer; 
begin 
     i := 0; j := 1; 
     while DestLen > 0 do 
     begin 
          srcptr := Src[j]; 
          Dest[i] := char(Byte(BTOH(srcptr)) shl 4); 
          srcptr := Src[j + 1]; 
          Dest[i] := char(Byte(Dest[i]) + Byte(BTOH(srcptr))); 
          i := i + 1; 
          j := j + 2; 
          DestLen := DestLen - 1; 
     end; 
end; 
procedure ATOH(Src : string; var Dest : u_short; DestLen : Integer); 
var 
     srcptr : Char; 
     j : Integer; 
     Destptr : PByte; 
begin 
     j := 1; 
     Destptr := PByte(@Dest); 
     while DestLen > 0 do 
     begin 
          srcptr := Src[j]; 
          Destptr^ := Byte(BTOH(srcptr)) shl 4; 
          srcptr := Src[j + 1]; 
          Destptr^ := Destptr^ + Byte(BTOH(srcptr)); 
          Inc(DestPtr); 
          j := j + 2; 
          DestLen := DestLen - 1; 
     end; 
end; 
 
{TIPXClientSocket} 
constructor TIPXClientSocket.Create(AOwner : TComponent); 
begin 
     Inherited; 
     FSocket := INVALID_SOCKET; 
     FWnd := AllocateHwnd(WndProc); 
     FActive := False; 
end; 
 
destructor TIPXClientSocket.Destroy; 
begin 
     Close; 
     DeAllocateHwnd(FWnd); 
     Inherited; 
end; 
 
procedure TIPXClientSocket.WndProc(var Msg : TMessage); 
begin 
     //不是网络事件 
     if Msg.Msg <> WM_SOCKET then 
     begin 
          Msg.Result := DefWindowProc(FWnd, Msg.Msg, Msg.WParam, Msg.LParam); 
          Exit; 
     end; 
 
     if TSocket(Msg.WParam) <> FSocket then Exit; 
 
     if WSAGetSelectError(Msg.LParam) <> 0 then 
     begin 
          if Assigned(FOnError) then 
               FOnError(Self,'网络事件消息出错'); 
          Exit; 
     end; 
 
     case WSAGetSelectEvent(Msg.LParam) of 
     FD_CONNECT : 
     begin 
          if Assigned(FOnConnected) then FOnConnected(Self); 
     end; 
     FD_READ : 
     begin 
          if Assigned(FOnRead) then FOnRead(self); 
     end; 
     FD_WRITE : 
     begin 
          if Assigned(FOnWrite) then FOnWrite(Self); 
     end; 
     FD_CLOSE : 
     begin 
          //由于服务器关闭，所以客户也要关闭套接字 
          Close; 
          if Assigned(FOnDisConnect) then FOnDisConnect(Self); 
     end; 
     end;//case 
end; 
//建立连接 
procedure TIPXClientSocket.Open; 
var 
     RemoteAddr : TSOCKADDR_IPX; 
     nRet : Integer; 
begin 
     FActive := False;//是否建立连接的标志 
     if not CanUseWinsock then 
     begin 
          if Assigned(FOnError) then 
               FOnError(self, '不能初始化套接口'); 
          Exit; 
     end; 
 
     Close; 
     if (Fsa_nodenum <> '') and 
        (Fsa_netnum <> '') and 
        (Fsa_socket <> '') then 
     begin 
	  //远程主机IPX地址 
	  RemoteAddr.sa_family := AF_IPX; 
          ATOH(Fsa_netnum, RemoteAddr.sa_netnum, 4); 
          ATOH(Fsa_socket, RemoteAddr.sa_socket, 2); 
          ATOH(Fsa_nodenum, RemoteAddr.sa_nodenum, 6); 
          //创建套接字 
	  FSocket := socket(AF_IPX, SOCK_STREAM, NSPROTO_SPX); 
	  if FSocket = INVALID_SOCKET then 
	  begin 
               if Assigned(FOnError) then 
                    FOnError(Self, '创建套接字失败'); 
	       Exit; 
	  end; 
          //选定事件 
	  nRet := WSAAsyncSelect(FSocket, Fwnd, 
                                    WM_SOCKET,FD_READ or FD_CONNECT 
		                           or FD_WRITE or FD_CLOSE); 
	  if nRet = SOCKET_ERROR then 
	  begin 
               if Assigned(FOnError) then 
                    FOnError(Self, '选定事件失败'); 
	       if closesocket(FSocket) <> 0 then 
                   if Assigned(FOnError) then 
                        FOnError(self, '关闭套接字失败'); 
               FSocket := INVALID_SOCKET; 
	       Exit; 
	  end; 
          //连接服务器 
          nRet := connect(FSocket, PSockAddr(@RemoteAddr), sizeof(TSOCKADDR_IPX)); 
	  if nRet = SOCKET_ERROR then 
          	if WSAGetLastError <> WSAEWOULDBLOCK then 
		begin 
			if Assigned(FOnError) then 
                             FOnError(Self,'连接到服务器失败'); 
		       	Exit; 
		end; 
          FActive := True; 
      end else 
      begin 
           if Assigned(FOnError) then 
                FOnError(Self,'请输入完整的地址信息'); 
           Exit; 
      end; 
end; 
//关闭套接字 
procedure TIPXClientSocket.Close; 
begin 
     if FSocket = INVALID_SOCKET then Exit; 
     if closesocket(FSocket) <> 0 then 
          if Assigned(FOnError) then 
               FOnError(self, '关闭套接字失败'); 
     FSocket := INVALID_SOCKET; 
end; 
 
function TIPXClientSocket.SendBuf(var Buf; BufLen : Integer) : Integer; 
var 
     nSend : Integer; 
begin 
     Result := 0; 
     if FSocket = INVALID_SOCKET then 
     begin 
          if Assigned(FOnError) then 
               FOnError(self, '没有创建套接字,不能发送数据'); 
          Exit; 
     end; 
 
     nSend := send(FSocket, Buf, BufLen, 0); 
     if nSend = SOCKET_ERROR then 
     begin 
          if WSAGetLastError <> WSAEWOULDBLOCK then 
          begin 
               if Assigned(FOnError) then 
                    FOnError(self,'发送数据失败'); 
               Exit; 
          end; 
     end; 
     Result := nSend; 
end; 
 
function TIPXClientSocket.RecvBuf(var Buf; BufLen : Integer) : Integer; 
var 
     nRecv : Integer; 
begin 
     Result := 0; 
     if FSocket = INVALID_SOCKET then 
     begin 
          if Assigned(FOnError) then 
               FOnError(self, '没有创建套接字,不能接收数据'); 
          Exit; 
     end; 
 
     nRecv := recv(FSocket, Buf, BufLen, 0); 
     if nRecv < 0 then 
     begin 
          if WSAGetLastError <> WSAEWOULDBLOCK then 
          begin 
               if Assigned(FOnError) then 
                    FOnError(self,'接收数据失败'); 
               Exit; 
          end; 
     end; 
     Result := nRecv; 
end; 
{TIPXServerSocket} 
constructor TIPXServerSocket.Create(AOwner : TComponent); 
var 
     i : Integer; 
begin 
     inherited; 
     //先分配5个 
     SetLength(FClientSocket, 5); 
     for i := 0 to 4 do 
     begin 
          FClientSocket[i] := INVALID_SOCKET; 
     end; 
     FListenSocket := INVALID_SOCKET; 
     FWnd := AllocateHWND(WndProc); 
     FActive := False; 
     FActiveClientCount := 0; 
end; 
 
destructor TIPXServerSocket.Destroy; 
begin 
     Close; 
     DeallocateHWND(FWnd); 
     inherited; 
end; 
 
procedure TIPXServerSocket.WndProc(var Msg : TMessage); 
var 
     i, j : Integer; 
begin 
     //不是网络事件 
     if Msg.Msg <> WM_SOCKET_SERVER then 
     begin 
          Msg.Result := DefWindowProc(FWnd, Msg.Msg, Msg.WParam, Msg.LParam); 
          Exit; 
     end; 
 
     if WSAGetSelectError(Msg.LParam) <> 0 then 
     begin 
          if Assigned(FOnError) then 
               FOnError(Self,'网络事件消息出错'); 
          Exit; 
     end; 
 
     case WSAGetSelectEvent(Msg.LParam) of 
     FD_ACCEPT : 
     begin 
          if AcceptConnect then 
          begin 
               if Assigned(FOnClientConnected) then 
                    FOnClientConnected(Self, TSOCKET(MSG.WParam)); 
          end 
          else 
               if Assigned(FOnError) then 
                    FOnError(self, '接受客户端连接失败'); 
     end; 
     FD_READ : 
     begin 
          if Assigned(FOnRead) then FOnRead(self, MSG.WParam); 
     end; 
     FD_WRITE : 
     begin 
          if Assigned(FOnWrite) then FOnWrite(Self, MSG.WParam); 
     end; 
     FD_CLOSE ://客户端关闭 
     begin 
          //定位客户套接字 
          for i := 0 to FActiveClientCount - 1 do 
          begin 
               if FClientSocket[i] = TSocket(MSG.WParam) then 
                    break; 
          end; 
          if CloseSocket(FClientSocket[i]) <> 0 then 
               if Assigned(FOnError) then 
                    FOnError(self, '关闭套接字失败'); 
          //调整数组 
          for j := i + 1 to FActiveClientCount - 1 do 
                FClientSocket[j - 1] := FClientSocket[j]; 
 
          FClientSocket[FActiveClientCount - 1] := INVALID_SOCKET; 
          //更改FActiveClientCount 
          FActiveClientCount := FActiveClientCount - 1; 
          if Assigned(FOnClientDisConnect) then 
               FOnClientDisConnect(self, TSocket(MSG.WParam)); 
     end; 
     end;//case 
end; 
 
procedure TIPXServerSocket.Open; 
var 
     	nRet : Integer; 
	LocalAddr : TSOCKADDR_IPX;//本地主机地址 
begin 
        FActive := False; 
        if not CanUseWinSock then 
             if Assigned(FOnError) then 
                  FOnError(self, '不能使用套接口'); 
        //创建侦听套接字 
	FListenSocket := socket(AF_IPX, SOCK_STREAM, NSPROTO_SPX); 
	if FListenSocket = INVALID_SOCKET then 
	begin 
	     if Assigned(FOnError) then 
                  FOnError(self, '创建侦听套接字失败'); 
             Exit; 
	end; 
        //地址协议族 
        LocalAddr.sa_family := AF_IPX; 
        if Fsa_socket = '' then 
        begin 
             if Assigned(FOnError) then 
                   FOnError(self, '请输入端口号'); 
             Exit; 
        end; 
        //端口号 
        ATOH(Fsa_socket, LocalAddr.sa_socket, 2); 
 
	//给SOCKET绑上本地主机地址; 
       	nRet := bind(FListenSocket, PSOCKADDR(@LocalAddr), sizeof(TSOCKADDR_IPX)); 
        if nRet = SOCKET_ERROR then 
	begin 
	     if Assigned(FOnError) then 
                  FOnError(self, '绑定主机地址和端口失败'); 
	     if CloseSocket(FListenSocket) <> 0 then 
                  if Assigned(FOnError) then 
                       FOnError(self, '关闭套接字失败'); 
             FListenSocket := INVALID_SOCKET; 
	     Exit; 
	end; 
 
        //选择可以发生的事件 
	nRet := WSAAsyncSelect(FListenSocket, FWnd, WM_SOCKET_SERVER, FD_ACCEPT); 
	if nRet = SOCKET_ERROR then 
	begin 
	     if Assigned(FOnError) then 
                   FOnError(self, '选择事件失败'); 
	     if CloseSocket(FListenSocket) <> 0 then 
                   if Assigned(FOnError) then 
                        FOnError(self, '关闭套接字失败'); 
             FListenSocket := INVALID_SOCKET; 
	     Exit; 
	end; 
 
        //建立侦听 
	nRet := Listen(FListenSocket, SOMAXCONN); 
	if nRet = SOCKET_ERROR then 
	begin 
		if Assigned(FOnError) then 
                     FOnError(self, '建立侦听失败'); 
		if CloseSocket(FListenSocket) <>0 then 
                     if Assigned(FOnError) then 
                         FOnError(self, '关闭套接字失败'); 
                FListenSocket := INVALID_SOCKET; 
		Exit; 
	end; 
        FActive := True; 
        if Assigned(FOnListen) then 
             FOnListen(self, FListenSocket); 
end; 
 
procedure TIPXServerSocket.Close; 
var 
     i : Integer; 
begin 
      //关闭所有套接字 
      for i := 0 to FActiveClientCount - 1 do 
      begin 
           if FClientSocket[i] <> INVALID_SOCKET then 
           begin 
                if CloseSocket(FClientSocket[i]) <> 0 then 
                     if Assigned(FOnError) then 
                          FOnError(self, '关闭套接字失败'); 
                FClientSocket[i] := INVALID_SOCKET; 
           end; 
      end; 
      //关闭侦听套接字 
      if FListenSocket <> INVALID_SOCKET then 
      begin 
           if CloseSocket(FListenSocket) <> 0 then 
                 if Assigned(FOnError) then 
                      FOnError(self, '关闭套接字失败'); 
           FlistenSocket := INVALID_SOCKET; 
      end; 
end; 
 
function TIPXServerSocket.AcceptConnect : Boolean; 
var 
     nRet : Integer; 
     len : Integer; 
     ClientAddr : TSOCKADDR_IPX;//客户机地址 
     i, j : Integer; 
begin 
     Result := False; 
     //如果还有空间 
     if FActiveClientCount <= High(FClientSocket) then 
           i := FActiveClientCount 
     else 
     begin 
          //再分配FClientSocket 
          SetLength(FClientSocket, High(FClientSocket) + 5); 
          for j := FActiveClientCount to High(FClientSocket) do 
               FClientSocket[j] := INVALID_SOCKET; 
          i := FActiveClientCount; 
     end; 
     //接受客户端连接 
     FClientSocket[i] := accept(FListenSocket, TSOCKADDR(ClientAddr), len); 
     if FClientSocket[i] = INVALID_SOCKET then 
     begin 
          if Assigned(FOnError) then 
               FOnError(self, '接受客户端连接失败'); 
 
          if closesocket(FClientSocket[i]) <> 0 then 
                if Assigned(FOnError) then 
                     FOnError(self, '关闭套接字失败'); 
          FClientSocket[i] := INVALID_SOCKET; 
	  Exit; 
     end; 
     //设定事件 
     nRet := WSAAsyncSelect(FClientSocket[i],FWnd ,WM_SOCKET_SERVER, FD_READ or FD_WRITE 
     	                                         or FD_CLOSE); 
     if nRet = SOCKET_ERROR then 
     begin 
          if Assigned(FOnError) then 
              FOnError(self, '设定事件失败'); 
 
          if closesocket(FClientSocket[i]) <> 0 then 
              if Assigned(FOnError) then 
                   FOnError(self, '关闭套接字失败'); 
 
          FClientSocket[i] := INVALID_SOCKET; 
     	  Exit; 
     end; 
     //活动的客户端数 
     FActiveClientCount := FActiveClientCount + 1; 
     Result := True; 
end; 
 
function TIPXServerSocket.SendBuf(ClientSocket : TSocket; var Buf; BufLen : Integer) : Integer; 
var 
     nSend : Integer; 
begin 
     Result := 0; 
     if ClientSocket = INVALID_SOCKET then 
     begin 
          if Assigned(FOnError) then 
               FOnError(self, '没有创建套接字,不能发送数据'); 
          Exit; 
     end; 
 
     nSend := send(ClientSocket, Buf, BufLen, 0); 
     if nSend = SOCKET_ERROR then 
     begin 
          if WSAGetLastError <> WSAEWOULDBLOCK then 
          begin 
               if Assigned(FOnError) then 
                    FOnError(self,'发送数据失败'); 
               Exit; 
          end; 
     end; 
     Result := nSend; 
end; 
 
function TIPXServerSocket.RecvBuf(ClientSocket : TSocket; var Buf; BufLen : Integer) : Integer; 
var 
     nRecv : Integer; 
begin 
     Result := 0; 
     if ClientSocket = INVALID_SOCKET then 
     begin 
          if Assigned(FOnError) then 
               FOnError(self, '没有创建套接字,不能接收数据'); 
          Exit; 
     end; 
 
     nRecv := recv(ClientSocket, Buf, BufLen, 0); 
     if nRecv < 0 then 
     begin 
          if WSAGetLastError <> WSAEWOULDBLOCK then 
          begin 
               if Assigned(FOnError) then 
                    FOnError(self,'接收数据失败'); 
               Exit; 
          end; 
     end; 
     Result := nRecv; 
end; 
 
Initialization 
     WSAStartError := WSAStartUp(WINSOCK_VERSION, WSAData); 
Finalization 
     WSACleanUp; 
end.