TEvent.WaitFor在Kylix中

时间等待 在Linux较旧的线程实现(LinuxThreads,在2.4中引入NPTL之前)中被破坏。一些发行版仍然将Kylix可执行文件与那些较旧的库链接为向后兼容性垫片,因为Kylix不包含链接器期望的版本信息。FreePascal没有这个问题,因为它包含了版本信息,所以它总是与较新的线程库相链接。

我们通过投票和睡觉来解决这个问题。它既不漂亮也不高效,但它是TEvent.WaitFor的替代品:

var
  IsPThreadsBroken: Boolean;

function TEvent.WaitFor(Timeout: LongWord): TWaitResult;
{$IFDEF MSWINDOWS}
begin
  case WaitForSingleObject(Handle, Timeout) of
    WAIT_ABANDONED: Result := wrAbandoned;
    WAIT_OBJECT_0: Result := wrSignaled;
    WAIT_TIMEOUT: Result := wrTimeout;
    WAIT_FAILED:
      begin
        Result := wrError;
        FLastError := GetLastError;
      end;
  else
    Result := wrError;
  end;
{$ENDIF}
{$IFDEF LINUX}
const
  NanoPerSec = 1000000000;
  NanoPerMilli = 1000000;
  MilliPerSec = 1000;

  function sem_timedpollwait(var __sem: TSemaphore; const __abstime: timespec): Integer;

    function Elapsed(Current: TTimespec; Target: TTimespec): Boolean;
    begin
      Result := False;
      if (Current.tv_sec > Target.tv_sec) or
         ((Current.tv_sec = Target.tv_sec) and (Current.tv_nsec >= Target.tv_nsec)) then
        Result := True;
    end;

  var 
    CurrentTime, SleepTime: TTimespec;
    SemResult: Integer;
  begin
    Result := 0;
    //Try and grab the semaphore.
    if sem_trywait(FEvent)= 0 then 
      SemResult := 0
    else
      SemResult := errno;

    if (SemResult = EAGAIN) then 
    begin
      //not grabbed, wait a little while and try again.
      clock_gettime(CLOCK_REALTIME, CurrentTime);
      while (not Elapsed(CurrentTime, __abstime)) and (SemResult = EAGAIN) do
      begin
        SleepTime.tv_sec := 0;
        SleepTime.tv_nsec := NanoPerMilli; //sleep for ~1millisecond.
        if nanosleep(SleepTime, @CurrentTime) <> 0 then
          SemResult := errno
        else if sem_trywait(FEvent) = 0 then
          SemResult := 0
        else begin
          SemResult := errno;
          clock_gettime(CLOCK_REALTIME, CurrentTime);
          end;
        end;
      end;
    //we waited and still don't have the semaphore, time out.
    if SemResult = EAGAIN then 
      Result := ETIMEDOUT
    // else some other error occured.
    else if SemResult <> 0 then 
      Result := EINTR;
  end;

var
  WaitResult: Integer;
  abs_timeout: TTimeSpec;
begin
  Result := wrError;
  if (Timeout <> LongWord($FFFFFFFF)) and (Timeout <> 0) then begin
    if clock_gettime(CLOCK_REALTIME, abs_timeout) <> 0 then
      Exit;
    Inc(abs_timeout.tv_sec, Timeout div MilliPerSec);
    Inc(abs_timeout.tv_nsec, (Timeout mod MilliPerSec) * NanoPerMilli);
    if abs_timeout.tv_nsec >= NanoPerSec then
    begin
      Inc(abs_timeout.tv_sec);
      Dec(abs_timeout.tv_nsec, NanoPerSec);
    end;
  end;
  { Wait in a loop in case the syscall gets interrupted by GDB during debugging }
  repeat
    if Timeout = LongWord($FFFFFFFF) then
      WaitResult := sem_wait(FEvent)
    else if Timeout = 0 then
      WaitResult := sem_trywait(FEvent)
    else
    begin
      if IsPThreadsBroken then
        WaitResult := sem_timedpollwait(FEvent, abs_timeout)
      else
        WaitResult := sem_timedwait(FEvent, abs_timeout);
    end
  until (Result <> wrError) or (errno <> EINTR);
  if WaitResult = 0 then
  begin
    Result := wrSignaled;
    if FManualReset then
    begin
      FEventCS.Enter;
      try
        { the event might have been signaled between the sem_wait above and now
          so we reset it again }
        while sem_trywait(FEvent) = 0 do {nothing};
        sem_post(FEvent);
      finally
        FEventCS.Leave;
      end;
    end;
  end
  else if (errno = EAGAIN) or (errno = ETIMEDOUT) then
    Result := wrTimeout
  else
    Result := wrError;
{$ENDIF}
end;



const
  _CS_GNU_LIBC_VERSION = 2;
  _CS_GNU_LIBPTHREAD_VERSION = 3;
var 
  Len: size_t;
  ThreadLib: string;
initialization
  IsPThreadsBroken := True;
  Len := confstr(_CS_GNU_LIBPTHREAD_VERSION, nil, 0);
  if Len > 0 then begin
    SetLength(ThreadLib, Len - 1);
    confstr(_CS_GNU_LIBPTHREAD_VERSION, PChar(ThreadLib), Len);
    IsPThreadsBroken := Pos('linuxthreads', ThreadLib) <> 0
  end;
end.

在谷歌上搜索“kylix tevent.waitfor”,你会看到关于这个问题的各种帖子/讨论至少可以追溯到2002年。我还没有详细浏览过,但看起来 http://www.mswil.ch/websvn/filedetails.php?repname=devphp&path=%2Fcomponent%2FIndy9%2FSource%2FIdHL7.pas&sc=1 有一个补丁。

我查看了FPC源代码,使用了基于pthread\u cont\u timedwait的较新函数

http://svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/rtl/unix/cthreads.pp?view=markup 750线附近

(过程intBasiceventwaitfor和intRTLEventWaitForTimeout这些是各种.waitfor函数的原语)