udpsocket.pas

针对 UDP 通讯协议的 Socket 构件

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. [e-mail].
            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 [e-mail]
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 ?? [e-mail] !
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 !