(* Программа 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.
