我也看过一个UDP的控件,我自己调老不对，我也没办法了。各位帮忙看看这个有何不妥,谢谢.
原程序来自 http://www.vclxx.org/DELPHI/D32FREE/UDPSOCKET.ZIP
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
word):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
ProtoEnt;
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
hostent;
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
;
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(ipword):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_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.
