wsockets.pas

DarkMoon v4.11 (远程控制) 国外收集的代码,控件下载: http://www.winio.cn/Blogs/jishuwenzhang/200712/20071208230135.

(**** TTCPClient Class ****)

constructor TTCPClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle:= AllocateHWnd(WndProc);
  FProtocol:= IPPROTO_TCP;
  FType:= SOCK_STREAM;
end;

destructor TTCPClient.Destroy;
begin
  Close;
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure TTCPClient.OpenConnection(Socket: TSocket; Error: word);
var
  EventMask: longint;
begin
  if Error <> 0 then
    SocketError(Error)
  else
    begin
      EventMask:= FD_READ or FD_CLOSE;
      if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, EventMask) <> 0 then
        SocketError(WSAGetLastError)
      else
        begin
          if Assigned(FOnConnect) then
            FOnConnect(Self, Socket);
          FSocketState:= ssConnected;
        end;
    end;
end;

procedure TTCPClient.CloseConnection(Socket: TSocket; Error: word);
begin
  if Error = WSAENETDOWN then
    SocketError(Error)
  else
    begin
      if Assigned(FOnClose) then
        FOnClose(Self, Socket);
      Close;
    end;
end;

procedure TTCPClient.IncommingData(Socket: TSocket; Error: word);
begin
  if Error <> 0 then
    SocketError(Error)
  else
    if Assigned(FOnData) then
      FOnData(Self, Socket);
end;

procedure TTCPClient.WndProc(var AMsg: TMessage);
var
  Error: word;
begin
  with AMsg do
    case Msg of
      WM_ASYNCSELECT:
        begin
          if (FSocketState = ssClosed) then
            Exit;
          Error:= WSAGetSelectError(LParam);
          case WSAGetSelectEvent(LParam) of
            FD_READ   : IncommingData(WParam, Error);
            FD_CONNECT: OpenConnection(WParam, Error);
            FD_CLOSE  : CloseConnection(WParam, Error);
          else
            if Error <> 0 then
              SocketError(Error);
          end;
        end;
    else
      Result:= DefWindowProc(FHandle, Msg, WParam, LParam);
    end;
end;

procedure TTCPClient.Open;
var
  SockAddrIn: TSockAddrIn;
  SockOpt: LongBool;
  EventMask: longint;
