unit SharedMem;
{ Ideas about shared memory taken from BomeOneInstance component
  http://www.bome.com }

{ Component that implements memory that can be shared between
  applications. Drop it on the main form of aplications that should
  cooperate. Example of usage is MemoryStyle msFifo for sending
  text commands from one application to the other. }

interface

uses
  Windows, Messages, SysUtils, Classes;

type
  ESharedMem = class(Exception);

  TSharedMem = class(TComponent)
  private
    { Private declarations }

     FMappingHandle:THandle;
     HSemaphore:THandle;

     //FHandle: THandle;
     FMem: Pointer;{sysutils}

     FMemSize: integer;
     FMemName: string;
     FActive: boolean;
     procedure DestroySemaphore;
     function Lock: Boolean;
     function Unlock: Boolean;
     procedure SetMemSize(ASize: integer);
     procedure SetMemName(const AName: string);
     procedure SetActive(OnOff: boolean);
     function GetSemName: string;
     property SemName: string read GetSemName;
     procedure InTheFirstApp;
     procedure InTheNextApp;
  protected
    { Protected declarations }
     procedure Loaded; override;
     procedure SetResult(AResult: integer; const Msg: string);
  public
    { Public declarations }
    constructor Create(AOwner :TComponent); override;
    destructor Destroy; override;
    { Procedure to safely increase longint at given address inside the Mem^ block.
      Can be used e.g. for implementation of circular buffer of memory slots
      inside the mem, i.e. application will increase index of head - pointer
      to the next free memory slot - by calling SharedMem.Inc(Head^, 1),
      and then it can use the slot at value returned by the Inc (usually
      Head^ - 1), without worries that some other application will use the
      same slot for something else (unless too many Inc requests are made
      causing an overflow). This procedure is NOT sutitable for FIFO buffer. }
    function Inc(APtr: PInteger; AIncrement: longint; AMaxValue: integer): integer;
    { Pointer to the allocated shared memory, valid if Active is true }
    property Mem: pointer read FMem;
  published
    { Published declarations }
    { Name of the shared memory. Set the same name in all applications that
      should share this memory. }
    property MemName: string read FMemName write SetMemName;
    { Size of the memory to be shared. Should be set to the same value in
      all applications sharing the memory }
    property MemSize: integer read FMemSize write SetMemSize;
    { Activate the shared memory block by setting to True. Mem pointer will then
      point to the shared memory block of the size MemSize.
      MemSize must be set > 0 and MemName <> '' before setting Active true. }
    property Active: boolean read FActive write SetActive;
  end;

procedure Register;

implementation
// this variable is to prevent multiple times this component in
// your application (like a mutex...)
var
  SingleInstInstance : TComponent = Nil;

const
// missing in windows.pas
// STANDARD_RIGHTS_REQUIRED = $000F0000;
// SYNCHRONIZE = $00100000;
// SEMAPHORE_MODIFY_STATE = $0002;
 SEMAPHORE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3);

const
  smeNotActive = -1;
  smeLockFailed = -2;
  smePointerOOR = -3;
  smeMemNameMustBeNonEmpty = -4;
  smeMemSizeMustBeNonZero = -5;
  smeCanNotChangeNameWhenActive = -6;
  smeCanNotChangeSizeWhenActive = -7;

constructor TSharedMem.Create(AOwner :TComponent);
begin
 // don't drop more than one of this component on the form !
  if SingleInstInstance <> Nil then
    raise Exception.Create('Drop only one of these components on your form !');
  inherited Create(AOwner);
  SingleInstInstance := Self;
end;

destructor TSharedMem.Destroy;
begin
  Active := false;
  inherited Destroy;
  SingleInstInstance := Nil;
end;

procedure TSharedMem.SetMemSize(ASize: integer);
begin
  if FMemSize = ASize then
    exit;
  if Active then begin
    SetResult(smeCanNotChangeSizeWhenActive, 'Can not change memory size when active');
  end;
  FMemSize := ASize;
end;

procedure TSharedMem.SetMemName(const AName: string);
begin
  if FMemName = AName then
    exit;
  if Active then begin
    SetResult(smeCanNotChangeNameWhenActive, 'Can not change memory name when active');
  end;
  FMemName := AName;
end;

procedure TSharedMem.SetResult(AResult: integer; const Msg: string);
begin
  raise ESharedMem.Create(IntToStr(AResult) + ' ' + Msg);
end;

procedure TSharedMem.DestroySemaphore;
begin
 if HSemaphore <> 0 then
   CloseHandle(HSemaphore);
 HSemaphore := 0;
end;

function TSharedMem.GetSemName: string;
begin
  Result := FMemName + 'Sem';
end;

procedure TSharedMem.Loaded;
begin
  inherited;
end;

