blcksock.pas

很不错的东东

    FBuffer := '';
  end
  else
    if CanRead(Timeout) then
    begin
      x := WaitingData;
      if x > 0 then
      begin
        SetLength(s, x);
        x := RecvBuffer(Pointer(s), x);
        Result := Copy(s, 1, x);
      end;
    end
    else
      FLastError := WSAETIMEDOUT;
  ExceptCheck;
  if x = 0 then
    FLastError := WSAECONNRESET;
end;


function TBlockSocket.RecvByte(Timeout: Integer): Byte;
var
  y: Integer;
  Data: Byte;
begin
  Data := 0;
  Result := 0;
  if CanRead(Timeout) then
  begin
    y := synsock.Recv(FSocket, Data, 1, 0);
    if y = 0 then
      FLastError := WSAECONNRESET
    else
      SockCheck(y);
    Result := Data;
    DoStatus(HR_ReadCount, '1');
  end
  else
    FLastError := WSAETIMEDOUT;
  ExceptCheck;
end;

function TBlockSocket.RecvString(Timeout: Integer): string;
const
  MaxBuf = 1024;
var
  x: Integer;
  s: string;
  c: Char;
  r: Integer;
begin
  s := '';
  FLastError := 0;
  c := #0;
  repeat
    if FBuffer = '' then
    begin
      x := WaitingData;
      if x = 0 then
        x := 1;
      if x > MaxBuf then
        x := MaxBuf;
      if x = 1 then
      begin
        c := Char(RecvByte(Timeout));
        if FLastError <> 0 then
          Break;
        FBuffer := c;
      end
      else
      begin
        SetLength(FBuffer, x);
        r := synsock.Recv(FSocket, Pointer(FBuffer)^, x, 0);
        SockCheck(r);
        if r = 0 then
          FLastError := WSAECONNRESET;
        if FLastError <> 0 then
          Break;
        DoStatus(HR_ReadCount, IntToStr(r));
        if r < x then
          SetLength(FBuffer, r);
      end;
    end;
    x := Pos(#10, FBuffer);
    if x < 1 then x := Length(FBuffer);
    s := s + Copy(FBuffer, 1, x - 1);
    c := FBuffer[x];
    Delete(FBuffer, 1, x);
    s := s + c;
  until c = #10;

  if FLastError = 0 then
  begin
{$IFDEF LINUX}
    s := AdjustLineBreaks(s, tlbsCRLF);
{$ELSE}
    s := AdjustLineBreaks(s);
{$ENDIF}
    x := Pos(#13 + #10, s);
    if x > 0 then
      s := Copy(s, 1, x - 1);
    Result := s;
  end
  else
    Result := '';
  ExceptCheck;
end;

function TBlockSocket.PeekBuffer(Buffer: Pointer; Length: Integer): Integer;
begin
  Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK);
  SockCheck(Result);
  ExceptCheck;
end;

function TBlockSocket.PeekByte(Timeout: Integer): Byte;
var
  y: Integer;
  Data: Byte;
begin
  Data := 0;
  Result := 0;
  if CanRead(Timeout) then
  begin
    y := synsock.Recv(FSocket, Data, 1, MSG_PEEK);
    if y = 0 then
      FLastError := WSAECONNRESET;
    SockCheck(y);
    Result := Data;
  end
  else
    FLastError := WSAETIMEDOUT;
  ExceptCheck;
end;

function TBlockSocket.SockCheck(SockResult: Integer): Integer;
begin
  if SockResult = SOCKET_ERROR then
    Result := synsock.WSAGetLastError
  else
    Result := 0;
  FLastError := Result;
end;

procedure TBlockSocket.ExceptCheck;
var
  e: ESynapseError;
  s: string;
begin
  if FRaiseExcept and (LastError <> 0) then
  begin
    s := GetErrorDesc(LastError);
    e := ESynapseError.CreateFmt('TCP/IP Socket error %d: %s', [LastError, s]);
    e.ErrorCode := LastError;
    e.ErrorMessage := s;
    raise e;
  end;
end;

function TBlockSocket.WaitingData: Integer;
var
  x: Integer;
begin
  synsock.IoctlSocket(FSocket, FIONREAD, u_long(x));
  Result := x;
end;

procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
var
  li: TLinger;
begin
  li.l_onoff := Ord(Enable);
  li.l_linger := Linger div 1000;
  SockCheck(synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_LINGER, @li, SizeOf(li)));
  ExceptCheck;
end;

function TBlockSocket.LocalName: string;
var
  buf: array[0..255] of Char;
  BufPtr: PChar;
  RemoteHost: PHostEnt;