begin
  if (FSocketState <> ssClosed) then
    Exit;

  if not GetSockAddrIn(FHost, FPort, SockAddrIn) then
    Exit;

  FLocalSocket:= socket(PF_INET, FType, 0);
  if FLocalSocket = INVALID_SOCKET then
    begin
      SocketError(WSAGetLastError);
      Exit;
    end;

  EventMask:= (FD_CONNECT or FD_READ or FD_CLOSE);
  if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, EventMask) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  SockOpt:= true; {Enable OOB Data inline}
  if setsockopt(FLocalSocket, SOL_SOCKET, SO_OOBINLINE, PChar(@SockOpt), SizeOf(SockOpt)) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if connect(FLocalSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 then
    begin
      if WSAGetLastError <> WSAEWOULDBLOCK then
        begin
          SocketError(WSAGetLastError);
          closesocket(FLocalSocket);
          Exit;
        end;
    end;

  FSocketState:= ssOpen;
end;

procedure TTCPClient.Close;
begin
  if (FSocketState = ssNotStarted) or (FSocketState = ssClosed) then
    Exit;

  SocketClose(FLocalSocket, FHandle);
  if FLocalSocket = INVALID_SOCKET then
    FSocketState:= ssClosed;
end;

procedure TTCPClient.Write(Data: string);
begin
  SocketWrite(FLocalSocket, 0, Data);
end;

function TTCPClient.Read: string;
begin
  Result:= SocketRead(FLocalSocket, 0);
end;

function TTCPClient.Peek: string;
begin
  Result:= SocketRead(FLocalSocket, MSG_PEEK);
end;

function TTCPClient.WriteBuffer(Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketWriteBuffer(FLocalSocket, Buffer, Size, 0);
end;

function TTCPClient.ReadBuffer(Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketReadBuffer(FLocalSocket, Buffer, Size, 0);
end;

function TTCPClient.GetPeerAddress: string;
begin
  Result:= PeerToAddress(FLocalSocket);
end;

function TTCPClient.GetPeerPort: string;
begin
  Result:= PeerToPort(FLocalSocket);
end;

(**** TTCPServer Class ****)

constructor TTCPServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle:= AllocateHWnd(WndProc);
  FProtocol:= IPPROTO_TCP;
  FType:= SOCK_STREAM;
  FClients:= TClientList.Create;
end;

destructor TTCPServer.Destroy;
begin
  Close;
  DeallocateHWnd(FHandle);
  FClients.Free;
  inherited Destroy;
end;

procedure TTCPServer.OpenConnection(Socket: TSocket; Error: word);
var
  Len: integer;
  NewSocket: TSocket;
  SockAddrIn: TSockAddrIn;
  SockOpt: LongBool;
  EventMask: longint;
begin
  if Error <> 0 then
    SocketError(Error)
  else
    begin
      Len:= SizeOf(SockAddrIn);
      {$IFDEF VER140} // Delphi 6
      NewSocket:= accept(FLocalSocket, @SockAddrIn, @Len);

      {$ELSE}         // Delphi 2
      NewSocket:= accept(FLocalSocket, SockAddrIn, Len);

      {$ENDIF}
      if NewSocket = INVALID_SOCKET then
        begin
          SocketError(WSAGetLastError);
          Exit;
        end;

      EventMask:= (FD_READ or FD_CLOSE);
      if WSAASyncSelect(NewSocket, FHandle, WM_ASYNCSELECT, EventMask) <> 0 then
        begin
          SocketError(WSAGetLastError);
          closesocket(NewSocket);
          Exit;
        end;

      SockOpt:= true; {Enable OOB Data inline}
      if setsockopt(NewSocket, SOL_SOCKET, SO_OOBINLINE	, PChar(@SockOpt), SizeOf(SockOpt)) <> 0 then
        begin
          SocketError(WSAGetLastError);
          closesocket(NewSocket);
          Exit;
        end;

      if not FClients.Add(NewSocket) then
        SocketClose(NewSocket, FHandle)
      else
        if Assigned(FOnAccept) then
          FOnAccept(Self, NewSocket);
    end;
end;

procedure TTCPServer.CloseConnection(Socket: TSocket; Error: word);
begin
  if Error = WSAENETDOWN then
    SocketError(Error)
  else
    begin
      if Assigned(FOnClose) then
        FOnClose(Self, Socket);
      Disconnect(Socket);
    end;
end;

procedure TTCPServer.IncommingData(Socket: TSocket; Error: word);
begin
  if Error <> 0 then
    SocketError(Error)
  else
    if Assigned(FOnData) then
      FOnData(Self, Socket);
end;

procedure TTCPServer.WndProc(var AMsg: TMessage);
var
  Error: word;
begin
  with AMsg do
    case Msg of
      WM_ASYNCSELECT:
        begin
          if (FSocketState = ssClosed) then
            Exit;
          Error:= WSAGetSelectError(LParam);
          case WSAGetSelectEvent(LParam) of
            FD_READ  : IncommingData(WParam, Error);
            FD_ACCEPT: OpenConnection(WParam, Error);
            FD_CLOSE : CloseConnection(WParam, Error);
          else
            if Error <> 0 then
              SocketError(Error);
          end;
        end;
    else
      Result:= DefWindowProc(FHandle, Msg, WParam, LParam);
    end;
end;

procedure TTCPServer.Open;
var
  SockAddrIn: TSockAddrIn;
begin
  if (FSocketState <> ssClosed) then
    Exit;

  if not GetAnySockAddrIn(FPort, SockAddrIn) then
    Exit;

  FLocalSocket:= socket(PF_INET, FType, 0);
  if FLocalSocket = INVALID_SOCKET then
    begin
      SocketError(WSAGetLastError);
      Exit;
    end;

  if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, FD_ACCEPT) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if bind(FLocalSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if listen(FLocalSocket, 5) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  FSocketState:= ssListening;
end;

procedure TTCPServer.Close;
var
  i: integer;
  Dummy: TSocket;
begin
  if (FSocketState = ssNotStarted) or (FSocketState = ssClosed) then
    Exit;

  for i:= 0 to FClients.Count-1 do
    begin
      Dummy:= FClients[i];
      SocketClose(Dummy, FHandle);
    end;
  FClients.Clear;

  SocketClose(FLocalSocket, FHandle);
  if FLocalSocket = INVALID_SOCKET then
    FSocketState:= ssClosed;
end;

procedure TTCPServer.Write(Socket: TSocket; Data: string);
begin
  SocketWrite(Socket, 0, Data);
end;

function TTCPServer.Read(Socket: TSocket): string;
begin
  Result:= SocketRead(Socket, 0);
end;

function TTCPServer.Peek(Socket: TSocket): string;
begin
  Result:= SocketRead(Socket, MSG_PEEK);
end;

function TTCPServer.WriteBuffer(Socket: TSocket; Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketWriteBuffer(Socket, Buffer, Size, 0);
end;

function TTCPServer.ReadBuffer(Socket: TSocket; Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketReadBuffer(Socket, Buffer, Size, 0);
end;

procedure TTCPServer.Disconnect(Socket: TSocket);
begin
  FClients.Delete(Socket);
  SocketClose(Socket, FHandle);
end;

end.