// (c) 1g0r  ' 2002
// mailto://1g0r@ukr.net

unit UDP;

interface

uses
  Windows, Messages, Classes, Forms, Winsock, SyncObjs;

const
  CM_SOCKETMESSAGE = WM_USER + $100;

type
  TOnDataReceived = procedure(Sender: TComponent; const Data: String; FromIP: string; Port: integer) of object;
  TOnError = procedure(Sender: TComponent; const ErrCode: Integer) of object;

  TCMSocketMessage = record
    Msg: Cardinal;
    Socket: TSocket;
    SelectEvent: Word;
    SelectError: Word;
    Result: Longint;
  end;

  TSockOptions = class;

  TUDP = class(TComponent)
  private
    FActive: Boolean;
    FLocalPort: Word;
    FRemotePort: Word;
    FRemoteHost: String;
    FHandle: TSocket;
    FWinHandle: THandle;
    FSession: TWSAData;
    FSocketLock: TCriticalSection;
    FOptions: TSockOptions;
    FOnDataReceived: TOnDataReceived;
    FOnReady: TNotifyEvent;
    FOnClose: TNotifyEvent;
    FOnError: TOnError;
  protected
    procedure WMSocket(var Message: TCMSocketMessage); message CM_SOCKETMESSAGE;
    procedure WinsockEvent(var Message: TMessage);
    procedure SetActive(Value: Boolean);
    procedure DoError;
  public
    procedure Lock;
    procedure UnLock;
    function SendBuf(var Buf; Count: Integer): Integer;
    function SendText(const S: string): Integer;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Activate;
    procedure Deactivate;
    property Active: Boolean read FActive write SetActive;
    property Handle: TSocket read FHandle;
    property Options: TSockOptions read FOptions write FOptions;
  published
    property LocalPort: Word read FLocalPort write FLocalPort;
    property RemotePort: Word read FRemotePort write FRemotePort;
// RemoteHost вида 'a.b.c.d' only !!!
    property RemoteHost: String read FRemoteHost write FRemoteHost;
    property OnDataReceived: TOnDataReceived read FOnDataReceived write FOnDataReceived;
    property OnReady: TNotifyEvent read FOnReady write FOnReady;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnError: TOnError read FOnError write FOnError;
  end;

  TSockOptions = class(TPersistent)
  private
    function GetHandle: TSocket;
    function GetBroadcast: LongBool;
    procedure SetBroadcast(Value: LongBool);
    function GetRoute: LongBool;
    procedure SetRoute(Value: LongBool);
    function GetSendBufSize: Integer;
    procedure SetSendBufSize(Value: Integer);
    function GetRecvBufSize: Integer;
    procedure SetRecvBufSize(Value: Integer);
  public
    Owner: TComponent;
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy; override;
    property Handle: TSocket read GetHandle;
  published
// Флаг для отправки широковещательных сообщений
// при отправке сообщений установите RemoteHost := '255.255.255.255'
    property Broadcast: LongBool read GetBroadcast write SetBroadcast;
// Флаг маршрутизации   TRUE - разрешена
    property Route: LongBool read GetRoute write SetRoute;
// Размер буфера для отправки
    property SendBufSize: Integer read GetSendBufSize write SetSendBufSize;
// Размер буфера для приема
    property RecvBufSize: Integer read GetRecvBufSize write SetRecvBufSize;
  end;

procedure Register;

implementation

constructor TSockOptions.Create(AOwner: TComponent);
begin
  Owner := AOwner
end;

destructor TSockOptions.Destroy;
begin
  inherited
end;

function TSockOptions.GetHandle: TSocket;
begin
  if Assigned(Owner)
    then Result := TUDP(Owner).Handle
    else Result := INVALID_SOCKET
end;

function TSockOptions.GetBroadcast: LongBool;
var optlen: Integer;
begin
  optlen := SizeOf(Result);
  if Handle <> INVALID_SOCKET
    then getsockopt(Handle, SOL_SOCKET, SO_BROADCAST, PChar(@Result), optlen)
    else Result := False
end;

procedure TSockOptions.SetBroadcast(Value: LongBool);
begin
  if Handle <> INVALID_SOCKET then setsockopt(Handle, SOL_SOCKET, SO_BROADCAST, PChar(@Value), Sizeof(Value))
end;

function TSockOptions.GetRoute: LongBool;
var optlen: Integer;
begin
  optlen := SizeOf(Result);
  if Handle <> INVALID_SOCKET
    then begin
      getsockopt(Handle, SOL_SOCKET, SO_DONTROUTE, PChar(@Result), optlen);
      Result := not Result
    end
    else Result := True
end;

procedure TSockOptions.SetRoute(Value: LongBool);
begin
  Value := not Value;
  if Handle <> INVALID_SOCKET then setsockopt(Handle, SOL_SOCKET, SO_DONTROUTE, PChar(@Value), Sizeof(Value))
end;

