psiwinsock.pas

一个delphi的p2p控件的源代码

  {$NODEFINE ETIMEDOUT          }
  ETIMEDOUT          =  WSAETIMEDOUT;
  {$NODEFINE ECONNREFUSED       }
  ECONNREFUSED       =  WSAECONNREFUSED;
  {$NODEFINE ELOOP              }
  ELOOP              =  WSAELOOP;
  {$NODEFINE ENAMETOOLONG       }
  ENAMETOOLONG       =  WSAENAMETOOLONG;
  {$NODEFINE EHOSTDOWN          }
  EHOSTDOWN          =  WSAEHOSTDOWN;
  {$NODEFINE EHOSTUNREACH       }
  EHOSTUNREACH       =  WSAEHOSTUNREACH;
  {$NODEFINE ENOTEMPTY          }
  ENOTEMPTY          =  WSAENOTEMPTY;
  {$NODEFINE EPROCLIM           }
  EPROCLIM           =  WSAEPROCLIM;
  {$NODEFINE EUSERS             }
  EUSERS             =  WSAEUSERS;
  {$NODEFINE EDQUOT             }
  EDQUOT             =  WSAEDQUOT;
  {$NODEFINE ESTALE             }
  ESTALE             =  WSAESTALE;
  {$NODEFINE EREMOTE            }
  EREMOTE            =  WSAEREMOTE;

