////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Shared memory access class.                                                //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20030113 - Creation & test                                                 //
// 20030330 - Struggle for safety (add some try/except checks)...             //
// 20040424 - FileMappingResult,MapViewResult                                 //
// 20230827 - Modified for FPC (A.K.)                                         //
// 20240521 - _SharedMem log chahhel                                          //
// 20250129 - Use TAtomicCounter                                              //
////////////////////////////////////////////////////////////////////////////////

unit _crw_sharm; // Shared memory

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF UNIX} baseunix, unix, {$ENDIF}
  {$IFDEF WINDOWS} jwanative, {$ENDIF}
 sysutils, classes, math,
 _crw_alloc, _crw_ef, _crw_str, _crw_fio, _crw_dynar, _crw_sysid, _crw_dbglog;

 ///////////////////////////////////////////////////////////////////////////////
 // Shared memory is simple and fast way for Inter-Process Communication (IPC).
 // Class TSharedMemory gives you shared memory access, you may use it for IPC.
 // Notes:
 //  1) To access shared memory block, processes must use the same NAME and SIZE.
 //     Blocks with diffrenent NAMEs will not be shared.
 //  2) Memory will be allocated by 4K pages, so allocated size will be adjusted
 //     to 4096 bytes. For example, if you want allocate 4097 bytes (4096+1),
 //     8192 (4096*2) bytes will be really allocated. Function CAPACITY returns
 //     size, adjusted by page size.
 //  3) Use ASINTEGER,ASDOUBLE for protected data access.
 //     Use ASPTR,ASCHAR for common access with exception handling.
 //     For example:
 //      buf:=NewSharedMemory('SharedBufer',4096);
 //      buf.AsInteger[1024]:=1;  // No exception, neither assignment.
 //      Integer(buf[4096]^):=1;  // Exception will be raised.
 //  4) Data access benchmark result on P4-2000:
 //      p:=PIntegerArray(buf[0]); p[0]^:=p[0]^+1;  -> 140 millions op/sec
 //      Integer(buf[0]^):=Integer(buf[0]^)+1;      -> 90  millions op/sec
 //      buf.AsInteger[0]:=buf.AsInteger[0]+1;      -> 33  millions op/sec
 //  5) TSharedMemory designed for inter-process communications. No reason
 //     to use this one for inter-thread communications, because threads
 //     has the same address space.
 // Example:
 //  Process A:
 //   buf:=NewSharedMemory('SharedBufer',5000); // Create shared memory block
 //   Echo(Format('Buffer name = %s',[buf.Name]));
 //   Echo(Format('Buffer size = %s',[buf.Size]));
 //   Echo(Format('Allocated size = %d',[buf.Capacity]));
 //   buf.AsInteger[0]:=1;
 //   buf.AsDouble[1]:=pi;
 //   Double(buf[12]^):=exp(1);
 //   ..etc
 //   Kill(buf);
 //  Process B:
 //   buf:=NewSharedMemory('SharedBufer',5000); // Access the same memory block
 //   if buf.AsInteger[0]=1 then begin ...
 //   ..etc
 //   Kill(buf);
 ///////////////////////////////////////////////////////////////////////////////
