idstackwindows.pas

网络控件适用于Delphi6

begin
  Lock; try
    if FFDSet.fd_count >= FD_SETSIZE then begin
      raise EIdStackSetSizeExceeded.Create(RSSetSizeExceeded);
    end;
    FFDSet.fd_array[FFDSet.fd_count] := AHandle;
    Inc(FFDSet.fd_count);
  finally Unlock; end;
end;

procedure TIdSocketListWindows.Clear;
begin
  Lock; try
    fd_zero(FFDSet);
  finally Unlock; end;
end;

function TIdSocketListWindows.Contains(AHandle: TIdStackSocketHandle): Boolean;
begin
  Lock; try
    Result := fd_isset(AHandle, FFDSet);
  finally Unlock; end;
end;

function TIdSocketListWindows.Count: Integer;
begin
  Lock; try
    Result := FFDSet.fd_count;
  finally Unlock; end;
end;

function TIdSocketListWindows.GetItem(AIndex: Integer): TIdStackSocketHandle;
begin
  Result := 0;
  Lock; try
    if (AIndex >= 0) and (AIndex < FFDSet.fd_count) then begin
      Result := FFDSet.fd_array[AIndex];
    end else begin
      raise EIdStackSetSizeExceeded.Create(RSSetSizeExceeded);
    end;
  finally Unlock; end;
end;

procedure TIdSocketListWindows.Remove(AHandle: TIdStackSocketHandle);
var
  i: Integer;
begin
  Lock; try
    for i:= 0 to FFDSet.fd_count - 1 do begin
      if FFDSet.fd_array[i] = AHandle then begin
        dec(FFDSet.fd_count);
        FFDSet.fd_array[i] := FFDSet.fd_array[FFDSet.fd_count];
        FFDSet.fd_array[FFDSet.fd_count] := 0; //extra purity
        Break;
      end;//if found
    end;
  finally Unlock; end;
end;

function TIdStackWindows.WSTranslateSocketErrorMsg(const AErr: integer): string;
begin
  case AErr of
    wsahost_not_found: Result := RSStackHOST_NOT_FOUND;
  else
    Result :=  inherited WSTranslateSocketErrorMsg(AErr);
    EXIT;
  end;
  Result := Format(RSStackError, [AErr, Result]);
end;

function TIdSocketListWindows.SelectRead(const ATimeout: Integer): Boolean;
var
  LSet: TFDSet;
begin
  // Windows updates this structure on return, so we need to copy it each time we need it
  GetFDSet(LSet);
  FDSelect(@LSet, nil, nil, ATimeout);
  Result := LSet.fd_count > 0;
end;

class function TIdSocketListWindows.FDSelect(AReadSet, AWriteSet,
 AExceptSet: PFDSet; const ATimeout: Integer): Boolean;
var
  LResult: Integer;
  LTime: TTimeVal;
begin
  if ATimeout = IdTimeoutInfinite then begin
    LResult := IdWinsock2.Select(0, AReadSet, AWriteSet, AExceptSet, nil);
  end else begin
    LTime.tv_sec := ATimeout div 1000;
    LTime.tv_usec := (ATimeout mod 1000) * 1000;
    LResult := IdWinsock2.Select(0, AReadSet, AWriteSet, AExceptSet, @LTime);
  end;
  //TODO: Remove this cast
  Result := (GStack as TIdStackBSDBase).CheckForSocketError(LResult) > 0;
end;

function TIdSocketListWindows.SelectReadList(var VSocketList: TIdSocketList; const ATimeout: Integer): Boolean;
var
  LSet: TFDSet;
begin
  // Windows updates this structure on return, so we need to copy it each time we need it
  GetFDSet(LSet);
  FDSelect(@LSet, nil, nil, ATimeout);
  Result := LSet.fd_count > 0;
  if Result then begin
    if VSocketList = nil then begin
      VSocketList := TIdSocketList.CreateSocketList;
    end;
    TIdSocketListWindows(VSocketList).SetFDSet(LSet);
  end;
end;

class function TIdSocketListWindows.Select(AReadList, AWriteList,
 AExceptList: TIdSocketList; const ATimeout: Integer): Boolean;
