{
  ipcobjs.pas - Implements System V IPC objects.

  TVSemaphore, TVMessageQueue, TVSharedMemory

  Author: Jim Mischel

  --- modificada en 2008 para compilar con FreePascal ---- by Ruben Chaer.
}
unit ipcobjs;
{$ALIGN 4}

interface

uses ERRORS, baseunix, ctypes, SysUtils, ipc;
//Libc;

{ definitions for all IPC functions }
const
  // mode bits for msgget, semget, shmget
  ipcCreate    = IPC_CREAT;
  ipcExclusive = IPC_EXCL;
  ipcNoWait    = IPC_NOWAIT;

  // control commands for msgctl, semctl, shmctl
  ipcRemoveID  = IPC_RMID;
  ipcSet       = IPC_SET;
  ipcStat      = IPC_STAT;
  ipcInfo      = IPC_INFO;

(*
  // special key value
  ipcPrivate   = IPC_PRIVATE;
  *)

type
  // ipc_perm structure to correct ipc.
  // data structure used to pass permission info to IPC operations.
  PVIpcPermission = ^TVIpcPermission;
  TVIpcPermission = TIPC_Perm;
  (*
  record
    __key: __key_t; // Key
    uid: word;      // Owner's user ID
    gid: word;      // Owner's group ID
    cuid: word;     // Creator's user ID
    cgid: word;     // Creator's group ID
    mode: word;     // Read/Write permission
    __seq: word;    // Sequence number
  end;
    *)
{ Definitions for TVSemaphore }
const
  // flags for semop
  semUndo      = ipc.SEM_UNDO;

  // commands for semctl
  semGetPid    = ipc.SEM_GETPID;
  semGetVal    = ipc.SEM_GETVAL;
  semGetAll    = ipc.SEM_GETALL;
  semGetNCnt   = ipc.SEM_GETNCNT;
  semGetZCnt   = ipc.SEM_GETZCNT;
  semSetVal    = ipc.SEM_SETVAL;
  semSetAll    = ipc.SEM_SETALL;

  semStat      = ipc.IPC_STAT;
  // note, semInfo conflicts with ipc.seminfo record
  _semInfo     = ipc.IPC_INFO;

type
  PVSemaphoreIdDescriptor = ^TVSemaphoreIdDescriptor;
  TVSemaphoreIdDescriptor = ipc.TSEMid_ds;

  PSemaphoreInfo= ipc.PSEMinfo;

  TSemaphoreBuffer= TSEMbuf;

  PVSemUnion = ^TVSemUnion;
  TVSemUnion = ipc.TSEMun;

  PSemaphoreBuffer= ipc.PSEMbuf;
  size_t= cuint;

  TVSemaphoreItem =  class;  // forward declaration

  {
    TVSemaphoreSet implements a System V semaphore set.
    It contains an array of TVSemaphoreItem objects.
  }
  TVSemaphoreSet = class (TObject)
  private
    FSemID : Integer;
    FError : Integer;
    FSems  : array of TVSemaphoreItem;
    FCount : Integer;
    function  GetItem (Index: Integer): TVSemaphoreItem;
    function  GetAccessMode : Word;
    procedure SetAccessMode (aMode: Word);
  public
    constructor Create (key : key_t; members: Integer; flags: Integer);
    destructor Destroy; override;
    procedure Remove;
    function  GetStat: TVSemaphoreIDDescriptor;
    procedure SetStat (const aStat: TVSemaphoreIDDescriptor);
    procedure GetAll (aValues: PWord);
    procedure SetAll (aValues: PWord);
    function  SemOp (sops: PSemaphoreBuffer; nsops: size_t): Integer;
    function  SemCtl (Member, cmd: Integer; arg: PVSemUnion): Integer;
    property  AccessMode : Word read GetAccessMode write SetAccessMode;
    property  Count : Integer read FCount;
    property  Items[Index: Integer]: TVSemaphoreItem read GetItem;
    property  LastError : Integer read FError;
    property  SemID : Integer read FSemID;
  end;

  {
    TVSemaphoreItem implements operations that are performed on individual
    semaphores within a semaphore set.
  }
  TVSemaphoreItem = class (TObject)
  private
    FSemSet : TVSemaphoreSet;
    FSemNo  : Integer;
    function  GetValue: Integer;
    procedure SetValue (aVal: Integer);
    function  GetNCnt: Integer;
    function  GetPid: Integer;
    function  GetZCnt: Integer;
  public
    function  Lock (Value, Flags: Integer): boolean;
    function  TryLock (Value, Flags: Integer): boolean;
    procedure Unlock (Value, Flags: Integer);
    function  WaitZero (flags: Integer): boolean;
    function  TryZero (flags: Integer): boolean;
    property  SemSet: TVSemaphoreSet read FSemSet;
    property  Value: Integer read GetValue write SetValue;
    property  SemNo: Integer read FSemNo;
    property  NCnt: Integer read GetNCnt;
    property  Pid: Integer read GetPid;
    property  ZCnt: Integer read GetZCnt;
  end;

