多址广播控件

unit MulticastSocket;

{
    * 多址广播控件
    * 本文件提取自 U_UDPSock.pas
    * 整理于2001年11月17~2001年11月18日
    * 关于 NB30 单元，主要用于
    *   "取得本地计算机所有的MAC地址"
    *   procedure LocalMAC(slMac : TStringList);
    * 所以被我注释掉了
    * 并不影响使用
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  WinSock;//, NB30;

const
  MINBUFFERSIZE = 2048;
  DEFAULTBUFFERSIZE = 16384;
  MAXBUFFERSIZE = 63488; //62*1024
  MULTICAST_TTL = IP_DEFAULT_MULTICAST_TTL;
  MAX_MULTICAST_TTL = 128;

type
  PIP_mreq = ^TIP_mreq;
  TIP_mreq = record
     imr_multiaddr  : in_addr;
     imr_interface  : in_addr;
  end;

  TAPInAddr = Array [0..10] of PInAddr; // array of pInaddr
  PAPInAddr = ^TAPInaddr;               // pointer of Array

  (*
  PASTAT = ^TASTAT;
  TASTAT = record
    adapter : TAdapterStatus;
    name_buf : TNameBuffer;
  end;
  *)

  TUDPOnRecv = procedure (buffer: Pointer; len: integer; fromIP: string; fromPort: u_Short) of Object;

  //接收数据线程
  TUDPRecvThd = class(TThread)
    private
      fSocks : TSocket;
      fBufSize : integer;
      fOnRecv : TUDPOnRecv;
    protected
      procedure Execute ; override;
    public
      constructor Create(var Socks : TSocket; OnRecv : TUDPOnRecv; BufSize : integer);
  end;

type
  TMulticastSocket = class(TComponent)
  private
    { Private declarations }
    fActived    : Boolean;      {是否激活}

    fsock       : TSocket;      {socket}
    fRecvThd    : TUDPRecvThd;  {接收线程}
    fMCReq      : TIP_mreq;     {记录加入的组地址，释放资源时用}
    fSendBufSize: integer;      {发送缓冲区大小}
    fRecvBufSize: integer;      {接收缓冲区大小}
    fLocalIP    : String;       {本地IP地址}
    fAddrTo     : TSockAddr;    {发送IP地址}
    fCanRead    : Boolean;      {可以读取数据}
    fCanWrite   : Boolean;      {可以发送数据}
    fTTL        : integer;      {Time To Live,生存时间,即可以跨越的网关数}
    fGroupAddress:String;       {组地址}
    fGroupPort  : integer;      {组端口}
    //fRecvState  : Boolean;      {接收线程是否启动}
    fOnRecv     : TUDPOnRecv;   {响应的事件}

    {组地址}
    procedure SetGroupAddress(addr:String);
    {组端口}
    procedure SetGroupPort(port:integer);
    {读}
    procedure SetCanRead(CanRead:Boolean);
    {写}
    procedure SetCanWrite(CanWrite:Boolean);
    {发送缓冲区大小}
    procedure SetSendBufSize(SendBufSize:integer);
    {接收缓冲区大小}
    procedure SetRecvBufSize(RecvBufSize:integer);
    {本地IP地址}
    procedure SetLocalIP(addr:String);
    {是否激活}
    procedure SetActived(const Value: Boolean);
    {Time To Live,生存时间,即可以跨越的网关数}
    procedure SetTTL(const Value: integer);

    {改变响应事件的限制}
    //procedure SetOnRecv(const Value: Boolean);
    procedure SetOnRecv(const Value: TUDPOnRecv);

    {Local IP set valid?}
    {参数为''的话，就得到默认IP}
    function  LocalIPValid(var LocalIP:String) : Boolean;

    {设置Socket可以接收数据}
    function  EnabledListen:Boolean;
    {设置Socket不能接收数据}
    procedure DisabledListen;
    {设置Socket可以发送数据}
    function  EnabledSend:Boolean;
  protected
    { Protected declarations }
  public
    { Public declarations }
    function    Close:Boolean;
    function    Send(buffer : Pointer; len : integer ; Flag : integer = 0) : Boolean;
    function    AddToGroup : integer;
    procedure   StartReceive;

    {取得本地计算机所有的IP地址}
    procedure LocalIPs(slIPs : TStringList);
    {取得本地计算机所有的MAC地址}
    //procedure LocalMAC(slMac : TStringList);

    function  Connect:Boolean;
    function  DisConnect:Boolean;
  published
    { Published declarations }
    property    LocalAddress : String read fLocalIP write SetLocalIP nodefault;
    property    CanRead  : Boolean read fCanRead  write SetCanRead  default true;
    property    CanWrite : Boolean read fCanWrite write SetCanWrite default true;
    property    TTL : integer read fTTL write SetTTL default MULTICAST_TTL;
    property    SendBufSize: integer read fSendBufSize write SetSendBufSize default DEFAULTBUFFERSIZE;
    property    RecvBufSize: integer read fRecvBufSize write SetRecvBufSize default DEFAULTBUFFERSIZE;
    property    GroupAddress:String read fGroupAddress write SetGroupAddress nodefault;
    property    GroupPort:integer read fGroupPort write SetGroupPort default 6000;
    property    Actived:Boolean read fActived write SetActived default False;

    property    OnDataArrive:TUDPOnRecv read fOnRecv write SetOnRecv nodefault;

    constructor Create(AOwner:TComponent);override;
    destructor  Destroy;override;
  end;

procedure Register;

implementation

var
  wsData : TWSAData;

procedure Register;
begin
  RegisterComponents('FastNet', [TMulticastSocket]);
end;

{ TMulticastSocket }

function TMulticastSocket.AddToGroup:integer;
var
  nReuseAddr : integer;
  SockAddrLocal : TSockAddr;
  pPE : PProtoEnt;
begin
  Result:=-1;

  pPE := GetProtoByName('UDP');
  //Create Socket
  fSock := Socket(AF_INET, SOCK_DGRAM, pPE.p_proto);
  if fSock = INVALID_SOCKET then
    Exit;

  nReuseAddr := 1;
  if SetSockOpt(fSock, SOL_SOCKET, SO_REUSEADDR, @nReuseAddr, SizeOf(integer)) = SOCKET_ERROR then
  begin
    CloseSocket(fSock);
    Exit;
  end;

  //Set Local Address and bind
  FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);
  SockAddrLocal.sin_family := AF_INET;
    //发送用0
    //SockAddrLocal.sin_port := htons(0);
  SockAddrLocal.sin_port := htons(fGroupPort);
  SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));
  if Bind(fSock, SockAddrLocal, SizeOf(SockAddrLocal)) = SOCKET_ERROR then
  begin
    CloseSocket(fSock);
    Exit;
  end;

    if fCanWrite then
        if not EnabledSend then
            Exit;

    if fCanRead then
        if not EnabledListen then
            Exit;

    Result:=0;