type
 TSharedMemory = class(TMasterObject)
 private
  myFile       : THandle;
  myData       : Pointer;
  myName       : LongString;
  mySize       : Integer;
  myMode       : Integer;
  myCapacity   : Integer;
  myReporter   : TEchoProcedure;
  myUnlinkMode : Integer;
  function  GetSize:Integer;
  function  GetData:Pointer;
  function  GetMode:Integer;
  function  GetName:LongString;
  function  GetCapacity:Integer;
  function  GetPathName:LongString;
  function  GetAsPtr(Offset:Integer):Pointer;
  function  GetAsPChar(Offset:Integer):PChar;
  function  GetAsInteger(Index:Integer):Integer;
  procedure SetAsInteger(Index:Integer; v:Integer);
  function  GetAsDouble(Index:Integer):Double;
  procedure SetAsDouble(Index:Integer; v:Double);
  procedure UnlinkData;
  procedure LinkData;
 protected
  function  CheckOk:Boolean; override;
 public
  constructor Create(const aName:LongString; aSize:Integer; aMode:Integer=0);
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  property  Size                     : Integer    read GetSize;      // Requested size
  property  Mode                     : Integer    read GetMode;      // Access mode
  property  Data                     : Pointer    read GetData;      // Data pointer
  property  Name                     : LongString read GetName;      // Name of file (base) like shm_test
  property  PathName                 : LongString read GetPathName;  // Name of file (full) like /dev/shm/shm_test
  property  Capacity                 : Integer    read GetCapacity;  // Adjust to page
  property  AsPtr[Offset:Integer]    : Pointer    read GetAsPtr;     default;
  property  AsPChar[Offset:Integer]  : PChar      read GetAsPChar;
  property  AsInteger[Index:Integer] : Integer    read GetAsInteger  write SetAsInteger;
  property  AsDouble[Index:Integer]  : Double     read GetAsDouble   write SetAsDouble;
 public
  procedure Report(aSeverity:Integer; aMessage:LongString);
  procedure SetReporter(aReporter:TEchoProcedure);
 public
  class function SysPageSize(Def:Integer=4096):Integer;
  {$IFDEF UNIX}
  class function mmap(addr:Pointer; len:size_t; prot:longint; flags:longint; fd:longint; offset:longint):Pointer;
  class function mmap64(addr:Pointer; len:size_t; prot:longint; flags:longint; fd:longint; offset:Int64):Pointer;
  class function munmap(addr:Pointer; len:size_t):longint;
  class function mprotect(addr:Pointer; len:size_t; prot:longint):longint;
  class function msync(addr:Pointer; len:size_t; flags:longint):longint;
  class function madvise(addr:Pointer; len:size_t; advice:longint):longint;
  class function posix_madvise(addr:Pointer; len:size_t; advice:longint):longint;
  class function mlock(addr:Pointer; len:size_t):longint;
  class function munlock(addr:Pointer; len:size_t):longint;
  class function mlockall(flags:longint):longint;
  class function munlockall:longint;
  class function mremap(addr:Pointer; old_len:size_t; new_len:size_t; may_move:longint):Pointer;
  class function mincore(start:Pointer; len:size_t; vec:Pbyte):longint;
  class function shm_open(name:Pchar; oflag:longint; mode:mode_t):longint;
  class function shm_unlink(name:Pchar):longint;
  {$ENDIF ~UNIX}
 public
  class function  ValidSize(aSize:SizeInt):Boolean; inline;
  class function  ValidHandle(aHandle:THandle):Boolean; inline;
  class procedure InvalidateHandle(out aHandle:THandle); inline;
  class function  ValidPointer(aPointer:Pointer):Boolean; inline;
  class procedure InvalidatePointer(out aPointer:Pointer); inline;
  class function  ValidName(aName:LongString):Boolean;
  class procedure InvalidateName(out aName:LongString); inline;
  class function  ValidateName(const aName:LongString; FixChar:Char='_'):LongString;
 end;

function  NewSharedMemory(const aName:LongString; aSize:Integer; aMode:Integer=0):TSharedMemory;
procedure Kill(var TheObject:TSharedMemory); overload;

 ////////////////////////////////////////////////////
 // Full list of all existing TSharedMemory instances
 ////////////////////////////////////////////////////
function  FullSharedMemoryList:TObjectStorage;

 ///////////////////////////////
 // Simplified API for DaqPascal
 ///////////////////////////////

function shm_init(name:LongString; size,mode:Integer):Integer;
function shm_ref(ref:Integer):TSharedMemory;
function shm_free(ref:Integer):Boolean;
function shm_delink(name:LongString):Boolean;
function shm_iop(ref:Integer; offset:Integer; op:Char; data:LongInt):LongInt;
function shm_rop(ref:Integer; offset:Integer; op:Char; data:Double):Double;
function shm_fop(ref:Integer; offset:Integer; op:Char; data:Single):Single;
function shm_sop(ref:Integer; offset:Integer; op:Char; data:LongString):LongString;
function shm_ctrl(ref:Integer; arg:LongString):LongString;
function shm_ioresult(code:Integer=0):Integer;
function shm_total_errors:SizeInt;
threadvar shm_errno:Integer;

const
 shm_err_ok  = 0; // Success
 shm_err_op  = 1; // Bad operation code
 shm_err_ref = 2; // Bad object reference
 shm_err_arg = 3; // Bad arguments found
 shm_err_bug = 4; // Exception raised

const // Maximim length of shared file name
 SHM_NAME_MAX = {$IFDEF UNIX} NAME_MAX {$ELSE} 255 {$ENDIF ~UNIX};

const // Default access rights mode
 SHM_PRIVATE_MODE = S_IRWXU;                    // &700 Only current user
 SHM_USERGRP_MODE = S_IRWXUG;                   // &770 User and group
 SHM_ALLUSER_MODE = S_IRWXUGO;                  // &777 All users granted
 SHM_AUTOCLN_MODE = $10000000;                  // Auto clean on close
 SHM_MUSTCLN_MODE = $20000000;                  // Must clean on close

const // Default shm.create mode: user+group access; autoclean mode
 SHM_DEFAULT_MODE : Integer = SHM_USERGRP_MODE or SHM_AUTOCLN_MODE;

