udpsocket.pas

针对 UDP 通讯协议的 Socket 构件

  if Bind(Fsockethandle,sain,sizeof(sain)) = 0 then  begin
     // Bound ! , now we have to set Async mode
     if WSAAsyncSelect(FsocketHandle,FwinHandle,WM_SOCKET,FD_READ or FD_WRITE or FD_CLOSE) = 0 then begin
     // Async mode suxxessfully set up
     Fbnd := true;
     end else begin handlelastexception; UDP_unbind; end;
  end else begin handlelastexception; UDP_unbind; end;
end;
end;

procedure Tudpsocket.S_Open;
// The same, but this one is called by the user
begin
UDP_bind;
end;

// ---------------------------------------------------------------------
// The DNS LOOKUP stuff
// ---------------------------------------------------------------------


procedure TudpSocket.SetLocation(s:string);
// Say where to send UDP data. perform a lookup if needed
// this is for property Location
begin
Fhost.location:=s;
PDNSlookup(Fhost);
end;

procedure TudpSocket.PDNSlookup(var hostabout:Thostabout);
// The core of the DNS part, this asks windows to give as much
// information as possible about the given location.
var
Buff:array[0..256] of char;
SockAddrIn:TsockAddrIn;
hostent:Phostent;
L_string:string;
begin
L_string:=hostAbout.location;
strPcopy(buff,l_string);
// first test if the thingy is a dotted IP
SockAddrIn.sin_addr.S_addr:=inet_addr(buff);
if SockAddrIn.sin_addr.S_addr = INADDR_NONE then begin
   // well, the location was probably a DNS name
   // lets resolve it !

   hostent := gethostbyname(buff);

   if hostent <> nil then begin
   // OK, it WAS a DNS name. fill in the struct and were done
   hostabout.DNS_name:=hostabout.location;
   hostabout.IP_addr:=longint(plongint(hostent^.h_addr_list^)^);
   // Convert Addr to DOTDOT format.
   hostabout.IP_dotdot:=iptodotdot(hostabout.IP_addr);
   end else begin
     // Not an IP address, not a DNS name, NOTHING !!
     hostabout.IP_addr:=0;
     hostabout.DNS_name:='';
     hostabout.IP_dotdot:='';
     hostabout.location:='error';
   end;

end else begin
   // Yeh, it was an IP address. letz look for a name !
   hostabout.IP_addr:=SockAddrIn.sin_addr.S_addr;
   // dotdot
   hostabout.IP_dotdot:=iptodotdot(hostabout.IP_addr);
   // Now do a reverse DNS to find out a hostname.
   // set property reverseDNS to false if too slow.
   hostabout.DNS_name:='NO REVERSE DNS!';
   if FperformReverseDNS then begin
     hostent:=gethostbyaddr(@(hostabout.Ip_addr),4,AF_INET);
     if hostent <> nil then                                  // " " " " " " " " "
     hostabout.DNS_name:=strpas(hostent.h_name) else begin   // " " " " " " " " "
     hostabout.DNS_name:='reverse dns lookup error';         // " " " " " " " " "
     
     end;
   end;
end;
end;



function TudpSocket.DNSlookup(a_location:string):Thostabout;
//A function for the user, does the same
var
tt:Thostabout;
begin
fillchar(tt,sizeof(tt),0);
tt.location:=a_location;
PDNSlookup(tt);
result:=tt;
end;

// ---------------------------------------------------------------------
// The SEND - RECEIVE stuff
// ---------------------------------------------------------------------

procedure TudpSocket.SendBuff(var buff; var len:integer);
//Sends a PCHAR
var
intt:integer;
dw: dword;
ss:TsockAddrIn;
begin
fillchar(ss,sizeof(ss),0);
ss.sin_family:=AF_INET;
ss.sin_port  :=Fhost.Port;
ss.sin_addr.S_addr:=Fhost.IP_addr;
dw:=sizeof(ss);
intt:= sendto(Fsockethandle,buff,len,0,ss,dw);
if intt < 0 then HandleLastException else len:=intt;
end;

function TudpSocket.ReadBuff(var buff; var len:integer):Thostabout;
//Receives a PCHAR, and say from who
var TT : thostabout;
intt:integer;
ss:TsockAddrIn;
dw:dword;
begin
fillchar(ss,sizeof(ss),0);
ss.sin_family:=AF_INET;
ss.sin_port:=Fport;
dw:=sizeof(ss);
fillchar(TT,sizeof(TT),0);
intt:=  recvfrom(FsocketHandle,buff,len-1,0,ss,dw);
if intt < 0 then begin
  HandleLastException;
  TT.location:='error receiving';
end else begin
len:=intt;
TT.location:=IpToDotDot(ss.sin_addr.S_addr);
TT.port:=ss.sin_port;
PDNSlookup(tt);
end;
result:=tt;
end;


procedure Tudpsocket.SendString(s:string);
//Send a string. Whats the use ??
var
bf:array[0..STR_LENGTH] of char;
i,len:integer;
ss:string;
begin
ss:=s;
fillchar(bf,STR_LENGTH,0);
len:=length(ss);
if len > (STR_LENGTH - 1) then len:=(STR_LENGTH - 1);
for i:=1 to (len) do bf[i-1]:=ss[i];
SendBuff(bf,len);
end;

function  Tudpsocket.ReadString(var s:string): Thostabout;
//Receive a string. !! Delphi strings are 0- terminated also, so if
//there is a 0x00 char in your packet, u only receive a part.
//use readbuff instead.
var
bf:array[0..STR_LENGTH] of char;
tstring:string;
i,len:integer;
HA:Thostabout;
begin
len:=STR_LENGTH;
HA:=ReadBuff(bf,len);
for i:=1 to len do tstring:=tstring+bf[i-1];
s:=tstring;
result:=HA;
end;