end;

function TMulticastSocket.Close: Boolean;
begin
    //MulticastReceiver
    //Exception will be? :( I don't know
    //释放接收数据线程
    if fRecvThd <> nil then
    begin
        fRecvThd.Suspend;
        fRecvThd.Free;
        fRecvThd := nil;
    end;

    DisabledListen;
    //Close Socket
    CloseSocket(fSock);
    Result:=True;
end;

constructor TMulticastSocket.Create(AOwner:TComponent);
begin
    {这里设置默认属性,我不知道为什么在Default中写的没有效果}
    LocalIPValid(fLocalIP);
    fCanRead:=True;
    fCanWrite:=True;
    fSendBufSize:=DEFAULTBUFFERSIZE;
    fRecvBufSize:=DEFAULTBUFFERSIZE;
    fGroupAddress:='225.0.0.1';
    fGroupPort:=6000;
    fTTL:=MULTICAST_TTL;
    inherited Create(AOwner);
end;

destructor TMulticastSocket.Destroy;
begin
    Close;
    inherited Destroy;
end;

procedure TMulticastSocket.SetGroupAddress(addr: String);
var
    nMCAddr : Cardinal;
begin
    if Actived=True then
        Exit;

    //Multicast address valid?
    nMCAddr := ntohl(inet_addr(PChar(addr)));
    //though Multicast ip is between 224.0.0.0 to 239.255.255.255
    //the 224.0.0.0 to 224.0.0.225 ips are reserved for system
    if not ((nMCAddr <= $efffffff) and (nMCAddr >= $e0000100)) then
        Exit;
    fGroupAddress:=addr;