{ Socket function prototypes }
type
  TAcceptProc = function (s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket; stdcall;
  TBindProc   = function (s: TSocket; var addr: TSockAddr; namelen: Integer): Integer; stdcall;
  TClosesocketProc = function (s: TSocket): Integer; stdcall;
  TConnectProc = function (s: TSocket; var name: TSockAddr; namelen: Integer): Integer; stdcall;
  TIoctlSocketProc = function (s: TSocket; cmd: DWORD; var arg: u_long): Integer; stdcall;
  TGetPeerNameProc = function (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer; stdcall;
  TGetSockNameProc = function (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer; stdcall;
  TGetSockOptProc  = function (s: TSocket; level, optname: Integer; optval: PChar; var optlen: Integer): Integer; stdcall;
  THtonlProc = function (hostlong: u_long): u_long; stdcall;
  THtonsProc = function (hostshort: u_short): u_short; stdcall;
  TInet_AddrProc = function (cp: PChar): u_long; stdcall; {PInAddr;}  { TInAddr }
  TInet_NtoaProc = function (inaddr: TInAddr): PChar; stdcall;
  TListenProc = function (s: TSocket; backlog: Integer): Integer; stdcall;
  TNtohlProc = function (netlong: u_long): u_long; stdcall;
  TNtohsProc = function (netshort: u_short): u_short; stdcall;
  TRecvProc = function (s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
  TRecvFromProc = function (s: TSocket; var Buf; len, flags: Integer;
    var from: TSockAddr; var fromlen: Integer): Integer; stdcall;
  TSelectProc = function (nfds: Integer; readfds, writefds, exceptfds: PFDSet;
    timeout: PTimeVal): Longint; stdcall;
  TSendProc = function (s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
  TSendToProc = function (s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;
    tolen: Integer): Integer; stdcall;
  TSetSockOptProc = function (s: TSocket; level, optname: Integer; optval: PChar;
    optlen: Integer): Integer; stdcall;
  TShutDownProc = function (s: TSocket; how: Integer): Integer; stdcall;
  TSocketProc = function (af, Struct, protocol: Integer): TSocket; stdcall;
  TGetHostByAddrProc = function (addr: Pointer; len, Struct: Integer): PHostEnt; stdcall;
  TGetHostByNameProc = function (name: PChar): PHostEnt; stdcall;
  TGetHostNameProc = function (name: PChar; len: Integer): Integer; stdcall;
  TGetServByPortProc = function (port: Integer; proto: PChar): PServEnt; stdcall;
  TGetServByNameProc = function (name, proto: PChar): PServEnt; stdcall;
  TgetProtoByNumberProc = function (proto: Integer): PProtoEnt; stdcall;
  TGetProtoByNameProc = function (name: PChar): PProtoEnt; stdcall;
  TWSAStartupProc = function (wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;
  TWSACleanupProc = function : Integer; stdcall;
  TWSASetLastErrorProc = procedure (iError: Integer); stdcall;
  TWSAGetLastErrorProc = function : Integer; stdcall;
  TWSAIsBlockingProc = function : BOOL; stdcall;
  TWSAUnhookBlockingHookProc = function : Integer; stdcall;
  TWSASetBlockingHookProc = function (lpBlockFunc: TFarProc): TFarProc; stdcall;
  TWSACancelBlockingCallProc = function : Integer; stdcall;
  TWSAAsyncGetServByNameProc = function (HWindow: HWND; wMsg: u_int;
    name, proto, buf: PChar; buflen: Integer): THandle; stdcall;
  TWSAAsyncGetServByPortProc = function ( HWindow: HWND; wMsg, port: u_int;
    proto, buf: PChar; buflen: Integer): THandle; stdcall;
  TWSAAsyncGetProtoByNameProc = function (HWindow: HWND; wMsg: u_int;
    name, buf: PChar; buflen: Integer): THandle; stdcall;
  TWSAAsyncGetProtoByNumberProc = function (HWindow: HWND; wMsg: u_int; number: Integer;
    buf: PChar; buflen: Integer): THandle; stdcall;
  TWSAAsyncGetHostByNameProc = function (HWindow: HWND; wMsg: u_int;
    name, buf: PChar; buflen: Integer): THandle; stdcall;
  TWSAAsyncGetHostByAddrProc = function (HWindow: HWND; wMsg: u_int; addr: PChar;
    len, Struct: Integer; buf: PChar; buflen: Integer): THandle; stdcall;
  TWSACancelAsyncRequestProc = function (hAsyncTaskHandle: THandle): Integer; stdcall;
  TWSAAsyncSelectProc = function (s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer; stdcall;
  TWSARecvExProc = function (s: TSocket; var buf; len: Integer; var flags: Integer): Integer; stdcall;
  T__WSAFDIsSetProc = function (s: TSocket; var FDSet: TFDSet): Bool; stdcall;
  TTransmitFileProc = function (hSocket: TSocket; hFile: THandle; nNumberOfBytesToWrite: DWORD;
    nNumberOfBytesPerSend: DWORD; lpOverlapped: POverlapped;
    lpTransmitBuffers: PTransmitFileBuffers; dwReserved: DWORD): BOOL; stdcall;
  TAcceptExProc = function (sListenSocket, sAcceptSocket: TSocket;
    lpOutputBuffer: Pointer; dwReceiveDataLength, dwLocalAddressLength,
    dwRemoteAddressLength: DWORD; var lpdwBytesReceived: DWORD;
    lpOverlapped: POverlapped): BOOL; stdcall;
  TGetAcceptExSockaddrsProc = procedure (lpOutputBuffer: Pointer;
    dwReceiveDataLength, dwLocalAddressLength, dwRemoteAddressLength: DWORD;
    var LocalSockaddr: TSockAddr; var LocalSockaddrLength: Integer;
    var RemoteSockaddr: TSockAddr; var RemoteSockaddrLength: Integer); stdcall;

const
  Accept : TAcceptProc = nil;
  Bind   : TBindProc = nil;
  CloseSocket : TCloseSocketProc = nil;
  Connect : TConnectProc = nil;
  IoctlSocket : TIoctlSocketProc = nil;
  GetPeerName : TGetPeerNameProc = nil;
  GetSockName : TGetSockNameProc = nil;
  GetSockOpt  : TGetSockOptProc = nil;
  Htonl : THtonlProc = nil;
  Htons : THtonsProc = nil;
  Inet_Addr : TInet_AddrProc = nil;
  Inet_Ntoa : TInet_NtoaProc = nil;
  Listen : TListenProc = nil;
  Ntohl : TNtohlProc = nil;
  Ntohs : TNtohsProc = nil;
  Recv  : TRecvProc = nil;
  RecvFrom : TRecvFromProc = nil;
  Select : TSelectProc = nil;
  Send : TSendProc = nil;
  SendTo : TSendToProc = nil;
  SetSockOpt : TSetSockOptProc = nil;
  ShutDown : TShutDownProc = nil;
  Socket : TSocketProc = nil;
  GetHostByAddr : TGetHostByAddrProc = nil;
  GetHostByName : TGetHostByNameProc = nil;
  GetHostName : TGetHostNameProc = nil;
  GetServByPort : TGetServByPortProc = nil;
  GetServByName : TGetServByNameProc = nil;
  GetProtoByNumber : TGetProtoByNumberProc = nil;
  GetProtoByname : TGetProtoByNameProc = nil;
  WSAStartup : TWSAStartupProc = nil;
  WSACleanup : TWSACleanupProc = nil;
  WSASetLastError : TWSASetLastErrorProc = nil;
  WSAGetLastError : TWSAGetLastErrorProc = nil;
  WSAIsBlocking : TWSAIsBlockingProc = nil;
  WSAUnhookBlockingHook : TWSAUnhookBlockingHookProc = nil;
  WSASetBlockingHook : TWSASetBlockingHookProc = nil;
  WSACancelBlockingCall : TWSACancelBlockingCallProc = nil;
  WSAAsyncGetServByName : TWSAAsyncGetServByNameProc = nil;
  WSAAsyncGetServByPort : TWSAAsyncGetServByPortProc = nil;
  WSAAsyncGetProtoByName : TWSAAsyncGetProtoByNameProc = nil;
  WSAAsyncGetProtoByNumber : TWSAAsyncGetProtoByNumberProc = nil;
  WSAAsyncGetHostByName : TWSAAsyncGetHostByNameProc = nil;
  WSAAsyncGetHostByAddr : TWSAAsyncGetHostByAddrProc = nil;
  WSACancelAsyncRequest : TWSACancelAsyncRequestProc = nil;
  WSAAsyncSelect : TWSAAsyncSelectProc = nil;
  WSARecvEx : TWSARecvExProc = nil;
  __WSAFDIsSet : T__WSAFDIsSetProc = nil;
  TransmitFile : TTransmitFileProc = nil;
  AcceptEx : TAcceptExProc = nil;
  GetAcceptExSockaddrs : TGetAcceptExSockaddrsProc = nil;

function WSAMakeSyncReply(Buflen, Error: Word): Longint;
function WSAMakeSelectReply(Event, Error: Word): Longint;
function WSAGetAsyncBuflen(Param: Longint): Word;
function WSAGetAsyncError(Param: Longint): Word;
function WSAGetSelectEvent(Param: Longint): Word;
function WSAGetSelectError(Param: Longint): Word;

procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); // renamed due to conflict with fd_set (above)
procedure FD_ZERO(var FDSet: TFDSet);

{Winsock dynamic load management routines}
procedure LoadWinsock;
function WinsockLoaded : Boolean;
procedure UnloadWinsock;


implementation
uses PsiException, PsiResourceStrings, SysUtils;

const
  DLLStackName = 'wsock32.dll';

const
  LibHandle : THandle = 0;

function WSAMakeSyncReply;
begin
  WSAMakeSyncReply:= MakeLong(Buflen, Error);
end;

function WSAMakeSelectReply;
begin
  WSAMakeSelectReply:= MakeLong(Event, Error);
end;

function WSAGetAsyncBuflen;
begin
  WSAGetAsyncBuflen:= LOWORD(Param);
end;

function WSAGetAsyncError;
begin
  WSAGetAsyncError:= HIWORD(Param);
end;

function WSAGetSelectEvent;
begin
  WSAGetSelectEvent:= LOWORD(Param);
end;

function WSAGetSelectError;
begin
  WSAGetSelectError:= HIWORD(Param);
end;

procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
var
  I: Integer;
begin
  I := 0;
  while I < FDSet.fd_count do
  begin
    if FDSet.fd_array[I] = Socket then
    begin
      while I < FDSet.fd_count - 1 do
      begin
        FDSet.fd_array[I] := FDSet.fd_array[I + 1];
        Inc(I);
      end;
      Dec(FDSet.fd_count);
      Break;
    end;
    Inc(I);
  end;
end;

function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
begin
  Result := __WSAFDIsSet(Socket, FDSet);
end;

procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
begin
  if FDSet.fd_count < FD_SETSIZE then
  begin
    FDSet.fd_array[FDSet.fd_count] := Socket;
    Inc(FDSet.fd_count);
  end;
end;

procedure FD_ZERO(var FDSet: TFDSet);
begin
  FDSet.fd_count := 0;
end;

procedure LoadWinsock;
begin
  LibHandle := Windows.LoadLibrary ( PChar ( DLLStackName ) );
  if LibHandle <> 0 then begin
     Accept := Windows.GetProcAddress ( LibHandle, PChar ( 'accept' ) );
     Bind := Windows.GetProcAddress ( LibHandle, PChar ( 'bind' ) );
     CloseSocket := Windows.GetProcAddress ( LibHandle, PChar ( 'closesocket' ) );
     Connect := Windows.GetProcAddress ( LibHandle, PChar ( 'connect' ) );
     GetPeerName := Windows.GetProcAddress ( LibHandle, PChar (  'getpeername' ) );
     GetSockName := Windows.GetProcAddress ( LibHandle, PChar ('getsockname' ) );
     GetSockOpt := Windows.GetProcAddress ( LibHandle, PChar ( 'getsockopt' ) );
     Htonl := Windows.GetProcAddress ( LibHandle, PChar ( 'htonl' ) );
     Htons := Windows.GetProcAddress ( LibHandle, PChar ( 'htons' ) );
     Inet_Addr := Windows.GetProcAddress ( LibHandle, PChar ( 'inet_addr' ) );
     Inet_Ntoa := Windows.GetProcAddress ( LibHandle, PChar ( 'inet_ntoa' ) );
     IoctlSocket := Windows.GetProcAddress ( LibHandle, PChar ( 'ioctlsocket' ) );
     Listen := Windows.GetProcAddress ( LibHandle, PChar ( 'listen' ) );
     Ntohl := Windows.GetProcAddress ( LibHandle, PChar ( 'ntohl' ) );
     Ntohs := Windows.GetProcAddress ( LibHandle, PChar ( 'ntohs' ) );
     Recv := Windows.GetProcAddress ( LibHandle, PChar ( 'recv' ) );
     RecvFrom := Windows.GetProcAddress ( LibHandle, PChar ( 'recvfrom' ) );
     Select := Windows.GetProcAddress ( LibHandle, PChar ( 'select' ) );
     Send := Windows.GetProcAddress ( LibHandle, PChar ( 'send' ) );
     SendTo := Windows.GetProcAddress ( LibHandle, PChar ( 'sendto' ) );
     SetSockOpt := Windows.GetProcAddress ( LibHandle, PChar ( 'setsockopt' ) );
     ShutDown := Windows.GetProcAddress ( LibHandle, PChar ( 'shutdown' ) );
     Socket := Windows.GetProcAddress ( LibHandle, PChar ( 'socket' ) );

     GetHostByAddr := Windows.GetProcAddress ( LibHandle, PChar ( 'gethostbyaddr' ) );
     GetHostByName := Windows.GetProcAddress ( LibHandle, PChar ( 'gethostbyname' ) );
     GetProtoByName := Windows.GetProcAddress ( LibHandle, PChar ( 'getprotobyname' ) );
     GetProtoByNumber := Windows.GetProcAddress ( LibHandle, PChar ( 'getprotobynumber' ) );
     GetServByName := Windows.GetProcAddress ( LibHandle, PChar ( 'getservbyname' ) );
     GetServByPort := Windows.GetProcAddress ( LibHandle, PChar ( 'getservbyport' ) );
     GetHostName := Windows.GetProcAddress ( LibHandle, PChar ( 'gethostname' ) );

     WSAAsyncSelect := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAAsyncSelect' ) );
     WSARecvEx := Windows.GetProcAddress ( LibHandle, PChar ( 'WSARecvEx' ) );
     WSAAsyncGetHostByAddr := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAAsyncGetHostByAddr' ) );
     WSAAsyncGetHostByName := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAAsyncGetHostByName' ) );
     WSAAsyncGetProtoByNumber := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAAsyncGetProtoByNumber' ) );
     WSAAsyncGetProtoByName := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAAsyncGetProtoByName' ) );
     WSAAsyncGetServByPort:= Windows.GetProcAddress ( LibHandle, PChar ( 'WSAAsyncGetServByPort' ) );
     WSAAsyncGetServByName := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAAsyncGetServByName' ) );
     WSACancelAsyncRequest := Windows.GetProcAddress ( LibHandle, PChar ( 'WSACancelAsyncRequest' ) );
     WSASetBlockingHook := Windows.GetProcAddress ( LibHandle, PChar ('WSASetBlockingHook' ) );
     WSAUnhookBlockingHook := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAUnhookBlockingHook' ) );
     WSAGetLastError := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAGetLastError' ) );
     WSASetLastError := Windows.GetProcAddress ( LibHandle, PChar ( 'WSASetLastError' ) );
     WSACancelBlockingCall := Windows.GetProcAddress ( LibHandle, PChar ( 'WSACancelBlockingCall' ) );
     WSAIsBlocking := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAIsBlocking' ) );
     WSAStartup := Windows.GetProcAddress ( LibHandle, PChar ( 'WSAStartup' ) );
     WSACleanup := Windows.GetProcAddress ( LibHandle, PChar ( 'WSACleanup' ) );
     __WSAFDIsSet := Windows.GetProcAddress ( LibHandle, PChar ( '__WSAFDIsSet' ) );

     TransmitFile := Windows.GetProcAddress ( LibHandle, PChar ( 'TransmitFile' ) );
     AcceptEx := Windows.GetProcAddress ( LibHandle, PChar ( 'AcceptEx' ) );
     GetAcceptExSockaddrs := Windows.GetProcAddress ( LibHandle, PChar ( 'GetAcceptExSockaddrs' ) );
  end //if LibHandle <> 0 then begin
  else
  begin
    Raise EPsiException.CreateFmt(RSCouldNotLoad, [DLLStackName]);
  end; //else...if LibHandle <> 0 then begin
end;

procedure UnloadWinsock;
begin
  if LibHandle <> 0 then
    Windows.FreeLibrary ( libHandle );
  LibHandle := 0;                       //signify that the library is not loaded
end;

function WinsockLoaded : Boolean;
begin
  Result := ( LibHandle <> 0 );
end;

end.