function TSockOptions.GetSendBufSize: Integer;
var optlen: Integer;
begin
  optlen := SizeOf(Result);
  if Handle <> INVALID_SOCKET
    then getsockopt(Handle, SOL_SOCKET, SO_SNDBUF, PChar(@Result), optlen)
    else Result := -1
end;

procedure TSockOptions.SetSendBufSize(Value: Integer);
begin
  if Handle <> INVALID_SOCKET then setsockopt(Handle, SOL_SOCKET, SO_SNDBUF, PChar(@Value), Sizeof(Value))
end;

function TSockOptions.GetRecvBufSize: Integer;
var optlen: Integer;
begin
  optlen := SizeOf(Result);
  if Handle <> INVALID_SOCKET
    then getsockopt(Handle, SOL_SOCKET, SO_RCVBUF, PChar(@Result), optlen)
    else Result := -1
end;

procedure TSockOptions.SetRecvBufSize(Value: Integer);
begin
  if Handle <> INVALID_SOCKET then setsockopt(Handle, SOL_SOCKET, SO_RCVBUF, PChar(@Value), Sizeof(Value))
end;

constructor TUDP.Create(AOwner: TComponent);
begin
  inherited;
  FWinHandle := AllocateHWnd(WinsockEvent);
  FSocketLock := TCriticalSection.Create;
  FOptions := TSockOptions.Create(Self);
  FHandle := INVALID_SOCKET;
  FLocalPort := 0;
  FRemotePort := 0;
  FRemoteHost := '127.0.0.1'
end;

destructor TUDP.Destroy;
begin
  if FActive then Deactivate;
  FOptions.Free;
  FSocketLock.Free;
  DeallocateHWnd(FWinHandle);
  inherited
end;

procedure TUDP.WMSocket(var Message: TCMSocketMessage);
var
  From: sockaddr_in;
  Length, FromLen: Integer;
  Buf: String;
begin
  if Message.SelectError <> 0
    then DoError
    else case Message.SelectEvent of
      FD_READ:
        begin
          Lock;
          FromLen := SizeOf(From);
          ZeroMemory(@From, FromLen);
          if ioctlsocket(FHandle, FIONREAD, Length) = 0
            then begin
              SetLength(Buf, Length);
              Length := recvfrom(FHandle, Buf[1], Length, 0, From, FromLen);
              if Length >= 0
                then begin
                  SetLength(Buf, Length);
                  if Assigned(FOnDataReceived) then FOnDataReceived(Self, Buf, inet_ntoa(From.sin_addr), ntohs(From.sin_port))
                end
                else DoError
            end
            else DoError;
            UnLock
        end;
      FD_WRITE:
        begin
          FActive := True;
          if Assigned(FOnReady) then FOnReady(Self);
        end;
      FD_CLOSE:
        begin
          FActive := False;
          if Assigned(FOnClose) then FOnClose(Self)
        end;
    end;
end;

procedure TUDP.WinsockEvent(var Message: TMessage);
begin
  case Message.Msg of
  CM_SOCKETMESSAGE:
    try
      Dispatch(Message)
    except
      Application.HandleException(Self)
    end;
  WM_QUERYENDSESSION:
    begin
      Deactivate;
      Message.Result := 1
    end
  end
end;

procedure TUDP.Lock;
begin
  FSocketLock.Enter
end;

procedure TUDP.UnLock;
begin
  FSocketLock.Leave
end;

function TUDP.SendBuf(var Buf; Count: Integer): Integer;
var
  AddrTo: sockaddr_in;
  ToLen: Integer;
begin
  if FActive
    then begin
      Lock;
      ToLen := SizeOf(AddrTo);
      ZeroMemory(@AddrTo, ToLen);
      AddrTo.sin_family := AF_INET;
      AddrTo.sin_port := htons(FRemotePort);
      AddrTo.sin_addr.S_addr := inet_addr(PChar(FRemoteHost));
      Result := sendto(FHandle, Buf, Count, 0, AddrTo, ToLen);
      if Result = SOCKET_ERROR then DoError;
      UnLock
    end else Result := 0
end;

function TUDP.SendText(const S: string): Integer;
begin
  Result := SendBuf(Pointer(S)^, Length(S))
end;

procedure TUDP.Activate;
var
  Addr: sockaddr_in;
begin
  if FActive then Deactivate;
  if WSAStartup($0202, FSession) <> 0 then DoError;
  ZeroMemory(@Addr, SizeOf(Addr));
  Addr.sin_family := AF_INET;
  Addr.sin_port := htons(FLocalPort);
  FHandle := socket(PF_INET, SOCK_DGRAM, IPPROTO_UDP);
  if FHandle <> INVALID_SOCKET
    then if Winsock.bind(FHandle, Addr, SizeOf(Addr)) = 0
      then if WSAAsyncSelect(FHandle, FWinHandle, CM_SOCKETMESSAGE, FD_READ or FD_WRITE or FD_CLOSE) = 0
        then Exit
        else Deactivate
      else Deactivate
    else Deactivate;
  DoError
