unit usemaforopolenta;
interface
uses
  errors, baseunix, unixtype, ipc, sysutils, ipcobjs, syscall;

(****************************************************************************
 * Create a semaphore with a specified initial value.
 * If the semaphore already exists, we don't initialize it (of course).
 * We return the semaphore ID if all OK, else -1.
 *)
function sem_create(key: key_t; initval: integer): integer;

(**** crea un semáforo y lo inicializa, falla si el semáforo ya existe **)
function sem_createNew(key: key_t; initval: integer): integer;

(****************************************************************************
 * Wait until a semaphore's value is greater than 0, then decrement
 * it by 1 and return.
 * Dijkstra's P operation.  Tanenbaum's DOWN operation.
 *)
function sem_wait(id: integer): integer; //result= 0 ok; -1 error

(****************************************************************************
 * Wait until a semaphore's value is greater than 0 or timeOut_ms miliseconds
 * have elapsed. If the value gets greater than 0 then decrement it by 1 and
 * return. Else return.
 *)
function sem_timedwait(id: integer; timeOut_ms: Integer): integer; //result= 0 ok; -1 error

(****************************************************************************
 * Increment a semaphore by 1.
 * Dijkstra's V operation.  Tanenbaum's UP operation.
 *)
function sem_signal(id: integer): integer; //result= 0 ok; -1 error

(*********************************************************************
 * Close a semaphore.
 * Unlike the remove function above, this function is for a process
 * to call before it exits, when it is done with the semaphore.
 * We "decrement" the counter of processes using the semaphore, and
 * if this was the last one, we can remove the semaphore.
 *)
procedure sem_close(id: integer);