procedure TSharedMem.SetActive(OnOff: boolean);
begin
  if OnOff then begin
    if FMemSize = 0 then
      SetResult(smeMemSizeMustBeNonZero, 'Memory size must be non zero');
    if FMemName = '' then
      SetResult(smeMemNameMustBeNonEmpty, 'Memory name must not be empty');
  end;

  if csDesigning in ComponentState then begin
    exit;
  end;

  if FActive = OnOff then
    exit;
  if OnOff then begin
    // create shared memory block
    try
      FMappingHandle := CreateFileMapping($FFFFFFFF{-1}, NIL,
        PAGE_READWRITE, 0, FMemSize, PChar(FMemName));
      if FMappingHandle <> 0 then
      begin
        // get pointer to shared memory block
        FMem := MapViewOfFile(FMappingHandle,
          FILE_MAP_WRITE OR FILE_MAP_READ, 0, 0, FMemSize);
        if FMem <> Nil then begin
          if GetLastError = ERROR_ALREADY_EXISTS then begin
           // another application that uses this memory is already running
           // InTheNextApp;
          end else begin
           // OK, we are the first app
           // InTheFirstApp;
          end;
          InTheNextApp;//will eventually call InTheFirstApp if it does not find semaphore
        end;
      end else begin
        SetResult(GetLastError, 'CreateFileMapping');
      end;
    finally
      FActive := true;
      if FMem = nil then
        Active := false;
    end;
  end else begin
    if FMem <> nil then begin
      UnmapViewOfFile(FMem);
      FMem := nil;
    end;
    // and release the semaphore which was set by the other instance
    // Unlock;
    // deallocate shared memory block
    if FMappingHandle <> 0 then begin
      CloseHandle(FMappingHandle);
      FMappingHandle := 0;
    end;
    // destroy semaphore
    DestroySemaphore;
  end;
end;

procedure TSharedMem.InTheFirstApp;
begin
 // Create the semaphore object. It limits the access to the
 // shared memory block to one instance
  Unlock;
  DestroySemaphore;

  HSemaphore := CreateSemaphore(nil, 0, 1, PChar(SemName));
  FillChar(Mem^, MemSize, 0);
  if HSemaphore = 0 then
    SetResult(GetLastError, 'Unable to create semaphore: ' + SemName);
//  Assert(HSemaphore <> 0, 'Unable to create semaphore');

   // now eventually write something into the shared mem
   // Move(xxx, FMem^, ...)

  // release the semaphore
  Unlock;
end;

procedure TSharedMem.InTheNextApp;
//var
//  i:Integer;
//  tempStr:String;
begin
  if not Lock then begin
    // not successful to get the semaphore object
    // => the first app is down
    InTheFirstApp;
    exit;
  end;
  try
      // now we are REALLY in the next application

  //    put eventually something to the shared mem
  // move(xxx, FMem^,...)
  //    and notify the first instance
  // PostMessage(HWND_BROADCAST, MSG_2ND_INSTANCE, 0, 0);
  // the first instance must respond by releasing the semaphore
  // so we can wait for it to be released
  // if not Lock then
  // begin
    // not successful to get the semaphore object
    // => the first instance is down
    // and we become first instance
  //  ImTheFirstInstance(lpInfo);
  //  exit;
  // end;
  finally
    Unlock;
  end;
end;

function TSharedMem.Lock:Boolean;
begin
 // When this function returns false, then we couldn't get
 // the semaphore. That means either that the other application
 // is down or that the semaphore doesn't exist anymore.
 // In both cases we must take the role as first instance
 if HSemaphore = 0 then
   HSemaphore := OpenSemaphore(SEMAPHORE_ALL_ACCESS, false,
    PChar(SemName));
 Result := HSemaphore <> 0;
 if Result then
 begin
  // wait for 10 seconds to become owner of the semaphore
   Result := (WaitForSingleObject(HSemaphore, 10000) = WAIT_OBJECT_0);
 end;
end;

function TSharedMem.Unlock:Boolean;
begin
 // give the semaphore back
 Result := false;
 if HSemaphore <> 0 then
 begin
   Result := ReleaseSemaphore(HSemaphore, 1, nil);
 end;
end;

function TSharedMem.Inc(APtr: PInteger; AIncrement: longint; AMaxValue: integer): integer;
begin
  if not Active then
    SetResult(smeNotActive, 'Inc');
  if not Lock then
    SetResult(smeLockFailed, 'Inc');
  try
    if (longint(APtr) < longint(FMem)) or (longint(APtr) >= longint(FMem) + FMemSize) then begin
      SetResult(smePointerOOR, IntToStr(longint(APtr)) + ' Inc');
    end;
    Result := APtr^;
    System.Inc(APtr^, AIncrement);
    if APtr^ >= AMaxValue then
      APtr^ := 0;
    // Inc(APtr^, AIncrement);
  finally
    Unlock;
  end;
end;

procedure Register;
begin
  RegisterComponents('NonVis', [TSharedMem]);
end;

initialization
  SingleInstInstance := nil;
finalization
  if SingleInstInstance <> nil then
    SingleInstInstance.Free;
end.
