Delphi控件源码

开发平台：
Delphi

SHUDPSocket.pas：源码内容
							unit SHUDPSocket;
interface
uses
  SysUtils, Windows, Winsock2, Classes;
const
  DEFAULT_SENDBUF_SIZE = 8192; //系统默认的缓冲区大小
  DEFAULT_RECVBUF_SIZE = 8192; //系统默认的缓冲区大小
type
  TUDPRecvThread = class;
  TSHUDPSocket = class;
  TUDPException = class(Exception);
  //usInit包括设置缓冲区长度
  //usSend是发送数据的时候
  //usRecv是接受数据的时候
  //usClose是关闭套接字的时候
  TPeerInfo = record
    PeerIP: string; //接受到的数据包的IP
    PeerPort: integer;
  end;
  TUDPErrorClass = (usInit, usSend, usRecv, usClose);
  TUDPErrorEvent = procedure(UDPSocket: TSHUDPSocket; ErrorClass:
    TUdpErrorClass; var ErrorCode: integer) of object;
  TUDPReadEvent = procedure(UDPSocket: TSHUDPSocket; const PeerInf: TPeerInfo)
    of object;
  //主要的UDP类
  TSHUDPSocket = class(TComponent)
  private
    //套接字
    FSocket: TSocket;
    //绑定端口号
    FPort: integer;
    //错误处理事件
    FOnSocketError: TUDPErrorEvent;
    //读数据事件
    FOnDataRead: TUDPReadEvent;
    //发送和接受缓冲大小
    FSendBufSize: integer;
    FRecvBufSize: integer;
    //记录接受到数据的远程机器的信息
    FPeerInfo: TPeerInfo;
    //发送数据的套接字
    FAddrOut: TSockAddrIn;
    //可以在这段时间进行一些客户清理工作
    //得到数据到达时间
    FWaitForTime: Longword;
    FOnTimeOut: TThreadMethod;
    //判断是否打开了套接字
    FActive: boolean;
    //是否广播
    FBroadcast: boolean;
    //得到和设置缓冲大小的函数
    function GetSendBufSize: integer;
    function GetRecvBufSize: integer;
    procedure SetSendBufSize(Value: integer);
    procedure SetRecvBufSize(value: integer);
    procedure SetActive(value: boolean);
    procedure SetWaitForTime(Value: Longword);
    procedure DoActive(Active: boolean);
    procedure SetBroadcast(const Value: boolean);
    function GetVer: string;
  protected
    FUDPRecvThread: TUDPRecvThread;
    procedure Loaded; override;
    procedure ReadData; virtual; //供后代继承重新覆盖该事件
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    //两个普通的发送函数
    function SendBuf(var buf; Size: integer; IP: string; Port: integer):
      boolean;
    function SendText(Text: string; IP: string; Port: integer): boolean;
    //两个发送广播的函数
    function SendBroadBuf(var buf; Size: integer; Port: integer): boolean;
    function SendBroadText(Text: string; Port: integer): boolean;
    //接受函数
    function RecvBuf(var buf; Size: integer): Integer;
    //接受到远程数据的Client信息
    property RecvInf: TPeerInfo read FPeerInfo;
  published
    //发送和接受缓冲区大小
    property SendBufSize: integer read GetSendBufSize write SetSendBufSize
      default DEFAULT_SENDBUF_SIZE;
    property RecvBufSize: integer read GetRecvBufSize write SetRecvBufSize
      default DEFAULT_RECVBUF_SIZE;
    //监听端口
    property Port: integer read FPort write FPort default 0;
    //等待数据超时间 默认是$FFFFFFFF;
    property WaitForTime: DWORD read FWaitForTime write SetWaitForTime default
      $FFFFFFFF;
    //打开套接字
    property Active: boolean read FActive write SetActive default false;
    //
    //5种事件类型
    //
    //有数据到达的事件
    property OnDataRead: TUDPReadEvent read FOnDataRead write FOnDataRead;
    //套接字发生错误事件
    property OnSocketError: TUDPErrorEvent read FOnSocketError write
      FOnSocketError;
    //接受数据发生超时
    property OnTimeOut: TThreadMethod read FOnTimeOut write FOnTimeOut;
    //是否广播数据
    property Broadcast: boolean read FBroadcast write SetBroadcast default
      False;
    property Ver: string read GetVer;
  end;
  TUDPRecvThread = class(TThread)
  private
    FSocket: TSHUDPSocket;
    FEvent: WSAEvent;
    //接受到数据的事件
    FOnDataRecv: TThreadMethod;
    procedure InitEvent;
    procedure FreeEvent;
  protected
    procedure Execute; override;
  public
    property OnDataRecv: TThreadMethod read FOnDataRecv write FOnDataRecv;
    constructor Create(AUdpSocket: TSHUDPSocket);
    destructor Destroy; override;
    procedure Stop;
  end;
procedure Register;
implementation
{ TUdpSocket }
uses
  SHSocket;
procedure Register;
begin
  RegisterComponents('SHNetTool', [TSHUDPSocket]);