const // Debug level to report events
 SHM_DEBUG_LEVEL  : Integer = SEVERITY_WARNING; // Min. severity level to report

implementation

{$IFDEF UNIX}
type __off_t=LongInt; __off64_t=Int64; const rtlib='rt'; clib='c'; const MAP_FAILED=Pointer(-1);
function mmap(__addr:pointer; __len:size_t; __prot:longint; __flags:longint; __fd:longint; __offset:__off_t):pointer;cdecl;external clib name 'mmap';
function mmap64(__addr:pointer; __len:size_t; __prot:longint; __flags:longint; __fd:longint; __offset:__off64_t):pointer;cdecl;external clib name 'mmap64';
function munmap(__addr:pointer; __len:size_t):longint;cdecl;external clib name 'munmap';
function mprotect(__addr:pointer; __len:size_t; __prot:longint):longint;cdecl;external clib name 'mprotect';
function msync(__addr:pointer; __len:size_t; __flags:longint):longint;cdecl;external clib name 'msync';
function madvise(__addr:pointer; __len:size_t; __advice:longint):longint;cdecl;external clib name 'madvise';
function posix_madvise(__addr:pointer; __len:size_t; __advice:longint):longint;cdecl;external clib name 'posix_madvise';
function mlock(__addr:pointer; __len:size_t):longint;cdecl;external clib name 'mlock';
function munlock(__addr:pointer; __len:size_t):longint;cdecl;external clib name 'munlock';
function mlockall(__flags:longint):longint;cdecl;external clib name 'mlockall';
function munlockall:longint;cdecl;external clib name 'munlockall';
function mremap(__addr:pointer; __old_len:size_t; __new_len:size_t; __may_move:longint):pointer;cdecl;external clib name 'mremap';
function mincore(__start:pointer; __len:size_t; __vec:Pbyte):longint;cdecl;external clib name 'mincore';
function shm_open(__name:Pchar; __oflag:longint; __mode:mode_t):longint;cdecl;external rtlib name 'shm_open';
function shm_unlink(__name:Pchar):longint;cdecl;external rtlib name 'shm_unlink';
{$ENDIF ~UNIX}

const the_shm_total_errors:TAtomicCounter=nil;

procedure InitShmCounters;
begin
 LockedInit(the_shm_total_errors);
end;

procedure FreeShmCounters;
begin
 LockedFree(the_shm_total_errors);
end;

function shm_total_errors:SizeInt;
begin
 Result:=LockedGet(the_shm_total_errors);
end;

const
 dlc_SharedMem : Integer = 0;

class function TSharedMemory.ValidSize(aSize:SizeInt):Boolean; inline;
begin
 Result:=(aSize>0);
end;

class function TSharedMemory.ValidHandle(aHandle:THandle):Boolean; inline;
begin
 Result:=(aHandle<>INVALID_HANDLE_VALUE);
end;

class procedure TSharedMemory.InvalidateHandle(out aHandle:THandle); inline;
begin
 aHandle:=INVALID_HANDLE_VALUE;
end;

class function TSharedMemory.ValidPointer(aPointer:Pointer):Boolean; inline;
begin
 Result:=Assigned(aPointer);
 {$IFDEF UNIX}
 if (aPointer=MAP_FAILED) then Result:=false;
 {$ENDIF ~UNIX}
end;

class procedure TSharedMemory.InvalidatePointer(out aPointer:Pointer); inline;
begin
 aPointer:=nil;
end;

class function TSharedMemory.ValidName(aName:LongString):Boolean;
begin
 Result:=InRange(Length(aName),1,SHM_NAME_MAX);
end;

class procedure TSharedMemory.InvalidateName(out aName:LongString); inline;
begin
 aName:='';
end;

