www.pudn.com > UDPSOCKET.zip > UDPsocket.pas, change:1998-07-09,size:22900b


unit udpSocket; 
(* 
Similar to Tsockets, but uses UDP instead of 
TCP. I stole 1 procedure from the Tsockets 
component of Garry T Derosiers (available 
freeware everywhere on the net) 
The procedure is SocketErrorDesc , and gives 
a description of a winsock error, so u won't 
see 'socket error 0x004' anymore, but a nice 
description. 
 
Author    : Frank Dekervel 
            Belgium. kervel@hotmail.com. 
            http://kervel.home.ml.org 
 
Version   : 0.90 
 
Copyright : 1998 , GPL 
 
DELPHI    : compiles on D3 , needs winsock 
            unit (a converted .h file) 
            if u make update, plz contact me 
*) 
// --------------------------------------------------------------------- 
{ 
Description : 
 
* Properties 
------------ 
 
 (RO = readonly, DT = designtime) 
 NAME          RO DT   DESC 
 Sockethandle   X      Returns the socket handle used by TUDPsocket. 
 Winhandle      X      Returns the windows handle used by " ". 
                       CAUTION : do not use closehandle or closesocket 
                       on one of those properties. 
 IsBound        X      True when the socket is bound and 'listening' 
 RemoteHostInfo X      Gives u info about the host that is set up 
                       for sending packets. 
 SendPort          X   The port of the machine u send packets to 
 Location          X   The location (hostname/ip) of the machine u send packets to 
                       YOU DON'T HAVE TO REBIND WHEN YOU CHANGE THESE 2 
 port              X   The port the local machine is bound to. If you don't 
                       need a fixed port, use 0. 
 reverseDNS        X   do a reverse DNS for each IP address given. ONLY 
                       ENABLE THIS IF YOU REALLY NEED IT. IT IS SUPER- 
                       SLOW ! (if you need it one time, e.g u're writing 
                       a winnuke-protector using a Tsockets component, 
                       and u want to know the hostname of ur aggressor, 
                       set to true, call DNSlookup and set to false ) 
* Events 
-------- 
 
  Create               constructor 
  Destroy              destructor 
  DNSlookup            looks up the given hostname, or if it is an IP 
                       address, and reverseDNS is enabled, you'll get 
                       a hostname. 
  S_open               Opens a socket, and bind it to the port in the 
                       PORT propterty. 
  S_close              Closes the socket and releases the port. 
 
  OnError              Occurs when winsock detects an error, or when a 
                       winsock operation fails. it is recommended that 
                       you specify one, because errors are verry current, 
                       and it is important to take care of them. 
  OnReceive            Occurs when data arrives at your bound socket. 
                       In the handler, it is safe to call ReadBuf 
                       or ReadString. 
  OnWriteReady         Dunno if it works on UDP. occurs when buffers are 
                       sent, and you can send new data. If you get a 
                       'operation would block' error while sending, you'll 
                       have to wait until this event occurs before trying again. 
  OnClose              Occurs when the socket is closed. Useless. 
 
* Methods 
--------- 
 
  SendBuff             Sends a buffer to the machine in the location propterty, 
                       and the port in the SendPort property 
  ReadBuff             Fills a pchar (memory allocated or variabele/array 
                       declared by you) with received data. The second 
                       argument (len) lets you specify a maximum length, 
                       but check the len variable again after reading, 
                       now it contains the number of bytes received. 
                       ReadBuff returns also information about the host 
                       the packet was received from. If ReverseDNS is 
                       specified, you also ll get a hostname. 
  SendString           The same as sendbuff, but now with a pascal string. 
  ReadString                       readbuff 
 
* Types 
------- 
  TudpSocket           The actual UDP socket 
  Terrorproc           procedure type for error handlers 
  Teventproc           same as TnotifyEvent 
  ThostAbout           record that contains host information, such 
                       as IP address or DNS name or both. can also 
                       contain a port. 
  TSockMessage         Winsock Asynchronous mode Windows Message type 
 
MAIL IMPROVEMENTS TO kervel@hotmail.com 
I AM NOT RESPONSIBLE FOR ANY DAMAGE CAUSED BY THIS COMPONENT 
This component may only be used in non-commercial applications. 
For commercial use, mail me. 
Copyright Frank Dekervel 1998 
 
} 
 