end;

function TMulticastSocket.Send(buffer:Pointer;len:integer;Flag:integer=0):Boolean;
begin
    Result := False;
    if not CanWrite then
        Exit;
    if SendTo(fSock, buffer^, len, Flag{MSG_DONTROUTE}, fAddrTo,
            SizeOf(fAddrTo)) <> SOCKET_ERROR then
        Result := True;
end;

procedure TMulticastSocket.StartReceive;
begin
    if fRecvThd<> nil then
    //接收线程已经启动
        Exit;
    //启动接收线程
    if Assigned(fOnRecv) then
        fRecvThd := TUDPRecvThd.Create(fSock, fOnRecv, fSendBufSize);
end;

procedure TMulticastSocket.SetCanRead(CanRead: Boolean);
begin
    //if Actived=True then
    //    Exit;
    if fCanRead=CanRead then
        Exit;

    if CanRead then
    begin
        if not EnabledListen then
            Exit;
    end else
        DisabledListen;

    fCanRead:=CanRead;
end;

procedure TMulticastSocket.SetCanWrite(CanWrite: Boolean);
begin
    if Actived=True then
        Exit;

    fCanWrite:=CanWrite;
end;

procedure TMulticastSocket.SetGroupPort(Port: integer);
begin
    if Actived=True then
        Exit;

    fGroupPort:=Port;
end;

procedure TMulticastSocket.SetRecvBufSize(RecvBufSize: integer);
begin
    if Actived=True then
        Exit;

  //Buffer Size Valid?
  if not ((RecvBufSize <= MAXBUFFERSIZE) and (RecvBufSize >= MINBUFFERSIZE)) then
    Exit;
  fRecvBufSize:=RecvBufSize;
end;

procedure TMulticastSocket.SetSendBufSize(SendBufSize: integer);
begin
    if Actived=True then
        Exit;

  //Buffer Size Valid?
  if not ((SendBufSize <= MAXBUFFERSIZE) and (SendBufSize >= MINBUFFERSIZE)) then
    Exit;
  fSendBufSize:=SendBufSize;
end;

function TMulticastSocket.LocalIPValid(var LocalIP:String): Boolean;
var
  i : integer;
  slLocalIPs : TStringList;
begin
  Result := False;
  slLocalIPs := TStringList.Create;
  Self.LocalIPs(slLocalIPs);
  if slLocalIPs.Count = 0 then
  begin
    slLocalIPs.Free;
    Exit;
  end;

  if LocalIP = '' then
  begin
    LocalIP := slLocalIPs[0]; //Default Interface
    Result := True;
  end else
    for i:=0 to slLocalIPs.Count-1 do
      if Trim(slLocalIPs[i]) = Trim(LocalIP) then
      begin
        Result := True;
        Break;
      end;
  slLocalIPs.Free;
end;

procedure TMulticastSocket.SetLocalIP(addr: String);
begin
    if Actived=True then
        Exit;

    //Local IP set valid?
    if not LocalIPValid(addr) then
        Exit;
    fLocalIP:=addr;
end;

