sock.pas

为Delphi2005做了改动 DSPack 2.3.3 (Sep 2004). DSPack is a set of Components and class to write Multimedia

  begin
    if FListen then
      raise
        ESockException.Create('SocketType - Can''t Assign Socket Type While Listening');
    if FConnected then
      raise
        ESockException.Create('SocketType - Can''t Assign Socket Type While Connected');
    FSocketType := Value;
  end
end;

function TSock.GetRemoteHost: string;
begin
  // Convert FRecvAddrIn To A String IP Address
  Result := INet_NToA(FRecvAddrIn.SIn_Addr);
end;

procedure TSock.DoInfo(SocketInfo: TSocketInfo; Msg: string);
begin
  if Assigned(FOnInfo) then
    FOnInfo(Self, SocketInfo, Msg);
end;

procedure TSock.SetBitmap;
begin
  // Determine The Design-Time Bitmap To Use
  if FSocketType = stDatagram then
    FPicture := FBmp_UDP
  else if FListen then
    FPicture := FBmp_Listen
  else
    FPicture := FBmp_TCP;
  Invalidate;
end;

//*** Constructor/Destructor ***************************************************

constructor TSock.Create(AOwner: TComponent);
begin
  m_receiveForm := TForm.Create(nil);
  inherited Create(m_receiveForm);
  m_lock := TBCCritSec.Create;
  Parent := TWinControl(m_receiveForm);
    // <<--- added by blacktrip, wild cast but
  // prevent crashes !!!
  if WinSock.WSAStartup($0101, WSAData) <> 0 then
    raise ESockException.Create('WSAStartup - Could Not Initialize WinSock');
  IPCache := TStringList.Create;
  IPCache.Clear;

  if (csDesigning in ComponentState) then
  begin
    // Get Bitmaps For Design-Time Image
    FBmp_TCP := TBitmap.Create;
    FBmp_UDP := TBitmap.Create;
    FBmp_Listen := TBitmap.Create;
    FBmp_TCP.Handle := LoadBitmap(hInstance, 'TCP');
    FBmp_UDP.Handle := LoadBitmap(hInstance, 'UDP');
    FBmp_Listen.Handle := LoadBitmap(hInstance, 'LISTEN');
    FPicture := FBmp_TCP;
    Width := FPicture.Width;
    Height := FPicture.Height;
    SetZOrder(True);
  end
  else
  begin
    Width := 0;
    Height := 0;
    SetZOrder(False);
    Visible := False;
  end;
  FHostName := '';
  FPortName := '';
  FLocalPortName := '-1';
  FSocket := INVALID_SOCKET;
  FLineBreak := lbSmart;
  FLastChar := #0;
  FInBuffer := '';
  FOutBuffer := '';
  FListen := False;
  FBlocking := False;
  FAutoAccept := False;
  FConnected := False;
  FStream := TSockStream.Create(Self);
  FFreeOnClose := False;
end;

// This Constructor Assumes NewSocket Is A Valid Socket Handle

constructor TSock.CreateWithSocket(AOwner: TComponent; NewSocket: TSocket);
begin
  Create(AOwner);
  FSocket := NewSocket;
  SetBlocking(TSock(AOwner).Blocking);
  FBlockTime := TSock(AOwner).BlockingTimeout;
  FOnRead := TSock(AOwner).OnRead;
  FOnWrite := TSock(AOwner).OnWrite;
  FOnDisconnect := TSock(AOwner).OnDisconnect;
  FOnInfo := TSock(AOwner).OnInfo;
  FConnected := True;
  FLineBreak := TSock(AOwner).LineBreak;
  FRecvAddrIn := TSock(AOwner).RecvAddrIn;
  FFreeOnClose := not FBlocking;
end;

destructor TSock.Destroy;
begin
  if FListen or FConnected then
    Close;
  if (csDesigning in ComponentState) then
  begin
    FBmp_TCP.Free;
    FBmp_UDP.Free;
    FBmp_Listen.Free;
  end;
  FStream.Free;
  IPCache.Free;
  WinSock.WSACleanup;
  inherited Destroy;
end;

