unaclasses.pas

Voice Commnucation Components for Delphi

    function lock(): int;
    procedure unlock();
    //
    property data: pointer read f_data;
  end;


  //
  // -- unaMappedMemory --
  //

  {DP:CLASS
    This is wrapper class for the Windows mapped memory mechanism.
  }
  unaMappedMemory = class(unaObject)
  private
    f_doOpen: bool;
    f_access: DWORD;
    f_canCreate: bool;
    f_handle: tHandle;
    f_name: wideString;
    f_data: pArray;
    f_size: unsigned;
    f_fileHandle: tHandle;
    //
    procedure setSize(value: unsigned);
  protected
    function open2(access: DWORD = PAGE_READWRITE): bool; virtual;
    procedure close2(); virtual;
    procedure doSetNewSize(newValue: unsigned); virtual;
  public
    constructor create(const name: wideString; size: unsigned = 0; access: DWORD = PAGE_READWRITE; doOpen: bool = true; canCreate: bool = true);
    procedure AfterConstruction(); override;
    procedure BeforeDestruction(); override;
    //
    function open(access: DWORD = PAGE_READWRITE): bool;
    procedure close();
    //
    function read(buf: pointer; sz: unsigned): unsigned;
    function write(buf: pointer; sz: unsigned): unsigned;
    function flush(): bool;
    function getDataPtr(offset: unsigned): pointer;
    //
    property data: pArray read f_data;
    property size: unsigned read f_size write setSize;
    property handle: tHandle read f_handle;
  end;


  //
  // -- unaMappedFile --
  //

  {DP:CLASS
    This is wrapper class for the Windows mapped files mechanism.
  }
  unaMappedFile = class(unaMappedMemory)
  private
    f_fileName: wideString;
  protected
    function open2(access: DWORD = PAGE_READWRITE): bool; override;
    procedure close2(); override;
  public
    constructor create(const fileName: wideString; access: DWORD = PAGE_READWRITE; doOpen: bool = true; size: int = 0);
    //
    function openFile(const fileName: wideString; access: DWORD = PAGE_READWRITE; size: int = 0): bool;
    //
    function ensureSize(value: int): bool;
  end;


  //
  // -- unaConsoleApp --
  //

  {DP:CLASS
    This class encapsulates basic Windows console application.
  }
  unaConsoleApp = class(unaThread)
  private
    f_ok: bool;
    f_consoleInfo: CONSOLE_SCREEN_BUFFER_INFO;
    f_inHandle: tHandle;
    f_outHandle: tHandle;
    //
    function getConsoleInfo(): pConsoleScreenBufferInfo;
  protected
    f_executeComplete: bool;
    //
    {DP:METHOD
      You can override this method to perform additional initialization.
      <BR />If this method returns false the application will not be started.
    }
    function doInit(): bool; virtual;
    {DP:METHOD
      Processes Windows messages until the thread terminates.
    }
    function execute(globalIndex: unsigned): int; override;
  public
    {DP:METHOD
      Creates console application class. You can specify caption, icon and text attributes to be used in the console box initialization.
    }
    constructor create(const caption: wideString = ''; icon: hIcon = 0; textAttribute: unsigned = FOREGROUND_BLUE or FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_INTENSITY);
    destructor Destroy(); override;
    procedure AfterConstruction(); override;
    //
    {DP:METHOD
      Starts the application thread. This method returns only when user press the Enter key.
    }
    procedure run(enterStop: bool = true);
    //
    property consoleInfo: pConsoleScreenBufferInfo read getConsoleInfo;
    property outputHandle: tHandle read f_outHandle;
    property inputHandle: tHandle read f_inHandle;
  end;



{DP:METHOD
  Locks list if it is not nil and contains at least one element.
  list.Unlock() must be called if this function returns true.
}
function lockNonEmptyList(list: unaList; timeout: unsigned = INFINITE): bool;

