Полищук, Семериков. Системное программирование в UNIX средствами Free Pascal / examples / 8 / stest

(* рТПЗТБННБ stest -- РТПУФПК УЕТЧЕТ ДМС ПЮЕТЕДЙ *)
uses ipc,linux,stdio,sysutils;
{$i q.inc}

procedure warn (s:pchar);
begin
writeln(stderr, 'рТЕДХРТЕЦДЕОЙЕ: ', s);
end;

(* йОЙГЙБМЙЪБГЙС ПЮЕТЕДЙ -- РПМХЮЙФШ ЙДЕОФЙЖЙЛБФПТ ПЮЕТЕДЙ *)
function init_queue:longint;
var
queue_id:longint;
begin
(* рПРЩФЛБ УПЪДБОЙС ЙМЙ ПФЛТЩФЙС ПЮЕТЕДЙ УППВЭЕОЙК *)
queue_id := msgget (QKEY, IPC_CREAT or QPERM);
if queue_id = -1 then
perror ('пЫЙВЛБ ЧЩЪПЧБ msgget');
init_queue:=queue_id;
end;


function proc_obj (msg:pq_entry):integer;
begin
writeln(#$a'рТЙПТЙФЕФ: ',msg^.mtype,' ЙНС: ',msg^.mtext);
end;


(* рТПГЕДХТБ serve -- РТЙОЙНБЕФ Й ПВТБВБФЩЧБЕФ УППВЭЕОЙЕ ПВУМХЦЙЧБЕФ
* ПВЯЕЛФ ПЮЕТЕДЙ У ОБЙЧЩУЫЙН РТЙПТЙФЕФПН
*)
function serve:integer;
var
r_qid:longint;
r_entry:q_entry;
begin
(* йОЙГЙБМЙЪБГЙС ПЮЕТЕДЙ УППВЭЕОЙК, ЕУМЙ ЬФП ОЕПВИПДЙНП *)
r_qid := init_queue;
if r_qid = -1 then
begin
serve:=-1;
exit;
end;

(* рПМХЮЙФШ Й ПВТБВПФБФШ УМЕДХАЭЕЕ УППВЭЕОЙЕ *)
while true do
begin
if not msgrcv (r_qid, @r_entry, MAXOBN, (-1 * MAXPRIOR), MSG_NOERROR) then
begin
perror ('пЫЙВЛБ ЧЩЪПЧБ msgrcv');
serve:=-1;
exit;
end
else
begin
(* пВТБВПФБФШ ЙНС ПВЯЕЛФБ *)
proc_obj (@r_entry);
end;
end;
end;


var
pid:longint;
begin
pid := fork;
case pid of
0: (* ДПЮЕТОЙК РТПГЕУУ *)
serve;
-1: (* УЕТЧЕТ ОЕ УХЭЕУФЧХЕФ *)
warn ('оЕ ХДБМПУШ ЪБРХУФЙФШ УЕТЧЕТ');
else
writeln('уЕТЧЕТОЩК РТПГЕУУ У ЙДЕОФЙЖЙЛБФПТПН ', pid);
end;
if pid <> -1 then
halt (0)
else
halt (1);
end.