Next: 11. The LINUX unit. Up: Free Pascal supplied units Previous: 9. The HEAPTRC unit.
The chapter is divided in 2 sections:
Var IPCerror : longint;The IPCerror variable is used to report errors, by all calls.
Const
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 }
These constants are used in the various xxxget 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 }
These constants can be passed to the various xxxctl calls.
const MSG_NOERROR = 1 shl 12; MSG_EXCEPT = 2 shl 12; MSGMNI = 128; MSGMAX = 4056; MSGMNB = 16384;These constants are used in the messaging system, they are not for use by the programmer.
const SEM_UNDO = $1000; GETPID = 11; GETVAL = 12; GETALL = 13; GETNCNT = 14; GETZCNT = 15; SETVAL = 16; SETALL = 17;These constants call be specified in the semop call.
SEMMNI = 128; SEMMSL = 32; SEMMNS = (SEMMNI * SEMMSL); SEMOPM = 32; SEMVMX = 32767;These constanst are used internally by the semaphore system, they should not be used by the programmer.
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;These constants are used in the shmctl call.
Type PULong = ^Cardinal; PWord = ^Word;
Type TKey = Longint;TKey is the type returned by the ftok key generating function.
type
PIPC_Perm = ^TIPC_Perm;
TIPC_Perm = record
key : TKey;
uid,
gid,
cuid,
cgid,
mode,
seq : Word;
end;
The TIPC_Perm structure is used in all IPC systems to specify the
permissions.
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;
The TSHMid_ds strucure is used in the shmctl call to set or
retrieve settings concerning shared memory.
type
PSHMinfo = ^TSHMinfo;
TSHMinfo = record
shmmax : longint;
shmmin : longint;
shmmni : longint;
shmseg : longint;
shmall : longint;
end;
The TSHMinfo record is used by the shared memory system, and should
not be accessed by the programer directly.
type
PMSG = ^TMSG;
TMSG = record
msg_next : PMSG;
msg_type : Longint;
msg_spot : PChar;
msg_stime : Longint;
msg_ts : Integer;
end;
The TMSG record is used in the handling of message queues. There
should be few cases where the programmer needs to access this data.
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;
The TMSQid_ds record is returned by the msgctl call, and
contains all data about a message queue.
PMSGbuf = ^TMSGbuf;
TMSGbuf = record
mtype : longint;
mtext : array[0..0] of char;
end;
The TMSGbuf record is a record containing the data of a record. you
should never use this record directly, instead you should make your own
record that follows the structure of the TMSGbuf record, but that has
a size that is big enough to accomodate your messages. The mtype field
should always be present, and should always be filled.
Type
PMSGinfo = ^TMSGinfo;
TMSGinfo = record
msgpool : Longint;
msgmap : Longint;
msgmax : Longint;
msgmnb : Longint;
msgmni : Longint;
msgssz : Longint;
msgtql : Longint;
msgseg : Word;
end;
The TMSGinfo record is used internally by the message queue system,
and should not be used by the programmer directly.
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;
The TSEMid_ds structure is returned by the semctl call, and
contains all data concerning a semahore.
Type
PSEMbuf = ^TSEMbuf;
TSEMbuf = record
sem_num : word;
sem_op : integer;
sem_flg : integer;
end;
The TSEMbuf record us use in the semop call, and is used to
specify which operations you want to do.
Type
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;
The TSEMinfo record is used internally by the semaphore system, and
should not be used directly.
Type
PSEMun = ^TSEMun;
TSEMun = record
case longint of
0 : ( val : longint );
1 : ( buf : PSEMid_ds );
2 : ( arr : PWord );
3 : ( padbuf : PSeminfo );
4 : ( padpad : pointer );
end;
The TSEMun variant record (actually a C union) is used in the
semctl call.
Path is the name of a file in the file system, ID is a character of your choice. The ftok call does the same as it's C couterpart, so a pascal program and a C program will access the same resource if they use the same Path and ID
For an example, see msgctl, semctl, shmctl.
msgflg can have one or more of the following values (combined by ORs):
For an example, see msgctl.
The msgflg can have a combination of the following values (ORed together):
The function returns True if the message was sent successfully, False otherwise.
For an example, see msgctl.
The msgflg parameter can be used to control the behaviour of the msgrcv call. It consists of an ORed combination of the following flags:
The function returns True if the message was received correctly, False otherwise.
For an example, see msgctl.
buf contains the data that are needed by the call. It can be Nil in case the message queue should be removed.
The function returns True if successfull, False otherwise.
program msgtool;
Uses ipc;
Type
PMyMsgBuf = ^TMyMsgBuf;
TMyMsgBuf = record
mtype : Longint;
mtext : string[255];
end;
Procedure DoError (Const Msg : string);
begin
Writeln (msg,'returned an error : ',ipcerror);
halt(1);
end;
Procedure SendMessage (Id : Longint;
Var Buf : TMyMsgBuf;
MType : Longint;
Const MText : String);
begin
Writeln ('Sending message.');
Buf.mtype:=mtype;
Buf.Mtext:=mtext;
If not msgsnd(Id,PMsgBuf(@Buf),256,0) then
DoError('msgsnd');
end;
Procedure ReadMessage (ID : Longint;
Var Buf : TMyMsgBuf;
MType : longint);
begin
Writeln ('Reading message.');
Buf.MType:=MType;
If msgrcv(ID,PMSGBuf(@Buf),256,mtype,0) then
Writeln ('Type : ',buf.mtype,' Text : ',buf.mtext)
else
DoError ('msgrcv');
end;
Procedure RemoveQueue ( ID : Longint);
begin
If msgctl (id,IPC_RMID,Nil) then
Writeln ('Removed Queue with id',Id);
end;
Procedure ChangeQueueMode (ID,mode : longint);
Var QueueDS : TMSQid_ds;
begin
If Not msgctl (Id,IPC_STAT,@QueueDS) then
DoError ('msgctl : stat');
Writeln ('Old permissions : ',QueueDS.msg_perm.mode);
QueueDS.msg_perm.mode:=Mode;
if msgctl (ID,IPC_SET,@QueueDS) then
Writeln ('New permissions : ',QueueDS.msg_perm.mode)
else
DoError ('msgctl : IPC_SET');
end;
procedure usage;
begin
Writeln ('Usage : msgtool s(end) <type> <text> (max 255 characters)');
Writeln (' r(eceive) <type>');
Writeln (' d(elete)');
Writeln (' m(ode) <decimal mode>');
halt(1);
end;
Function StrToInt (S : String): longint;
Var M : longint;
C : Integer;
begin
val (S,M,C);
If C<>0 Then DoError ('StrToInt : '+S);
StrToInt:=M;
end;
Var
Key : TKey;
ID : longint;
Buf : TMyMsgBuf;
begin
If Paramcount<1 then Usage;
key :=Ftok('.','M');
ID:=msgget(key,IPC_CREAT or 438);
If ID<0 then DoError ('MsgGet');
Case upCase(Paramstr(1)[1]) of
'S' : If ParamCount<>3 then
Usage
else
SendMessage (id,Buf,StrToInt(Paramstr(2)),paramstr(3));
'R' : If ParamCount<>2 then
Usage
else
ReadMessage (id,buf,strtoint(Paramstr(2)));
'D' : If ParamCount<>1 then
Usage
else
RemoveQueue (ID);
'M' : If ParamCount<>2 then
Usage
else
ChangeQueueMode (id,strtoint(paramstr(2)));
else
Usage
end;
end.
semflg can have one or more of the following values (combined by ORs):
if a new set of semaphores is created, then there will be nsems semaphores in it.
The fields of the TSEMbuf structure
TSEMbuf = record
sem_num : word;
sem_op : integer;
sem_flg : integer;
should be filled as follows:
The function returns True if the operations were successful, False otherwise.
The arg parameter supplies the data needed for each call. This is a variant record that should be filled differently, according to the command:
Type
TSEMun = record
case longint of
0 : ( val : longint );
1 : ( buf : PSEMid_ds );
2 : ( arr : PWord );
3 : ( padbuf : PSeminfo );
4 : ( padpad : pointer );
end;
Which operation is performed, depends on the cmd parameter, which can have one of the following values:
The function returns -1 on error.
Program semtool;
{ Program to demonstrat the use of semaphores }
Uses ipc;
Const MaxSemValue = 5;
Procedure DoError (Const Msg : String);
begin
Writeln ('Error : ',msg,' Code : ',IPCerror);
Halt(1);
end;
Function getsemval (ID,Member : longint) : longint;
Var S : TSEMun;
begin
GetSemVal:=SemCtl(id,member,GETVAL,S);
end;
Procedure DispVal (ID,member : longint);
begin
writeln ('Value for member ',member,' is ',GetSemVal(ID,Member));
end;
Function GetMemberCount (ID : Longint) : longint;
Var opts : TSEMun;
semds : TSEMid_ds;
begin
opts.buf:=@semds;
If semctl(Id,0,IPC_STAT,opts)<>-1 then
GetMemberCount:=semds.sem_nsems
else
GetMemberCount:=-1;
end;
Function OpenSem (Key : TKey) : Longint;
begin
OpenSem:=semget(Key,0,438);
If OpenSem=-1 then
DoError ('OpenSem');
end;
Function CreateSem (Key : TKey; Members : Longint) : Longint;
Var Count : Longint;
Semopts : TSemun;
begin
If members>semmsl then
DoError ('Sorry, maximum number of semaphores in set exceeded');
Writeln ('Trying to create a new semaphore set with ',members,' members.');
CreateSem:=semget(key,members,IPC_CREAT or IPC_Excl or 438);
If CreateSem=-1 then
DoError ('Semaphore set already exists.');
Semopts.val:=MaxSemValue; { Initial value of semaphores }
For Count:=0 to Members-1 do
semctl(CreateSem,count,setval,semopts);
end;
Procedure lockSem (ID,Member: Longint);
Var lock : TSEMbuf;
begin
With lock do
begin
sem_num:=0;
sem_op:=-1;
sem_flg:=IPC_NOWAIT;
end;
if (member<0) or (member>GetMemberCount(ID)-1) then
DoError ('semaphore member out of range');
if getsemval(ID,member)=0 then
DoError ('Semaphore resources exhausted (no lock)');
lock.sem_num:=member;
Writeln ('Attempting to lock member ',member, ' of semaphore ',ID);
if not semop(Id,@lock,1) then
DoError ('Lock failed')
else
Writeln ('Semaphore resources decremented by one');
dispval(ID,Member);
end;
Procedure UnlockSem (ID,Member: Longint);
Var Unlock : TSEMbuf;
begin
With Unlock do
begin
sem_num:=0;
sem_op:=1;
sem_flg:=IPC_NOWAIT;
end;
if (member<0) or (member>GetMemberCount(ID)-1) then
DoError ('semaphore member out of range');
if getsemval(ID,member)=MaxSemValue then
DoError ('Semaphore not locked');
Unlock.sem_num:=member;
Writeln ('Attempting to unlock member ',member, ' of semaphore ',ID);
if not semop(Id,@unlock,1) then
DoError ('Unlock failed')
else
Writeln ('Semaphore resources incremented by one');
dispval(ID,Member);
end;
Procedure RemoveSem (ID : longint);
var S : TSemun;
begin
If semctl(Id,0,IPC_RMID,s)<>-1 then
Writeln ('Semaphore removed')
else
DoError ('Couldn''t remove semaphore');
end;
Procedure ChangeMode (ID,Mode : longint);
Var rc : longint;
opts : TSEMun;
semds : TSEMid_ds;
begin
opts.buf:=@semds;
If not semctl (Id,0,IPC_STAT,opts)<>-1 then
DoError ('Couldn''t stat semaphore');
Writeln ('Old permissions were : ',semds.sem_perm.mode);
semds.sem_perm.mode:=mode;
If semctl(id,0,IPC_SET,opts)<>-1 then
Writeln ('Set permissions to ',mode)
else
DoError ('Couldn''t set permissions');
end;
Procedure PrintSem (ID : longint);
Var I,cnt : longint;
begin
cnt:=getmembercount(ID);
Writeln ('Semaphore ',ID,' has ',cnt,' Members');
For I:=0 to cnt-1 Do
DispVal(id,i);
end;
Procedure USage;
begin
Writeln ('Usage : semtool c(reate) <count>');
Writeln (' l(ock) <member>');
Writeln (' u(nlock) <member>');
Writeln (' d(elete)');
Writeln (' m(ode) <mode>');
halt(1);
end;
Function StrToInt (S : String): longint;
Var M : longint;
C : Integer;
begin
val (S,M,C);
If C<>0 Then DoError ('StrToInt : '+S);
StrToInt:=M;
end;
Var Key : TKey;
ID : Longint;
begin
If ParamCount<1 then USage;
key:=ftok('.','s');
Case UpCase(Paramstr(1)[1]) of
'C' : begin
if paramcount<>2 then usage;
CreateSem (key,strtoint(paramstr(2)));
end;
'L' : begin
if paramcount<>2 then usage;
ID:=OpenSem (key);
LockSem (ID,strtoint(paramstr(2)));
end;
'U' : begin
if paramcount<>2 then usage;
ID:=OpenSem (key);
UnLockSem (ID,strtoint(paramstr(2)));
end;
'M' : begin
if paramcount<>2 then usage;
ID:=OpenSem (key);
ChangeMode (ID,strtoint(paramstr(2)));
end;
'D' : Begin
ID:=OpenSem(Key);
RemoveSem(Id);
end;
'P' : begin
ID:=OpenSem(Key);
PrintSem(Id);
end;
else
Usage
end;
end.
flag can have one or more of the following values (combined by ORs):
if a new memory block is created, then it will have size Size semaphores in it.
If shmaddr is Nil, then the system chooses a free unmapped memory region, as high up in memory space as possible.
If shmaddr is non-nil, and SHM_RND is in shmflg, then the returned address is shmaddr, rounded down to SHMLBA. If SHM_RND is not specified, then shmaddr must be a page-aligned address.
The parameter shmflg can be used to control the behaviour of the shmat call. It consists of a ORed combination of the following costants:
For an example, see shmctl.
The function returns True if the memory block was detached successfully, False otherwise.
The buf parameter points to a TSHMid_ds record. The cmd parameter is used to pass which operation is to be performed. It can have one of the following values :
If successful, the function returns True, False otherwise.
Program shmtool;
uses ipc,strings;
Const SegSize = 100;
var key : Tkey;
shmid,cntr : longint;
segptr : pchar;
Procedure USage;
begin
Writeln ('Usage : shmtool w(rite) text');
writeln (' r(ead)');
writeln (' d(elete)');
writeln (' m(ode change) mode');
halt(1);
end;
Procedure Writeshm (ID : Longint; ptr : pchar; S : string);
begin
strpcopy (ptr,s);
end;
Procedure Readshm(ID : longint; ptr : pchar);
begin
Writeln ('Read : ',ptr);
end;
Procedure removeshm (ID : Longint);
begin
shmctl (ID,IPC_RMID,Nil);
writeln ('Shared memory marked for deletion');
end;
Procedure CHangeMode (ID : longint; mode : String);
Var m : word;
code : integer;
data : TSHMid_ds;
begin
val (mode,m,code);
if code<>0 then
usage;
If Not shmctl (shmid,IPC_STAT,@data) then
begin
writeln ('Error : shmctl :',ipcerror);
halt(1);
end;
writeln ('Old permissions : ',data.shm_perm.mode);
data.shm_perm.mode:=m;
If Not shmctl (shmid,IPC_SET,@data) then
begin
writeln ('Error : shmctl :',ipcerror);
halt(1);
end;
writeln ('New permissions : ',data.shm_perm.mode);
end;
begin
if paramcount<1 then usage;
key := ftok ('.','S');
shmid := shmget(key,segsize,IPC_CREAT or IPC_EXCL or 438);
If shmid=-1 then
begin
Writeln ('Shared memory exists. Opening as client');
shmid := shmget(key,segsize,0);
If shmid = -1 then
begin
Writeln ('shmget : Error !',ipcerror);
halt(1);
end
end
else
Writeln ('Creating new shared memory segment.');
segptr:=shmat(shmid,nil,0);
if longint(segptr)=-1 then
begin
Writeln ('Shmat : error !',ipcerror);
halt(1);
end;
case upcase(paramstr(1)[1]) of
'W' : writeshm (shmid,segptr,paramstr(2));
'R' : readshm (shmid,segptr);
'D' : removeshm(shmid);
'M' : changemode (shmid,paramstr(2));
else
begin
writeln (paramstr(1));
usage;
end;
end;
end.