var
  LReadSet: TFDSet;
  LWriteSet: TFDSet;
  LExceptSet: TFDSet;
  LPReadSet: PFDSet;
  LPWriteSet: PFDSet;
  LPExceptSet: PFDSet;

  procedure ReadSet(AList: TIdSocketList; var ASet: TFDSet; var APSet: PFDSet);
  begin
    if AList <> nil then begin
      TIdSocketListWindows(AList).GetFDSet(ASet);
      APSet := @ASet;
    end else begin
      APSet := nil;
    end;
  end;

begin
  ReadSet(AReadList, LReadSet, LPReadSet);
  ReadSet(AWriteList, LWriteSet, LPWriteSet);
  ReadSet(AExceptList, LExceptSet, LPExceptSet);
  //
  Result := FDSelect(LPReadSet, LPWriteSet, LPExceptSet, ATimeout);
  //
  if AReadList <> nil then begin
    TIdSocketListWindows(AReadList).SetFDSet(LReadSet);
  end;
  if AWriteList <> nil then begin
    TIdSocketListWindows(AWriteList).SetFDSet(LWriteSet);
  end;
  if AExceptList <> nil then begin
    TIdSocketListWindows(AExceptList).SetFDSet(LExceptSet);
  end;
end;

procedure TIdSocketListWindows.SetFDSet(var VSet: TFDSet);
begin
  Lock; try
    FFDSet := VSet;
  finally Unlock; end;
end;

procedure TIdSocketListWindows.GetFDSet(var VSet: TFDSet);
begin
  Lock; try
    VSet := FFDSet;
  finally Unlock; end;
end;

procedure TIdStackWindows.SetBlocking(ASocket: TIdStackSocketHandle;
 const ABlocking: Boolean);
var
  LValue: Cardinal;
begin
  LValue := Cardinal(not ABlocking);
  CheckForSocketError(ioctlsocket(ASocket, FIONBIO, LValue));
end;

function TIdSocketListWindows.Clone: TIdSocketList;
begin
  Result := TIdSocketListWindows.Create;
  Lock; try
    TIdSocketListWindows(Result).SetFDSet(FFDSet);
  finally Unlock; end;
end;

function TIdStackWindows.WouldBlock(const AResult: Integer): Boolean;
begin
  Result := CheckForSocketError(AResult, [WSAEWOULDBLOCK]) <> 0;
end;

function TIdStackWindows.HostByName(const AHostName: string;
  const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION): string;
var
  LPa: PChar;
  LSa: TInAddr;
  LHost: PHostEnt;

  Hints:TAddrInfo;
  AddrInfo:pAddrInfo;
  RetVal:integer;
begin
  case AIPVersion of
    Id_IPv4: begin
      LHost := IdWinsock2.GetHostByName(PChar(AHostName));
      if LHost = nil then begin
        RaiseLastSocketError;
      end else begin
        LPa := LHost^.h_address_list^;
        LSa.S_un_b.s_b1 := Ord(LPa[0]);
        LSa.S_un_b.s_b2 := Ord(LPa[1]);
        LSa.S_un_b.s_b3 := Ord(LPa[2]);
        LSa.S_un_b.s_b4 := Ord(LPa[3]);
        Result := TranslateTInAddrToString(LSa,Id_IPv4);
      end;
    end;
    Id_IPv6: begin
      if not IdIPv6Available then raise EIdIPv6Unavailable.Create(RSIPv6Unavailable);
      ZeroMemory(@Hints,sizeof(Hints));
      Hints.ai_family := Id_PF_INET6;
      Hints.ai_socktype := SOCK_STREAM;
      AddrInfo:=nil;
      RetVal := getaddrinfo(pchar(AHostName), nil, @Hints, @AddrInfo);
      try
        if RetVal<>0 then
          RaiseSocketError(gaiErrorToWsaError(RetVal))
        else
          result:=TranslateTInAddrToString(AddrInfo^.ai_addr^.sin_zero,Id_IPv6);
      finally
        freeaddrinfo(AddrInfo);
      end;
    end;
    else begin
      IPVersionUnsupported;
    end;
  end;
end;

procedure TIdStackWindows.Connect(const ASocket: TIdStackSocketHandle;
 const AIP: string; const APort: TIdPort;
 const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION);
var
  LAddr: TSockAddrIn;
  Addr6: TSockAddrIn6;