procedure TMulticastSocket.LocalIPs(slIPs: TStringList);
var
  strLocalHost : string;
  pHE : PHostent;
  pInAd : PAPInAddr;
  saLocal : TSockAddr;
  i : integer;
begin
  SetLength(strLocalHost, 255);
  if GetHostName(PChar(strLocalHost), 254) = SOCKET_ERROR then
    Exit;

  pHE := GetHostByName(PChar(strLocalHost));
  pInAd := PAPInAddr(pHE^.h_addr_list);
  saLocal.sin_addr := (pInAd^[0]^);
  i := 0;
  while True do
  begin
    slIPs.Add(inet_ntoa(saLocal.sin_addr));
    i := i + 1;
    if(pInAd^[i] <> nil) then
      saLocal.sin_addr := (pInAd^[i]^)   //local host
    else
      break;
  end;
end;

(*
procedure TMulticastSocket.LocalMAC(slMac: TStringList);
var
  ncb : TNCB;
  adapt : TASTAT;
  lanaEnum : TLanaEnum;
  i, j : integer;
  strPart, strMac : string;
begin
  FillChar(ncb, SizeOf(TNCB), 0);
  ncb.ncb_command := Char(NCBEnum);
  ncb.ncb_buffer := PChar(@lanaEnum);
  ncb.ncb_length := SizeOf(TLanaEnum);
  Netbios(@ncb);

  for i := 0 to integer(lanaEnum.length)-1 do
  begin
    FillChar(ncb, SizeOf(TNCB), 0);
    ncb.ncb_command := Char(NCBReset);
    ncb.ncb_lana_num := lanaEnum.lana[i];
    Netbios(@ncb);

    FillChar(ncb, SizeOf(TNCB), 0);
    ncb.ncb_command := Chr(NCBAstat);
    ncb.ncb_lana_num := lanaEnum.lana[i];
    ncb.ncb_callname := '*               ';
    ncb.ncb_buffer := PChar(@adapt);
    ncb.ncb_length := SizeOf(TASTAT);
    if Netbios(@ncb) = Chr(0) then
    begin
      strMac := '';
      for j := 0 to 5 do
      begin
        strPart := IntToHex(integer(adapt.adapter.adapter_address[j]), 2);
        strMac := strMac + strPart + '-';
      end;
      SetLength(strMac, Length(strMac)-1);
      slMac.Add(strMac);
    end;
  end;
end;*)

procedure TMulticastSocket.SetActived(const Value: Boolean);
begin
    if Value=fActived then
    //状态未发生变化
        Exit;
    if Value then
        Connect
    else
        DisConnect;
end;

function TMulticastSocket.Connect: Boolean;
begin
    Result:=(AddToGroup=0);
    if not Result then
        Exit;
    if CanRead and Assigned(fOnRecv) then
        StartReceive;
    fActived:=Result;
end;

function TMulticastSocket.DisConnect: Boolean;
begin
    Result:=Close;
    if Result then
        fActived:=False;
end;

procedure TMulticastSocket.SetOnRecv(const Value: TUDPOnRecv);
begin
    if Actived and Assigned(fOnRecv) then
    //事件已经在运行了
        Exit;
    fOnRecv := Value;
    if Actived then
    //已经激活但未设置事件
        StartReceive;
end;

procedure TMulticastSocket.SetTTL(const Value: integer);
begin
    if Actived
        or (Value>MAX_MULTICAST_TTL)
        or (Value<0) then
        Exit;
    fTTL := Value;
end;

function  TMulticastSocket.EnabledListen : Boolean;
var
    MCReq : TIP_mreq;
