jclsynch.pas

East make Tray Icon in delphi

    Handles[I] := Objects[I].Handle;
  Result := Windows.WaitForMultipleObjectsEx(Count, @Handles[0], WaitAll, TimeOut, True);
end;

//=== { TJclCriticalSection } ================================================

constructor TJclCriticalSection.Create;
begin
  inherited Create;
  Windows.InitializeCriticalSection(FCriticalSection);
end;

destructor TJclCriticalSection.Destroy;
begin
  Windows.DeleteCriticalSection(FCriticalSection);
  inherited Destroy;
end;

class procedure TJclCriticalSection.CreateAndEnter(var CS: TJclCriticalSection);
var
  NewCritSect: TJclCriticalSection;
begin
  NewCritSect := TJclCriticalSection.Create;
  if LockedCompareExchange(Pointer(CS), Pointer(NewCritSect), nil) <> nil then
  begin
    // LoadInProgress was <> nil -> no exchange took place, free the CS
    NewCritSect.Free;
  end;
  CS.Enter;
end;

procedure TJclCriticalSection.Enter;
begin
  Windows.EnterCriticalSection(FCriticalSection);
end;

procedure TJclCriticalSection.Leave;
begin
  Windows.LeaveCriticalSection(FCriticalSection);
end;

//== { TJclCriticalSectionEx } ===============================================

const
  DefaultCritSectSpinCount = 4000;

constructor TJclCriticalSectionEx.Create;
begin
  CreateEx(DefaultCritSectSpinCount, False);
end;

{ TODO: Use RTDL Version of InitializeCriticalSectionAndSpinCount }

constructor TJclCriticalSectionEx.CreateEx(SpinCount: Cardinal;
  NoFailEnter: Boolean);
begin
  FSpinCount := SpinCount;
  if NoFailEnter then
    SpinCount := SpinCount or Cardinal($80000000);

  if not InitializeCriticalSectionAndSpinCount(FCriticalSection, SpinCount) then
    raise EJclCriticalSectionError.CreateRes(@RsSynchInitCriticalSection);
end;

function TJclCriticalSectionEx.GetSpinCount: Cardinal;
begin
  // Spinning only makes sense on multiprocessor systems. On a single processor
  // system the thread would simply waste cycles while the owning thread is
  // suspended and thus cannot release the critical section.
  if ProcessorCount = 1 then
    Result := 0
  else
    Result := FSpinCount;
end;

class function TJclCriticalSectionEx.GetSpinTimeOut: Cardinal;
begin
  Result := Cardinal(RegReadInteger(HKEY_LOCAL_MACHINE, RegSessionManager,
    RegCritSecTimeout));
end;

{ TODO: Use RTLD version of SetCriticalSectionSpinCount }
procedure TJclCriticalSectionEx.SetSpinCount(const Value: Cardinal);
begin
  FSpinCount := SetCriticalSectionSpinCount(FCriticalSection, Value);
end;

class procedure TJclCriticalSectionEx.SetSpinTimeOut(const Value: Cardinal);
begin
  RegWriteInteger(HKEY_LOCAL_MACHINE, RegSessionManager, RegCritSecTimeout,
    Integer(Value));
end;

{ TODO: Use RTLD version of TryEnterCriticalSection }
function TJclCriticalSectionEx.TryEnter: Boolean;
begin
  Result := TryEnterCriticalSection(FCriticalSection);
end;

//== { TJclEvent } ===========================================================

constructor TJclEvent.Create(SecAttr: PSecurityAttributes;
  Manual, Signaled: Boolean; const Name: string);
begin
  inherited Create;
  FName := Name;
  FHandle := Windows.CreateEvent(SecAttr, Manual, Signaled, PChar(FName));
  if FHandle = 0 then
    raise EJclEventError.CreateRes(@RsSynchCreateEvent);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

constructor TJclEvent.Open(Access: Cardinal; Inheritable: Boolean;
  const Name: string);