// --------------------------------------------------------------------- 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,winsock; 
const 
// --------------------------------------------------------------------- 
 WM_SOCKET=WM_USER+323; 
 WSA_VERSION_REQUIRED= $101; // Winsock version 1.01 for UDP protocol 
 STR_LENGTH = 512;           // maximum string length for strings to send. 
// --------------------------------------------------------------------- 
 
type 
  TerrorProc = procedure(msg:string;num:integer) of object; 
  TeventProc = procedure(sender:Tobject) of object; 
  ThostAbout = record 
    IP_addr : dword; 
    DNS_name : string; 
    IP_dotdot : string; 
    location : string; 
    Port : integer; // port, used for sending | receiving 
  end; 
  TSockMessage = record 
    Msg: Cardinal; 
    SockID: Thandle; 
    SelectEvent: Word; 
    SelectError: Word; 
    Result: Longint; 
  end; 
// --------------------------------------------------------------------- 
// --------------------------------------------------------------------- 
  TudpSocket = class(Tcomponent) 
  private 
    //Handles 
    Fsockethandle:Thandle; 
    FwinHandle:Thandle; 
    // Winsock info 
    Fsession:TWSAdata; 
    // Port to bind on 
    Fport : dword; 
    // Event handlers 
    FerrorProc:Terrorproc; 
    FonReceive:Teventproc; 
    FonReady  :Teventproc; 
    FonClose  :Teventproc; 
    // Host to send to 
    FHost : ThostAbout; 
    // bound ??? 
    Fbnd : boolean; 
    // Perform Reverse DNS ? 
    FperformReverseDns : boolean; 
 
  protected 
 
    // Property settings 
    procedure SetLocation(s:string); 
 
    // Error stuff. 
    procedure HandleLastException; 
    function  ErrToString(err:integer):string; 
    Procedure MakeException(num:integer;str:string); 
 
    // Winsock stuff 
    procedure PStartWSA; 
    procedure PStopWSA; 
 
    procedure PDNSlookup(var hostabout:Thostabout); 
    procedure UDP_Bind; 
    procedure UDP_Unbind; 
 
 
    // Event handler stuff 
    procedure _WM_SOCKET(var msg:TsockMessage); message WM_SOCKET; 
    procedure WinsockEvent(var msg:TMessage); 
 
    // Misc functions 
    function IPtoDotDot(ip:Dword):string; 
 
  public 
 
    // the constructor\destructor 
    constructor create(Aowner:Tcomponent); override; 
    destructor destroy; override; 
 
    // highlevel winsock 
    function DNSlookup(a_location:string):Thostabout; 
    procedure S_Open; 
    procedure S_Close; 
    procedure SendBuff(var buff; var len:integer); 
    function  ReadBuff(var buff; var len:integer):ThostAbout; 
    // Super - highlevel winsock 
    procedure SendString(s:string); 
    function  ReadString(var s:string): Thostabout; 
    // Informative READ-ONLY properties 
    Property SocketHandle:Thandle read Fsockethandle; 
    Property WinHandle:Thandle read Fwinhandle; 
    Property IsBound:boolean read Fbnd; 
    Property RemoteHostInfo : Thostabout read Fhost; 
    // you may look at these , but don't touch them !! (no close etc...) 
 
  published 
    // The event handlers 
    property OnError       : Terrorproc Read Ferrorproc write Ferrorproc; 
    property OnReceive     : Teventproc Read FonReceive write FonReceive; 
    property OnWriteReady  : TeventProc Read FonReady write FonReady; 
    property OnCloseSocket : TeventProc Read FonClose write FonClose; 
    // the properties 
    property sendport : integer read Fhost.port write Fhost.port; 
    property Port : integer read Fport write Fport; 
    // Location of host to send 
    property Location : string read Fhost.ip_DotDot write setLocation; 
    // have i to perform reverse dns on each packet i receive ?? 
    property ReverseDNS : boolean read FperformReverseDns write FperformReverseDns; 
  end; 
 
procedure Register; 
 
implementation 
// --------------------------------------------------------------------- 
// The Constructor and the Destructor 
// --------------------------------------------------------------------- 
 
constructor TudpSocket.create(Aowner:Tcomponent); 
// indeed, the constructor 
begin 
inherited create(Aowner); 
    Fport:=0; 
    Fbnd :=false; 
    FperformReverseDns:=false; 
