idstacklinux.pas

photo.163.com 相册下载器 多线程下载

  LAddr6: sockaddr_in6;
begin
  i := SizeOf(LAddr6);
  CheckForSocketError(GetSockName(ASocket, Psockaddr(@LAddr6)^, i));
  case LAddr6.sin6_family of
    Id_PF_INET4: begin
      VIP := TranslateTInAddrToString(Psockaddr(@LAddr6)^.sin_addr, Id_IPv4);
      VPort := Ntohs(Psockaddr(@LAddr6)^.sin_port);
    end;
    Id_PF_INET6: begin
      VIP := TranslateTInAddrToString(LAddr6.sin6_addr, Id_IPv6);
      VPort := Ntohs(LAddr6.sin6_port);
    end;
    else begin
      IPVersionUnsupported;
    end;
  end;
end;

procedure TIdStackLinux.WSGetSockOpt(ASocket: TIdStackSocketHandle; ALevel, AOptname: Integer; AOptval: PChar; var AOptlen: Integer);
begin
  CheckForSocketError(Libc.GetSockOpt(ASocket, ALevel, AOptname, AOptval, Cardinal(AOptlen)));
end;

procedure TIdStackLinux.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;


{ TIdSocketListLinux }

procedure TIdSocketListLinux.Add(AHandle: TIdStackSocketHandle);
begin
  lock;
  try
    if not FD_ISSET(AHandle, FFDSet) then begin
      if Count >= __FD_SETSIZE then begin
        raise EIdStackSetSizeExceeded.Create(RSSetSizeExceeded);
      end;
      FD_SET(AHandle, FFDSet);
      Inc(FCount);
    end;
  finally
    Unlock;
  end;
end;//

procedure TIdSocketListLinux.Clear;
begin
  lock;
  try
    FD_ZERO(FFDSet);
    FCount := 0;
  finally
    Unlock;
  end;
end;

function TIdSocketListLinux.Contains(
  AHandle: TIdStackSocketHandle): boolean;
begin
  lock; try
    Result := FD_ISSET(AHandle, FFDSet);
  finally Unlock; end;
end;

function TIdSocketListLinux.Count: Integer;
begin
  lock; try
    Result := FCount;
  finally Unlock; end;
end;//

class function TIdSocketListLinux.FDSelect(AReadSet, AWriteSet,
  AExceptSet: PFDSet; const ATimeout: Integer): integer;
var
  LTime: TTimeVal;
begin
  if ATimeout = IdTimeoutInfinite then begin
    Result := Libc.Select(MaxLongint, AReadSet, AWriteSet, AExceptSet, nil);
  end else begin
    LTime.tv_sec := ATimeout div 1000;
    LTime.tv_usec := (ATimeout mod 1000) * 1000;
    Result := Libc.Select(MaxLongint, AReadSet, AWriteSet, AExceptSet, @LTime);
  end;
end;

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

function TIdSocketListLinux.GetItem(AIndex: Integer): TIdStackSocketHandle;
var
  LIndex, i: Integer;
begin
  Result := 0;
  LIndex := 0;
  //? use FMaxHandle div x
  for i:= 0 to __FD_SETSIZE - 1 do begin
    if FD_ISSET(i, FFDSet) then begin
      if LIndex = AIndex then begin
        Result := i;
        break;
      end else begin
        Inc(LIndex);
      end;
    end;
  end;
End;//

procedure TIdSocketListLinux.Remove(AHandle: TIdStackSocketHandle);
begin
  Lock;
  try
    if FD_ISSET(AHandle, FFDSet) then begin
      Dec(FCount);
      FD_CLR(AHandle, FFDSet);
    end;
  finally
    Unlock;
  end;
end;//


function TIdStackLinux.WSTranslateSocketErrorMsg(const AErr: Integer): string;
begin
  //we override this function for the herr constants that
  //are returned by the DNS functions
  case AErr of
    Libc.HOST_NOT_FOUND: Result := RSStackHOST_NOT_FOUND;
    Libc.TRY_AGAIN: Result := RSStackTRY_AGAIN;
    Libc.NO_RECOVERY: Result := RSStackNO_RECOVERY;
    Libc.NO_DATA: Result := RSStackNO_DATA;
  else
    Result := inherited WSTranslateSocketErrorMsg(AErr);
  end;
end;

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