(****************************************************************************
 * General semaphore operation.  Increment or decrement by a user-specified
 * amount (positive or negative; amount can't be zero).
 *)
function sem_op(id, value: integer): integer; //result= 0 ok; -1 error

(****************************************************************************
 * General semaphore operation.  Increment or decrement by a user-specified
 * amount (positive or negative; amount can't be zero).
 *)
function sem_timedop(id, value, timeOut_ms: integer): integer; //result= 0 ok; -1 error

(****************************************************************************
 * Open a semaphore that must already exist.
 * This function should be used, instead of sem_create(), if the caller
 * knows that the semaphore must already exist.  For example a client
 * from a client-server pair would use this, if its the server's
 * responsibility to create the semaphore.
 * We return the semaphore ID if all OK, else -1.
 *)
function sem_open(key: key_t ): integer;

(****************************************************************************
 * Remove a semaphore.
 * This call is intended to be called by a server, for example,
 * when it is being shut down, as we do an IPC_RMID on the semaphore,
 * regardless whether other processes may be using it or not.
 * Most other processes should use sem_close().
 *)
procedure sem_rm(id: integer);

(***** Dispara una excepcin de error *****)
procedure err_sys( s: string );

implementation

 (* Provide an simpler and easier to understand interface to the System V
 * semaphore system calls.
 *)

const
   BIGCOUNT= 10000; // initial value of process counter
   octal_666= (6*8+6)*8+6;

//*
// * Define the semaphore operation arrays for the semop() calls.
// */

const
   op_lock: array[0..1] of TSemaphoreBuffer = (
       (  sem_num: 2; sem_op:0; sem_flg:0 ),
      (  sem_num: 2; sem_op:1; sem_flg: SEM_UNDO ) );

(*
    2, 0, 0,        /* wait for [2] (lock) to equal 0 */
    2, 1, SEM_UNDO  /* then increment [2] to 1 - this locks it */
         /* UNDO to release the lock if processes exits
         before explicitly unlocking */
*)

   op_endcreate: array[0..1] of TSemaphoreBuffer = (
      (   sem_num: 1; sem_op:-1; sem_flg:SEM_UNDO ),
      (  sem_num: 2; sem_op:-1; sem_flg: SEM_UNDO ) );

(*
       1, -1, SEM_UNDO,/* decrement [1] (proc counter) with undo on exit */
                        /* UNDO to adjust proc counter if process exits
                           before explicitly calling sem_close() */
        2, -1, SEM_UNDO /* then decrement [2] (lock) back to 0 */
*)

   op_open: TSemaphoreBuffer= (
         sem_num: 1; sem_op:-1; sem_flg:SEM_UNDO);

(*
static struct sembuf    op_open[1] = {
   1, -1, SEM_UNDO /* decrement [1] (proc counter) with undo on exit */
*)


   op_close: array[0..2] of TSemaphoreBuffer = (
      (   sem_num: 2; sem_op:0; sem_flg:0 ),
      (   sem_num: 2; sem_op:1; sem_flg:SEM_UNDO ),
      (  sem_num: 1; sem_op:1; sem_flg: SEM_UNDO ) );

(*
static struct sembuf    op_close[3] = {
        2, 0, 0,        /* wait for [2] (lock) to equal 0 */
        2, 1, SEM_UNDO, /* then increment [2] to 1 - this locks it */
        1, 1, SEM_UNDO  /* then increment [1] (proc counter) */
*)

   op_unlock: TSemaphoreBuffer=
      (   sem_num: 2; sem_op:-1; sem_flg:SEM_UNDO );
//        2, -1, SEM_UNDO /* decrement [2] (lock) back to 0 */




procedure err_sys( s: string );
var
  error: Integer;
begin
  error:= errno;
  raise Exception.Create(s + ' :errno= ' + IntToStr(error) + ', ' + strerror(error));
end;

(****************************************************************************
 * Create a semaphore with a specified initial value.
 * If the semaphore already exists, we don't initialize it (of course).
 * We return the semaphore ID if all OK, else -1.
 *)
function sem_create(key: key_t; initval: integer): integer;
label
   again;

var
  error: Integer;
   id, semval: integer;
   semctl_arg: TVSemUnion;
begin

  if (key = IPC_PRIVATE) then
  begin
   result:= -1;
   exit;//* not intended for private semaphores */
  end
  else if (key = key_t(-1)) then
  begin
   result:= -1;
   exit;   //* probably an ftok() error by caller */
  end;

again:

   id:= semget(key, 3, octal_666 or IPC_CREAT);

   if ( id < 0) then
   begin
      result:= -1;
      err_sys('usemaforopolenta.sem_create: can''t semget');
      exit; //* permission problem or tables full */
   end;
(*        /*
   * When the semaphore is created, we know that the value of all
   * 3 members is 0.
   * Get a lock on the semaphore by waiting for [2] to equal 0,
   * then increment it.
   *
   * There is a race condition here.  There is a possibility that
   * between the semget() above and the semop() below, another
   * process can call our sem_close() function which can remove
   * the semaphore if that process is the last one using it.
   * Therefore, we handle the error condition of an invalid
   * semaphore ID specially below, and if it does happen, we just
   * go back and create it again.
   */ *)


   if (semop(id, @op_lock[0], 2) < 0) then
   begin
      error:= errno;
      if (error = ESysEIDRM) or (error = ESysEINVAL) then goto again
      else
        err_sys('usemaforopolenta.sem_create: can''t lock');
   end;


(* /*
   * Get the value of the process counter.  If it equals 0,
   * then no one has initialized the semaphore yet.
   */ *)


   semval:= semctl(id, 1, SEM_GETVAL, semctl_arg );
   if ( semval < 0) then
                err_sys('usemaforopolenta.sem_create: can''t GETVAL');

   if (semval = 0)  then
   begin
    (*
     * We could initialize by doing a SETALL, but that
     * would clear the adjust value that we set when we
     * locked the semaphore above.  Instead, we'll do 2
     * system calls to initialize [0] and [1].
     *)

      semctl_arg.val:= initval;
      if (semctl(id, 0, SEM_SETVAL, semctl_arg) < 0) then
              err_sys('usemaforopolenta.sem_create: can SETVAL[0]');


      semctl_arg.val:= BIGCOUNT;
      if (semctl(id, 1, SEM_SETVAL, semctl_arg) < 0) then
              err_sys('usemaforopolenta.sem_create: cant SETVAL[1]');
   end;


// Decrement the process counter and then release the lock.
     if (semop(id, @op_endcreate[0], 2) < 0) then
                err_sys('usemaforopolenta.sem_create: can''t end create');
     result:= id;
end;

(****************************************************************************
 * Open a semaphore that must already exist.
 * This function should be used, instead of sem_create(), if the caller
 * knows that the semaphore must already exist.  For example a client
 * from a client-server pair would use this, if its the server's
 * responsibility to create the semaphore.
 * We return the semaphore ID if all OK, else -1.
 *)
function sem_open(key: key_t ): integer;
var
   id: integer;
begin
   if (key =IPC_PRIVATE) then
   begin
      result:= -1;
      exit;  //* not intended for private semaphores */
   end
   else if (key = key_t(-1)) then
   begin
      result:= -1;
      exit;//* probably an ftok() error by caller */
   end;

   id:= semget(key, 3, 0);
   if ( id ) < 0 then
   begin
      result:= -1;
      exit;  (* doesn't exist, or tables full *)
   end;

  (*
   * Decrement the process counter.  We don't need a lock
   * to do this.
   *)

   if (semop(id, @op_open, 1) < 0) then
                err_sys('usemaforopolenta.sem_open: can''t open');
   result:= id;
end;



(****************************************************************************
 * Create a NEW semaphore with a specified initial value.
 * If the semaphore already exists, el resultado es -1
 *)
function sem_createNew(key: key_t; initval: integer): integer;
label
   again;

var
   id, semval: integer;
   semctl_arg: TVSemUnion;
begin
  if (key = IPC_PRIVATE) then
  begin
   result:= -1;
   exit;//* not intended for private semaphores */
  end
  else if (key = key_t(-1)) then
  begin
   result:= -1;
   writeln( 'usemaforopolenta.sem_createNew: key = -1 (probable, error ftok())');
   readln;
   exit;   //* probably an ftok() error by caller */
  end;

again:

   id:= semget(key, 3, octal_666 or IPC_CREAT or IPC_EXCL);
   if ( id < 0) then
   begin
      result:= -1;
      exit; //* permission problem or tables full */
   end;
(*        /*
   * When the semaphore is created, we know that the value of all
   * 3 members is 0.
   * Get a lock on the semaphore by waiting for [2] to equal 0,
   * then increment it.
   *
   * There is a race condition here.  There is a possibility that
   * between the semget() above and the semop() below, another
   * process can call our sem_close() function which can remove
   * the semaphore if that process is the last one using it.
   * Therefore, we handle the error condition of an invalid
   * semaphore ID specially below, and if it does happen, we just
   * go back and create it again.
   */ *)

   if (semop(id, @op_lock[0], 2) < 0) then
   begin
      if (errno = ESysEINVAL) then  goto again;
      err_sys('usemaforopolenta.sem_createNew: can''t lock');
   end;

(* /*
   * Get the value of the process counter.  If it equals 0,
   * then no one has initialized the semaphore yet.
   */ *)

   semval:= semctl(id, 1, SEM_GETVAL, semctl_arg );
   if ( semval < 0) then
                err_sys('usemaforopolenta.sem_createNew: can''t GETVAL');

   if (semval = 0)  then
   begin
    (*
     * We could initialize by doing a SETALL, but that
     * would clear the adjust value that we set when we
     * locked the semaphore above.  Instead, we'll do 2
     * system calls to initialize [0] and [1].
     *)

      semctl_arg.val:= initval;
      if (semctl(id, 0, SEM_SETVAL, semctl_arg) < 0) then
              err_sys('usemaforopolenta.sem_createNew: can SETVAL[0]');

      semctl_arg.val:= BIGCOUNT;
      if (semctl(id, 1, SEM_SETVAL, semctl_arg) < 0) then
              err_sys('usemaforopolenta.sem_createNew: can SETVAL[1]');
   end;

// Decrement the process counter and then release the lock.
     if (semop(id, @op_endcreate[0], 2) < 0) then
                err_sys('usemaforopolenta.sem_createNew: can''t end create');
     result:= id;
end;



(****************************************************************************
 * Remove a semaphore.
 * This call is intended to be called by a server, for example,
 * when it is being shut down, as we do an IPC_RMID on the semaphore,
 * regardless whether other processes may be using it or not.
 * Most other processes should use sem_close() below.
 *)
procedure sem_rm(id: integer);
var
   res: integer;
   semctl_arg: TVSemUnion;
begin
   res:= semctl(id, 0, IPC_RMID, semctl_arg );
//   writeln( 'sem_rm: ', res );
   if (res < 0) then
                err_sys('usemaforopolenta.sem_rm: can''t IPC_RMID');
end;

(*********************************************************************
 * Close a semaphore.
 * Unlike the remove function above, this function is for a process
 * to call before it exits, when it is done with the semaphore.
 * We "decrement" the counter of processes using the semaphore, and
 * if this was the last one, we can remove the semaphore.
 *)
procedure sem_close(id: integer);
var
   semval: integer;
   semctl_arg: TVSemUnion;
begin
  (*
   * The following semop() first gets a lock on the semaphore,
   * then increments [1] - the process counter.
   *)

  semval:=semop(id, @op_close[0], 3);
  if (semval < 0) then
          err_sys('usemaforopolenta.sem_close: can''t semop, sem_id: '+IntToStr(id)+' res: '+IntToStr(semval));

  (*
   * Now that we have a lock, read the value of the process
   * counter to see if this is the last reference to the
   * semaphore.
   * There is a race condition here - see the comments in
   * sem_create().
   *)

  semval:= semctl(id, 1, SEM_GETVAL, semctl_arg);
  if ( semval < 0) then
     err_sys('usemaforopolenta.sem_close: can''t GETVAL');

  if (semval > BIGCOUNT) then
     err_sys('usemaforopolenta.sem_close: sem[1] > BIGCOUNT')
  else if (semval = BIGCOUNT) then
     sem_rm(id)
  else  if (semop(id, @op_unlock, 1) < 0) then
     err_sys('usemaforopolenta.sem_close: can''t unlock');    //* unlock */
end;

(****************************************************************************
 * General semaphore operation.  Increment or decrement by a user-specified
 * amount (positive or negative; amount can't be zero).
 *)
function sem_op(id, value: integer): integer;
var
  op_op: TSemaphoreBuffer;
begin
  if ( value= 0) then
    err_sys('usemaforopolenta.sem_op: can''t have value = 0');

  with op_op do
  begin
    sem_num:= 0; //* decrement or increment [0]
    sem_op:= value; //actual amount to add or subtract (positive or negative)
    sem_flg:= SEM_UNDO;//with undo on exit */
  end;

  result:= semop(id, @op_op, 1);
end;

function sem_timedop(id, value, timeOut_ms: integer): integer;
var
  timeOut: timespec;
  op_op: TSemaphoreBuffer;
begin
  with op_op do
  begin
    sem_num:= 0; //* decrement or increment [0]
    sem_op:= value; //actual amount to add or subtract (positive or negative)
    sem_flg:= SEM_UNDO;//with undo on exit */
  end;

  with timeOut do
  begin
    tv_sec:= timeOut_ms div 1000;
    tv_nsec:= (timeOut_ms mod 1000) * 1000000;
  end;

  result:= semtimedop(id, @op_op, 1, @timeOut);
end;

(****************************************************************************
 * Wait until a semaphore's value is greater than 0, then decrement
 * it by 1 and return.
 * Dijkstra's P operation.  Tanenbaum's DOWN operation.
 *)
function sem_wait(id: integer): integer;
begin
  result:= sem_op(id, -1);
end;

function sem_timedwait(id: integer; timeOut_ms: Integer): integer; //result= 0 ok; -1 erro
begin
  result:= sem_timedop(id, -1, timeOut_ms);
end;

(****************************************************************************
 * Increment a semaphore by 1.
 * Dijkstra's V operation.  Tanenbaum's UP operation.
 *)
function sem_signal(id: integer): integer;
begin
  result:= sem_op(id, 1);
end;

{initialization
  writeln('ini-> uSemaforoPolenta');}

end.