{DP:METHOD
  Returns true if files' content is the same.
  Uses mapped file class.
}
function sameFiles(const fileName1, fileName2: wideString): bool;

{}
function getFolderSize(const folder: wideString; includeSubFolders: bool = true): int64;


implementation


uses
  Messages;



{ unaObject }

// --  --
procedure unaObject.AfterConstruction();
begin
  assert(f_inheritedCreateWasCalled, _classID + ' inherited create() was not called!');
  //
  inherited;
end;

// --  --
constructor unaObject.create();
begin
  f_inheritedCreateWasCalled := true;
end;

// --  --
function unaObject.getClassID(): string;
begin
  {$IFDEF DEBUG }
  result := className;
  {$ELSE }
  result := '';
  {$ENDIF }
  //
  result := result + '[$' + int2str(uint(self), 16) + ']'
end;

// --  --
function unaObject.getThis(): unaObject;
begin
  result := self;	// self is not this! :)
end;


{ unaEvent }

// --  --
constructor unaEvent.create(manualReset, initialState: bool; const name: wideString);
begin
  inherited create();
  //
  f_name := name;
  //
  if (g_wideApiSupported) then
    //
    f_handle := CreateEventW(nil, manualReset, initialState, pWideChar(f_name))
  else
    f_handle := CreateEventA(nil, manualReset, initialState, pChar(string(f_name)));
  //
end;

// --  --
destructor unaEvent.Destroy();
begin
  inherited;
  //
  CloseHandle(f_handle);
end;

// --  --
procedure unaEvent.setState(signaled: bool);
begin
  if (signaled) then
    SetEvent(f_handle)
  else
    ResetEvent(f_handle);
end;

// --  --
function unaEvent.waitFor(timeout: unsigned): bool;
begin
  result := waitForObject(f_handle, timeout);
end;

{ unaAbstractGate }

// --  --
constructor unaAbstractGate.create({$IFDEF DEBUG}const title: string{$ENDIF});
begin
{$IFDEF DEBUG}
  f_title := title;
{$ENDIF}
  //
{$IFDEF UNA_GATE_PROFILE}
  f_profileIndex := profileMarkRegister(_classID + '(' + title + ')', unsigned(self));
{$ENDIF}
  //
  inherited create();
end;

// --  --
function unaAbstractGate.enter(timeout: unsigned{$IFDEF DEBUG}; const masterName: string{$ENDIF}): bool;
{$IFDEF DEBUG }
var
{$ELSE }
  {$IFDEF UNA_GATE_DEBUG_TIMEOUT }
var
  {$ENDIF }
{$ENDIF }

{$IFDEF UNA_GATE_DEBUG_TIMEOUT }
  mark: int64;
{$ENDIF}
{$IFDEF DEBUG }
  owner: unsigned;
  TLC, RLC: int;
{$ENDIF }
begin
  if (nil = self) then begin
    //
    assert(false, {$IFDEF DEBUG}'(' + masterName + ')' + {$ENDIF}'.enter(' + int2str(timeout) + ') - self is nil!');
    //
    result := false;
    exit;
  end;
  //
  if (INFINITE = timeout) then
    assert(assertLog(self._classID{$IFDEF DEBUG} + '(' + masterName + ')'{$ENDIF} + '.enter(' + int2str(timeout) + ') - INFINITE.'));
  //
{$IFDEF UNA_GATE_DEBUG_TIMEOUT }
  mark := timeMark();
{$ENDIF}
{$IFDEF DEBUG }
  if (self is unaInProcessGate) then begin
    //
    owner := (self as unaInProcessGate).owningThreadId;
    TLC := (self as unaInProcessGate).tryLockCount;
    RLC := (self as unaInProcessGate).recursionLockCount;
  end
  else begin
    //
    owner := unsigned(-1);
    TLC := -1;
    RLC := -1;
  end;
{$ENDIF }
  //
  result := gateEnter(timeout{$IFDEF DEBUG}, masterName{$ENDIF});
{$IFDEF UNA_GATE_DEBUG_TIMEOUT }
  logMessage({$IFDEF DEBUG}'(' + masterName + ')' + {$ENDIF}'.enter(' + int2str(timeout) + ') takes ' + int2str(timeElapsed64(mark), 10, 3));
{$ENDIF}
  //
  if (not result and (1 < timeout)) then begin
    //
    {$IFDEF DEBUG }
    assert(assertLog({$IFDEF DEBUG}self._classID + '(' + masterName + ').enter(timeout=' + int2str(timeout) + 'ms) ' + {$ENDIF}' gate is locked by [' + int2str(owner, 16) + ']; RLC=' + int2str(RLC) + '; TLC=' + int2str(TLC)));
    {$ENDIF }
    //
  end;
