/usr/share/ada/adainclude/dbus-ada/d

--
--  D_Bus/Ada - An Ada binding to D-Bus
--
--  Copyright (C) 2011  Reto Buerki <reet@codelabs.ch>
--
--  This program is free software; you can redistribute it and/or
--  modify it under the terms of the GNU General Public License
--  as published by the Free Software Foundation; either version 2
--  of the License, or (at your option) any later version.
--
--  This program 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
--  along with this program; if not, write to the Free Software
--  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
--  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.
--

with Interfaces.C.Strings;

with dbus_bus_h;
with dbus_shared_h;
with dbus_errors_h;
with dbus_connection_h;
with dbus_message_h;
with dbus_types_h;
with dbus_arch_deps_h;

package body D_Bus.Connection is

   package C renames Interfaces.C;

   Bus_Types : constant array (Bus_Type) of dbus_shared_h.DBusBusType
     := (Bus_Session => dbus_shared_h.DBUS_BUS_SESSION,
         Bus_System  => dbus_shared_h.DBUS_BUS_SYSTEM,
         Bus_Starter => dbus_shared_h.DBUS_BUS_STARTER);
   --  Mapping of Ada bus type enum to low-level D-Bus bus types.

   procedure Check (Result : access dbus_errors_h.DBusError);
   --  Check D-Bus error object and raise an exception if error is set. The
   --  D-Bus error object is freed before the exception is raised.

   procedure Add_Args
     (D_Message : System.Address;
      Args      : Arguments.Argument_List_Type);
   --  Add arguments to low-level D-Bus message.

   -------------------------------------------------------------------------

   procedure Add_Args
     (D_Message : System.Address;
      Args      : Arguments.Argument_List_Type)
   is
      D_Args : aliased dbus_message_h.DBusMessageIter;
   begin
      dbus_message_h.dbus_message_iter_init_append
        (arg1 => D_Message,
         arg2 => D_Args'Access);

      Arguments.Serialize
        (Args   => Args,
         D_Args => D_Args'Access);
   end Add_Args;

   -------------------------------------------------------------------------

   procedure Add_Match
     (Connection : Connection_Type;
      Rule       : String)
   is
      D_Err : aliased dbus_errors_h.DBusError;
      C_Str : C.Strings.chars_ptr := C.Strings.New_String
        (Str => Rule);
   begin
      dbus_bus_h.dbus_bus_add_match
        (arg1 => Connection.Thin_Connection,
         arg2 => C_Str,
         arg3 => D_Err'Access);
      C.Strings.Free (Item => C_Str);
      Check (Result => D_Err'Access);
   end Add_Match;

   -------------------------------------------------------------------------

   function Call_Blocking
     (Connection  : Connection_Type;
      Destination : String;
      Path        : String;
      Iface       : String;
      Method      : String;
      Args        : Arguments.Argument_List_Type :=
        Arguments.Empty_Argument_List)
      return Arguments.Argument_List_Type
   is
      use type System.Address;
      use type C.int;

      D_Msg   : System.Address := System.Null_Address;
      D_Reply : System.Address := System.Null_Address;
      D_Err   : aliased dbus_errors_h.DBusError;

      C_Dest   : C.Strings.chars_ptr;
      C_Path   : C.Strings.chars_ptr;
      C_Iface  : C.Strings.chars_ptr;
      C_Method : C.Strings.chars_ptr;

      ----------------------------------------------------------------------

      procedure Free_Strings;
      --  Free allocated memory.

      procedure Free_Strings
      is
      begin
         C.Strings.Free (Item => C_Dest);
         C.Strings.Free (Item => C_Path);
         C.Strings.Free (Item => C_Iface);
         C.Strings.Free (Item => C_Method);
      end Free_Strings;

   begin
      C_Dest   := C.Strings.New_String (Str => Destination);
      C_Path   := C.Strings.New_String (Str => Path);
      C_Iface  := C.Strings.New_String (Str => Iface);
      C_Method := C.Strings.New_String (Str => Method);

      D_Msg := dbus_message_h.dbus_message_new_method_call
        (arg1 => C_Dest,
         arg2 => C_Path,
         arg3 => C_Iface,
         arg4 => C_Method);
      Free_Strings;

      if D_Msg = System.Null_Address then
         raise D_Bus_Error with "Could not allocate message";
      end if;

      Add_Args (D_Message => D_Msg,
                Args      => Args);

      D_Reply := dbus_connection_h.dbus_connection_send_with_reply_and_block
        (arg1 => Connection.Thin_Connection,
         arg2 => D_Msg,
         arg3 => -1,
         arg4 => D_Err'Access);
      dbus_message_h.dbus_message_unref (arg1 => D_Msg);
      D_Msg := System.Null_Address;

      if D_Reply = System.Null_Address then
         Check (Result => D_Err'Access);
      end if;

      declare
         use type dbus_types_h.dbus_bool_t;

         D_Args : aliased dbus_message_h.DBusMessageIter;
      begin
         if dbus_message_h.dbus_message_iter_init
           (arg1 => D_Reply,
            arg2 => D_Args'Access) = 0
         then
            dbus_message_h.dbus_message_unref (arg1 => D_Reply);
            return Arguments.Empty_Argument_List;
         end if;

         return A : Arguments.Argument_List_Type do
            A := Arguments.Deserialize (D_Args => D_Args'Access);
            dbus_message_h.dbus_message_unref (arg1 => D_Reply);
         end return;
      end;
   end Call_Blocking;

   -------------------------------------------------------------------------

   procedure Check (Result : access dbus_errors_h.DBusError)
   is
      use type dbus_types_h.dbus_bool_t;
   begin
      if dbus_errors_h.dbus_error_is_set (arg1 => Result) = 1 then
         declare
            Error_String : constant String := C.Strings.Value (Result.message);
         begin
            dbus_errors_h.dbus_error_free (arg1 => Result);
            raise D_Bus_Error with Error_String;
         end;
      end if;
   end Check;

   -------------------------------------------------------------------------

   function Connect (Bus : Bus_Type := Bus_Session) return Connection_Type
   is
      D_Conn : System.Address := System.Null_Address;
      D_Err  : aliased dbus_errors_h.DBusError;
   begin
      D_Conn := dbus_bus_h.dbus_bus_get
        (arg1 => Bus_Types (Bus),
         arg2 => D_Err'Access);
      Check (Result => D_Err'Access);

      return Connection_Type'(Thin_Connection => D_Conn);
   end Connect;

   -------------------------------------------------------------------------

   function Connect (Address : String) return Connection_Type
   is
      C_Addr : C.Strings.chars_ptr := C.Strings.New_String (Str => Address);
      D_Conn : System.Address      := System.Null_Address;
      D_Err  : aliased dbus_errors_h.DBusError;
   begin
      D_Conn := dbus_connection_h.dbus_connection_open
        (arg1 => C_Addr,
         arg2 => D_Err'Access);
      C.Strings.Free (Item => C_Addr);
      Check (Result => D_Err'Access);

      return Connection_Type'(Thin_Connection => D_Conn);
   end Connect;

   -------------------------------------------------------------------------

   procedure Dispatch
     (Connection : Connection_Type;
      Callback   : Callbacks.Message_Callback)
   is
      use type C.int;
      use type dbus_types_h.dbus_bool_t;

      function Call_Back
        (D_Conn   : System.Address;
         Msg      : System.Address;
         Usr_Data : System.Address)
         return dbus_shared_h.DBusHandlerResult;
      --  Dispatch deserialized message to given callback procedure.

      function Call_Back
        (D_Conn   : System.Address;
         Msg      : System.Address;
         Usr_Data : System.Address)
         return dbus_shared_h.DBusHandlerResult
      is
         pragma Unreferenced (D_Conn, Usr_Data);
      begin
         Callback (Msg => Messages.Create (D_Msg => Msg));

         return dbus_shared_h.DBUS_HANDLER_RESULT_HANDLED;
      end Call_Back;

      procedure Free_Usr_Data (arg1 : System.Address) is null;

      D_Res : dbus_types_h.dbus_bool_t;
   begin
      D_Res := dbus_connection_h.dbus_connection_add_filter
        (arg1 => Connection.Thin_Connection,
         arg2 => Call_Back'Access,
         arg3 => System.Null_Address,
         arg4 => Free_Usr_Data'Access);

      if D_Res = 0 then
         raise D_Bus_Error with "Could not add connection filter";
      end if;

      while dbus_connection_h.dbus_connection_read_write_dispatch
        (arg1 => Connection.Thin_Connection,
         arg2 => -1) = 1
      loop
         null;
      end loop;
   end Dispatch;

   -------------------------------------------------------------------------

   procedure Request_Name
     (Connection : Connection_Type;
      Name       : String)
   is
      use type C.int;
      use type C.unsigned;

      C_Res  : C.int;
      C_Name : C.Strings.chars_ptr := C.Strings.New_String (Str => Name);
      D_Err  : aliased dbus_errors_h.DBusError;
   begin
      C_Res := dbus_bus_h.dbus_bus_request_name
        (arg1 => Connection.Thin_Connection,
         arg2 => C_Name,
         arg3 => dbus_shared_h.DBUS_NAME_FLAG_REPLACE_EXISTING,
         arg4 => D_Err'Access);
      C.Strings.Free (Item => C_Name);

      Check (Result => D_Err'Access);

      if C_Res /= dbus_shared_h.DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER then
         raise D_Bus_Error with "Not primary owner for '"
           & Name & "' (" & C_Res'Img & ")";
      end if;
   end Request_Name;

   -------------------------------------------------------------------------

   procedure Send
     (Connection : Connection_Type;
      Message    : Messages.Message_Type)
   is
      use type dbus_types_h.dbus_bool_t;

      D_Serial : aliased dbus_arch_deps_h.dbus_uint32_t := 0;
   begin
      if dbus_connection_h.dbus_connection_send
        (arg1 => Connection.Thin_Connection,
         arg2 => Messages.To_Thin (Msg => Message),
         arg3 => D_Serial'Access) = 0
      then
         raise D_Bus_Error with "Could not send message: out of memory";
      end if;
   end Send;

   -------------------------------------------------------------------------

   procedure Send_Signal
     (Connection  : Connection_Type;
      Object_Name : String;
      Iface       : String;
      Name        : String;
      Args        : Arguments.Argument_List_Type :=
        Arguments.Empty_Argument_List)
   is
      use type System.Address;

      D_Msg : System.Address := System.Null_Address;

      C_Object : C.Strings.chars_ptr;
      C_Iface  : C.Strings.chars_ptr;
      C_Name   : C.Strings.chars_ptr;

      ----------------------------------------------------------------------

      procedure Free_Strings;
      --  Free allocated memory.

      procedure Free_Strings
      is
      begin
         C.Strings.Free (Item => C_Object);
         C.Strings.Free (Item => C_Iface);
         C.Strings.Free (Item => C_Name);
      end Free_Strings;

   begin
      C_Object := C.Strings.New_String (Str => Object_Name);
      C_Iface  := C.Strings.New_String (Str => Iface);
      C_Name   := C.Strings.New_String (Str => Name);

      D_Msg := dbus_message_h.dbus_message_new_signal
        (arg1 => C_Object,
         arg2 => C_Iface,
         arg3 => C_Name);

      if D_Msg = System.Null_Address then
         Free_Strings;
         raise D_Bus_Error with "Could not allocate message";
      end if;

      begin
         Add_Args (D_Message => D_Msg,
                   Args      => Args);

      exception
         when D_Bus_Error =>
            Free_Strings;
            raise;
      end;

      declare
         use type C.unsigned;

         D_Serial : aliased dbus_arch_deps_h.dbus_uint32_t := 0;
      begin
         if dbus_connection_h.dbus_connection_send
           (arg1 => Connection.Thin_Connection,
            arg2 => D_Msg,
            arg3 => D_Serial'Access) = 0
         then
            Free_Strings;
            raise D_Bus_Error with "Could not send signal";
         end if;
      end;

      Free_Strings;
      dbus_message_h.dbus_message_unref (arg1 => D_Msg);
   end Send_Signal;

end D_Bus.Connection;
libdbusada0.2-dev 0.2-2 / usr / share / ada / adainclude / dbus-ada / d_bus-connection.adb
