jclsynch.pas

East make Tray Icon in delphi

  MustWait: Boolean;
begin
  MustWait := False;
  FLock.Enter;
  try
    ThreadId := Windows.GetCurrentThreadId;
    Index := FindThread(ThreadId);
    if Index < 0 then
    begin
      // Request to write (first time)
      AddToThreadList(ThreadId, False);
      if FState = 0 then
      begin
        // MREW is unowned so start writing
        FState := -1;
      end
      else
      begin
        // MREW is owner, must wait
        Inc(FWaitingWriters);
        MustWait := True;
      end;
    end
    else
    begin
      if FThreads[Index].Reader then
      begin
        // Request to write while reading
        Inc(FThreads[Index].RecursionCount);
        FThreads[Index].Reader := False;
        Dec(FState);
        if FState = 0 then
        begin
          // MREW is unowned so start writing
          FState := -1;
        end
        else
        begin
          // MREW is owned, must wait
          MustWait := True;
          Inc(FWaitingWriters);
        end;
      end
      else
        // Requesting to write while already writing
        Inc(FThreads[Index].RecursionCount);
    end;
  finally
    FLock.Leave;
  end;
  if MustWait then
    FSemWriters.WaitFor(INFINITE);
end;

procedure TJclMultiReadExclusiveWrite.EndRead;
begin
  Release;
end;

procedure TJclMultiReadExclusiveWrite.EndWrite;
begin
  Release;
end;

function TJclMultiReadExclusiveWrite.FindThread(ThreadId: Longword): Integer;
var
  I: Integer;
begin
  // Caller must lock
  Result := -1;
  for I := 0 to Length(FThreads) - 1 do
    if FThreads[I].ThreadId = ThreadId then
    begin
      Result := I;
      Exit;
    end;
end;

procedure TJclMultiReadExclusiveWrite.Release;
var
  ThreadId: Longword;
  Index: Integer;
  WasReading: Boolean;
begin
  ThreadId := GetCurrentThreadId;
  FLock.Enter;
  try
    Index := FindThread(ThreadId);
    if Index >= 0 then
    begin
      Dec(FThreads[Index].RecursionCount);
      if FThreads[Index].RecursionCount = 0 then
      begin
        WasReading := FThreads[Index].Reader;
        if WasReading then
          Dec(FState)
        else
          FState := 0;
        RemoveFromThreadList(Index);
        if FState = 0 then
          ReleaseWaiters(WasReading);
      end;
    end;
  finally
    FLock.Leave;
  end;
end;

procedure TJclMultiReadExclusiveWrite.ReleaseWaiters(WasReading: Boolean);
var
  ToRelease: TMrewPreferred;
begin
  // Caller must Lock
  ToRelease := mpEqual;
  case FPreferred of
    mpReaders:
      if FWaitingReaders > 0 then
        ToRelease := mpReaders
      else
      if FWaitingWriters > 0 then
        ToRelease := mpWriters;
    mpWriters:
      if FWaitingWriters > 0 then
        ToRelease := mpWriters
      else
      if FWaitingReaders > 0 then
        ToRelease := mpReaders;
    mpEqual:
      if WasReading then
      begin
        if FWaitingWriters > 0 then
          ToRelease := mpWriters
        else
        if FWaitingReaders > 0 then
          ToRelease := mpReaders;
      end
      else
      begin
        if FWaitingReaders > 0 then
          ToRelease := mpReaders
        else
        if FWaitingWriters > 0 then
          ToRelease := mpWriters;
      end;
  end;
  case ToRelease of
    mpReaders:
      begin
        FState := FWaitingReaders;
        FWaitingReaders := 0;
        FSemReaders.Release(FState);
      end;
    mpWriters:
      begin
        FState := -1;
        Dec(FWaitingWriters);
        FSemWriters.Release(1);
      end;
    mpEqual:
      // no waiters
  end;
end;

procedure TJclMultiReadExclusiveWrite.RemoveFromThreadList(Index: Integer);
var
  L: Integer;
begin
  // Caller must Lock
  L := Length(FThreads);
  Move(FThreads[Index + 1], FThreads[Index], SizeOf(TMrewThreadInfo) * (L - Index - 1));
  SetLength(FThreads, L - 1);
end;

//=== { TJclMeteredSection } =================================================

const
  MAX_METSECT_NAMELEN = 128;

constructor TJclMeteredSection.Create(InitialCount, MaxCount: Integer; const Name: string);
begin
  if (MaxCount < 1) or (InitialCount > MaxCount) or (InitialCount < 0) or
    (Length(Name) > MAX_METSECT_NAMELEN) then
    raise EJclMeteredSectionError.CreateRes(@RsMetSectInvalidParameter);
  FMetSect := PMeteredSection(AllocMem(SizeOf(TMeteredSection)));
  if FMetSect <> nil then
  begin
    if not InitMeteredSection(InitialCount, MaxCount, Name, False) then
    begin
      CloseMeteredSection;
      FMetSect := nil;
      raise EJclMeteredSectionError.CreateRes(@RsMetSectInitialize);
    end;
  end;
