UDP文件传送
unit U_UDPSock;
interface
uses
Classes, SysUtils, WinSock, Windows, NB30;
const
MINBUFFERSIZE = 2048;
DEFAULTBUFFERSIZE = 16384;
MAXBUFFERSIZE = 63488; //62*1024
MULTICAST_TTL = 10;
type
TArraySocket = Array Of TSocket;
PASTAT = ^TASTAT;
TASTAT = record
adapter : TAdapterStatus;
name_buf : TNameBuffer;
end;
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
//Note : Dut to broadcast fragmentation's problem, broadcast message can be at most
//512 bytes long defined by WinSock, not longer than 1472 by Berkeley Socket
//not longer than 1468 under MIPS machine
//So don't send a broadcast message longer than 512 here, no use
TUDPSockType = (stMultiCastSender, stMultiCastReceiver, stUnicastSender, stUnicastReceiver,
stBroadcastSender, stBroadcastReceiver);
TUDPOnRecv = procedure (buffer: Pointer; len: integer; fromIP: string; fromPort: integer) of Object;
TUDPRecvThd = class(TThread)
private
fSocks : TArraySocket;
fSockCount : integer;
fBufSize : integer;
fOnRecv : TUDPOnRecv;
protected
procedure Execute ; override;
public
constructor Create(var Socks : TArraySocket; OnRecv : TUDPOnRecv; BufSize : integer);
end;
TUDPSock2 = class(TObject)
private
fbSetupReady : Boolean;
fSockType : TUDPSockType;
fOnRecv : TUDPOnRecv;
fSockCount : integer;
fAddrTo : array of TSockAddr;
fMCReq : array of TIP_mreq;
fSocks : TArraySocket;
fRecvThd : TUDPRecvThd;
fLocalIP : String;
fBufSize : integer;
function LocalIPValid(var LocalIP : string): Boolean;
public
property OnRecv : TUDPOnRecv read fOnRecv write fOnRecv;
constructor Create; ReIntroduce;
destructor Destroy; Override;
procedure LocalIPs(slIPs : TStringList);
procedure LocalMAC(slMac : TStringList);
procedure StartReceive;
function Add(RemoteIP : string; Port : Cardinal): integer;
function Setup(udpSockType : TUDPSockType; LocalIP : string = '';
BufferSize : integer = DEFAULTBUFFERSIZE) : Boolean;
function Close : Boolean;
function Send(index : integer; buffer : Pointer; len : integer) : Boolean;
end;
implementation
var
wsData : TWSAData;
procedure TUDPRecvThd.Execute;
var
readFDs : TFDSet;
i, 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);
for i := 0 to fSockCount-1 do
FD_SET(fSocks[i], readFDs);
//The first param of select is provided just for
//compatibility with Berkeley Sockets, no meaning in WinSock
//Note!!! the select's last param here is nil
//so it can be blocked forever
Select(0, @readFDs, nil, nil, nil);
for i := 0 to fSockCount-1 do
if FD_ISSET(fSocks[i], readFDs) then
begin
nRecved := RecvFrom(fSocks[i], buf, fBufSize, 0, SockFrom, nAddrLen);
if Assigned(fOnRecv) then
//Note!!! I didn't call Synchronize here so u can call Terminate and WaitFor
//but I suggest using Suspend and Free STRONGLY!
//For the call of select can be blocked forever
fOnRecv(@buf, nRecved, string(Inet_Ntoa(SockFrom.sin_addr)),
Cardinal(Ntohs(SockFrom.sin_port)));
end;
end;
end;
constructor TUDPRecvThd.Create(var Socks : TArraySocket; OnRecv : TUDPOnRecv; BufSize : integer);
begin
fSocks := Socks;
fOnRecv := OnRecv;
fBufSize := BufSize;
fSockCount := High(Socks) + 1; //must start with 0, Low(Socks) is always 0
FreeOnTerminate := True;
inherited Create(False);
end;
procedure TUDPSock2.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 TUDPSock2.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 TUDPSock2.StartReceive;
begin
if ((fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)
or (fSockType = stBroadcastReceiver)) and (fSockCount > 0) then
fRecvThd := TUDPRecvThd.Create(fSocks, fOnRecv, fBufSize);
end;
function TUDPSock2.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;
function TUDPSock2.Setup(udpSockType : TUDPSockType; LocalIP : string = '';
BufferSize : integer = DEFAULTBUFFERSIZE):Boolean;
begin
Result := False;
//Already started?
if fSockCount > 0 then
Exit;
//Local IP set valid?
if not LocalIPValid(LocalIP) then
Exit;
//Buffer Size Valid?
if not ((BufferSize <= MAXBUFFERSIZE) and (BufferSize >= MINBUFFERSIZE)) then
Exit;
fSockType := udpSockType;
fBufSize := BufferSize;
fLocalIP := LocalIP;
fbSetupReady := True;
Result := True;
end;
function TUDPSock2.Add(RemoteIP : string; Port : Cardinal): integer;
var
nMCAddr : Cardinal;
nTTL, nReuseAddr : integer;
Sock : TSocket;
SockAddrLocal, SockAddrRemote : TSockAddr;
MCReq : TIP_mreq;
pPE : PProtoEnt;
begin
Result := -1;
//Maximum fds allowed
if fSockCount = FD_SETSIZE then
Exit;
//Already started?
if (fRecvThd <> nil) or (not fbSetupReady) then
Exit;
//Multicast address valid?
if (fSockType = stMultiCastSender) or (fSockType = stMultiCastReceiver) then
begin
nMCAddr := ntohl(inet_addr(PChar(RemoteIP)));
//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;
end;
pPE := GetProtoByName('UDP');
//Create Socket
Sock := Socket(AF_INET, SOCK_DGRAM, pPE.p_proto);
if Sock = INVALID_SOCKET then
Exit;
//Reuse the address, according to WinSock help, nReuseAddr must be a BOOL and
//the fifth param must be SizeOf(integer), but in a sample codes, the fifth is SizeOf(BOOL)
//faint! I used integer and SizeOf(integer) is also OK
nReuseAddr := 1;
if SetSockOpt(Sock, SOL_SOCKET, SO_REUSEADDR, @nReuseAddr, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
//Set Local Address and bind
FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);
SockAddrLocal.sin_family := AF_INET;
if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)
or (fSockType = stBroadcastSender) then
SockAddrLocal.sin_port := htons(0)
else
SockAddrLocal.sin_port := htons(Port);
SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));
if Bind(Sock, SockAddrLocal, SizeOf(SockAddrLocal)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)
or (fSockType = stBroadcastSender)then
begin
//Set Send Buffer Size
if SetSockOpt(Sock, SOL_SOCKET, SO_SNDBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
//Set output interface
if fSockType = stMultiCastSender then
begin
if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_IF, @(SockAddrLocal.sin_addr),
SizeOf(In_Addr)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
nTTL := MULTICAST_TTL;
if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_TTL, @nTTL, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
end else //For send, must set the opt SO_BROADCAST
if fSockType = stBroadcastSender then
if SetSockOpt(Sock, SOL_SOCKET, SO_BROADCAST, @nReuseAddr, SizeOf(integer))
= SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
FillChar(SockAddrRemote, SizeOf(SockAddrRemote), 0);
SockAddrRemote.sin_family := AF_INET;
SockAddrRemote.sin_port := htons(Port);
if fSockType = stBroadcastSender then
SockAddrRemote.sin_addr.S_addr := htonl(INADDR_BROADCAST)
else
SockAddrRemote.sin_addr.S_addr := Inet_Addr(PChar(RemoteIP));
fSockCount := fSockCount + 1;
SetLength(fAddrTo, fSockCount);
fAddrTo[fSockCount-1] := SockAddrRemote;
end else //UDPReceiver or MulticastReceiver or BroadcastReceiver
begin
//Set Receive Buffer Size
if SetSockOpt(Sock, SOL_SOCKET, SO_RCVBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
//Join Group
if fSockType = stMulticastReceiver then
begin
MCReq.imr_multiaddr.S_addr := Inet_Addr(PChar(RemoteIP));
MCReq.imr_interface.S_addr := Inet_Addr(PChar(fLocalIP));
if SetSockOpt(Sock, IPPROTO_IP, IP_ADD_MEMBERSHIP, @MCReq,
SizeOf(TIP_mreq)) = SOCKET_ERROR then
begin
CloseSocket(Sock);
Exit;
end;
end;
fSockCount := fSockCount + 1;
if fSockType = stMulticastReceiver then
begin
SetLength(fMCReq, fSockCount);
fMCReq[fSockCount-1] := MCReq;
end;
end;
SetLength(fSocks, fSockCount);
fSocks[fSockCount-1] := Sock;
Result := fSockCount - 1;
end;
function TUDPSock2.Close:Boolean;
var
i : integer;
begin
Result := False;
if fSockCount = 0 then
Exit;
if (fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)
or (fSockType = stBroadcastReceiver) then
begin
//Exception will be? :( I don't know
if fRecvThd <> nil then
begin
fRecvThd.Suspend;
fRecvThd.Free;
fRecvThd := nil;
end;
if fSockType = stMulticastReceiver then
for i := 0 to fSockCount - 1 do
SetSockOpt(fSocks[i], IPPROTO_IP, IP_DROP_MEMBERSHIP, @fMCReq[i], SizeOf(fMCReq[i]));
end;
for i := 0 to fSockCount - 1 do
CloseSocket(fSocks[i]);
SetLength(fMCReq, 0);
SetLength(fSocks, 0);
SetLength(fAddrTo, 0);
fbSetupReady := False;
fSockCount := 0;
end;
function TUDPSock2.Send(index : integer; buffer : Pointer; len : integer) : Boolean;
begin
Result := False;
if (len < 0) or (index < 0) or (index >= fSockCount) then
Exit;
if (fSockType <> stMultiCastSender) and (fSockType <> stUnicastSender)
and (fSockType <> stBroadcastSender) then
Exit;
if SendTo(fSocks[index], buffer^, len, 0{MSG_DONTROUTE}, fAddrTo[index],
SizeOf(fAddrTo[index])) <> SOCKET_ERROR then
Result := True;
end;
constructor TUDPSock2.Create;
begin
fbSetupReady := False;
fSockCount := 0;
fRecvThd := nil;
end;
destructor TUDPSock2.Destroy;
begin
if fSockCount > 0 then
Self.Close;
end;
initialization
if WSAStartup(MakeWord(2,0), wsData)<>0 then
raise Exception.Create('Cannot use the socket service!');
finalization
WSACleanup;
end.