------------------------------------------------------------------------------ -- -- -- 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-2002 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.7 $ 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; 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); return Result; else Restore_Signals (Masked_Signals, Old_Mask); return Result; end if; 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;