end;

procedure TUDP.Deactivate;
begin
  closesocket(FHandle);
  FHandle := INVALID_SOCKET;
  WSACleanup;
  FActive := False
end;

procedure TUDP.SetActive(Value: Boolean);
begin
  if Value then Activate else Deactivate
end;

procedure TUDP.DoError;
var ErrCode: Integer;
begin
  if Assigned(FOnError)
    then begin
      ErrCode := WSAGetLastError;
      if ErrCode <> 0 then FOnError(Self, ErrCode)
    end
end;

procedure Register;
begin
  RegisterComponents('Internet', [TUDP]);
end;

end.


{ Перечень ошибок:

  WSABASEERR              = 10000;
  WSAEINTR                = (WSABASEERR+4)      Interrupted system call
  WSAEBADF                = (WSABASEERR+9)      Bad file number
  WSAEACCES               = (WSABASEERR+13)     Permission denied
  WSAEFAULT               = (WSABASEERR+14)     Bad address
  WSAEINVAL               = (WSABASEERR+22)     Invalid argument
  WSAEMFILE               = (WSABASEERR+24)     Too many open files
  WSAEWOULDBLOCK          = (WSABASEERR+35)     Operation would block
  WSAEINPROGRESS          = (WSABASEERR+36)     Operation now in progress
  WSAEALREADY             = (WSABASEERR+37)     Operation already in progress
  WSAENOTSOCK             = (WSABASEERR+38)     Socket operation on non-socket
  WSAEDESTADDRREQ         = (WSABASEERR+39)     Destination address required
  WSAEMSGSIZE             = (WSABASEERR+40)     Message too long
  WSAEPROTOTYPE           = (WSABASEERR+41)     Protocol wrong type for socket
  WSAENOPROTOOPT          = (WSABASEERR+42)     Protocol not available
  WSAEPROTONOSUPPORT      = (WSABASEERR+43)     Protocol not supported
  WSAESOCKTNOSUPPORT      = (WSABASEERR+44)     Socket type not supported
  WSAEOPNOTSUPP           = (WSABASEERR+45)     Operation not supported on socket
  WSAEPFNOSUPPORT         = (WSABASEERR+46)     Protocol family not supported
  WSAEAFNOSUPPORT         = (WSABASEERR+47)     Address family not supported by protocol family
  WSAEADDRINUSE           = (WSABASEERR+48)     Address already in use
  WSAEADDRNOTAVAIL        = (WSABASEERR+49)     Can't assign requestes address
  WSAENETDOWN             = (WSABASEERR+50)     Network is down
  WSAENETUNREACH          = (WSABASEERR+51)     Network is unrechable
  WSAENETRESET            = (WSABASEERR+52)     Network dropped connection on reset
  WSAECONNABORTED         = (WSABASEERR+53)     Software caused connection abort
  WSAECONNRESET           = (WSABASEERR+54)     Connection reset by peer
  WSAENOBUFS              = (WSABASEERR+55)     No buffer space available
  WSAEISCONN              = (WSABASEERR+56)     Socket is already connected
  WSAENOTCONN             = (WSABASEERR+57)     Socket is not connected
  WSAESHUTDOWN            = (WSABASEERR+58)     Can't send aftersocket shutdown
  WSAETOOMANYREFS         = (WSABASEERR+59)     Too many references: can't splice
  WSAETIMEDOUT            = (WSABASEERR+60)     Connection timed out
  WSAECONNREFUSED         = (WSABASEERR+61)     Connection refused
  WSAELOOP                = (WSABASEERR+62)     Too many levels of symbolic links
  WSAENAMETOOLONG         = (WSABASEERR+63)     File name too long
  WSAEHOSTDOWN            = (WSABASEERR+64)     Host is down
  WSAEHOSTUNREACH         = (WSABASEERR+65)     No route to host
  WSAENOTEMPTY            = (WSABASEERR+66)     Directory not empty
  WSAEPROCLIM             = (WSABASEERR+67)     Too many processes
  WSAEUSERS               = (WSABASEERR+68)     Too many users
  WSAEDQUOT               = (WSABASEERR+69)     Disc quota exceeded
  WSAESTALE               = (WSABASEERR+70)     Stale NFS file handle
  WSAEREMOTE              = (WSABASEERR+71)     Too many levels of remote in path
  WSASYSNOTREADY          = (WSABASEERR+91)     Network sub-system is unusable
  WSAVERNOTSUPPORTED      = (WSABASEERR+92)     Winsock DLL cannot support this application
  WSANOTINITIALISED       = (WSABASEERR+93)     Winsock not initialized
  WSAHOST_NOT_FOUND       = (WSABASEERR+1001)   Host not found
  WSATRY_AGAIN            = (WSABASEERR+1002)   Non-authoritative host not found
  WSANO_RECOVERY          = (WSABASEERR+1003)   Non-recoverable error
  WSANO_DATA              = (WSABASEERR+1004)   No Data }