begin
  BufPtr := buf;
  Result := '';
  synsock.GetHostName(BufPtr, SizeOf(buf));
  if BufPtr[0] <> #0 then
  begin
    // try get Fully Qualified Domain Name
    RemoteHost := synsock.GetHostByName(BufPtr);
    if RemoteHost <> nil then
      Result := PChar(RemoteHost^.h_name);
  end;
  if Result = '' then
    Result := '127.0.0.1';
end;

procedure TBlockSocket.ResolveNameToIP(Name: string; IPList: TStrings);
type
  TaPInAddr = array[0..250] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  RemoteHost: PHostEnt;
  IP: u_long;
  PAdrPtr: PaPInAddr;
  i: Integer;
  s: string;
  InAddr: TInAddr;
begin
  IPList.Clear;
  IP := synsock.inet_addr(PChar(Name));
  if IP = u_long(INADDR_NONE) then
  begin
    RemoteHost := synsock.GetHostByName(PChar(Name));
    if RemoteHost <> nil then
    begin
      PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
      i := 0;
      while PAdrPtr^[i] <> nil do
      begin
        InAddr := PAdrPtr^[i]^;
        with InAddr.S_un_b do
          s := Format('%d.%d.%d.%d',
            [Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]);
        IPList.Add(s);
        Inc(i);
      end;
    end;
    if IPList.Count = 0 then
      IPList.Add('0.0.0.0');
  end
  else
    IPList.Add(Name);
end;

function TBlockSocket.ResolveName(Name: string): string;
var
  l: TStringList;
begin
  l := TStringList.Create;
  try
    ResolveNameToIP(Name, l);
    Result := l[0];
  finally
    l.Free;
  end;
end;

function TBlockSocket.ResolvePort(Port: string): Word;
var
  ProtoEnt: PProtoEnt;
  ServEnt: PServEnt;
begin
  ProtoEnt := synsock.GetProtoByNumber(FProtocol);
  ServEnt := nil;
  if ProtoEnt <> nil then
    ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
  if ServEnt = nil then
    Result := synsock.htons(StrToIntDef(Port, 0))
  else
    Result := ServEnt^.s_port;
end;

procedure TBlockSocket.SetRemoteSin(IP, Port: string);
begin
  SetSin(FRemoteSin, IP, Port);
end;

function TBlockSocket.GetLocalSinIP: string;
begin
  Result := GetSinIP(FLocalSin);
end;

function TBlockSocket.GetRemoteSinIP: string;
begin
  Result := GetSinIP(FRemoteSin);
end;

function TBlockSocket.GetLocalSinPort: Integer;
begin
  Result := GetSinPort(FLocalSin);
end;

function TBlockSocket.GetRemoteSinPort: Integer;
begin
  Result := GetSinPort(FRemoteSin);
end;

function TBlockSocket.CanRead(Timeout: Integer): Boolean;
var
  FDSet: TFDSet;
  TimeVal: PTimeVal;
  TimeV: TTimeVal;
  x: Integer;
begin
  TimeV.tv_usec := (Timeout mod 1000) * 1000;
  TimeV.tv_sec := Timeout div 1000;
  TimeVal := @TimeV;
  if Timeout = -1 then
    TimeVal := nil;
  FD_ZERO(FDSet);
  FD_SET(FSocket, FDSet);
  x := synsock.Select(FSocket + 1, @FDSet, nil, nil, TimeVal);
  SockCheck(x);
  if FLastError <> 0 then
    x := 0;
  Result := x > 0;
  ExceptCheck;
  if Result then
    DoStatus(HR_CanRead, '');
end;

function TBlockSocket.CanWrite(Timeout: Integer): Boolean;
var
  FDSet: TFDSet;
  TimeVal: PTimeVal;
  TimeV: TTimeVal;
  x: Integer;
begin
  TimeV.tv_usec := (Timeout mod 1000) * 1000;
  TimeV.tv_sec := Timeout div 1000;
  TimeVal := @TimeV;
  if Timeout = -1 then
    TimeVal := nil;
  FD_ZERO(FDSet);
  FD_SET(FSocket, FDSet);
  x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal);
  SockCheck(x);
  if FLastError <> 0 then
    x := 0;
  Result := x > 0;
  ExceptCheck;
  if Result then
    DoStatus(HR_CanWrite, '');
end;

function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer;
var
  Len: Integer;
begin
  Len := SizeOf(FRemoteSin);
  Result := synsock.SendTo(FSocket, Buffer^, Length, 0, FRemoteSin, Len);
  SockCheck(Result);
  ExceptCheck;