end;
constructor TSHUDPSocket.Create(AOwner: TComponent);
begin
  //初始化所有的参数
  inherited Create(AOwner);
  FActive := False;
  FPort := 0;
  FillChar(FPeerInfo, SizeOf(FPeerInfo), 0);
  FSendBufSize := DEFAULT_SENDBUF_SIZE;
  FRecvBufSize := DEFAULT_RECVBUF_SIZE;
  FSocket := INVALID_SOCKET;
  FUdpRecvThread := nil;
  FWaitForTime := $FFFFFFFF;
  FBroadcast := False;
end;
destructor TSHUDPSocket.Destroy;
begin
  if FActive then
    DoActive(False);
  inherited Destroy;
end;
procedure TSHUDPSocket.DoActive(Active: boolean);
var
  iError: Integer;
begin
  if Active and (FSocket = INVALID_SOCKET) then //开始初始化套接字
  begin
    FSocket := SHSocket.InitUDPSocket(FPort);
    if FSocket <> INVALID_SOCKET then
    begin
      FActive := True;
      try
        SetBroadcast(FBroadCast);
        SetSendBufSize(FSendBufSize);
        SetRecvBufSize(FRecvBufSize);
        FUDPRecvThread := TUdpRecvThread.Create(Self);
        FUDPRecvThread.FOnDataRecv := ReadData;
        FUDPRecvThread.Resume;
      except
        DoActive(False);
        raise TUDPException.Create('建立监听线程发生错误...');
      end;
    end
    else
    begin
      iError := WSAGetLastError();
      if Assigned(FOnSocketError) then
        FOnSocketError(Self, usInit, iError);
      if iError <> 0 then
        raise TUDPException.CreateFmt('初始化套接字发生错误，错误代码是%d',
          [iError]);
    end;
  end
  else //关闭套接字
  begin
    if Assigned(FUdpRecvThread) then
    begin
      FUdpRecvThread.Stop;
      FreeAndNil(FUdpRecvThread);
    end;
    FreeSocket(FSocket);
    FActive := False;
  end;
end;
function TSHUDPSocket.GetRecvBufSize: integer;
begin
  if FActive then
  begin
    Result := SHSocket.GetRecvBufSize(FSocket);
    FRecvBufSize := Result;
  end
  else
    Result := FRecvBufSize;
end;
function TSHUDPSocket.GetSendBufSize: integer;
begin
  if FActive then
  begin
    Result := SHSocket.GetSendBufSize(FSocket);
    FSendBufSize := Result;
  end
  else
    Result := FSendBufSize;
end;
function TSHUDPSocket.GetVer: string;
const
  TAB = #13#10;
begin
  MessageBox(0,
    PChar('SHUDPSocket 2.0A' + TAB + '作者：孙辉 EMAIL:sunhuiNO1@hotmail.com'),
    '版本',
    MB_ICONINFORMATION);
  Result := 'SHUDPSocket 2.0A';
end;
procedure TSHUDPSocket.Loaded;
begin
  inherited Loaded;
  SetActive(FActive);
end;
procedure TSHUDPSocket.ReadData;
begin
  if Assigned(FOnDataRead) then
    FOnDataRead(Self, FPeerInfo);
end;
function TSHUDPSocket.RecvBuf(var buf; Size: integer): Integer;
var
  AddrIn: TSockAddrIn;
  iRc, iAddr: integer;
  iError: Integer;
begin
  iAddr := SizeOf(AddrIn);
  iRc := RecvFrom(FSocket, buf, Size, 0, AddrIn, iAddr);
  with FPeerInfo do
  begin
    PeerPort := ntohs(AddrIn.sin_port);
    PeerIP := inet_ntoa(AddrIn.sin_addr);
  end;
  Result := iRc;
  if iRc = SOCKET_ERROR then
  begin
    iError := WSAGetLastError();
    if iError <> WSAEWOULDBLOCK then //缓冲区满的错误代码
    begin
      if Assigned(FOnSocketError) then
        FOnSocketError(Self, usRecv, iError);
      if iError <> 0 then
        raise TUDPException.CreateFmt('接受数据发生错误，错误代码是%d',
          [iError]);
    end;
  end;
end;
function TSHUDPSocket.SendBroadBuf(var buf; Size, Port: integer): boolean;
begin
  if not FBroadcast then
    SetBroadcast(True);
  Result := SendBuf(buf, size, '255,255,255,255', Port);
end;
function TSHUDPSocket.SendBroadText(Text: string; Port: integer): boolean;
begin
  Result := SendText(Text, '255,255,255,255', Port);
end;
function TSHUDPSocket.SendBuf(var buf; Size: integer; IP: string;
  Port: integer): boolean;
var
  iRc, iError: integer;
begin
  Result := False;
  FAddrOut.sin_family := AF_INET;
  FAddrOut.sin_port := htons(Port);
  FAddrOut.sin_addr.S_addr := inet_addr(pchar(IP));
  if (not FBroadcast) and (FAddrOut.sin_addr.S_addr = INADDR_NONE) then
    raise TUDPException.Create('无效的远程IP地址...');
  iRc := SendTo(FSocket, buf, Size, 0, FAddrOut, SizeOf(FAddrOut));
  if iRc = SOCKET_ERROR then
  begin
    iError := WSAGetLastError();
    if iError <> WSAEWOULDBLOCK then
    begin
      if Assigned(FOnSocketError) then
        FOnSocketError(Self, usSend, iError);
      if iError <> 0 then
        raise TUDPException.CreateFmt('发送数据发生错误，错误代码是%d',
          [iError]);
    end;
  end
  else
    Result := True;