begin
    Result:=False;

    {接收数据缓冲区大小}
    if SetSockOpt(fSock, SOL_SOCKET, SO_RCVBUF, @fRecvBufSize, SizeOf(integer)) = SOCKET_ERROR then
    begin
      CloseSocket(fSock);
      Exit;
    end;

    {加入多址广播组}
    MCReq.imr_multiaddr.S_addr := Inet_Addr(PChar(fGroupAddress));
    MCReq.imr_interface.S_addr := Inet_Addr(PChar(fLocalIP));
    if SetSockOpt(fSock, IPPROTO_IP, IP_ADD_MEMBERSHIP, @MCReq,
                  SizeOf(TIP_mreq)) = SOCKET_ERROR then
    begin
        CloseSocket(fSock);
        Exit;
    end;
    fMCReq := MCReq;

    if Actived and Assigned(fOnRecv) then
        StartReceive;

    Result:=True;
end;

function TMulticastSocket.EnabledSend: Boolean;
var
  SockAddrLocal, SockAddrRemote : TSockAddr;
begin
    Result:=False;

    FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);
    SockAddrLocal.sin_family := AF_INET;
    SockAddrLocal.sin_port := htons(fGroupPort);
    SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));

    {发送数据缓冲区大小}
    if SetSockOpt(fSock, SOL_SOCKET, SO_SNDBUF, @fSendBufSize, SizeOf(integer)) = SOCKET_ERROR then
    begin
      CloseSocket(fSock);
      Exit;
    end;
    {IP multicast output interface}
    if SetSockOpt(fSock, IPPROTO_IP, IP_MULTICAST_IF, @(SockAddrLocal.sin_addr),
                  SizeOf(In_Addr)) = SOCKET_ERROR then
    begin
        CloseSocket(fSock);
        Exit;
    end;
    {设置Time To Livw}
    if SetSockOpt(fSock, IPPROTO_IP, IP_MULTICAST_TTL, @fTTL, SizeOf(integer)) = SOCKET_ERROR then
    begin
        CloseSocket(fSock);
        Exit;
    end;

    {设置发送的目的位置到fAddrTo中}
    FillChar(SockAddrRemote, SizeOf(SockAddrRemote), 0);
    SockAddrRemote.sin_family := AF_INET;
    SockAddrRemote.sin_port := htons(fGroupPort);
    SockAddrRemote.sin_addr.S_addr := Inet_Addr(PChar(fGroupAddress));
    fAddrTo := SockAddrRemote;

    Result:=True;
end;

procedure TMulticastSocket.DisabledListen;
begin
    SetSockOpt(fSock, IPPROTO_IP, IP_DROP_MEMBERSHIP, @fMCReq, SizeOf(fMCReq));
end;

{ TUDPRecvThd }

constructor TUDPRecvThd.Create(var Socks: TSocket; OnRecv: TUDPOnRecv;
  BufSize: integer);
begin
    fSocks := Socks;
    fOnRecv := OnRecv;
    fBufSize := BufSize;
    FreeOnTerminate := True;
    inherited Create(False);
end;

procedure TUDPRecvThd.Execute;
var
    readFDs : TFDSet;
    nRecved, nAddrLen: integer;
    buf : array [0..MAXBUFFERSIZE] of Byte;
    SockFrom : TSockAddr;
begin
    Priority := tpHighest;
    while not Terminated do
    begin
        nAddrLen := SizeOf(SockFrom);
        FD_ZERO(readFDs);
        FD_SET(fSocks, readFDs);
        Select(0, @readFDs, nil, nil, nil);
        if FD_ISSET(fSocks, readFDs) then
        begin
            nRecved := RecvFrom(fSocks, buf, fBufSize, 0, SockFrom, nAddrLen);
            if Assigned(fOnRecv) then
            fOnRecv(@buf, nRecved, string(Inet_Ntoa(SockFrom.sin_addr)),
                Cardinal(Ntohs(SockFrom.sin_port)));
        end;
    end;
end;

initialization
  if WSAStartup(MakeWord(2,0), wsData)<>0 then
    raise Exception.Create('Cannot use the socket service!');

finalization
  WSACleanup;

end.