freepascal.compiler/rtl/linux/ipc.pp

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1998 by the Free Pascal development team

    This file implements IPC calls calls for Linux
    
    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

Unit ipc;

interface

{ ----------------------------------------------------------------------
  General IPC stuff
  ----------------------------------------------------------------------}

Var
  IPCError : longint;

Type 
   TKey   = Longint;
   PULong = ^Cardinal;

Const 
  { IPC flags for get calls }

  IPC_CREAT  =  1 shl 9;  { create if key is nonexistent }
  IPC_EXCL   =  2 shl 9;  { fail if key exists }
  IPC_NOWAIT =  4 shl 9;  { return error on wait }

  { Actions for ctl calls }

  IPC_RMID = 0;     { remove resource }
  IPC_SET  = 1;     { set ipc_perm options }
  IPC_STAT = 2;     { get ipc_perm options }
  IPC_INFO = 3;     { see ipcs }

type
  PIPC_Perm = ^TIPC_Perm;
  TIPC_Perm = record
    key : TKey;
    uid, 
    gid,
    cuid,
    cgid,
    mode,
    seq : Word;   
  end;

{ Function to generate a IPC key. }
Function ftok (Path : String; ID : char) : TKey;

{ ----------------------------------------------------------------------
  Shared memory stuff
  ----------------------------------------------------------------------}

Type  
  PShmid_DS = ^TShmid_ds; 
  TShmid_ds = record
    shm_perm  : TIPC_Perm;
    shm_segsz : longint;
    shm_atime : longint;
    shm_dtime : longint;
    shm_ctime : longint;
    shm_cpid  : word;
    shm_lpid  : word;
    shm_nattch : integer;
    shm_npages : word;
    shm_pages  : Pointer;
    attaches   : pointer;
  end;

  const
     SHM_R      = 4 shl 6;
     SHM_W      = 2 shl 6;
     SHM_RDONLY = 1 shl 12;
     SHM_RND    = 2 shl 12;
     SHM_REMAP  = 4 shl 12;
     SHM_LOCK   = 11;
     SHM_UNLOCK = 12;

type
  PSHMinfo = ^TSHMinfo;
  TSHMinfo = record
    shmmax : longint;
    shmmin : longint;
    shmmni : longint;
    shmseg : longint;
    shmall : longint;
  end;

Function shmget(key: Tkey; size:longint; flag:longint):longint;
Function shmat (shmid:longint; shmaddr:pchar; shmflg:longint):pchar;
Function shmdt (shmaddr:pchar):boolean;
Function shmctl(shmid:longint; cmd:longint; buf: pshmid_ds): Boolean;

{ ----------------------------------------------------------------------
  Message queue stuff
  ----------------------------------------------------------------------}

const
  MSG_NOERROR = 1 shl 12;
  MSG_EXCEPT  = 2 shl 12;

  MSGMNI = 128;
  MSGMAX = 4056;
  MSGMNB = 16384;


type
  PMSG = ^TMSG;
  TMSG = record
    msg_next  : PMSG;
    msg_type  : Longint;
    msg_spot  : PChar;
    msg_stime : Longint;
    msg_ts    : Integer;
  end;

type

  PMSQid_ds = ^TMSQid_ds;
  TMSQid_ds = record
    msg_perm   : TIPC_perm;
    msg_first  : PMsg;
    msg_last   : PMsg;
    msg_stime  : Longint;
    msg_rtime  : Longint;
    msg_ctime  : Longint;
    wwait      : Pointer;
    rwait      : pointer;
    msg_cbytes : word;
    msg_qnum   : word;
    msg_qbytes : word;
    msg_lspid  : word;
    msg_lrpid  : word;
  end;

  PMSGbuf = ^TMSGbuf;
  TMSGbuf = record
    mtype : longint;
    mtext : array[0..0] of char;
  end;

  PMSGinfo = ^TMSGinfo;
  TMSGinfo = record
    msgpool : Longint;
    msgmap  : Longint;
    msgmax  : Longint;
    msgmnb  : Longint;
    msgmni  : Longint;
    msgssz  : Longint;
    msgtql  : Longint;
    msgseg  : Word;
  end;

Function msgget(key: TKey; msgflg:longint):longint;	
Function msgsnd(msqid:longint; msgp: PMSGBuf; msgsz: longint; msgflg:longint): Boolean;
Function msgrcv(msqid:longint; msgp: PMSGBuf; msgsz: longint; msgtyp:longint; msgflg:longint): Boolean;
Function msgctl(msqid:longint; cmd: longint; buf: PMSQid_ds): Boolean;

{ ----------------------------------------------------------------------
  Semaphores stuff
  ----------------------------------------------------------------------}

const
     SEM_UNDO = $1000;
     GETPID = 11;
     GETVAL = 12;
     GETALL = 13;
     GETNCNT = 14;
     GETZCNT = 15;
     SETVAL = 16;
     SETALL = 17;

     SEMMNI = 128;
     SEMMSL = 32;
     SEMMNS = (SEMMNI * SEMMSL);
     SEMOPM = 32;
     SEMVMX = 32767;