class function TIdSocketListLinux.Select(AReadList: TIdSocketList; AWriteList: TIdSocketList;
      AExceptList: TIdSocketList; const ATimeout: Integer = IdTimeoutInfinite): 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
      TIdSocketListLinux(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) >0;
  //
  TIdSocketListLinux(AReadList).SetFDSet(LReadSet);
  TIdSocketListLinux(AWriteList).SetFDSet(LWriteSet);
  TIdSocketListLinux(AExceptList).SetFDSet(LExceptSet);
end;

function TIdSocketListLinux.SelectRead(const ATimeout: Integer): Boolean;
var
  LSet: TFDSet;
begin
  Lock; try
    LSet := FFDSet;
    // select() updates this structure on return,
    // so we need to copy it each time we need it
  finally
    Unlock;
  end;
  Result := FDSelect(@LSet, nil, nil, ATimeout) > 0;
end;

function TIdSocketListLinux.SelectReadList(var VSocketList: TIdSocketList; const ATimeout: Integer = IdTimeoutInfinite): Boolean;
var
  LSet: TFDSet;
begin
  lock;
  try
    LSet := FFDSet;
    // select() updates this structure on return,
    // so we need to copy it each time we need it
  finally
    Unlock;
  end;
  Result := FDSelect(@LSet, nil, nil, ATimeout) > 0;
  if Result then begin
    if VSocketList = NIL then begin
      VSocketList := TIdSocketList.CreateSocketList;
    end;
    TIdSocketListLinux(VSocketList).SetFDSet(LSet);
  end;
end;

procedure TIdStackLinux.SetBlocking(ASocket: TIdStackSocketHandle;
  const ABlocking: Boolean);
begin
  if (ABlocking=False) then begin
    Raise EIdBlockingNotSupported.Create( RSStackNotSupportedOnLinux );
  end;
end;

(*
Why did I remove this again?

 1) it sends SIGPIPE even if the socket is created with the no-sigpipe bit set
    that could be solved by blocking sigpipe within this thread
    This is probably a bug in the Linux kernel, but we could work around it
    by blocking that signal for the time of sending the file (just get the
    sigprocmask, see if pipe bit is set, if not set it and remove again after
    sending the file)

But the more serious reason is another one, which exists in Windows too:
 2) I think that ServeFile is misdesigned:
    ServeFile does not raise an exception if it didn't send all the bytes.
    Now what happens if I have OnExecute assigned like this
      AThread.Connection.ServeFile('...', True); // <-- true to send via kernel
    is that it will return 0, but notice that in this case I didn't ask for the
    result. Net effect is that the thread will loop in OnExecute even if the
    socket is long gone. This doesn't fit Indy semantics at all, exceptions are
    always raised if the remote end disconnects. Even if I would do
      AThread.Connection.ServeFile('...', False);
    then it would raise an exception.
    I think this is a big flaw in the design of the ServeFile function.
    Maybe GServeFile should only return the bytes sent, but then
    TCPConnection.ServeFile() should raise an exception if GServeFile didn't
    send all the bytes.

JM Berg, 2002-09-09

function ServeFile(ASocket: TIdStackSocketHandle; AFileName: string): cardinal;
var
  LFileHandle: integer;
  offset: integer;
  stat: _stat;
begin
  LFileHandle := open(PChar(AFileName), O_RDONLY);
  try
    offset := 0;
    fstat(LFileHandle, stat);
    Result := sendfile(ASocket, LFileHandle, offset, stat.st_size);
//**    if Result = Cardinal(-1) then RaiseLastOSError;
  finally libc.__close(LFileHandle); end;
end;
*)
function TIdSocketListLinux.Clone: TIdSocketList;
begin
  Result := TIdSocketListLinux.Create;
  Lock; try
    TIdSocketListLinux(Result).SetFDSet(FFDSet);
  finally
    Unlock;
  end;
end;

function TIdStackLinux.WouldBlock(const AResult: Integer): Boolean;
begin
  //non-blocking does not exist in Linux, always indicate things will block
  Result := True;
end;

function TIdStackLinux.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
  //TODO: Implement Kylix version of this, it is very Windows-specific.
  Result := False;
{
  Result := False;
  LLen:=0;
  Libc.WSAEnumProtocols(nil,nil,LLen);
  GetMem(LPInfo,LLen);
  try
    LCount := Libc.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 := TIdSocketListLinux;
end.