end;

// --  --
function unaAbstractGate.gateEnter(timeout: unsigned{$IFDEF DEBUG}; const masterName: string{$ENDIF}): bool;
begin
{$IFDEF DEBUG}
  f_masterName := masterName;
{$ENDIF}
  result := true;
end;

// --  --
procedure unaAbstractGate.gateLeave();
begin
{$IFDEF DEBUG}
  f_masterName := '';
{$ENDIF}
  f_isBusy := false;
end;

// --  --
procedure unaAbstractGate.leave();
begin
  gateLeave();
end;

{ unaOutProcessGate }

// --  --
function unaOutProcessGate.checkDeadlock(timeout: unsigned; const name: string): bool;
var
  ct: tHandle;
begin
  // simple deadlock check (seems not working properly / 10 Feb 2002)
  ct := GetCurrentThread();
  //
  if ((INFINITE = timeout) and f_inside and (f_masterThread = ct)) then begin
    result := true;
    assert(false, self._classID + '.enter(' + name + ') - potential deadlock');
  end
  else
    result := false;
end;

// --  --
constructor unaOutProcessGate.create({$IFDEF DEBUG}const title: string{$ENDIF});
begin
  inherited create({$IFDEF DEBUG}title{$ENDIF});
  //
  f_event := unaEvent.create(false, true);
end;

// --  --
destructor unaOutProcessGate.Destroy();
begin
  inherited;
  //
  leave();
  freeAndNil(f_event);
end;

// --  --
function unaOutProcessGate.gateEnter(timeout: unsigned{$IFDEF DEBUG}; const masterName: string{$ENDIF}): bool;
begin
{$IFDEF UNA_GATE_PROFILE}
  profileMarkEnter(f_profileIndex);
{$ENDIF}
  result := f_event.waitFor(timeout);
{$IFDEF UNA_GATE_PROFILE}
  profileMarkLeave(f_profileIndex);
{$ENDIF}
  //
  if (result) then begin
    //
    inherited gateEnter(timeout, {$IFDEF DEBUG}masterName{$ENDIF});
    //
    f_masterThread := GetCurrentThread();
    f_inside := true;
    f_isBusy := true;
  end;
end;

// --  --
procedure unaOutProcessGate.gateLeave();
begin
  f_masterThread := 0;
  f_inside := false;
  f_event.setState();
  //
  inherited gateLeave();
end;


{ unaInProcessGate }

{$IFDEF UNA_USE_CS }

type
  proc_tryEnterCriticalSection = function(var lpCriticalSection: TRTLCriticalSection): BOOL; stdcall;
  proc_InitializeCriticalSectionAndSpinCount = function(var lpCriticalSection: TRTLCriticalSection; dwSpinCount: DWORD): BOOL; stdcall;

var
  te_proc: proc_tryEnterCriticalSection;
  te_procTested: bool = false;
  is_proc: proc_InitializeCriticalSectionAndSpinCount;
  //
  k32: hModule;

{$ENDIF }

// --  --
procedure unaInProcessGate.AfterConstruction();
{$IFDEF UNA_U