type
  PSEMid_ds = ^PSEMid_ds;
  TSEMid_ds = record
    sem_perm : tipc_perm;
    sem_otime : longint;
    sem_ctime : longint;
    sem_base         : pointer;
    sem_pending      : pointer;
    sem_pending_last : pointer;
    undo             : pointer;
    sem_nsems : word;
  end;

  PSEMbuf = ^TSEMbuf;
  TSEMbuf = record
    sem_num : word;
    sem_op  : integer;
    sem_flg : integer;
  end;


  PSEMinfo = ^TSEMinfo;
  TSEMinfo = record
    semmap : longint;
    semmni : longint;
    semmns : longint;
    semmnu : longint;
    semmsl : longint;
    semopm : longint;
    semume : longint;
    semusz : longint;
    semvmx : longint;
    semaem : longint;
  end;

  PSEMun = ^TSEMun;
  TSEMun = record
   case longint of
      0 : ( val : longint );
      1 : ( buf : PSEMid_ds );
      2 : ( arr : Pointer );
      3 : ( padbuf : PSeminfo );
      4 : ( padpad : pointer );
   end;

Function semget(key:Tkey; nsems:longint; semflg:longint): longint;
Function semop(semid:longint; sops: pointer; nsops: cardinal): Boolean;
Function semctl(semid:longint; semnum:longint; cmd:longint; arg: tsemun): longint;

implementation

uses Linux;

{ The following definitions come from linux/ipc.h }

Const
  CALL_SEMOP   = 1;
  CALL_SEMGET  = 2;
  CALL_SEMCTL  = 3;
  CALL_MSGSND  = 11;
  CALL_MSGRCV  = 12;
  CALL_MSGGET  = 13;
  CALL_MSGCTL  = 14;
  CALL_SHMAT   = 21;
  CALL_SHMDT   = 22;
  CALL_SHMGET  = 23;
  CALL_SHMCTL  = 24;

{ generic call that handles all IPC calls }

function ipccall(Call,First,Second,Third : Longint; P : Pointer) : longint;

Var SR : SysCallRegs;

begin
  SR.Reg2:=Call;
  SR.reg3:=first;
  SR.reg4:=second;
  SR.Reg5:=third;
  SR.Reg6:=Longint(P);
  ipccall:=syscall(syscall_nr_ipc,sr);
  ipcerror:=Errno;
end;

Function ftok (Path : String; ID : char) : TKey;

Var Info : Stat;

begin
  If not fstat(path,info) then
    ftok:=-1
  else
    begin
    ftok:= (info.ino and $FFFF) or ((info.dev and $ff) shl 16) or (byte(ID) shl 24)
    end;
end;

function shmget(key: Tkey; size:longint; flag:longint):longint;

begin
  shmget:=ipccall (CALL_SHMGET,key,size,flag,nil);
end;

function shmat (shmid:longint; shmaddr:pchar; shmflg:longint): pchar;

Var raddr : pchar;
    error : longint;
    
begin
  error:=ipccall(CALL_SHMAT,shmid,shmflg,longint(@raddr),shmaddr);
  If Error<0 then
    shmat:=pchar(error)
  else
    shmat:=raddr;
end;

function shmdt (shmaddr:pchar): boolean;
begin
  shmdt:=ipccall(CALL_SHMDT,0,0,0,shmaddr)<>-1;
end;

function shmctl(shmid:longint; cmd:longint; buf: pshmid_ds): Boolean;
begin
 shmctl:=ipccall(CALL_SHMCTL,shmid,cmd,0,buf)=0;
end;

Function msgget(key:Tkey; msgflg:longint):longint;

begin
  msgget:=ipccall(CALL_MSGGET,key,msgflg,0,Nil);
end;

Function msgsnd(msqid:longint; msgp: PMSGBuf; msgsz: longint; msgflg:longint):Boolean;

begin
  msgsnd:=ipccall(Call_MSGSND,msqid,msgsz,msgflg,msgp)=0;
end;

Function msgrcv(msqid:longint; msgp: PMSGBuf; msgsz: longint; msgtyp:longint; msgflg:longint):Boolean;

Type
  TIPC_Kludge = Record
    msgp   : pmsgbuf;
    msgtyp : longint;
  end;

Var 
   tmp : TIPC_Kludge;

begin
  tmp.msgp   := msgp;
  tmp.msgtyp := msgtyp;
  msgrcv:=ipccall(CALL_MSGRCV,msqid,msgsz,msgflg,@tmp)>=0;
end;

Function msgctl(msqid:longint; cmd: longint; buf: PMSQid_ds): Boolean;

begin
  msgctl:=ipccall(CALL_MSGCTL,msqid,cmd,0,buf)=0;
end;

Function semget(key:Tkey; nsems:longint; semflg:longint): longint;

begin
  semget:=ipccall (CALL_SEMGET,key,nsems,semflg,Nil);
end;

Function semop(semid:longint; sops: pointer; nsops:cardinal): Boolean;

begin
  semop:=ipccall (CALL_SEMOP,semid,Longint(nsops),0,Pointer(sops))=0;
end;

Function semctl(semid:longint; semnum:longint; cmd:longint; arg: tsemun): longint;
begin
  semctl:=ipccall(CALL_SEMCTL,semid,semnum,cmd,@arg);
end;

end.