procedure TSock.Loaded;
begin
  if not (csDesigning in ComponentState) then
  begin
    // If Component Has Been Loaded At Run-Time And Listen Then Start Listening
    SetBlocking(FBlocking);
    if FListen then
    begin
      FListen := False;
      SetListen(True);
    end;
  end;
end;

//*** Event Handling ***********************************************************

procedure TSock.WMSock(var Message: TMessage);
var
  Event: Word;
  Error: Word;
  Res: Integer;
  AcSck: TSocket;
  Addr: TSockAddrIn;
  AddrL: Integer;
  CSock: TSock;
  Spawn: TSockThread;
begin
  m_lock.Lock;
  inherited;
  // Message Handling For Non-Blocking Sockets
  Event := WinSock.WSAGetSelectEvent(Message.LParam);
  Error := WinSock.WSAGetSelectError(Message.LParam);
  if (Error > WSABASEERR) then
    DoInfo(SiError, 'Error #' + IntToStr(Error) + ' (' + ErrToStr(Error) + ')');
  if (Error <= WSABASEERR) or (Event = FD_CLOSE) then
    // Messages Mean Different Things Depending On Whether You're Listening Or Not
    case Event of
      FD_ACCEPT:
        begin
          // Incoming Socket
          if FAutoAccept and Assigned(FOnAutoAccept) then
          begin
            // If AutoAccept Is Set To True And OnAutoAccept Is Set...
            // Create A New Socket Based On The Accepted One And Begin
            // AutoAccept As If It Were A Thread... The AutoAccept
            // Routine Is Responsible For Destroying The New Socket
            // Component.
            AddrL := SizeOf(Addr);
            FillChar(Addr, SizeOf(Addr), #0);
{$IFDEF VER93}
            AcSck := WinSock.Accept(FSocket, Addr, AddrL);
{$ELSE}
{$IFDEF WIN32}
            AcSck := WinSock.Accept(FSocket, @Addr, @AddrL);
{$ELSE}
            AcSck := WinSock.Accept(FSocket, Addr, AddrL);
{$ENDIF}
{$ENDIF}
            FRecvAddrIn := Addr;
            CSock := TSock.CreateWithSocket(Self, AcSck);
            CSock.PortName := FPortName;
            CSock.LocalPortName := FLocalPortName;
            CSock.HostName := INet_NToA(Addr.SIn_Addr);
            if FBlocking then
            begin
              Spawn := TSockThread.Create(True);
              Spawn.RunThread(Self, CSock);
            end
            else
              FOnAutoAccept(Self, CSock);
          end
          else if Assigned(FOnAccept) then
            FOnAccept(Self);
        end;
      FD_CONNECT:
        begin
          FConnected := True;
          DoInfo(SiConnect, 'Non-Blocking Socket Connected');
          if Assigned(FOnConnect) then
            FOnConnect(Self);
        end;
      FD_CLOSE:
        begin
          if Assigned(FOnDisconnect) then
            FOnDisconnect(Self);
          Close;
        end;
      FD_READ:
        begin
          if FSocketType = stStream then
          begin
            Res := WinSock.Recv(FSocket, FCharBuf, SizeOf(FCharBuf), 0);
            if Res > 0 then
              FInBuffer := FInBuffer + Copy(FCharBuf, 1, Res);
            DoInfo(SiReceive, 'Non-Blocking Incoming Data');
            if Assigned(FOnRead) then
            begin
              FOnRead(Self, Length(FInBuffer));
            end;
          end
          else if Assigned(FOnRead) then
            FOnRead(Self, Length(FInBuffer));
        end;
      FD_WRITE:
        begin
          if FOutBuffer <> '' then
            Send('');
          DoInfo(SiSend, 'Non-Blocking Outgoing Data');
          if Assigned(FOnWrite) then
            FOnWrite(Self);
        end;
    end;
  Message.Result := 0;
  m_lock.UnLock;
end;

procedure TSock.WMPaint(var Message: TWMPaint);
begin
  inherited;
  if (csDesigning in ComponentState) then
    Canvas.Draw(0, 0, FPicture);
  Message.Result := 0;
end;

procedure TSock.WMSize(var Message: TWMSize);
begin
  inherited;
  if (csDesigning in ComponentState) then
  begin
    if Width <> FPicture.Width then
      Width := FPicture.Width;
    if Height <> FPicture.Height then
      Height := FPicture.Height;
  end;
  Message.Result := 0;
end;

//*** Support Methods **********************************************************

function TSock.Open: Boolean;
var
  Res: Integer;
  ST: Integer;
  LAddrIn: TSockAddrIn;
  //optval: integer;
begin
  if FSocket = INVALID_SOCKET then
  begin
    if FSocketType = stStream then
      ST := SOCK_STREAM
    else
      ST := SOCK_DGRAM;

    // Create The Socket
    FSocket := WinSock.Socket(AF_INET, ST, IPPROTO_IP);

    SetBlocking(FBlocking);

    // Set local options
    LAddrIn.SIn_Family := AF_INET;
    if FLocalPortName = '-1' then
      LAddrIn.SIn_Port := PortLookup(FPortName)
        // Default behaviour for backward compatibility
    else
      LAddrIn.SIn_Port := PortLookup(FLocalPortName);
    LAddrIn.SIn_Addr.S_Addr := HToNL(INADDR_ANY);
      // No HostLookup(...) Because INADDR_ANY Is A Windows Constant

    // Set Up The Remote Address And Port
    FSockAddrIn.SIn_Family := AF_INET;
    FSockAddrIn.SIn_Port := PortLookup(FPortName);
    FSockAddrIn.SIn_Addr := HostLookup(FHostName);

    if FSocketType = stStream then
    begin
      // Stream Sockets Require A Connect
      Res := WinSock.Bind(FSocket, LAddrIn, SizeOf(LAddrIn)) +
        WinSock.Connect(FSocket, FSockAddrIn, SizeOf(TSockAddrIn));
      if FBlocking then
      begin
        if Res = 0 then
        begin
          FConnected := True;
          DoInfo(SiConnect, 'Blocking Socket Connected');
          if Assigned(FOnConnect) then
            FOnConnect(Self);
        end
        else
        begin
          DoInfo(SiClose, 'Blocking Socket Can''t Connect');
          Close;
        end;
      end;
    end
    else
    begin
      //Datagram Sockets are connectionless, so they don't get connected.
      //It is possible to call WinSock.Connect, but it would produce extra overhead
      //as it only sets the default destination.
      Res := WinSock.Bind(FSocket, LAddrIn, SizeOf(LAddrIn));
      if Res = 0 then
      begin
        FConnected := True;
        DoInfo(SiConnect, 'Datagram Socket Connected');
        if Assigned(FOnConnect) then
          FOnConnect(Self);
      end
      else
      begin
        DoInfo(SiClose, 'Datagram Socket Can''t Connect');
        Close;
      end;
    end;
  end;
  Result := FConnected;
end;

function TSock.Close: Boolean;
begin
  Result := (WinSock.CloseSocket(FSocket) = 0);
  FSocket := INVALID_SOCKET;
  FConnected := False;
  if not FListen then
    DoInfo(SiClose, 'Socket Closed');
  FListen := False;
  if FFreeOnClose then
    Free;
end;

function TSock.Send(Value: string): Boolean;
var
  Remain: Integer;
begin
  Result := True;
  if FSocket = INVALID_SOCKET then
    raise ESockException.Create('Send - Socket Not Connected');
  if FListen then
    raise ESockException.Create('Send - Cannot Send On A Listener Socket');
  if FSocketType = stStream then
  begin
    FOutBuffer := FOutBuffer + Value;
    if FOutBuffer = '' then
      Exit;
    if FBlocking then
    begin
      Remain := Length(FOutBuffer);
      // While Any Content Remains Or No Errors Have Happened, Then Loop
      while Remain > 0 do
      begin
        Remain := WinSock.Send(FSocket, FOutBuffer[1], Length(FOutBuffer), 0);
        if (Remain = SOCKET_ERROR) and (WinSock.WSAGetLastError <>
          WSAEINPROGRESS) then
        begin
          DoInfo(SiError, 'Socket Error On Send');
          raise ESockException.Create('Send - Socket Error');
        end
        else
        begin
          if Remain > 0 then
            Delete(FOutBuffer, 1, Remain);
          Remain := Length(FOutBuffer);
          DoInfo(SiSend, 'Blocking Outgoing Data');
        end;
      end;
      FOutBuffer := '';
    end
    else
    begin
      // Do Not Loop For A Non-Blocking Socket
      DoInfo(SiSend, 'Non-Blocking Outgoing Data');
      Remain := WinSock.Send(FSocket, FOutBuffer[1], Length(FOutBuffer), 0);
      if Remain > 0 then
        Delete(FOutBuffer, 1, Remain);
    end;
  end
  else
    SendDatagram(Value, FHostName);
end;

function TSock.SendLine(Value: string): Boolean;
var
  Break: string;
begin
  case FLineBreak of
    lbCR: Break := #13;
    lbLF: Break := #10;
  else
    Break := #13#10;
  end;
  Result := Send(Value + Break);
end;

function TSock.Receive: string;
begin
  Result := ReceiveCount(-1);
end;

function TSock.ReceiveCount(Count: Integer): string;
var
  Res: Integer;
  FDSet: PFDSet;
  TV: PTimeVal;
  Err: Integer;
  HostN: string;
  Cnt: Integer;
begin
  if (FSocket = INVALID_SOCKET) and (FInBuffer = '') then
    raise ESockException.Create('Receive - Socket Not Connected');
  if FListen then
    raise
      ESockException.Create('Receive - Cannot Receive On A Listener Socket');
  Cnt := Count;
  if (Cnt = -1) or (Cnt > SizeOf(FCharBuf)) then
    Cnt := SizeOf(FCharBuf);
  if FSocketType = stStream then
  begin
    if FBlocking then
    begin
      FDSet := New(PFDSet);
      FDSet^.FD_Count := 1;
      FDSet^.FD_Array[0] := FSocket;
      if FBlockTime >= 0 then
      begin
        TV := New(PTimeVal);
        TV^.tv_sec := FBlockTime;
      end
      else
        TV := nil;
      // Used To Loop While We're Connected And Anything Is In The Input Queue
      if FConnected and (WinSock.Select(FSocket, FDSet, nil, nil, TV) > 0) then
      begin
        DoInfo(SiReceive, 'Blocking Incoming Data');
        Res := WinSock.Recv(FSocket, FCharBuf, Cnt, 0);
        if (Res = SOCKET_ERROR) then
        begin
          Err := WSAGetLastError;
          Result := '';
          FInBuffer := '';
          Dispose(FDSet);
          Dispose(TV);
          DoInfo(SiError, 'Socket Error On Receive');
          if (not (Err - WSABASEERR in [WSAEINTR - WSABASEERR, WSAEINPROGRESS -
            WSABASEERR, WSAEOPNOTSUPP - WSABASEERR, WSAEWOULDBLOCK - WSABASEERR,
            WSAEMSGSIZE - WSABASEERR])) then
          begin
            DoInfo(siClose, 'Socket Disconnected On Error On Receive');
            Close;
            if Assigned(FOnDisconnect) then
              FOnDisconnect(Self);
          end;
          raise ESockException.Create('Receive - Socket Error ' +
            ErrToStr(Err));
        end
        else
        begin
          if Res > 0 then
            FInBuffer := FInBuffer + Copy(FCharBuf, 1, Res)
          else if Res = 0 then
          begin
            DoInfo(siClose, 'Socket Disconnected On Receive');
            Close;
            if Assigned(FOnDisconnect) then
              FOnDisconnect(Self);
          end;
        end;
      end;
      Result := FInBuffer;
      FInBuffer := '';
      Dispose(FDSet);
      Dispose(TV);
    end
    else
    begin
      if ((Count <> -1) and (Length(FInBuffer) > Count)) then
      begin
        Result := Copy(FInBuffer, 1, Count);
        Delete(FInBuffer, 1, Count);
      end
      else
      begin
        Result := FInBuffer;
        FInBuffer := '';
      end;
    end;
  end
  else