FwinHandle := allocateHWND(WinsockEvent); 
PStartWSA; 
end; 
 
destructor Tudpsocket.Destroy; 
// guess... 
begin 
if Fbnd then UDP_unbind; 
closehandle(FwinHandle); 
PStopWSA; 
inherited destroy; 
end; 
 
// --------------------------------------------------------------------- 
// The WSA startup , cleanup and the event handlers 
// --------------------------------------------------------------------- 
 
procedure Tudpsocket.WinsockEvent(var msg:TMessage); 
// Dispatch windows messages to specific event handlers 
begin 
if msg.Msg = WM_SOCKET then begin 
// if we parse each message, the destructor 
// will be called by the form, but also a 
// WM_CLOSE event will be sent to this component. 
// when the form ll call the destructor, the 
// object ll already be destroyed, resulting 
// in ... an axxess violation. Are there 
// better ways to do this ?? kervel@hotmail.com ! 
try 
dispatch(msg); 
except 
application.HandleException(self); 
end; 
end; 
end; 
 
procedure TudpSocket._WM_SOCKET(var msg:TsockMessage); 
// Specific event handler for WM_SOCKET 
begin 
 
// this should never happen in UDP, but to 
// be complete , the handlers are ther. 
 
if msg.SelectError <> 0 then begin 
    case msg.SelectEvent of 
       FD_CONNECT :MakeException(wsagetlasterror,'+Error while connecting.'); 
       FD_CLOSE   :MakeException(wsagetlasterror,'+Error while disconnecting.'); 
       FD_READ    :MakeException(wsagetlasterror,'+Error while receiving.'); 
       FD_WRITE   :MakeException(wsagetlasterror,'+Error while sending.'); 
       FD_ACCEPT  :MakeException(wsagetlasterror,'+Error while accepting incoming connection.'); 
       FD_OOB     :MakeException(wsagetlasterror,'+Error OOB.'); 
    else 
       MakeException(wsagetlasterror,'+Undefined error.'); 
    end; 
 
// no error, just an event 
 
end else begin 
    case msg.selectevent of 
         FD_READ   :    if Assigned(FonReceive) then Fonreceive(self) ; 
         FD_WRITE  :    if Assigned(FonReady)   then FonReady(self)   ; 
         FD_CLOSE  :    if Assigned(FonClose)   then FonClose(self)   ; 
         //FD_ACCEPT :    if Assigned() then ; //          "" 
         //FD_CONNECT:    if assigned() then ; // this is TCP 
         //FD_OOB    :    if assigned() then ; //          "" 
    end; 
end; 
end; 
 
procedure TudpSocket.PStartWSA; 
// Start winsock 
var errNum:integer; 
begin 
errNum := WSAstartup(WSA_VERSION_REQUIRED,Fsession); 
if errNum <> 0 then MakeException(wsagetlasterror,'+Ooppz No Winsock, this app ll be boring without it.'); 
end; 
 
procedure Tudpsocket.PStopWSA; 
// Stop winsock 
var errNum:integer; 
begin 
errNum := WSAcleanup; 
if errNum <> 0 then MakeException(wsagetlasterror,'+Hmm, Winsock doesnot want to stop.'); 
end; 
// --------------------------------------------------------------------- 
// The BIND - UNBIND stuff 
// --------------------------------------------------------------------- 
 
procedure TudpSocket.UDP_unBind; 
// Closes the socket and release the port 
begin 
if closesocket(Fsockethandle) <> 0 then HandleLastException; 
Fbnd := false; 
end; 
 
procedure Tudpsocket.S_Close; 
// The same, but this one is called by the user 
begin 
UDP_unbind; 
end; 
 
 
procedure TudpSocket.UDP_Bind; 
// Opens a socket, and bind to port. 
var 
protoent:PProtoEnt; 
sain:TsockAddrIn; 
begin 
// learn about the UDP protocol 
if Fbnd then UDP_unbind; 
protoent :=getprotobyname('udp'); 
// initialise 
sain.sin_family      := AF_INET; 
sain.sin_port        := Fport; 
sain.sin_addr.S_addr := 0; 
// create a nice socket 
FsocketHandle:=socket( PF_INET , SOCK_DGRAM, protoent^.p_proto ); 
if FsocketHandle < 0 then HandleLastException else begin 
  // socket created ! 
  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.