begin
  case AIPVersion of
    Id_IPv4: begin
      LAddr.sin_family := Id_PF_INET4;
      TranslateStringToTInAddr(AIP, LAddr.sin_addr, Id_IPv4);
      LAddr.sin_port := HToNS(APort);
      CheckForSocketError(IdWinsock2.Connect(ASocket, @LAddr, SizeOf(LAddr)));
    end;
    Id_IPv6: begin
      Addr6.sin6_flowinfo:=0;
      Addr6.sin6_scope_id:=0;
      Addr6.sin6_family := Id_PF_INET6;
      TranslateStringToTInAddr(AIP, Addr6.sin6_addr, Id_IPv6);
      Addr6.sin6_port := HToNs(APort);
      CheckForSocketError(IdWinsock2.Connect(ASocket, psockaddr(@Addr6), SizeOf(Addr6)));
    end;
    else begin
      IPVersionUnsupported;
    end;
  end;
end;

procedure TIdStackWindows.GetPeerName(ASocket: TIdStackSocketHandle;
 var VIP: string; var VPort: Integer);
var
  i: Integer;
  LAddr: TSockAddrIn6;
begin
  i := SizeOf(LAddr);
  CheckForSocketError(IdWinsock2.GetPeerName(ASocket, PSockAddr(Pointer(@LAddr)), i));

  case LAddr.sin6_family of
    Id_PF_INET4: begin
      VIP := TranslateTInAddrToString(TSockAddr(Pointer(@LAddr)^).sin_addr,Id_IPv4);
      VPort := Ntohs(TSockAddr(Pointer(@LAddr)^).sin_port);
    end;
    Id_PF_INET6: begin
      VIP := TranslateTInAddrToString(LAddr.sin6_addr, Id_IPv6);
      VPort := Ntohs(LAddr.sin6_port);
    end;
    else begin
      IPVersionUnsupported;
    end;
  end;
end;

procedure TIdStackWindows.Disconnect(ASocket: TIdStackSocketHandle);
begin
  // Windows uses Id_SD_Send, Linux should use Id_SD_Both
  WSShutdown(ASocket, Id_SD_Send);
  // SO_LINGER is false - socket may take a little while to actually close after this
  WSCloseSocket(ASocket);
end;

procedure TIdStackWindows.SetSocketOption(
  const ASocket: TIdStackSocketHandle; const Alevel, Aoptname: Integer;
  Aoptval: PChar; const Aoptlen: Integer);
begin
  CheckForSocketError( setsockopt(ASocket,ALevel,Aoptname,Aoptval,Aoptlen ));
end;

procedure TIdStackWindows.GetSocketOption(ASocket: TIdStackSocketHandle;
  ALevel: TIdSocketOptionLevel; AOptName: TIdSocketOption;
  out AOptVal: Integer);
var LP : PAnsiChar;
  LLen : Integer;
  LBuf : Integer;
begin
  LP := Addr(LBuf);
  LLen := SizeOf(Integer);
  WSGetSockOpt(ASocket,ALevel,AOptName,LP,LLen);
  AOptVal := LBuf;
end;

function TIdStackWindows.SupportsIPv6:boolean; 
{
based on
http://groups.google.com/groups?q=Winsock2+Delphi+protocol&hl=en&lr=&ie=UTF-8&oe=utf-8&selm=3cebe697_2%40dnews&rnum=9
}
var LLen : Cardinal;
  LPInfo, LPCurPtr : LPWSAProtocol_Info;
  LCount : Integer;
  i : Integer;
begin
  Result := False;
  LLen:=0;
  IdWinsock2.WSAEnumProtocols(nil,nil,LLen);
  GetMem(LPInfo,LLen);
  try
    LCount := IdWinsock2.WSAEnumProtocols(nil,LPInfo,LLen);
    if LCount <> SOCKET_ERROR then
    begin
      LPCurPtr := LPInfo;
      for i := 0 to LCount-1 do
      begin
        Result := (LPCurPtr^.iAddressFamily=PF_INET6);
        if Result then
        begin
          Break;
        end;
        Inc(LPCurPtr);
      end;
    end;
  finally
    FreeMem(LPInfo);
  end;
end;



initialization
  GSocketListClass := TIdSocketListWindows;
  // Check if we are running under windows NT
  if (SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT) then begin
    GServeFileProc := ServeFile;
  end;
finalization
  if GStarted then begin
    WSACleanup;
  end;
end.