end;

constructor TJclMeteredSection.Open(const Name: string);
begin
  FMetSect := nil;
  if Name = '' then
    raise EJclMeteredSectionError.CreateRes(@RsMetSectNameEmpty);
  FMetSect := PMeteredSection(AllocMem(SizeOf(TMeteredSection)));
  Assert(FMetSect <> nil);
  if not InitMeteredSection(0, 0, Name, True) then
  begin
    CloseMeteredSection;
    FMetSect := nil;
    raise EJclMeteredSectionError.CreateRes(@RsMetSectInitialize);
  end;
end;

destructor TJclMeteredSection.Destroy;
begin
  CloseMeteredSection;
  inherited Destroy;
end;

procedure TJclMeteredSection.AcquireLock;
begin
  while Windows.InterlockedExchange(FMetSect^.SharedInfo^.SpinLock, 1) <> 0 do
    Windows.Sleep(0);
end;

procedure TJclMeteredSection.CloseMeteredSection;
begin
  if FMetSect <> nil then
  begin
    if FMetSect^.SharedInfo <> nil then
      Windows.UnmapViewOfFile(FMetSect^.SharedInfo);
    if FMetSect^.FileMap <> 0 then
      Windows.CloseHandle(FMetSect^.FileMap);
    if FMetSect^.Event <> 0 then
      Windows.CloseHandle(FMetSect^.Event);
    FreeMem(FMetSect);
  end;
end;

function TJclMeteredSection.CreateMetSectEvent(const Name: string; OpenOnly: Boolean): Boolean;
var
  FullName: string;
begin
  if Name = '' then
    FMetSect^.Event := Windows.CreateEvent(nil, False, False, nil)
  else
  begin
    FullName :=  'JCL_MSECT_EVT_' + Name;
    if OpenOnly then
      FMetSect^.Event := Windows.OpenEvent(0, False, PChar(FullName))
    else
      FMetSect^.Event := Windows.CreateEvent(nil, False, False, PChar(FullName));
  end;
  Result := FMetSect^.Event <> 0;
end;

function TJclMeteredSection.CreateMetSectFileView(InitialCount, MaxCount: Longint;
  const Name: string; OpenOnly: Boolean): Boolean;
var
  FullName: string;
  LastError: DWORD;
begin
  Result := False;
  if Name = '' then
    FMetSect^.FileMap := Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TMetSectSharedInfo), nil)
  else
  begin
    FullName := 'JCL_MSECT_MMF_' + Name;
    if OpenOnly then
      FMetSect^.FileMap := Windows.OpenFileMapping(0, False, PChar(FullName))
    else
      FMetSect^.FileMap := Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TMetSectSharedInfo), PChar(FullName));
  end;
  if FMetSect^.FileMap <> 0 then
  begin
    LastError := GetLastError;
    FMetSect^.SharedInfo := Windows.MapViewOfFile(FMetSect^.FileMap, FILE_MAP_WRITE, 0, 0, 0);
    if FMetSect^.SharedInfo <> nil then
    begin
      if LastError = ERROR_ALREADY_EXISTS then
        while not FMetSect^.SharedInfo^.Initialized do Sleep(0)
      else
      begin
        FMetSect^.SharedInfo^.SpinLock := 0;
        FMetSect^.SharedInfo^.ThreadsWaiting := 0;
        FMetSect^.SharedInfo^.AvailableCount := InitialCount;
        FMetSect^.SharedInfo^.MaximumCount := MaxCount;
        Windows.InterlockedExchange(Integer(FMetSect^.SharedInfo^.Initialized), 1);
      end;
      Result := True;
    end;
  end;
end;

function TJclMeteredSection.Enter(TimeOut: Longword): TJclWaitResult;
begin
  Result := wrSignaled;
  while Result = wrSignaled do
  begin
    AcquireLock;
    try
      if FMetSect^.SharedInfo^.AvailableCount >= 1 then
      begin
        Dec(FMetSect^.SharedInfo^.AvailableCount);
        Result := MapSignalResult(WAIT_OBJECT_0);
        Exit;
      end;
      Inc(FMetSect^.SharedInfo^.ThreadsWaiting);
      Windows.ResetEvent(FMetSect^.Event);
    finally
      ReleaseLock;
    end;
    Result := MapSignalResult(Windows.WaitForSingleObject(FMetSect^.Event, TimeOut));
  end;
end;

function TJclMeteredSection.InitMeteredSection(InitialCount, MaxCount: Longint;
  const Name: string; OpenOnly: Boolean): Boolean;
begin
  Result := False;
  if CreateMetSectEvent(Name, OpenOnly) then
    Result := CreateMetSectFileView(InitialCount, MaxCount, Name, OpenOnly);
end;

function TJclMeteredSection.Leave(ReleaseCount: Integer; var PrevCount: Integer): Boolean;
var
  Count: Integer;
