File : posix-message_queues.adb
------------------------------------------------------------------------------
-- --
-- FLORIST (FSU Implementation of POSIX.5) COMPONENTS --
-- --
-- P O S I X . M E S S A G E _ Q U E U E S --
-- --
-- B o d y --
-- --
-- --
-- Copyright (c) 1996-1998 Florida State University (FSU), --
-- All Rights Reserved. --
-- --
-- This file is a component of FLORIST, an implementation of an Ada API --
-- for the POSIX OS services, for use with the GNAT Ada compiler and --
-- the FSU Gnu Ada Runtime Library (GNARL). The interface is intended --
-- to be close to that specified in IEEE STD 1003.5: 1990 and IEEE STD --
-- 1003.5b: 1996. --
-- --
-- FLORIST is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 2, or (at your option) any --
-- later version. FLORIST 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. See the GNU --
-- General Public License for more details. You should have received a --
-- copy of the GNU General Public License distributed with GNARL; see --
-- file COPYING. If not, write to the Free Software Foundation, 59 --
-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
------------------------------------------------------------------------------
-- $Revision: 1.5 $
with Ada.Streams,
POSIX.C,
POSIX.Implementation,
POSIX.IO,
POSIX.Configurable_System_Limits,
POSIX.Permissions,
POSIX.Permissions.Implementation,
POSIX.Signals,
System,
Unchecked_Conversion;
package body POSIX.Message_Queues is
use Ada.Streams;
use POSIX.C;
use POSIX.Implementation;
use POSIX.Permissions.Implementation;
-- check that Stream_Element and char are the same size
Assertion : constant := Boolean'Pos
(Boolean'Pred (Stream_Element'Size = char'Size));
function To_int is new Unchecked_Conversion (Bits, int);
function To_Bits is new Unchecked_Conversion (int, Bits);
C_File_Mode : constant array (POSIX.IO.File_Mode) of Bits :=
(POSIX.IO.Read_Only => O_RDONLY,
POSIX.IO.Write_Only => O_WRONLY,
POSIX.IO.Read_Write => O_RDWR);
function Check_NNeg_And_Restore_Signals
(Result : Message_Queue_Descriptor;
Masked_Signals : Signal_Masking;
Old_Mask : access Signal_Mask) return Message_Queue_Descriptor;
function Check_NNeg_And_Restore_Signals
(Result : Message_Queue_Descriptor;
Masked_Signals : Signal_Masking;
Old_Mask : access Signal_Mask) return Message_Queue_Descriptor is
begin
if Result < 0 then
Restore_Signals_And_Raise_POSIX_Error (Masked_Signals, Old_Mask);
else
Restore_Signals (Masked_Signals, Old_Mask);
end if;
return Result;
end Check_NNeg_And_Restore_Signals;
------------------------
-- Set_Max_Messages --
------------------------
procedure Set_Max_Messages
(Attrs : in out Attributes;
Value : Natural) is
begin
Attrs.Attrs.mq_maxmsg := long (Value);
end Set_Max_Messages;
------------------------
-- Get_Max_Messages --
------------------------
function Get_Max_Messages (Attrs : Attributes) return Natural is
begin
return Natural (Attrs.Attrs.mq_maxmsg);
end Get_Max_Messages;
--------------------------
-- Set_Message_Length --
--------------------------
procedure Set_Message_Length
(Attrs : in out Attributes;
Value : Natural) is
begin
Attrs.Attrs.mq_msgsize := long (Value);
end Set_Message_Length;
--------------------------
-- Get_Message_Length --
--------------------------
function Get_Message_Length (Attrs : Attributes) return Natural is
begin
return Natural (Attrs.Attrs.mq_msgsize);
end Get_Message_Length;
-------------------
-- Set_Options --
-------------------
procedure Set_Options
(Attrs : in out Attributes;
Value : Message_Queue_Options) is
begin
Attrs.Attrs.mq_flags := long (To_int (Option_Set (Value).Option));
end Set_Options;
-------------------
-- Get_Options --
-------------------
function Get_Options (Attrs : Attributes) return Message_Queue_Options is
begin
return Message_Queue_Options
(Option_Set '(Option => To_Bits (int (Attrs.Attrs.mq_flags))));
-- ????
-- The above conversion of long value to int is risky.
-- If the high-order bits are used, we may need to consider
-- reimplementing Option_Set as long, or changing the POSIX.5b spec.
-- .... Change POSIX.5b?
-- It was a mistake to use Option_Set here for a value that the
-- C-language interface says is a "long". Option_Set in other places
-- is only used to map bit-vectors of type "int".
end Get_Options;
-------------------------
-- Get_Message_Count --
-------------------------
function Get_Message_Count (Attrs : Attributes) return Natural is
begin
return Natural (Attrs.Attrs.mq_curmsgs);
end Get_Message_Count;
------------
-- Open --
------------
function mq_open
(name : char_ptr;
oflag : int;
mode : mode_t;
attr : mq_attr_ptr) return Message_Queue_Descriptor;
pragma Import (C, mq_open, mq_open_LINKNAME);
function Open
(Name : POSIX_String;
Mode : POSIX.IO.File_Mode;
Options : POSIX.IO.Open_Option_Set := -- POSIX.IO.Empty_Set;
POSIX.IO.Open_Option_Set (POSIX.IO.Empty_Set);
-- Conversion is only to work around a GNAT3.09 problem.
Masked_Signals : Signal_Masking := RTS_Signals)
return Message_Queue_Descriptor is
Name_With_NUL : POSIX_String := Name & NUL;
Old_Mask : aliased Signal_Mask;
Result : Message_Queue_Descriptor;
begin
Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access);
Result := mq_open (Name_With_NUL (Name_With_NUL'First)'Unchecked_Access,
To_int (Option_Set (Options).Option or C_File_Mode (Mode)), 0, null);
return Check_NNeg_And_Restore_Signals
(Result, Masked_Signals, Old_Mask'Unchecked_Access);
end Open;
----------------------
-- Open_Or_Create --
----------------------
function Open_Or_Create
(Name : POSIX_String;
Mode : POSIX.IO.File_Mode;
Permissions : POSIX.Permissions.Permission_Set;
Options : POSIX.IO.Open_Option_Set := -- POSIX.IO.Empty_Set;
POSIX.IO.Open_Option_Set (POSIX.IO.Empty_Set);
-- Conversion is only to work around a GNAT3.09 problem.
Masked_Signals : Signal_Masking := RTS_Signals)
return Message_Queue_Descriptor is
Name_With_NUL : POSIX_String := Name & NUL;
Old_Mask : aliased Signal_Mask;
Result : Message_Queue_Descriptor;
begin
Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access);
Result := mq_open (Name_With_NUL (Name_With_NUL'First)'Unchecked_Access,
To_int (Option_Set (Options).Option or C_File_Mode (Mode) or O_CREAT),
Form_C_Permission (Permissions), null);
return Check_NNeg_And_Restore_Signals
(Result, Masked_Signals, Old_Mask'Unchecked_Access);
end Open_Or_Create;
function Open_Or_Create
(Name : POSIX_String;
Mode : POSIX.IO.File_Mode;
Permissions : POSIX.Permissions.Permission_Set;
Options : POSIX.IO.Open_Option_Set := -- POSIX.IO.Empty_Set;
POSIX.IO.Open_Option_Set (POSIX.IO.Empty_Set);
-- Conversion is only to work around a GNAT3.09 problem.
Attrs : Attributes;
Masked_Signals : Signal_Masking := RTS_Signals)
return Message_Queue_Descriptor is
Name_With_NUL : POSIX_String := Name & NUL;
Old_Mask : aliased Signal_Mask;
Result : Message_Queue_Descriptor;
begin
Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access);
Result := mq_open (Name_With_NUL (Name_With_NUL'First)'Unchecked_Access,
To_int (Option_Set (Options).Option or C_File_Mode (Mode) or O_CREAT),
Form_C_Permission (Permissions), Attrs.Attrs'Unchecked_Access);
return Check_NNeg_And_Restore_Signals
(Result, Masked_Signals, Old_Mask'Unchecked_Access);
end Open_Or_Create;
-------------
-- Close --
-------------
procedure Close (MQ : in out Message_Queue_Descriptor) is
function mq_close (mqdes : Message_Queue_Descriptor) return int;
pragma Import (C, mq_close, mq_close_LINKNAME);
begin
Check (mq_close (MQ));
end Close;
----------------------------
-- Unlink_Message_Queue --
----------------------------
procedure Unlink_Message_Queue (Name : in POSIX_String) is
function mq_unlink (name : char_ptr) return int;
pragma Import (C, mq_unlink, mq_unlink_LINKNAME);
Name_With_NUL : POSIX_String := Name & NUL;
begin
Check (mq_unlink (Name_With_NUL (Name_With_NUL'First)'Unchecked_Access));
end Unlink_Message_Queue;
------------
-- Send --
------------
function mq_send
(mqdes : Message_Queue_Descriptor;
msg_ptr : char_ptr;
msg_len : size_t;
msg_prio : unsigned) return int;
pragma Import (C, mq_send, mq_send_LINKNAME);
function To_char_ptr is
new Unchecked_Conversion (System.Address, char_ptr);
procedure Send
(MQ : in Message_Queue_Descriptor;
Message : in Ada.Streams.Stream_Element_Array;
Priority : in Message_Priority;
Masked_Signals : in Signal_Masking := RTS_Signals) is
Old_Mask : aliased Signal_Mask;
Result : int;
begin
Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access);
Result := mq_send
(MQ, To_char_ptr (Message (Message'First)'Address),
size_t (Message'Length),
unsigned (Priority));
Check_NNeg_And_Restore_Signals
(Result, Masked_Signals, Old_Mask'Unchecked_Access);
end Send;
---------------
-- Receive --
---------------
function mq_receive
(mqdes : Message_Queue_Descriptor;
msg_ptr : System.Address;
msg_len : size_t;
msg_prio : access unsigned) return ssize_t;
pragma Import (C, mq_receive, mq_receive_LINKNAME);
procedure Receive
(MQ : in Message_Queue_Descriptor;
Message : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
Priority : out Message_Priority;
Masked_Signals : in Signal_Masking := RTS_Signals) is
Old_Mask : aliased Signal_Mask;
Prio : aliased unsigned;
Result : ssize_t;
begin
Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access);
Result := mq_receive
(MQ, Message (Message'First)'Address,
size_t (Message'Length),
Prio'Unchecked_Access);
Check_NNeg_And_Restore_Signals
(int (Result), Masked_Signals, Old_Mask'Unchecked_Access);
Priority := Message_Priority (Prio);
Last := Message'First + Stream_Element_Offset (Result) - 1;
end Receive;
package body Generic_Message_Queues is
SES : constant Stream_Element_Offset := Stream_Element'Size;
Buffer_Length : constant Stream_Element_Offset :=
(Message_Type'Size + SES - 1) / SES;
Buffer : aliased Stream_Element_Array (1 .. Buffer_Length);
Length : Stream_Element_Offset;
------------
-- Send --
------------
procedure Send
(MQ : in Message_Queue_Descriptor;
Message : in Message_Type;
Priority : in Message_Priority;
Masked_Signals : in Signal_Masking := RTS_Signals) is
Old_Mask : aliased Signal_Mask;
Result : int;
begin
Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access);
Result := mq_send
(MQ, To_char_ptr (Message'Address),
size_t ((Message'Size + char'Size - 1) / char'Size),
unsigned (Priority));
Check_NNeg_And_Restore_Signals
(int (Result), Masked_Signals, Old_Mask'Unchecked_Access);
end Send;
---------------
-- Receive --
---------------
type Message_Ptr is access all Message_Type;
function To_Message_Ptr is
new Unchecked_Conversion (System.Address, Message_Ptr);
procedure Receive
(MQ : in Message_Queue_Descriptor;
Message : out Message_Type;
Priority : out Message_Priority;
Masked_Signals : in Signal_Masking := RTS_Signals) is
Old_Mask : aliased Signal_Mask;
Prio : aliased unsigned;
Result : ssize_t;
begin
Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access);
Result := mq_receive
(MQ, Buffer'Address,
size_t (Buffer'Size / char'Size),
Prio'Unchecked_Access);
Check_NNeg_And_Restore_Signals
(int (Result), Masked_Signals, Old_Mask'Unchecked_Access);
Length := Stream_Element_Offset (Result);
if Result /= Buffer'Size / char'Size then
raise Constraint_Error;
end if;
Priority := Message_Priority (Prio);
Message := To_Message_Ptr (Buffer'Address).all;
end Receive;
------------------------
-- Get_Error_Buffer --
------------------------
function Get_Error_Buffer return Ada.Streams.Stream_Element_Array is
begin
return Buffer (1 .. Length);
end Get_Error_Buffer;
end Generic_Message_Queues;
----------------------
-- Request_Notify --
----------------------
type Event_Ptr is access all POSIX.Signals.Signal_Event;
function mq_notify
(mqdes : Message_Queue_Descriptor;
notification : Event_Ptr) return int;
pragma Import (C, mq_notify, mq_notify_LINKNAME);
procedure Request_Notify
(MQ : in Message_Queue_Descriptor;
Event : in POSIX.Signals.Signal_Event) is
E : aliased POSIX.Signals.Signal_Event := Event;
begin
Check (mq_notify (MQ, E'Unchecked_Access));
end Request_Notify;
---------------------
-- Remove_Notify --
---------------------
procedure Remove_Notify (MQ : in Message_Queue_Descriptor) is
begin
Check (mq_notify (MQ, null));
end Remove_Notify;
----------------------
-- Set_Attributes --
----------------------
function mq_setattr
(mqdes : Message_Queue_Descriptor;
mqstat : mq_attr_ptr;
omqstat : mq_attr_ptr) return int;
pragma Import (C, mq_setattr, mq_setattr_LINKNAME);
procedure Set_Attributes
(MQ : in Message_Queue_Descriptor;
New_Attrs : in Attributes;
Old_Attrs : out Attributes) is
begin
Check (mq_setattr
(MQ,
New_Attrs.Attrs'Unchecked_Access,
Old_Attrs.Attrs'Unchecked_Access));
end Set_Attributes;
----------------------
-- Set_Attributes --
----------------------
procedure Set_Attributes
(MQ : in Message_Queue_Descriptor;
New_Attrs : in Attributes) is
begin
Check (mq_setattr (MQ, New_Attrs.Attrs'Unchecked_Access, null));
end Set_Attributes;
----------------------
-- Get_Attributes --
----------------------
function Get_Attributes (MQ : Message_Queue_Descriptor) return Attributes is
function mq_getattr
(mqdes : Message_Queue_Descriptor;
mqstat : access struct_mq_attr) return int;
pragma Import (C, mq_getattr, mq_getattr_LINKNAME);
Attrs : Attributes;
begin
Check (mq_getattr (MQ, Attrs.Attrs'Unchecked_Access));
return Attrs;
end Get_Attributes;
end POSIX.Message_Queues;