class function TSharedMemory.ValidateName(const aName:LongString; FixChar:Char='_'):LongString;
const AddonDelimiters=['|','&','<','>',QuoteMark,Apostrophe];
var i:Integer; BadChars:TCharSet;
begin
 Result:=Trim(aName);
 {$IFDEF WINDOWS}
 BadChars:=JustSpaces+ScanSpaces+DosDelimiters+AddonDelimiters;
 for i:=1 to Length(Result) do
 if (Result[i] in BadChars) and (FixChar<>#0) then Result[i]:=FixChar;
 {$ENDIF ~WINDOWS}
 {$IFDEF UNIX}
 if (StrFetch(Result,1)='/') then Delete(Result,1,1);
 BadChars:=JustSpaces+ScanSpaces+DosDelimiters+AddonDelimiters;
 for i:=1 to Length(Result) do
 if (Result[i] in BadChars) and (FixChar<>#0) then Result[i]:=FixChar;
 Result:='/'+Result; // see: man shm_open
 {$ENDIF ~UNIX}
end;

constructor TSharedMemory.Create(const aName:LongString; aSize:Integer; aMode:Integer=0);
begin
 inherited Create;
 Exceptions:=false;
 mySize:=Max(0,aSize);
 InvalidateName(myName);
 InvalidateHandle(myFile);
 InvalidatePointer(myData);
 myCapacity:=AdjustBufferSize(mySize,SysPageSize);
 if ValidSize(mySize) then myName:=ValidateName(aName);
 if (aMode=0) then aMode:=SHM_DEFAULT_MODE; myMode:=aMode;
 SetReporter(SystemEchoProcedure);
 myUnlinkMode:=1+2;
 LinkData;
end;

destructor  TSharedMemory.Destroy;
begin
 UnlinkData;
 inherited Destroy;
end;

procedure TSharedMemory.AfterConstruction;
begin
 inherited AfterConstruction;
 FullSharedMemoryList.Add(Self);
end;

procedure TSharedMemory.BeforeDestruction;
begin
 FullSharedMemoryList.Remove(Self);
 inherited BeforeDestruction;
end;


procedure TSharedMemory.LinkData;
{$IFDEF UNIX}var Buff:LongString;{$ENDIF ~UNIX}
begin
 if Assigned(Self) then
 try
  if not ValidName(myName) then Exit;
  if not ValidSize(mySize) then Exit;
  if not ValidSize(myCapacity) then Exit;
  {$IFDEF WINDOWS}
  myFile:=CreateFileMapping(INVALID_HANDLE_VALUE,nil,PAGE_READWRITE+SEC_COMMIT,0,Capacity,PChar(myName));
  if not ValidHandle(myFile) then begin
   Report(SEVERITY_ERROR,SysErrorMessage(GetLastOSError));
   Exit;
  end;
  myData:=MapViewOfFile(myFile,FILE_MAP_ALL_ACCESS,0,0,0);
  if not ValidPointer(myData) then begin
   Report(SEVERITY_ERROR,SysErrorMessage(GetLastOSError));
   Exit;
  end;
  {$ENDIF ~WINDOWS}
  {$IFDEF UNIX}
  // In MustClean mode should unlink /dev/shm/name
  // always - this mode may be usefull for servers
  if HasFlags(myMode,SHM_MUSTCLN_MODE) then LiftFlags(myUnlinkMode,4);
  // In AutoClean mode should unlink /dev/shm/name
  // if it does not exist to return initial status
  if not HasFlags(myUnlinkMode,4) then
  if HasFlags(myMode,SHM_AUTOCLN_MODE) then
  if not FileExists(PathName) then LiftFlags(myUnlinkMode,4);
  // Create shared memory object - /dev/shm/name.
  myFile:=shm_open(PChar(myName),(O_RDWR or O_CREAT),myMode);
  if not ValidHandle(myFile) then begin
   Report(SEVERITY_ERROR,SysErrorMessage(GetLastOSError));
   Exit;
  end;
  // Fill file with zeros.
  Buff:=StringBuffer(Capacity); // capacity = size adjusted to system page
  if (fplseek(myFile,0,SEEK_END)<Length(Buff)) then begin // Fill with zero
   fplseek(myFile, 0, SEEK_SET);
   if (fpwrite(myFile,PChar(Buff),Length(Buff))<Length(Buff)) then begin
    Report(SEVERITY_ERROR,SysErrorMessage(GetLastOSError));
    UnlinkData;
    Exit;
   end;
  end;
  // Map file to memory
  myData:=mmap(nil,Capacity,(PROT_READ or PROT_WRITE),MAP_SHARED,myFile,0);
  if not ValidPointer(myData) then begin
   Report(SEVERITY_ERROR,SysErrorMessage(GetLastOSError));
   UnlinkData;
   Exit;
  end;
  {$ENDIF ~UNIX}
  Report(SEVERITY_INFO,'LinkData');
 except
  on E:Exception do BugReport(E,Self,'LinkData');
 end;
end;

procedure TSharedMemory.UnlinkData;
var Who:Integer;
begin
 if Assigned(Self) then
 try
  Who:=myUnlinkMode;
  Report(SEVERITY_INFO,'UnlinkData');
  {$IFDEF WINDOWS}
  if HasFlags(Who,1) then if ValidPointer(myData) then UnmapViewOfFile(myData);
  if HasFlags(Who,2) then if ValidHandle(myFile) then CloseHandle(myFile);
  {$ENDIF ~WINDOWS}
  {$IFDEF UNIX}
  // Unmap and unlink the shared memory.
  if HasFlags(Who,1) then if ValidPointer(myData) then munmap(myData,Capacity);
  if HasFlags(Who,2) then if ValidHandle(myFile) then fpclose(myFile);
  if HasFlags(Who,4) then if ValidName(myName) then shm_unlink(PChar(myName));
  {$ENDIF ~UNIX}
  if HasFlags(Who,1) then InvalidatePointer(myData);
  if HasFlags(Who,2) then InvalidateHandle(myFile);
  if HasFlags(Who,4) then InvalidateName(myName);
 except
  on E:Exception do BugReport(E,Self,'UnlinkData');
 end;
end;

procedure TSharedMemory.Report(aSeverity:Integer; aMessage:LongString);
var aSevName:LongString;
begin
 if (Self=nil) then Exit;
 if (aMessage='') then Exit;
 if (aSeverity>=SHM_DEBUG_LEVEL) or DebugLogEnabled(dlc_SharedMem) then
 try
  aSevName:=ExtractWord(aSeverity+1,SEVERITY_NAMES,JustSpaces);
  if (aSevName<>'') then aMessage:=Format('%s: "%s" from %s %s.',[aSevName,aMessage,ClassName,Name]);
  if DebugLogEnabled(dlc_SharedMem) then DebugLog(dlc_SharedMem,aMessage);
  if (aSeverity>=SHM_DEBUG_LEVEL) then begin
   if Assigned(myReporter)
   then myReporter(aMessage)
   else Echo(aMessage);
  end;
 except
  on E:Exception do BugReport(E,Self,'ReportError');
 end;
end;

procedure TSharedMemory.SetReporter(aReporter:TEchoProcedure);
begin
 if (Self=nil) then Exit;
 myReporter:=aReporter;
end;

class function TSharedMemory.SysPageSize(Def:Integer=4096):Integer;
{$IFDEF WINDOWS}var SysInfo:TSystemInfo;{$ENDIF}
const ThePageSize:Integer=0;
begin
 if (ThePageSize=0) then begin
  {$IFDEF WINDOWS}
  SafeFillChar(SysInfo,SizeOf(SysInfo),0);
  GetSystemInfo(SysInfo);
  if (SysInfo.dwPageSize>0)
  then ThePageSize:=SysInfo.dwPageSize;
  {$ENDIF ~WINDOWS}
  {$IFDEF UNIX}
  ThePageSize:=sysconf(_SC_PAGESIZE);
  {$ENDIF ~UNIX}
 end;
 if (ThePageSize>0)
 then Result:=ThePageSize
 else Result:=Def;
end;

{$IFDEF UNIX}
class function TSharedMemory.mmap(addr:Pointer; len:size_t; prot:longint; flags:longint; fd:longint; offset:longint):Pointer;
begin
 Result:=_crw_sharm.mmap(addr,len,prot,flags,fd,offset);
end;
class function TSharedMemory.mmap64(addr:Pointer; len:size_t; prot:longint; flags:longint; fd:longint; offset:Int64):Pointer;
begin
 Result:=_crw_sharm.mmap64(addr,len,prot,flags,fd,offset);
end;
class function TSharedMemory.munmap(addr:Pointer; len:size_t):longint;
begin
 Result:=_crw_sharm.munmap(addr,len);
end;
class function TSharedMemory.mprotect(addr:Pointer; len:size_t; prot:longint):longint;
begin
 Result:=_crw_sharm.mprotect(addr,len,prot);
end;
class function TSharedMemory.msync(addr:Pointer; len:size_t; flags:longint):longint;
begin
 Result:=_crw_sharm.msync(addr,len,flags);
end;
class function TSharedMemory.madvise(addr:Pointer; len:size_t; advice:longint):longint;
begin
 Result:=_crw_sharm.madvise(addr,len,advice);
end;
class function TSharedMemory.posix_madvise(addr:Pointer; len:size_t; advice:longint):longint;
begin
 Result:=_crw_sharm.posix_madvise(addr,len,advice);
end;
class function TSharedMemory.mlock(addr:Pointer; len:size_t):longint;
begin
 Result:=_crw_sharm.mlock(addr,len);
end;
class function TSharedMemory.munlock(addr:Pointer; len:size_t):longint;
begin
 Result:=_crw_sharm.munlock(addr,len);
end;
class function TSharedMemory.mlockall(flags:longint):longint;
begin
 Result:=_crw_sharm.mlockall(flags);
end;
class function TSharedMemory.munlockall:longint;
begin
 Result:=_crw_sharm.munlockall;
end;
class function TSharedMemory.mremap(addr:Pointer; old_len:size_t; new_len:size_t; may_move:longint):Pointer;
begin
 Result:=_crw_sharm.mremap(addr,old_len,new_len,may_move);
end;
class function TSharedMemory.mincore(start:Pointer; len:size_t; vec:Pbyte):longint;
begin
 Result:=_crw_sharm.mincore(start,len,vec);
end;
class function TSharedMemory.shm_open(name:Pchar; oflag:longint; mode:mode_t):longint;
begin
 Result:=_crw_sharm.shm_open(name,oflag,mode);
end;
class function TSharedMemory.shm_unlink(name:Pchar):longint;
begin
 Result:=_crw_sharm.shm_unlink(name);
end;
{$ENDIF ~UNIX}

function TSharedMemory.GetSize:Integer;
begin
 if Assigned(Self)
 then Result:=mySize
 else Result:=0;
end;

function TSharedMemory.GetMode:Integer;
begin
 if Assigned(Self)
 then Result:=myMode
 else Result:=0;
end;

function TSharedMemory.GetCapacity:Integer;
begin
 if Assigned(Self)
 then Result:=myCapacity
 else Result:=0;
end;

function TSharedMemory.GetData:Pointer;
begin
 if Assigned(Self)
 then Result:=myData
 else Result:=nil;
end;

function TSharedMemory.GetName:LongString;
begin
 if Assigned(Self)
 then Result:=myName
 else Result:='';
end;

{$IFDEF WINDOWS}
function GetWinObjectName(aFile:THandle):LongString;
var buf:LongString;
begin
 buf:=StringBuffer(1024*4);
 if (NtQueryObject(aFile,ObjectNameInformation,Pointer(buf),Length(buf),nil)=0)
 then Result:=POBJECT_NAME_INFORMATION(Pointer(buf)).Name.Buffer;
end;
{$ENDIF ~WINDOWS}

function TSharedMemory.GetPathName:LongString;
begin
 Result:='';
 if Assigned(Self) then begin
  {$IFDEF UNIX}
  Result:=ExpandFileName('/dev/shm/'+myName);
  {$ENDIF ~UNIX}
  {$IFDEF WINDOWS}
  Result:=GetWinObjectName(myFile);
  {$ENDIF ~WINDOWS}
 end;
end;

function TSharedMemory.GetAsPtr(Offset:Integer):Pointer;
begin
 if Assigned(Self) and Assigned(myData)
 then Result:=(PChar(myData)+Offset)
 else Result:=nil;
end;

function TSharedMemory.GetAsPChar(Offset:Integer):PChar;
begin
 if Assigned(Self) and Assigned(myData)
 then Result:=(PChar(myData)+Offset)
 else Result:=nil;
end;

function TSharedMemory.GetAsInteger(Index:Integer):Integer;
begin
 Result:=0;
 if Assigned(Self) and Assigned(myData) then
 if (Index>=0) and (Index<(mySize div SizeOf(Integer))) then
 try
  Result:=PIntegerArray(myData)[Index];
 except
  on E:Exception do BugReport(E,Self,'GetAsInteger');
 end;
end;

procedure TSharedMemory.SetAsInteger(Index:Integer; v:Integer);
begin
 if Assigned(Self) and Assigned(myData) then
 if (Index>=0) and (Index<(mySize div SizeOf(Integer))) then
 try
  PIntegerArray(myData)[Index]:=v;
 except
  on E:Exception do BugReport(E,Self,'SetAsInteger');
 end;
end;

function TSharedMemory.GetAsDouble(Index:Integer):Double;
begin
 Result:=0;
 if Assigned(Self) and Assigned(myData) then
 if (Index>=0) and (Index<(mySize div SizeOf(Double))) then
 try
  Result:=PDoubleArray(myData)[Index];
 except
  on E:Exception do BugReport(E,Self,'GetAsDouble');
 end;
end;

procedure TSharedMemory.SetAsDouble(Index:Integer; v:Double);
begin
 if Assigned(Self) then
 if (Index>=0) and (Index<(mySize div SizeOf(Double))) then
 try
  PDoubleArray(myData)[Index]:=v;
 except
  on E:Exception do BugReport(E,Self,'SetAsDouble');
 end;
end;

function TSharedMemory.CheckOk:Boolean;
begin
 Result:=ValidPointer(myData);
end;

function  NewSharedMemory(const aName:LongString; aSize:Integer; aMode:Integer=0):TSharedMemory;
begin
 Result:=nil;
 try
  Result:=TSharedMemory.Create(aName,aSize);
  if not Result.Ok then Kill(Result);
 except
  on E:Exception do BugReport(E,nil,'NewSharedMemory');
 end;
end;

procedure Kill(var TheObject:TSharedMemory); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

 ///////////////////////////////
 // Simplified API for DaqPascal
 ///////////////////////////////

function shm_init(name:LongString; size,mode:Integer):Integer;
var shm:TSharedMemory;
begin
 Result:=0;
 if (name<>'') and (size>0) then
 try
  shm:=NewSharedMemory(name,size,mode);
  if shm.Ok then Result:=shm.Ref else Kill(shm);
 except
  on E:Exception do BugReport(E,nil,'shm_init');
 end;
end;

function shm_ref(ref:Integer):TSharedMemory;
var obj:TObject;
begin
 Result:=nil;
 if (ref=0) then Exit;
 obj:=ObjectRegistry[ref];
 if (obj is TSharedMemory)
 then Result:=TSharedMemory(obj);
end;

function shm_free(ref:Integer):Boolean;
var shm:TSharedMemory;
begin
 shm:=shm_ref(ref);
 Result:=Assigned(shm);
 if Result then Kill(shm);
end;

function shm_delink(name:LongString):Boolean;
begin
 Result:=false;
 {$IFDEF WINDOWS}
 name:=TSharedMemory.ValidateName(name);
 if TSharedMemory.ValidName(Name) then Result:=true;
 {$ENDIF ~WINDOWS}
 {$IFDEF UNIX}
 name:=TSharedMemory.ValidateName(name);
 if TSharedMemory.ValidName(name) then Result:=(TSharedMemory.shm_unlink(PChar(name))<>-1);
 {$ENDIF ~UNIX}
end;

function shm_fail(cond:Boolean; err:Integer):Boolean; inline;
begin
 Result:=cond;
 if Result then shm_errno:=err;
 if Result then LockedInc(the_shm_total_errors);
end;

function shm_iop(ref:Integer; offset:Integer; op:Char; data:LongInt):LongInt;
var shm:TSharedMemory; Ptr:Pointer;
begin
 Result:=0;
 if shm_fail(ref=0,shm_err_ref) then Exit;
 if shm_fail(offset<0,shm_err_arg) then Exit;
 try
  shm:=shm_ref(ref);
  if shm_fail(shm=nil,shm_err_ref) then Exit;
  if shm_fail(offset>shm.Size-SizeOf(data),shm_err_arg) then Exit;
  case op of
   'r','R': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=LongInt(Ptr^);
   end;
   'w','W': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=LongInt(Ptr^);
    LongInt(Ptr^):=data;
   end;
   '+': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=LockedAdd(LongInt(Ptr^),data);
   end;
   '-': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=LockedSub(LongInt(Ptr^),data);
   end;
   'e','E': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=LockedExchange(LongInt(Ptr^),data);
   end;
   else shm_errno:=shm_err_op;
  end;
 except
  on E:Exception do begin
   BugReport(E,nil,'shm_iop');
   shm_errno:=shm_err_bug;
  end;
 end;
end;

function shm_rop(ref:Integer; offset:Integer; op:Char; data:Double):Double;
var shm:TSharedMemory; Ptr:Pointer;
begin
 Result:=0;
 if shm_fail(ref=0,shm_err_ref) then Exit;
 if shm_fail(offset<0,shm_err_arg) then Exit;
 try
  shm:=shm_ref(ref);
  if shm_fail(shm=nil,shm_err_ref) then Exit;
  if shm_fail(offset>shm.Size-SizeOf(data),shm_err_arg) then Exit;
  Result:=data;
  case op of
   'r','R': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=Double(Ptr^);
   end;
   'w','W': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=Double(Ptr^);
    Double(Ptr^):=data;
   end;
   else shm_errno:=shm_err_op;
  end;
 except
  on E:Exception do begin
   BugReport(E,nil,'shm_rop');
   shm_errno:=shm_err_bug;
  end;
 end;
end;

function shm_fop(ref:Integer; offset:Integer; op:Char; data:Single):Single;
var shm:TSharedMemory; Ptr:Pointer;
begin
 Result:=0;
 if shm_fail(ref=0,shm_err_ref) then Exit;
 if shm_fail(offset<0,shm_err_arg) then Exit;
 try
  shm:=shm_ref(ref);
  if shm_fail(shm=nil,shm_err_ref) then Exit;
  if shm_fail(offset>shm.Size-SizeOf(data),shm_err_arg) then Exit;
  Result:=data;
  case op of
   'r','R': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=Single(Ptr^);
   end;
   'w','W': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=Single(Ptr^);
    Single(Ptr^):=data;
   end;
   else shm_errno:=shm_err_op;
  end;
 except
  on E:Exception do begin
   BugReport(E,nil,'shm_fop');
   shm_errno:=shm_err_bug;
  end;
 end;
end;

function shm_sop(ref:Integer; offset:Integer; op:Char; data:LongString):LongString;
var shm:TSharedMemory; Ptr:Pointer;
begin
 Result:='';
 if shm_fail(ref=0,shm_err_ref) then Exit;
 if shm_fail(data='',shm_err_arg) then Exit;
 if shm_fail(offset<0,shm_err_arg) then Exit;
 try
  shm:=shm_ref(ref);
  if shm_fail(shm=nil,shm_err_ref) then Exit;
  if shm_fail(offset>shm.Size-Length(data),shm_err_arg) then Exit;
  Result:=data;
  case op of
   'r','R': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=StringBuffer(Ptr,Length(data));
   end;
   'w','W': begin
    Ptr:=shm.AsPtr[offset];
    if shm_fail(Ptr=nil,shm_err_arg) then Exit;
    Result:=StringBuffer(Ptr,Length(data));
    SafeMove(PChar(data)^,Ptr^,Length(data));
   end;
   else shm_errno:=shm_err_op;
  end;
 except
  on E:Exception do begin
   BugReport(E,nil,'shm_sop');
   shm_errno:=shm_err_bug;
  end;
 end;
end;

function shm_ioresult(code:Integer=0):Integer;
begin
 Result:=shm_errno;
 shm_errno:=code;
end;

function shm_ctrl(ref:Integer; arg:LongString):LongString;
var shm:TSharedMemory; sn,sv,par,pars:LongString; p,i,iv:Integer; qv:Int64;
const rParams='Name,PathName,Size,Mode,Capacity,SysPageSize';
const wParams='ioresult,shm_total_errors';
begin
 Result:='';
 p:=ExtractNameValuePair(arg,sn,sv);
 // Get/Set common system Parameters
 if SameText(sn,'SysPageSize') then begin
  Result:=IntToStr(TSharedMemory.SysPageSize);
  Exit;
 end;
 if SameText(sn,'shm_total_errors') then begin
  if (p>0) and (sv<>'') and TryStrToInt64(sv,qv)
  then Result:=IntToStr(LockedExchange(the_shm_total_errors,qv))
  else Result:=IntToStr(shm_total_errors);
  Exit;
 end;
 // Get/Set object (ref) Parameters
 if shm_fail(ref=0,shm_err_ref) then Exit;
 if shm_fail(arg='',shm_err_arg) then Exit;
 try
  shm:=shm_ref(ref);
  if shm_fail(shm=nil,shm_err_ref) then Exit;
  if SameText(sn,'Name') then begin
   Result:=shm.Name;
  end else
  if SameText(sn,'PathName') then begin
   Result:=shm.PathName;
  end else
  if SameText(sn,'Size') then begin
   Result:=IntToStr(shm.Size);
  end else
  if SameText(sn,'Mode') then begin
   Result:=IntToStr(shm.Mode);
  end else
  if SameText(sn,'Capacity') then begin
   Result:=IntToStr(shm.Capacity);
  end else
  if SameText(sn,'ioresult') or SameText(sn,'shm_ioresult') then begin
   if (p>0) and (sv<>'') and TryStrToInt(sv,iv)
   then Result:=IntToStr(shm_ioresult(iv))
   else Result:=IntToStr(shm_ioresult(0));
  end else
  if SameText(sn,'*') or SameText(sn,'?') then begin
   if (p=0) then pars:=rParams+','+wParams else pars:=wParams;
   for i:=1 to WordCount(pars,ScanSpaces) do begin
    par:=ExtractWord(i,pars,ScanSpaces);
    if (sn='*') then Result:=Result+par+EOL;
    if (sn='?') then Result:=Result+par+'='+shm_ctrl(ref,par)+EOL;
   end;
  end;
 except
  on E:Exception do begin
   BugReport(E,nil,'shm_ctrl');
   shm_errno:=shm_err_bug;
  end;
 end;
end;

 //////////////////////////////////////
 // FullSharedMemoryList implementation
 //////////////////////////////////////
const
 TheFullSharedMemoryList : TObjectStorage = nil;

function FullSharedMemoryList:TObjectStorage;
begin
 if not Assigned(TheFullSharedMemoryList) then begin
  TheFullSharedMemoryList:=NewObjectStorage(false);
  TheFullSharedMemoryList.Master:=@TheFullSharedMemoryList;
  TheFullSharedMemoryList.OwnsObjects:=false;
 end;
 Result:=TheFullSharedMemoryList;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_sharm;
begin
 InitShmCounters;
 FullSharedMemoryList.Ok;
 dlc_SharedMem:=RegisterDebugLogChannel('_SharedMem');
end;

procedure Free_crw_sharm;
begin
 ResourceLeakageLog(Format('%-60s = %d',['FullSharedMemoryList.Count', TheFullSharedMemoryList.Count]));
 Kill(TheFullSharedMemoryList);
 FreeShmCounters;
end;

initialization

 Init_crw_sharm;

finalization

 Free_crw_sharm;

end.

//////////////
// END OF FILE
//////////////