begin
  Result := False;
  AcquireLock;
  try
    PrevCount := FMetSect^.SharedInfo^.AvailableCount;
    if (ReleaseCount < 0) or
      (FMetSect^.SharedInfo^.AvailableCount + ReleaseCount > FMetSect^.SharedInfo^.MaximumCount) then
    begin
      Windows.SetLastError(ERROR_INVALID_PARAMETER);
      Exit;
    end;
    Inc(FMetSect^.SharedInfo^.AvailableCount, ReleaseCount);
    ReleaseCount := Min(ReleaseCount, FMetSect^.SharedInfo^.ThreadsWaiting);
    if FMetSect^.SharedInfo^.ThreadsWaiting > 0 then
    begin
      for Count := 0 to ReleaseCount - 1 do
      begin
        Dec(FMetSect^.SharedInfo^.ThreadsWaiting);
        Windows.SetEvent(FMetSect^.Event);
      end;
    end;
  finally
    ReleaseLock;
  end;
  Result := True;
end;

function TJclMeteredSection.Leave(ReleaseCount: Integer): Boolean;
var
  Previous: Longint;
begin
  Result := Leave(ReleaseCount, Previous);
end;

procedure TJclMeteredSection.ReleaseLock;
begin
  Windows.InterlockedExchange(FMetSect^.SharedInfo^.SpinLock, 0);
end;

//=== Debugging ==============================================================

function QueryCriticalSection(CS: TJclCriticalSection; var Info: TRTLCriticalSection): Boolean;
begin
  Result := CS <> nil;
  if Result then
    Info := CS.FCriticalSection;
end;

// Native API functions
// http://undocumented.ntinternals.net/

{ TODO: RTLD version }

type
 TNtQueryProc = function (Handle: THandle; InfoClass: Byte; Info: Pointer;
     Len: Longint; ResLen: PLongint): Longint; stdcall;

 var
   _QueryEvent: TNtQueryProc = nil;
   _QueryMutex: TNtQueryProc = nil;
   _QuerySemaphore: TNtQueryProc = nil;
   _QueryTimer: TNtQueryProc = nil;

 function CallQueryProc(var P: TNtQueryProc; const Name: string; Handle: THandle;
   Info: Pointer; InfoSize: Longint): Boolean;
 var
   NtDll: THandle;
   Status: Longint;
 begin
   Result := False;
   if @P = nil then
   begin
     NtDll := GetModuleHandle(PChar('ntdll.dll'));
     if NtDll <> 0 then
       @P := GetProcAddress(NtDll, PChar(Name));
   end;
   if @P <> nil then
   begin
     Status := P(Handle, 0, Info, InfoSize, nil);
     Result := (Status and $80000000) = 0;
   end;
 end;

function QueryEvent(Handle: THandle; var Info: TEventInfo): Boolean;
begin
  Result := CallQueryProc(_QueryEvent, 'NtQueryEvent', Handle, @Info, SizeOf(Info));
end;

function QueryMutex(Handle: THandle; var Info: TMutexInfo): Boolean;
begin
  Result := CallQueryProc(_QueryMutex, 'NtQueryMutex', Handle, @Info, SizeOf(Info));
end;

function QuerySemaphore(Handle: THandle; var Info: TSemaphoreCounts): Boolean;
begin
  Result := CallQueryProc(_QuerySemaphore, 'NtQuerySemaphore', Handle, @Info, SizeOf(Info));
end;

function QueryTimer(Handle: THandle; var Info: TTimerInfo): Boolean;
begin
  Result := CallQueryProc(_QueryTimer, 'NtQueryTimer', Handle, @Info, SizeOf(Info));
end;

// History:

// $Log: JclSynch.pas,v $
// Revision 1.17  2005/03/08 08:33:23  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.16  2005/03/04 06:40:26  marquardt
// changed overloaded constructors to constructor with default parameter (BCB friendly)
//
// Revision 1.15  2005/02/24 16:34:53  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.14  2004/10/21 08:40:11  marquardt
// style cleaning
//
// Revision 1.13  2004/10/17 23:09:37  mthoma
// More cleaning. Removing RTLD versions of some functions.
//
// Revision 1.12  2004/10/17 21:00:16  mthoma
// cleaning
//
// Revision 1.11  2004/08/01 11:40:23  marquardt
// move constructors/destructors
//
// Revision 1.10  2004/07/28 18:00:54  marquardt
// various style cleanings, some minor fixes
//
// Revision 1.9  2004/07/26 03:47:36  rrossmair
// replaced SetCriticalSectionSpinCount by RtdlSetCriticalSectionSpinCount to make it Win95 compatible
//
// Revision 1.8  2004/06/02 03:23:47  rrossmair
// cosmetic changes in several units (code formatting, help TODOs processed etc.)
//
// Revision 1.7  2004/05/09 10:13:38  ahuser
// Better Delphi 7.1 fix that does not throw hints for older versions
//
// Revision 1.6  2004/05/07 19:29:09  ahuser
// Fix for Delphi 7.1 compiler warning bug.
//
// Revision 1.5  2004/05/05 07:33:49  rrossmair
// header updated according to new policy: initial developers & contributors listed
//
// Revision 1.4  2004/04/06 04:55:18  
// adapt compiler conditions, add log entry
//

end.