NMUDP 在 DELPHI 有问题吗？

我有一个解决了问题的控件代码
要的话写信来:[email protected]
记得给分哦~~~
各位，能否将如何更改这个 BUG 写出来吗？
源代码
作者是电子日记本作者郝新庚
{**********************************************************}
{                                                          }
{  TDDUdp Component Version 1.00                           }
{                                                          }
{  Author: DayDream Studio                                 }
{  (Modified UDPSocket Component)                          }
{  Email: [email protected]                                    }
{  URL: http://haoxg.yeah.net                              }
{                                                          }
{**********************************************************}unit DDUdp;interfaceuses
  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;//---------------------------------------------------------------------  TDDUdp = class(TComponent)
  private
    //Handles
    FSocketHandle: THandle;
    FWinHandle: THandle;
    // Winsock info
    FSession: TWSAdata;
    // Port to bind on
    FPort: Integer;
    // Event handlers
    FErrorProc: TErrorProc;
    FOnDataReceive: TEventProc;
    FOnDataSend: TEventProc;
    FOnReady: TEventProc;
    FOnClose: TEventProc;
    // Host to send to
    FRemoteHost: THostAbout;
    // bound ???
    FBnd: Boolean;
    // Perform Reverse DNS ?
    FPerformReverseDns: Boolean;  protected
    // Property settings
    procedure SetRemoteHost(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
    constructor Create(Aowner: TComponent); override;
    destructor Destroy; override;    // highlevel winsock
    function DNSLookup(ALocation: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 FRemoteHost;
    // 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 OnDataReceive : TEventProc read FOnDataReceive write FOnDataReceive;
    property OnDataSend    : TEventProc read FOnDataSend write FOnDataSend;
    property OnReady       : TEventProc read FOnReady write FOnReady;
    property OnCloseSocket : TEventProc read FOnClose write FOnClose;
    // the properties
    property RemotePort: Integer read FRemoteHost.Port write FRemoteHost.Port;
    property LocalPort: Integer read FPort write FPort;
    // Location of host to send
    property RemoteHost: string read FRemoteHost.ip_DotDot write SetRemoteHost;
    // have i to perform reverse dns on each packet i receive ??
    property ReverseDNS: Boolean read FPerformReverseDns write FPerformReverseDns;
  end;procedure Register;implementationprocedure Register;
begin
  RegisterComponents('DayDream', [TDDUdp]);
end;constructor TDDUdp.Create(Aowner:TComponent);
begin
  inherited Create(Aowner);
  FPort :=0;
  FBnd :=false;
  FPerformReverseDns:=false;
  FWinHandle := allocateHWND(WinsockEvent);
  PStartWSA;
end;destructor TDDUdp.Destroy;
begin
  if FBnd then UDP_Unbind;
  DeallocateHWnd(FWinHandle);
  PStopWSA;
  inherited Destroy;
end;procedure TDDUdp.WinsockEvent(var Msg:TMessage);
begin
if Msg.Msg = WM_SOCKET then begin
  try
    Dispatch(Msg);
  except
    Application.HandleException(Self);
  end;
end else
    Msg.Result := DefWindowProc(FWinHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;procedure TDDUdp._WM_SOCKET(var Msg:TSockMessage);
begin
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(FOnDataReceive) then FOnDataReceive(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;// Start winsock
procedure TDDUdp.PStartWSA;
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;// Stop winsock
procedure TDDUdp.PStopWSA;
var ErrNum: Integer;
begin
  ErrNum := WSACleanup;
  if ErrNum <> 0 then MakeException(wsagetlasterror,'+Hmm, Winsock doesnot want to stop.');
end;// Closes the socket and release the Port
procedure TDDUdp.UDP_Unbind;
begin
  if CloseSocket(FSocketHandle) <> 0 then HandleLastException;
  FBnd := false;
end;// The same, but this one is called by the user
procedure TDDUdp.S_Close;
begin
  UDP_Unbind;
end;
// Opens a socket, and bind to Port.
procedure TDDUdp.UDP_Bind;
var
  protoent: PProtoEnt;
  sain: TSockAddrIn;
begin
  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;// The same, but this one is called by the user
procedure TDDUdp.S_Open;
begin
  UDP_Bind;
end;// Say where to send UDP data. perform a lookup if needed
// this is for property Location
procedure TDDUdp.SetRemoteHost(s: string);
begin
  FRemoteHost.Location:=s;
  PDNSlookup(FRemoteHost);
end;// The core of the DNS part, this asks windows to give as much
// information as possible about the given Location.
procedure TDDUdp.PDNSlookup(var HostAbout:THostAbout);
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 = u_long(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;//A function for the user, does the same
function TDDUdp.DNSLookup(ALocation:string): THostAbout;
var
  tt:THostAbout;
begin
  FillChar(tt,sizeof(tt),0);
  tt.Location:=ALocation;
  PDNSlookup(tt);
  Result:=tt;
end;//Sends a PCHAR
procedure TDDUdp.SendBuff(var Buff; var Len: Integer);
var
  intt: Integer;
  dw: DWORD;
  ss:TSockAddrIn;
begin
  FillChar(ss,sizeof(ss),0);
  ss.sin_family:=AF_INET;
  ss.sin_port  :=FRemoteHost.Port;
  ss.sin_addr.S_addr:=FRemoteHost.IP_addr;
  dw:=sizeof(ss);
  intt:= sendto(FSocketHandle,Buff,Len,0,ss,dw);
  if intt < 0 then
    HandleLastException
  else begin
    Len:=intt;
    if Assigned(FOnDataSend) then FOnDataSend(Self);
  end;
end;//Receives a PCHAR, and say from who
function TDDUdp.ReadBuff(var Buff; var Len: Integer):THostAbout;
var
  TT : THostAbout;
  intt: Integer;
  ss:TSockAddrIn;
  dw: Integer;
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;//Send a string. Whats the use ??
procedure TDDUdp.SendString(s:string);
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;//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.
function  TDDUdp.ReadString(var s:string): THostAbout;
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
// ---------------------------------------------------------------------//Yeh, translates  3232235521 to 192.168.0.1
function TDDUdp.IPtoDotDot(ip:DWORD):string;
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
// ---------------------------------------------------------------------// handle the last exception occured in winsock.dll
procedure TDDUdp.HandleLastException;
var
  n: Integer;
begin
  n:=WSAgetLastError;
  MakeException(n,'');
end;// 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.
Procedure TDDUdp.MakeException(Num: Integer;Str:string);
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 !!!'
                );
  end;
end;function  TDDUdp.ErrToString(Err: Integer):string;
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;end.

调试易

NMUDP 在 DELPHI 有问题吗？

解决方案 »