// ---------------------------------------------------------------------
// The MISC stuff
// ---------------------------------------------------------------------


function TudpSocket.IPtoDotDot(ip:Dword):string;
//Yeh, translates  3232235521 to 192.168.0.1
type
P_rec = ^T_rec;
T_rec = packed record
  b1 : byte;
  b2 : byte;
  b3 : byte;
  b4 : byte;
end;
var
p:P_rec;
i:dword;
s:string;
begin
i:=ip;
p:=@i;
s:= inttostr(p^.b1)+'.'+inttostr(p^.b2)+'.'+inttostr(p^.b3)+'.'+inttostr(p^.b4);
result:=s;
end;



// ---------------------------------------------------------------------
// The exception stuff
// ---------------------------------------------------------------------


procedure TudpSocket.HandleLastException;
// handle the last exception occured in winsock.dll
var n:integer;
begin
n:=WSAgetLastError;
MakeException(n,'');
end;

Procedure TudpSocket.MakeException(num:integer;str:string);
// call the OnError event handler.
// Num = a valid winsock error code number
// STR = a string, when the error is non-winsock.
// if the string is not empty, the string is used instead of the code.
// if the string begins with a '+', both are used.
var s:string;
begin
if str = '' then s := ErrToString(num) else
if pos('+',str) <> 1 then s:=str else begin
s:=' ('+copy(str,2,length(str))+').';
s:=ErrToString(num) + s;
end;
if assigned(FerrorProc) then Ferrorproc(s,num) else begin
Showmessage('Ugh I got an Error, and you don''t write error handlers'+#13#10+
            'Shame on you !!!!. Take a look at it :' + #13#10 +
            s + ' (error number : 0x'+inttohex(num,6)+').'+#13#10+
            'Assign an OnError event handler !!!'
            );
// That should be clear.
end;
end;


function  Tudpsocket.ErrToString(err:integer):string;
// Thanks to Gary T. Desrosiers , this procedure translates error codes
// into readable strings.
begin
 case err of
    WSAEINTR:
      result := 'Interrupted system call';
    WSAEBADF:
      result := 'Bad file number';
    WSAEACCES:
      result := 'Permission denied';
    WSAEFAULT:
      result := 'Bad address';
    WSAEINVAL:
      result := 'Invalid argument';
    WSAEMFILE:
      result := 'Too many open files';
    WSAEWOULDBLOCK:
      result := 'Operation would block';
    WSAEINPROGRESS:
      result := 'Operation now in progress';
    WSAEALREADY:
      result := 'Operation already in progress';
    WSAENOTSOCK:
      result := 'Socket operation on non-socket';
    WSAEDESTADDRREQ:
      result := 'Destination address required';
    WSAEMSGSIZE:
      result := 'Message too long';
    WSAEPROTOTYPE:
      result := 'Protocol wrong type for socket';
    WSAENOPROTOOPT:
      result := 'Protocol not available';
    WSAEPROTONOSUPPORT:
      result := 'Protocol not supported';
    WSAESOCKTNOSUPPORT:
      result := 'Socket type not supported';
    WSAEOPNOTSUPP:
      result := 'Operation not supported on socket';
    WSAEPFNOSUPPORT:
      result := 'Protocol family not supported';
    WSAEAFNOSUPPORT:
      result := 'Address family not supported by protocol family';
    WSAEADDRINUSE:
      result := 'Address already in use';
    WSAEADDRNOTAVAIL:
      result := 'Can''t assign requested address';
    WSAENETDOWN:
      result := 'Network is down';
    WSAENETUNREACH:
      result := 'Network is unreachable';
    WSAENETRESET:
      result := 'Network dropped connection on reset';
    WSAECONNABORTED:
      result := 'Software caused connection abort';
    WSAECONNRESET:
      result := 'Connection reset by peer';
    WSAENOBUFS:
      result := 'No buffer space available';
    WSAEISCONN:
      result := 'Socket is already connected';
    WSAENOTCONN:
      result := 'Socket is not connected';
    WSAESHUTDOWN:
      result := 'Can''t send after socket shutdown';
    WSAETOOMANYREFS:
      result := 'Too many references: can''t splice';
    WSAETIMEDOUT:
      result := 'Connection timed out';
    WSAECONNREFUSED:
      result := 'Connection refused';
    WSAELOOP:
      result := 'Too many levels of symbolic links';
    WSAENAMETOOLONG:
      result := 'File name too long';
    WSAEHOSTDOWN:
      result := 'Host is down';
    WSAEHOSTUNREACH:
      result := 'No route to host';
    WSAENOTEMPTY:
      result := 'Directory not empty';
    WSAEPROCLIM:
      result := 'Too many processes';
    WSAEUSERS:
      result := 'Too many users';
    WSAEDQUOT:
      result := 'Disc quota exceeded';
    WSAESTALE:
      result := 'Stale NFS file handle';
    WSAEREMOTE:
      result := 'Too many levels of remote in path';
    WSASYSNOTREADY:
      result := 'Network sub-system is unusable';
    WSAVERNOTSUPPORTED:
      result := 'WinSock DLL cannot support this application';
    WSANOTINITIALISED:
      result := 'WinSock not initialized';
    WSAHOST_NOT_FOUND:
      result := 'Host not found';
    WSATRY_AGAIN:
      result := 'Non-authoritative host not found';
    WSANO_RECOVERY:
      result := 'Non-recoverable error';
    WSANO_DATA:
      result := 'No Data';
    else result := 'Not a WinSock error';
  end;
end;




procedure Register;
begin
  RegisterComponents('TCP/IP', [TudpSocket]);
end;

end.