end;

function TBlockSocket.RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer;
var
  Len: Integer;
begin
  Len := SizeOf(FRemoteSin);
  Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, FRemoteSin, Len);
  SockCheck(Result);
  ExceptCheck;
end;

function TBlockSocket.GetSizeRecvBuffer: Integer;
var
  l: Integer;
begin
  l := SizeOf(Result);
  SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l));
  if FLastError <> 0 then
    Result := 1024;
  ExceptCheck;
end;

procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer);
begin
  SockCheck(synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Size, SizeOf(Size)));
  ExceptCheck;
end;

function TBlockSocket.GetSizeSendBuffer: Integer;
var
  l: Integer;
begin
  l := SizeOf(Result);
  SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l));
  if FLastError <> 0 then
    Result := 1024;
  ExceptCheck;
end;

procedure TBlockSocket.SetSizeSendBuffer(Size: Integer);
begin
  SockCheck(synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Size, SizeOf(Size)));
  ExceptCheck;
end;

//See 'winsock2.txt' file in distribute package!
function TBlockSocket.SetTimeout(Timeout: Integer): Boolean;
begin
  Result := SetSendTimeout(Timeout) and SetRecvTimeout(Timeout);
end;

//See 'winsock2.txt' file in distribute package!
function TBlockSocket.SetSendTimeout(Timeout: Integer): Boolean;
begin
  Result := synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO,
    @Timeout, SizeOf(Timeout)) <> SOCKET_ERROR;
end;

//See 'winsock2.txt' file in distribute package!
function TBlockSocket.SetRecvTimeout(Timeout: Integer): Boolean;
begin
  Result := synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO,
    @Timeout, SizeOf(Timeout)) <> SOCKET_ERROR;
end;

function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer;
  const CanReadList: TList): boolean;
var
  FDSet: TFDSet;
  TimeVal: PTimeVal;
  TimeV: TTimeVal;
  x, n: Integer;
  Max: Integer;
begin
  TimeV.tv_usec := (Timeout mod 1000) * 1000;
  TimeV.tv_sec := Timeout div 1000;
  TimeVal := @TimeV;
  if Timeout = -1 then
    TimeVal := nil;
  FD_ZERO(FDSet);
  Max := 0;
  for n := 0 to SocketList.Count - 1 do
    if TObject(SocketList.Items[n]) is TBlockSocket then
    begin
      if TBlockSocket(SocketList.Items[n]).Socket > Max then
        Max := TBlockSocket(SocketList.Items[n]).Socket;
      FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet);
    end;
  x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal);
  SockCheck(x);
  ExceptCheck;
  if FLastError <> 0 then
    x := 0;
  Result := x > 0;
  CanReadList.Clear;
  if Result then
    for n := 0 to SocketList.Count - 1 do
      if TObject(SocketList.Items[n]) is TBlockSocket then
        if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then
          CanReadList.Add(TBlockSocket(SocketList.Items[n]));
end;

procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string);
begin
  if assigned(OnStatus) then
    OnStatus(Self, Reason, Value);
end;

class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
begin
  case ErrorCode of
    0:
      Result := 'OK';
    WSAEINTR: {10004}
      Result := 'Interrupted system call';
    WSAEBADF: {10009}
      Result := 'Bad file number';
    WSAEACCES: {10013}
      Result := 'Permission denied';
    WSAEFAULT: {10014}
      Result := 'Bad address';
    WSAEINVAL: {10022}
      Result := 'Invalid argument';
    WSAEMFILE: {10024}
      Result := 'Too many open files';
    WSAEWOULDBLOCK: {10035}
      Result := 'Operation would block';
    WSAEINPROGRESS: {10036}
      Result := 'Operation now in progress';
    WSAEALREADY: {10037}
      Result := 'Operation already in progress';
    WSAENOTSOCK: {10038}
      Result := 'Socket operation on nonsocket';
    WSAEDESTADDRREQ: {10039}
      Result := 'Destination address required';
    WSAEMSGSIZE: {10040}
      Result := 'Message too long';
    WSAEPROTOTYPE: {10041}
      Result := 'Protocol wrong type for Socket';
    WSAENOPROTOOPT: {10042}
      Result := 'Protocol not available';
    WSAEPROTONOSUPPORT: {10043}
      Result := 'Protocol not supported';
    WSAESOCKTNOSUPPORT: {10044}
      Result := 'Socket not supported';
    WSAEOPNOTSUPP: {10045}
      Result := 'Operation not supported on Socket';
    WSAEPFNOSUPPORT: {10046}