{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 1997-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.SyncObjs platform;

{$H+,X+}

interface

uses
  Windows, SysUtils, Classes;

type
  TSynchroObject = class(TObject)
  public
    procedure Acquire; virtual;
    procedure Release; virtual;
  end;

  TWaitResult = (wrSignaled, wrTimeout, wrAbandoned, wrError);

  THandleObject = class(TSynchroObject)
  protected
    FHandle: THandle;
    FLastError: Integer;
    FUseCOMWait: Boolean;
  strict protected
    procedure Finalize; override;
  public
    { Specify UseCOMWait to ensure that when blocked waiting for the object
      any STA COM calls back into this thread can be made. }
    constructor Create(UseCOMWait: Boolean = False);
    destructor Destroy; override;
    function WaitFor(Timeout: LongWord): TWaitResult; virtual;
    property LastError: Integer read FLastError;
    property Handle: THandle read FHandle;
  end;

  TEvent = class(THandleObject)
  public
    constructor Create(var EventAttributes: TSecurityAttributes; ManualReset,
      InitialState: Boolean; const Name: string; UseCOMWait: Boolean = False); overload;
    constructor Create(EventAttributes: IntPtr; ManualReset,
      InitialState: Boolean; const Name: string; UseCOMWait: Boolean = False); overload;
    constructor Create(UseCOMWait: Boolean = False); overload;
    procedure SetEvent;
    procedure ResetEvent;
  end;

  TSimpleEvent = class(TEvent);

  TMutex = class(THandleObject)
  public
    constructor Create(UseCOMWait: Boolean = False); overload;
    constructor Create(var MutexAttributes: TSecurityAttributes;
      InitialOwner: Boolean; const Name: string; UseCOMWait: Boolean = False); overload;
    constructor Create(MutexAttributes: IntPtr;
      InitialOwner: Boolean; const Name: string; UseCOMWait: Boolean = False); overload;
    constructor Create(DesiredAccess: LongWord; InheritHandle: Boolean; const Name: string; UseCOMWait: Boolean = False); overload;
    procedure Acquire; override;
    procedure Release; override;
  end;

  TCriticalSection = class(TSynchroObject)
  strict protected
    FSection: TRTLCriticalSection;
    FValid: Boolean;
    procedure Finalize; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Acquire; override;
    procedure Release; override;
    function TryEnter: Boolean;
    procedure Enter;
    procedure Leave;
  end;

implementation

uses
  System.Runtime.InteropServices;

type
  TCoWaitForMultipleHandlesProc = function (dwFlags: DWORD; dwTimeOut: DWORD;
    cHandles: LongWord; lpHandles: array of THandle; var lpdwIndex: DWORD): HRESULT;

var
  CanCoWaitForMultipleHandles: Boolean;
  CoWaitChecked: Boolean = False;

[DllImport('ole32.dll', CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'CoWaitForMultipleHandles')] // do not localize
function _CoWaitForMultipleHandles(dwFlags: DWORD; dwTimeOut: DWORD;
    cHandles: LongWord; lpHandles: array of THandle; var lpdwIndex: DWORD): HRESULT; external;

threadvar
  OleThreadWnd: HWND;

const
  OleThreadWndClassName = 'OleMainThreadWndClass'; //do not localize
  COWAIT_WAITALL = $00000001;
  COWAIT_ALERTABLE = $00000002;

function GetOleThreadWindow: HWND;
var
  ChildWnd: HWND;
  ParentWnd: HWND;
begin
  if (OleThreadWnd = 0) or not IsWindow(OleThreadWnd) then
  begin
    if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then
      ParentWnd := HWND(HWND_MESSAGE)
    else
      ParentWnd := 0;
    ChildWnd := 0;
    repeat
      OleThreadWnd := FindWindowEx(ParentWnd, ChildWnd, OleThreadWndClassName, nil);
      ChildWnd := OleThreadWnd;
    until (OleThreadWnd = 0) or (GetWindowThreadProcessId(OleThreadWnd, nil) = GetCurrentThreadId);
  end;
  Result := OleThreadWnd;
end;

function InternalCoWaitForMultipleHandles(dwFlags: DWORD; dwTimeOut: DWORD;
  cHandles: LongWord; lpHandles: array of THandle; var lpdwIndex: DWORD): HRESULT;
var
  WaitResult: DWORD;
  OleThreadWnd: HWnd;
  Msg: TMsg;
begin
  WaitResult := 0; // supress warning
  OleThreadWnd := GetOleThreadWindow;
  if OleThreadWnd <> 0 then
    while True do
    begin
      WaitResult := MsgWaitForMultipleObjectsEx(cHandles, lpHandles, dwTimeOut, QS_ALLEVENTS, dwFlags);
      if WaitResult = WAIT_OBJECT_0 + cHandles then
      begin
        if PeekMessage(Msg, OleThreadWnd, 0, 0, PM_REMOVE) then
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
      end else
        Break;
    end
  else
    WaitResult := WaitForMultipleObjectsEx(cHandles, lpHandles,
      dwFlags and COWAIT_WAITALL <> 0, dwTimeOut, dwFlags and COWAIT_ALERTABLE <> 0);
  if WaitResult = WAIT_TIMEOUT then
    Result := RPC_E_TIMEOUT
  else if WaitResult = WAIT_IO_COMPLETION then
    Result := RPC_S_CALLPENDING
  else
  begin
    Result := S_OK;
    if (WaitResult >= WAIT_ABANDONED_0) and (WaitResult < WAIT_ABANDONED_0 + cHandles) then
      lpdwIndex := WaitResult - WAIT_ABANDONED_0
    else
      lpdwIndex := WaitResult - WAIT_OBJECT_0;
  end;
end;

function CoWaitForMultipleHandles(dwFlags: DWORD; dwTimeOut: DWORD;
  cHandles: LongWord; Handles: array of THandle; var lpdwIndex: DWORD): HRESULT;

  procedure LookupProc;
  var
    Ole32Handle: HMODULE;
  begin
    CoWaitChecked := True;
    Ole32Handle := GetModuleHandle('ole32.dll'); //do not localize
    if Ole32Handle <> 0 then
      CanCoWaitForMultipleHandles := GetProcAddress(Ole32Handle, 'CoWaitForMultipleHandles') <> nil; { do not localize}
  end;

begin
  if not CoWaitChecked then
    LookupProc;
  if CanCoWaitForMultipleHandles then
    Result := _CoWaitForMultipleHandles(dwFlags, dwTimeOut, cHandles, Handles, lpdwIndex)
  else
    Result := InternalCoWaitForMultipleHandles(dwFlags, dwTimeOut, cHandles, Handles, lpdwIndex);
end;

{ TSynchroObject }

procedure TSynchroObject.Acquire;
begin
end;

procedure TSynchroObject.Release;
begin
end;

{ THandleObject }

constructor THandleObject.Create(UseComWait: Boolean);
begin
  inherited Create;
  FUseCOMWait := UseCOMWait;
end;

procedure THandleObject.Finalize;
begin
  if FHandle <> 0 then
    CloseHandle(FHandle);
  inherited;
end;

destructor THandleObject.Destroy;
begin
  if FHandle <> 0 then
    CloseHandle(FHandle);
  FHandle := 0;
  System.GC.SuppressFinalize(self);
  inherited;
end;

function THandleObject.WaitFor(Timeout: LongWord): TWaitResult;
var
  Index: DWORD;
begin
  if FUseCOMWait then
  begin
    case CoWaitForMultipleHandles(0, TimeOut, 1, FHandle, Index) of
      S_OK: Result := wrSignaled;
      RPC_S_CALLPENDING,
      RPC_E_TIMEOUT: Result := wrTimeout;
    else
      Result := wrError;
      FLastError := GetLastError;
    end;
  end else
  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;
  end;
end;

{ TEvent }

constructor TEvent.Create(var EventAttributes: TSecurityAttributes; ManualReset,
  InitialState: Boolean; const Name: string; UseCOMWait: Boolean);
begin
  inherited Create(UseCOMWait);
  FHandle := CreateEvent(EventAttributes, ManualReset, InitialState, Name);
end;

constructor TEvent.Create(EventAttributes: IntPtr; ManualReset,
  InitialState: Boolean; const Name: string; UseCOMWait: Boolean);
begin
  inherited Create(UseCOMWait);
  FHandle := CreateEvent(EventAttributes, ManualReset, InitialState, Name);
end;

constructor TEvent.Create(UseCOMWait: Boolean);
begin
  Create(nil, True, False, '', UseCOMWait);
end;

procedure TEvent.SetEvent;
begin
  Windows.SetEvent(Handle);
end;

procedure TEvent.ResetEvent;
begin
  Windows.ResetEvent(Handle);
end;

{ TCriticalSection }

constructor TCriticalSection.Create;
begin
  inherited Create;
  InitializeCriticalSection(FSection);
  FValid := True;
end;

procedure TCriticalSection.Finalize;
begin
  if FValid then
    DeleteCriticalSection(FSection);
  inherited;
end;

destructor TCriticalSection.Destroy;
begin
  if FValid then
  begin
    DeleteCriticalSection(FSection);
    FValid := False;
  end;
  System.GC.SuppressFinalize(self);
  inherited;
end;

procedure TCriticalSection.Acquire;
begin
  EnterCriticalSection(FSection);
end;

procedure TCriticalSection.Release;
begin
  LeaveCriticalSection(FSection);
end;

function TCriticalSection.TryEnter: Boolean;
begin
  Result := TryEnterCriticalSection(FSection);
end;

procedure TCriticalSection.Enter;
begin
  Acquire;
end;

procedure TCriticalSection.Leave;
begin
  Release;
end;

{ TMutex }

procedure TMutex.Acquire;
begin
  if WaitFor(INFINITE) = wrError then
    RaiseLastOSError;
end;

constructor TMutex.Create(UseCOMWait: Boolean);
begin
  Create(nil, False, '', UseCOMWait);
end;

constructor TMutex.Create(var MutexAttributes: TSecurityAttributes;
  InitialOwner: Boolean; const Name: string; UseCOMWait: Boolean);
begin
  inherited Create(UseCOMWait);
  FHandle := CreateMutex(MutexAttributes, InitialOwner, Name);
  if FHandle = 0 then
    RaiseLastOSError;
end;

constructor TMutex.Create(MutexAttributes: IntPtr;
  InitialOwner: Boolean; const Name: string; UseCOMWait: Boolean);
begin
  inherited Create(UseCOMWait);
  FHandle := CreateMutex(MutexAttributes, InitialOwner, Name);
  if FHandle = 0 then
    RaiseLastOSError;
end;

constructor TMutex.Create(DesiredAccess: LongWord; InheritHandle: Boolean;
  const Name: string; UseCOMWait: Boolean);
begin
  inherited Create(UseCOMWait);
  FHandle := OpenMutex(DesiredAccess, InheritHandle, Name);
  if FHandle = 0 then
    RaiseLastOSError;
end;

procedure TMutex.Release;
begin
  if not ReleaseMutex(FHandle) then
    RaiseLastOSError;
end;

end.
