 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2003, <kouriakine@mail.ru>
 Shared memory access class.
 Modifications:
 20030113 - Creation & test
 20030330 - Struggle for safety (add some try/except checks)...
 20040424 - FileMappingResult,MapViewResult
 ****************************************************************************
 }

unit _sharm;

{$I _sysdef}

interface

uses
 SysUtils, Windows, Math, _alloc;

 ///////////////////////////////////////////////////////////////////////////////
 // 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;
  mySize  : Integer;
  myName  : packed array[0..255] of Char;
  myFMR   : Integer;
  myMVR   : Integer;
  function  GetSize:Integer;
  function  GetData:Pointer;
  function  GetName:ShortString;
  function  GetCapacity:Integer;
  function  GetAsPtr(i:Integer):Pointer;
  function  GetAsPChar(i:Integer):PChar;
  function  GetAsInteger(i:Integer):Integer;
  procedure SetAsInteger(i:Integer; v:Integer);
  function  GetAsDouble(i:Integer):Double;
  procedure SetAsDouble(i:Integer; v:Double);
  function  GetFileMappingResult:Integer;
  function  GetMapViewResult:Integer;
 protected
  function  CheckOk:Boolean; override;
 public
  constructor Create(const aName:ShortString; aSize:Integer);
  destructor  Destroy; override;
  property    Size                 : Integer     read GetSize;
  property    Data                 : Pointer     read GetData;
  property    Name                 : ShortString read GetName;
  property    Capacity             : Integer     read GetCapacity;
  property    AsPtr[i:Integer]     : Pointer     read GetAsPtr;     default;
  property    AsPChar[i:Integer]   : PChar       read GetAsPChar;
  property    AsInteger[i:Integer] : Integer     read GetAsInteger  write SetAsInteger;
  property    AsDouble[i:Integer]  : Double      read GetAsDouble   write SetAsDouble;
  property    FileMappingResult    : Integer     read GetFileMappingResult;
  property    MapViewResult        : Integer     read GetMapViewResult;
 end;

function  NewSharedMemory(const aName:ShortString; aSize:Integer):TSharedMemory;
procedure Kill(var TheObject:TSharedMemory); overload;

implementation

constructor TSharedMemory.Create(const aName:ShortString; aSize:Integer);
begin
 inherited Create;
 Exceptions:=false;
 myFile:=0;
 myData:=nil;
 mySize:=Max(0,aSize);
 myName:='';
 if mySize>0 then StrPCopy(myName,Trim(aName));
 if myName<>'' then begin
  myFile:=CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE+SEC_COMMIT, 0, mySize, myName);
  myFMR:=GetLastError;
 end else myFMR:=0;
 if myFile<>0 then begin
  myData:=MapViewOfFile(myFile, FILE_MAP_ALL_ACCESS, 0, 0, 0);
  myMVR:=GetLastError;
 end else myMVR:=0;
end;

destructor  TSharedMemory.Destroy;
begin
 if myData<>nil then UnmapViewOfFile(myData);
 if myFile<>0 then CloseHandle(myFile);
 inherited Destroy;
end;

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

function TSharedMemory.GetCapacity:Integer;
const
 PageSize : Integer = 0;
var
 SystemInfo : TSystemInfo;
begin
 if PageSize = 0 then begin
  GetSystemInfo(SystemInfo);
  PageSize:=SystemInfo.dwPageSize;
 end;
 Result:=AdjustBufferSize(Size,PageSize);
end;

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

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

function TSharedMemory.GetAsPtr(i:Integer):Pointer;
begin
 if Assigned(Self) and Assigned(myData) then Result:=@(PChar(myData)[i]) else Result:=nil;
end;

function TSharedMemory.GetAsPChar(i:Integer):PChar;
begin
 if Assigned(Self) and Assigned(myData) then Result:=@(PChar(myData)[i]) else Result:=nil;
end;

function TSharedMemory.GetAsInteger(i:Integer):Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Result:=PIntegerArray(myData)[i];
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TSharedMemory.SetAsInteger(i:Integer;v:Integer);
begin
 if Assigned(Self) then
 try
  PIntegerArray(myData)[i]:=v;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TSharedMemory.GetAsDouble(i:Integer):Double;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Result:=PDoubleArray(myData)[i];
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TSharedMemory.SetAsDouble(i:Integer; v:Double);
begin
 if Assigned(Self) then
 try
  PDoubleArray(myData)[i]:=v;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

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

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

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

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

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

end.