begin
  FName := Name;
  FExisted := True;
  FHandle := Windows.OpenEvent(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclEventError.CreateRes(@RsSynchOpenEvent);
end;

function TJclEvent.Pulse: Boolean;
begin
  Result := Windows.PulseEvent(FHandle);
end;

function TJclEvent.ResetEvent: Boolean;
begin
  Result := Windows.ResetEvent(FHandle);
end;

function TJclEvent.SetEvent: Boolean;
begin
  Result := Windows.SetEvent(FHandle);
end;

//=== { TJclWaitableTimer } ==================================================

{ TODO: Use RTLD version of CreateWaitableTimer }
constructor TJclWaitableTimer.Create(SecAttr: PSecurityAttributes;
  Manual: Boolean; const Name: string);
begin
  FName := Name;
  FResume := False;
  FHandle := CreateWaitableTimer(SecAttr, Manual, PChar(Name));
  if FHandle = 0 then
    raise EJclWaitableTimerError.CreateRes(@RsSynchCreateWaitableTimer);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

{ TODO: Use RTLD version of CancelWaitableTimer }
function TJclWaitableTimer.Cancel: Boolean;
begin
  Result := CancelWaitableTimer(FHandle);
end;

{ TODO: Use RTLD version of OpenWaitableTimer }

constructor TJclWaitableTimer.Open(Access: Cardinal; Inheritable: Boolean;
  const Name: string);
begin
  FExisted := True;
  FName := Name;
  FResume := False;
  FHandle := OpenWaitableTimer(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclWaitableTimerError.CreateRes(@RsSynchOpenWaitableTimer);
end;

{ TODO: Use RTLD version of SetWaitableTimer }
function TJclWaitableTimer.SetTimer(const DueTime: Int64; Period: Longint;
  Resume: Boolean): Boolean;
var
  DT: Int64;
begin
  DT := DueTime;
  Result := SetWaitableTimer(FHandle, DT, Period, nil, nil, FResume);
end;

{ TODO -cHelp : OS restrictions }
function TJclWaitableTimer.SetTimerApc(const DueTime: Int64; Period: Longint;
  Resume: Boolean; Apc: TFNTimerAPCRoutine; Arg: Pointer): Boolean;
var
  DT: Int64;
begin
  DT := DueTime;
  Result := RtdlSetWaitableTimer(FHandle, DT, Period, Apc, Arg, FResume);
  { TODO : Exception for Win9x, older WinNT? }
  // if not Result and (GetLastError = ERROR_CALL_NOT_IMPLEMENTED) then
  //   RaiseLastOSError;
end;

//== { TJclSemaphore } =======================================================

constructor TJclSemaphore.Create(SecAttr: PSecurityAttributes;
  Initial, Maximum: Integer; const Name: string);
begin
  Assert((Initial >= 0) and (Maximum > 0));
  FName := Name;
  FHandle := Windows.CreateSemaphore(SecAttr, Initial, Maximum, PChar(Name));
  if FHandle = 0 then
    raise EJclSemaphoreError.CreateRes(@RsSynchCreateSemaphore);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

constructor TJclSemaphore.Open(Access: Cardinal; Inheritable: Boolean;
  const Name: string);
begin
  FName := Name;
  FExisted := True;
  FHandle := Windows.OpenSemaphore(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclSemaphoreError.CreateRes(@RsSynchOpenSemaphore);
end;

function TJclSemaphore.ReleasePrev(ReleaseCount: Longint;
  var PrevCount: Longint): Boolean;
begin
  Result := Windows.ReleaseSemaphore(FHandle, ReleaseCount, @PrevCount);
end;

function TJclSemaphore.Release(ReleaseCount: Integer): Boolean;
begin
  Result := Windows.ReleaseSemaphore(FHandle, ReleaseCount, nil);
end;

//=== { TJclMutex } ==========================================================

constructor TJclMutex.Create(SecAttr: PSecurityAttributes; InitialOwner: Boolean; const Name: string);
begin
  FName := Name;
  FHandle := JclWin32.CreateMutex(SecAttr, Ord(InitialOwner), PChar(Name));
  if FHandle = 0 then
    raise EJclMutexError.CreateRes(@RsSynchCreateMutex);
  FExisted := GetLastError = ERROR_ALREADY_EXISTS;
end;

constructor TJclMutex.Open(Access: Cardinal; Inheritable: Boolean; const Name: string);
begin
  FName := Name;
  FExisted := True;
  FHandle := Windows.OpenMutex(Access, Inheritable, PChar(Name));
  if FHandle = 0 then
    raise EJclMutexError.CreateRes(@RsSynchOpenMutex);
end;

function TJclMutex.Release: Boolean;
begin
  Result := Windows.ReleaseMutex(FHandle);
end;

//=== { TJclOptex } ==========================================================

constructor TJclOptex.Create(const Name: string; SpinCount: Integer);
begin
  FExisted := False;
  FName := Name;
  if Name = '' then
  begin
    // None shared optex, don't need filemapping, sharedinfo is local
    FFileMapping := 0;
    FEvent := TJclEvent.Create(nil, False, False, '');
    FSharedInfo := AllocMem(SizeOf(TOptexSharedInfo));
  end
  else
  begin
    // Shared optex, event protects access to sharedinfo. Creation of filemapping
    // doesn't need protection as it will automatically "open" instead of "create"
    // if another process already created it.
    FEvent := TJclEvent.Create(nil, False, False, 'Optex_Event_' + Name);
    FExisted := FEvent.Existed;
    FFileMapping := Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE,
      0, SizeOf(TOptexSharedInfo), PChar('Optex_MMF_' + Name));
    Assert(FFileMapping <> 0);
    FSharedInfo := Windows.MapViewOfFile(FFileMapping, FILE_MAP_WRITE, 0, 0, 0);
    Assert(FSharedInfo <> nil);
  end;
  SetSpinCount(SpinCount);
end;

destructor TJclOptex.Destroy;
begin
  FreeAndNil(FEvent);
  if UniProcess then
    FreeMem(FSharedInfo)
  else
  begin
    Windows.UnmapViewOfFile(FSharedInfo);
    Windows.CloseHandle(FFileMapping);
  end;
  inherited Destroy;
end;

procedure TJclOptex.Enter;
var
  ThreadId: Longword;
begin
  if TryEnter then
    Exit;
  ThreadId := Windows.GetCurrentThreadId;
  if Windows.InterlockedIncrement(FSharedInfo^.LockCount) = 1 then
  begin
    // Optex was unowned
    FSharedInfo^.ThreadId := ThreadId;
    FSharedInfo^.RecursionCount := 1;
  end
  else
  begin
    if FSharedInfo^.ThreadId = ThreadId then
    begin
      // We already owned it, increase ownership count
      Inc(FSharedInfo^.RecursionCount)
    end
    else
    begin
      // Optex is owner by someone else, wait for it to be released and then
      // immediately take ownership
      FEvent.WaitForever;
      FSharedInfo^.ThreadId := ThreadId;
      FSharedInfo^.RecursionCount := 1;
    end;
  end;
end;

function TJclOptex.GetSpinCount: Integer;
begin
  Result := FSharedInfo^.SpinCount;
end;

function TJclOptex.GetUniProcess: Boolean;
begin
  Result := FFileMapping = 0;
end;

procedure TJclOptex.Leave;
begin
  Dec(FSharedInfo^.RecursionCount);
  if FSharedInfo^.RecursionCount > 0 then
    Windows.InterlockedDecrement(FSharedInfo^.LockCount)
  else
  begin
    FSharedInfo^.ThreadId := 0;
    if Windows.InterlockedDecrement(FSharedInfo^.LockCount) > 0 then
      FEvent.SetEvent;
  end;
end;

procedure TJclOptex.SetSpinCount(Value: Integer);
begin
  if Value < 0 then
    Value := DefaultCritSectSpinCount;
  // Spinning only makes sense on multiprocessor systems
  if ProcessorCount > 1 then
    Windows.InterlockedExchange(Integer(FSharedInfo^.SpinCount), Value);
end;

function TJclOptex.TryEnter: Boolean;
var
  ThreadId: Longword;
  ThreadOwnsOptex: Boolean;
  SpinCount: Integer;
begin
  ThreadId := Windows.GetCurrentThreadId;
  SpinCount := FSharedInfo^.SpinCount;
  repeat
    //ThreadOwnsOptex := InterlockedCompareExchange(Pointer(FSharedInfo^.LockCount),
    //  Pointer(1), Pointer(0)) = Pointer(0); // not available on win95
    ThreadOwnsOptex := LockedCompareExchange(FSharedInfo^.LockCount, 1, 0) = 0;
    if ThreadOwnsOptex then
    begin
      // Optex was unowned
      FSharedInfo^.ThreadId := ThreadId;
      FSharedInfo^.RecursionCount := 1;
    end
    else
    begin
      if FSharedInfo^.ThreadId = ThreadId then
      begin
        // We already owned the Optex
        Windows.InterlockedIncrement(FSharedInfo^.LockCount);
        Inc(FSharedInfo^.RecursionCount);
        ThreadOwnsOptex := True;
      end;
    end;
    Dec(SpinCount);
  until ThreadOwnsOptex or (SpinCount <= 0);
  Result := ThreadOwnsOptex;
end;

//=== { TJclMultiReadExclusiveWrite } ========================================

constructor TJclMultiReadExclusiveWrite.Create(Preferred: TMrewPreferred);
begin
  inherited Create;
  FLock := TJclCriticalSection.Create;
  FPreferred := Preferred;
  FSemReaders := TJclSemaphore.Create(nil, 0, MaxInt, '');
  FSemWriters := TJclSemaphore.Create(nil, 0, MaxInt, '');
  SetLength(FThreads, 0);
  FState := 0;
  FWaitingReaders := 0;
  FWaitingWriters := 0;
end;

destructor TJclMultiReadExclusiveWrite.Destroy;
begin
  FreeAndNil(FSemReaders);
  FreeAndNil(FSemWriters);
  FreeAndNil(FLock);
  inherited Destroy;
end;

procedure TJclMultiReadExclusiveWrite.AddToThreadList(ThreadId: Longword;
  Reader: Boolean);
var
  L: Integer;
begin
  // Caller must own lock
  L := Length(FThreads);
  SetLength(FThreads, L + 1);
  FThreads[L].ThreadId := ThreadId;
  FThreads[L].RecursionCount := 1;
  FThreads[L].Reader := Reader;
end;

procedure TJclMultiReadExclusiveWrite.BeginRead;
var
  ThreadId: Longword;
  Index: Integer;
  MustWait: Boolean;
begin
  MustWait := False;
  ThreadId := Windows.GetCurrentThreadId;
  FLock.Enter;
  try
    Index := FindThread(ThreadId);
    if Index >= 0 then
    begin
      // Thread is on threadslist so it is already reading
      Inc(FThreads[Index].RecursionCount);
    end
    else
    begin
      // Request to read (first time)
      AddToThreadList(ThreadId, True);
      if FState >= 0 then
      begin
        // MREW is unowned or only readers. If there are no waiting writers or
        // readers are preferred then allow thread to continue, otherwise it must
        // wait it's turn
        if (FPreferred = mpReaders) or (FWaitingWriters = 0) then
          Inc(FState)
        else
        begin
          Inc(FWaitingReaders);
          MustWait := True;
        end;
      end
      else
      begin
        // MREW is owner by a writer, must wait
        Inc(FWaitingReaders);
        MustWait := True;
      end;
    end;
  finally
    FLock.Leave;
  end;
  if MustWait then
    FSemReaders.WaitForever;
end;

procedure TJclMultiReadExclusiveWrite.BeginWrite;
var
  ThreadId: Longword;
  Index: Integer;