{ Definitions for TVSharedMemory }
const
  { Permission flag for shmget.  }
  shmRead     = ipc.SHM_R;
  shmWrite    = ipc.SHM_W;

  { flags for shmat }
  shmReadOnly = ipc.SHM_RDONLY;
  shmRound    = ipc.SHM_RND;
  shmRemap    = ipc.SHM_REMAP;

  { Commands for `shmctl'.  }
  shmLock     = ipc.SHM_LOCK;
  shmUnlock   = ipc.SHM_UNLOCK;

  { ipcs ctl commands }
  shmStat     = ipc.IPC_STAT;
  shmInfo     = ipc.IPC_INFO;

  (*
  { shm_mode upper byte flags }
  shmDest     = ipc.SHM_DEST;
  shmLocked   = ipc.SHM_LOCKED;
  *)

type
  PVSharedMemIdDescriptor = ^TVSharedMemIdDescriptor;
  TVSharedMemIdDescriptor = ipc.TShmid_ds;

  TVSharedMemory = class (TObject)
  private
    FShmID : Integer;
    FError : Integer;
    FSegPtr : Pointer;
    function  GetAccessMode: Word;
    procedure SetAccessMode (aMode: Word);
    function  GetSize: Integer;
    procedure Attach (aAddr: Pointer; flags: Integer);
    procedure Detach;
  public
    constructor Create (key: key_t; size: size_t; flags, atchFlags: integer);
    destructor Destroy; override;
    procedure Remove;
    function  GetStat: TVSharedMemIdDescriptor;
    procedure SetStat (const ds: TVSharedMemIDDescriptor);
    function  ShmCtl (cmd: Integer; buf: PVSharedMemIdDescriptor): Integer;
    property  AccessMode: Word read GetAccessMode write SetAccessMode;
    property  SegPtr : Pointer read FSegPtr;
    property  SegSize: integer read GetSize;
    property  LastError : Integer read FError;
    property  ShmID : Integer read FShmID;
  end;

{ Definitions for TVMessageQueue }
const
  { flags for send and receive }
  mqExcept    = ipc.MSG_EXCEPT;
  mqNoError   = ipc.MSG_NOERROR;

  mqAny       = 0;  { receive any message on queue }
  mqMsgMax    = 4080;

  mqStat      = ipc.IPC_STAT;
  mqInfo      = ipc.IPC_INFO;

type
  PVMsgQueueIdDesc = ^TVMsgQueueIdDesc ;
  TVMsgQueueIdDesc = ipc.TMSQid_ds;
  (*
  record
    msg_perm: TVIpcPermission;  // operation permissions
    __msg_first: Pointer;       // pointer to first message on queue
    __msg_last: Pointer;        // pointer to last message on queue
    msg_stime: time_t;          // time of last msgsnd command
    msg_rtime: time_t;          // time of last msgrcv command
    msg_ctime: time_t;          // time of last change;
    __wait: Pointer;            // ???
    __rwait: Pointer;           // ???
    __msg_cbytes: Word;         // current number of bytes on queue
    msg_qnum: msgqnum_t;        // number of messages currently on queue
    msg_qbytes: msglen_t;       // max number of bytes allowed on queue
    msg_lspid: __ipc_pid_t;     // pid of last msgsnd
    msg_lrpid: __ipc_pid_t;     // pid of last msgrcv
  end;
  *)
  TVMessageQueue = class (TObject)
  private
    FQueueID : Integer;
    FError   : Integer;
    function  GetAccessMode: Integer;
    procedure SetAccessMode (aMode: Integer);
    function  GetNumBytes: Longword;
    function  GetNumMsgs: msgqnum_t;
    function  GetMaxBytes: msglen_t;
  public
    constructor Create (key: key_t; flags: Integer);
    function  Send (const buf; bufSize: Integer; flags: Integer): boolean;
    function  Recv (var buf; var bufsize: Integer; mtype: longint; flags: Integer): boolean;
    procedure Remove;
    function  GetStat: TVMsgQueueIdDesc;
    procedure SetStat (const ds : TVMsgQueueIDDesc);
    function  MsgCtl (cmd: Integer; buf: PVMsgQueueIdDesc): Integer;
    property  AccessMode: Integer read GetAccessMode write SetAccessMode;
    property  QueueID : Integer read FQueueID;
    property  NumBytes: LongWord read GetNumBytes;
    property  NumMsgs: msgqnum_t read GetNumMsgs;
    property  MaxBytes: msglen_t read GetMaxBytes;
    property  LastError : Integer read FError;
  end;

implementation

{ TVSemaphoreSet }
constructor TVSemaphoreSet.Create (key: key_t; members: Integer; flags: Integer);
var
  iSem : Integer;
begin
  inherited Create;
  FSemID := semget (key, members, flags);
  FError := errno;
  if FSemID = -1 then
    raise Exception.Create (strerror(fpgeterrno));

  FCount := GetStat.sem_nsems;
  // Create and initialize array of TVSemaphoreItem objects
  SetLength (FSems, FCount);
  for iSem := Low(FSems) to High(FSems) do
  begin
    FSems[iSem] := TVSemaphoreItem.Create;
    FSems[iSem].FSemSet := Self;
    FSems[iSem].FSemNo := iSem;
  end;
end;

destructor TVSemaphoreSet.Destroy;
var
  iSem: Integer;
begin
  // free the individual semaphore items and free the array
  for iSem := Low(FSems) to High(FSems) do
    FSems[iSem].Free;
  Finalize (FSems);
  inherited Destroy;
end;

function TVSemaphoreSet.GetItem (Index: Integer): TVSemaphoreItem;
begin
  if (Index < Low(FSems)) or (Index >= High(FSems)) then
    raise Exception.CreateFmt ('Array index out of bounds (%d)', [Index]);
  Result := FSems[Index];
end;

function  TVSemaphoreSet.GetAccessMode : Word;
var
  ds: TVSemaphoreIDDescriptor;
begin
  ds := GetStat;
  Result := ds.sem_perm.mode;
end;

procedure TVSemaphoreSet.SetAccessMode (aMode: Word);
var
  ds: TVSemaphoreIDDescriptor;
begin
  ds := GetStat;
  ds.sem_perm.mode := aMode;
  SetStat (ds);
end;

procedure TVSemaphoreSet.Remove;
begin
  SemCtl (0, ipcRemoveID, nil);
end;

function TVSemaphoreSet.GetStat: TVSemaphoreIDDescriptor;
var
  semopts : TVSemUnion;
  rc : Integer;
begin
  // get current values for internal data structure
  semopts.buf := @Result;
  rc := SemCtl (0, ipcStat, @semopts);
  FError := errno;
  if rc = -1 then
    raise Exception.Create (strerror (errno));
end;

procedure TVSemaphoreSet.SetStat (const aStat: TVSemaphoreIDDescriptor);
var
  semopts : TVSemUnion;
begin
  semopts.buf := @aStat;
  SemCtl (0, ipcSet, @semopts);
end;

function TVSemaphoreSet.SemOp (sops: PSemaphoreBuffer; nsops: size_t): integer;
begin
  Result := ipc.semop (FSemID, sops, nsops);
  FError := errno;
  if (Result = -1) and (not ((errno = ESysEAGAIN) or (errno = ESysEINTR))) then
    raise Exception.Create (strerror (errno))
end;

function TVSemaphoreSet.SemCtl (Member, cmd: Integer; arg: PVSemUnion): Integer;
var
  rc : Integer;
begin

//  if Assigned (arg) then
    rc := ipc.semctl(FSemID, Member, cmd, arg^);
    (*
  else
    rc := ipc.semctl(FSemID, Member, cmd);
      *)

  FError := errno;
  if (rc = -1) and (errno <> 0) then
    raise Exception.Create (strerror (errno));
  Result := rc;
end;

procedure TVSemaphoreSet.GetAll (aValues: PWord);
var
  arg : TVSemUnion;
begin
  arg.arr := aValues;
  SemCtl (0, semGetAll, @arg);
end;

procedure TVSemaphoreSet.SetAll (aValues: PWord);
var
  arg : TVSemUnion;
begin
  arg.arr := aValues;
  SemCtl (0, semSetAll, @arg);
end;

{ TVSemaphoreItem }

function TVSemaphoreItem.GetValue: Integer;
begin
  Result := FSemSet.SemCtl (FSemNo, semGetVal, nil);
end;

procedure TVSemaphoreItem.SetValue (aVal: Integer);
var
  semopts : TVSemUnion;
begin
  semopts.val := aVal;
  FSemSet.SemCtl (FSemNo, semSetVal, @semopts);
end;

function  TVSemaphoreItem.GetNCnt: Integer;
begin
  Result := FSemSet.SemCtl (FSemNo, semGetNCnt, nil);
end;

function  TVSemaphoreItem.GetPid: Integer;
begin
  Result := FSemSet.SemCtl (FSemNo, semGetPid, nil);
end;

function  TVSemaphoreItem.GetZCnt: Integer;
begin
  Result := FSemSet.SemCtl (FSemNo, semGetZCnt, nil);
end;

function TVSemaphoreItem.Lock (Value, Flags: Integer): boolean;
var
  sem_lock : TSemaphoreBuffer;
begin
  sem_lock.sem_num := FSemNo;
  sem_lock.sem_op := -Value;
  sem_lock.sem_flg := Flags;
  Result := (FSemSet.SemOp (@sem_lock, 1) <> -1);
end;

function TVSemaphoreItem.TryLock (Value, Flags: Integer): boolean;
begin
  Result := Lock (Value, Flags or ipcNoWait);
end;

procedure TVSemaphoreItem.Unlock (Value, Flags: Integer);
var
  sem_unlock : TSemaphoreBuffer;
begin
  sem_unlock.sem_num := FSemNo;
  sem_unlock.sem_op := Value;
  sem_unlock.sem_flg := Flags;
  FSemSet.SemOp (@sem_unlock, 1);
end;

function TVSemaphoreItem.WaitZero (flags: Integer): boolean;
var
  sem_lock : TSemaphoreBuffer;
begin
  sem_lock.sem_num := FSemNo;
  sem_lock.sem_op := 0;
  sem_lock.sem_flg := Flags;
  Result := (FSemSet.SemOp (@sem_lock, 1) <> -1);
end;

function TVSemaphoreItem.TryZero (flags: Integer): boolean;
begin
  Result := WaitZero (flags or ipcNoWait);
end;


{ TVSharedMemory }

constructor TVSharedMemory.Create (key: key_t; size: size_t;
  flags, atchFlags: integer);
begin
  inherited Create;
  FShmID := shmget (key, size, flags);
  FError := errno;
  if FShmID = -1 then
    raise Exception.Create (strerror (errno));
  Attach (nil, atchFlags);
end;

destructor TVSharedMemory.Destroy;
begin
  Detach;
  inherited Destroy;
end;

procedure TVSharedMemory.Remove;
begin
  Detach;
  ShmCtl (ipcRemoveID, nil);
end;

procedure TVSharedMemory.Attach (aAddr: Pointer; flags: Integer);
var
  rc : Pointer;
begin
  rc := shmat (FShmID, aAddr, flags);
  FError := errno;
  if Integer(rc) = -1 then
    raise Exception.Create (strerror (errno));
  FSegPtr := rc;
end;

procedure TVSharedMemory.Detach;
var
  rc : Integer;
begin
  if Assigned (FSegPtr) then
  begin
    rc := shmdt (FSegPtr);
    FError := errno;
    if rc = -1 then
      raise Exception.Create (strerror (errno));
    FSegPtr := nil;
  end;
end;

function TVSharedMemory.GetAccessMode: Word;
var
  ds: TVSharedMemIDDescriptor;
begin
  ds := GetStat;
  Result := ds.shm_perm.mode;
end;

procedure TVSharedMemory.SetAccessMode (aMode: Word);
var
  ds: TVSharedMemIDDescriptor;
begin
  ds := GetStat;
  ds.shm_perm.mode := aMode;
  SetStat (ds);
end;

function TVSharedMemory.GetStat: TVSharedMemIdDescriptor;
begin
  ShmCtl (ipcStat, @Result);
end;

procedure TVSharedMemory.SetStat (const ds: TVSharedMemIDDescriptor);
begin
  ShmCtl (ipcSet, @ds);
end;

function TVSharedMemory.ShmCtl (cmd: Integer; buf: PVSharedMemIdDescriptor): Integer;
var
  rc: Integer;
begin
  // The typecast is required to use the correct structures...
  rc := ipc.shmctl (FShmID, cmd, buf);
  FError := errno;
  if rc = -1 then
    raise Exception.Create (strerror (errno));
  Result := rc;
end;

function TVSharedMemory.GetSize: Integer;
begin
  Result := GetStat.shm_segsz;
end;

{ TVMessageQueue }
constructor TVMessageQueue.Create (key: key_t; flags: Integer);
begin
  inherited Create;
  FQueueID := msgget (Key, flags);
  FError := errno;
  if FQueueID = -1 then
    raise Exception.Create (strerror (errno));
end;

procedure TVMessageQueue.Remove;
begin
  MsgCtl (ipcRemoveID, nil);
end;

function TVMessageQueue.Send (const buf; bufSize: Integer; flags: Integer): boolean;
var
  rc : Integer;
begin
  rc := msgsnd (FQueueID, @TMSGbuf(buf), bufSize, flags);
  FError := errno;
  if rc = -1 then
    if (errno = ESysEAGAIN) or (errno = ESysEINTR) then
      Result := false
    else
      raise Exception.Create (strerror (errno))
  else
    Result := true;
end;

function TVMessageQueue.Recv (var buf; var bufsize: Integer; mtype: longint;
  flags: Integer): boolean;
begin
  bufsize := msgrcv (FQueueID, @TMSGbuf(buf), bufsize, mtype, flags);
  FError := errno;
  if bufsize = -1 then
    if (errno = ESysENOMSG) or (errno = ESysEINTR) then
      Result := false
    else
      raise Exception.Create (strerror (errno))
  else
    Result := true;
end;

function  TVMessageQueue.GetAccessMode: Integer;
var
  ds: TVMsgQueueIDDesc;
begin
  ds := GetStat;
  Result := ds.msg_perm.mode;
end;

procedure TVMessageQueue.SetAccessMode (aMode: Integer);
var
  ds: TVMsgQueueIDDesc;
begin
  ds := GetStat;
  ds.msg_perm.mode := aMode;
  SetStat (ds);
end;

function  TVMessageQueue.GetNumBytes: Longword;
begin
  Result := GetStat.msg_cbytes;
end;

function  TVMessageQueue.GetNumMsgs: msgqnum_t;
begin
  Result := GetStat.msg_qnum;
end;

function  TVMessageQueue.GetMaxBytes: msglen_t;
begin
  Result := GetStat.msg_qbytes;
end;

function TVMessageQueue.GetStat: TVMsgQueueIdDesc;
begin
  MsgCtl (ipcStat, @Result);
end;

procedure TVMessageQueue.SetStat (const ds : TVMsgQueueIDDesc);
begin
  MsgCtl (ipcSet, @ds);
end;

function TVMessageQueue.MsgCtl (cmd: Integer; buf: PVMsgQueueIdDesc): Integer;
var
  rc: Integer;
begin
  rc := ipc.msgctl (FQueueID, cmd, buf);
  FError := errno;
  if rc = -1 then
    raise Exception.Create (strerror (errno));
  Result := rc;
end;


{initialization
writeln('ini-> ipcobjs');}
end.