end;
function TSHUDPSocket.SendText(Text: string; IP: string; Port: integer):
  boolean;
begin
  Result := SendBuf(Pointer(Text)^, Length(Text), IP, Port);
end;
procedure TSHUDPSocket.SetActive(value: boolean);
begin
  if (csDesigning in ComponentState)
    or (csLoading in ComponentState) then
  begin
    if (FActive <> Value) then
      FActive := Value
  end
  else
  begin
    DoActive(Value);
  end;
end;
procedure TSHUDPSocket.SetBroadcast(const Value: boolean);
var
  iError: integer;
begin
  if (Value <> FBroadcast)
    or (csDesigning in ComponentState)
    or (csLoading in ComponentState) then
  begin
    FBroadcast := Value;
    Exit;
  end;
  if (FSocket <> INVALID_SOCKET) and (not SHSocket.SetBroadCasst(FSocket, Value))
    then
  begin
    iError := WSAGetLastError();
    if Assigned(FOnSocketError) then
      FOnSocketError(Self, usInit, iError);
    if iError <> 0 then
      raise TUDPException.CreateFmt(
        '设置广播出错，错误代码是%d',
        [iError]);
  end
  else
    FBroadCast := Value;
end;
procedure TSHUDPSocket.SetRecvBufSize(value: integer);
begin
  if (csDesigning in ComponentState) or (csLoading in ComponentState) then
  begin
    if (Value <> FRecvBufSize) and (Value >= 0) then
      FRecvBufSize := Value;
    Exit;
  end
  else if SHSocket.SetRecvBufSize(FSocket, Value) then
  begin
    FRecvBufSize := Value;
  end
  else
    raise TUDPException.CreateFmt('设置接受缓冲区出错，错误代码是%d',
      [WSAGetLastError()]);
end;
procedure TSHUDPSocket.SetSendBufSize(Value: integer);
begin
  if (csDesigning in ComponentState) or (csLoading in ComponentState) then
  begin
    if (Value <> FSendBufSize) and (Value >= 0) then
      FSendBufSize := Value;
    Exit;
  end
  else
  begin
    if SHSocket.SetSendBufSize(FSocket, Value) then
    begin
      FSendBufSize := Value;
    end
    else
      raise TUDPException.CreateFmt('设置发送缓冲区出错，错误代码是%d',
        [WSAGetLastError()]);
  end;
end;
procedure TSHUDPSocket.SetWaitForTime(Value: Longword);
begin
  if Value <> FWaitForTime then
  begin
    FWaitForTime := Value;
  end;
end;
{ TUdpRecvThread }
constructor TUDPRecvThread.Create(AUdpSocket: TSHUDPSocket);
begin
  inherited Create(true);
  FSocket := AUdpSocket;
  FEvent := WSA_INVALID_EVENT;
  InitEvent;
end;
destructor TUDPRecvThread.Destroy;
begin
  if not Terminated then
    Stop;
  FreeEvent;
  inherited Destroy;
end;
procedure TUDPRecvThread.Execute;
var
  dwRc: DWORD;
begin
  while not Terminated do
  begin
    dwRc := WSAWaitForMultipleEvents(
      1,
      @FEvent,
      False,
      FSocket.FWaitForTime,
      False);
    if Terminated then
      Break;
    if (dwRc = WAIT_IO_COMPLETION) or (dwRc = WSA_WAIT_FAILED) then
      Break
    else
    begin
      WSAResetEvent(FEvent);
      if dwRc = WSA_WAIT_TIMEOUT then
      begin
        if Assigned(FSocket.FOnTimeOut) then //设置处理多长时间没有收到数据
          Synchronize(FSocket.FOnTimeOut);
      end
      else if Assigned(FOnDataRecv) then
        Synchronize(FOnDataRecv);
    end;
  end;
end;
procedure TUDPRecvThread.FreeEvent;
begin
  if FEvent <> WSA_INVALID_EVENT then
  begin
    WSACloseEvent(FEvent);
    FEvent := WSA_INVALID_EVENT;
  end;
end;
procedure TUDPRecvThread.InitEvent;
var
  iRc: integer;
begin
  FEvent := WSACreateEvent();
  if FEvent = WSA_INVALID_EVENT then
    raise TUDPException.CreateFmt('创建套接字事件句柄出错..，错误代码是%d',
      [WSAGetLastError()]);
  iRc := WSAEventSelect(FSocket.FSocket, FEvent, FD_READ);
  if iRc = SOCKET_ERROR then
    raise TUDPException.CreateFmt('设置套接字事件句柄出错..，错误代码是%d',
      [WSAGetLastError()]);
end;
procedure TUDPRecvThread.Stop;
begin
  Terminate;
  SetEvent(FEvent);
  WaitFor;
end;
end.

						