libgtkada2.24.1-dev 2.24.1-14 / usr / share / ada / adainclude / gtkada / glib-object.adb

-----------------------------------------------------------------------
--               GtkAda - Ada95 binding for Gtk+/Gnome               --
--                                                                   --
--                Copyright (C) 2001-2011, AdaCore                   --
--                                                                   --
-- This library 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 library 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 library; if not, write to the             --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330,      --
-- Boston, MA 02111-1307, USA.                                       --
--                                                                   --
-----------------------------------------------------------------------

with Interfaces.C.Strings;
with Unchecked_Conversion;
with Unchecked_Deallocation;

with Glib.Type_Conversion_Hooks;
with Gtkada.Bindings;  use Gtkada.Bindings;
with Gtkada.C;         use Gtkada.C;
with Gtkada.Types;     use Gtkada.Types;

package body Glib.Object is
   package Signal_Id_Arrays is new Gtkada.C.Unbounded_Arrays
     (Glib.Signal_Id, Glib.Null_Signal_Id, Glib.Guint,
      Glib.Object.Signal_Id_Array);

   procedure Free_User_Data (Data : System.Address);
   --  Free the user data Data. This function should not be called directly

   procedure Set_User_Data
     (Obj     : System.Address;
      Quark   : Glib.GQuark;
      Data    : System.Address;
      Destroy : System.Address);
   pragma Import (C, Set_User_Data, "g_object_set_qdata_full");

   function To_Object is new Ada.Unchecked_Conversion
     (System.Address, GObject);

   ----------------
   -- Deallocate --
   ----------------

   procedure Deallocate (Object : access GObject_Record) is
      procedure Free is new Unchecked_Deallocation
        (GObject_Record'Class, GObject);

      Obj : GObject := GObject (Object);

   begin
      Free (Obj);
   end Deallocate;

   --------------------
   -- Free_User_Data --
   --------------------

   procedure Free_User_Data (Data : System.Address) is
      pragma Warnings (Off);
      --  This UC is safe aliasing-wise, so kill warning
      function Convert is new Unchecked_Conversion (System.Address, GObject);
      pragma Warnings (On);

   begin
      Deallocate (Convert (Data));
   end Free_User_Data;

   -----------
   -- G_New --
   -----------

   procedure G_New (Object : out GObject) is
   begin
      Object := new GObject_Record;
      Initialize (Object);
   end G_New;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Object : access GObject_Record'Class) is
      function Internal (Typ : GType) return System.Address;
      pragma Import (C, Internal, "ada_g_object_new");
   begin
      Set_Object (Object, Internal (GType_Object));
   end Initialize;

   ----------------
   -- Get_Object --
   ----------------

   function Get_Object
     (Object : access GObject_Record'Class) return System.Address is
   begin
      return Object.Ptr;
   end Get_Object;

   ------------------------
   -- Get_Object_Or_Null --
   ------------------------

   function Get_Object_Or_Null (Object : GObject) return System.Address is
   begin
      if Object = null then
         return System.Null_Address;
      else
         return Object.Ptr;
      end if;
   end Get_Object_Or_Null;

   --------------
   -- Get_Type --
   --------------

   function Get_Type (Object : access GObject_Record) return GType is
      function Internal (Object : System.Address) return GType;
      pragma Import (C, Internal, "ada_gobject_get_type");

   begin
      return Internal (Get_Object (Object));
   end Get_Type;

   -------------------
   -- Get_User_Data --
   -------------------

   function Get_User_Data
     (Obj  : System.Address;
      Stub : GObject_Record'Class) return GObject
   is
      function Internal
        (Object : System.Address;
         Quark  : Glib.GQuark) return System.Address;
      pragma Import (C, Internal, "g_object_get_qdata");

      use type System.Address;

      R : GObject;

   begin
      if Obj = System.Null_Address then
         return null;
      end if;

      if GtkAda_String_Quark = Glib.Unknown_Quark then
         GtkAda_String_Quark := Glib.Quark_From_String (GtkAda_String);
      end if;

      R := To_Object (Internal (Obj, GtkAda_String_Quark));

      if R = null then
         R := Glib.Type_Conversion_Hooks.Conversion_Function (Obj, Stub);

         --  This function will either simply return what we expect (Stub), or
         --  try to create the exact Ada type corresponding to the C type.

         Set_Object (R, Obj);
      end if;

      return R;
   end Get_User_Data;

   ------------------------
   -- Get_User_Data_Fast --
   ------------------------

   function Get_User_Data_Fast
     (Obj  : System.Address;
      Stub : GObject_Record'Class) return GObject
   is
      pragma Suppress (All_Checks);

      function Internal
        (Object : System.Address;
         Quark  : Glib.GQuark) return System.Address;
      pragma Import (C, Internal, "g_object_get_qdata");

      use type System.Address;

      R : GObject;

   begin
      if Obj = System.Null_Address then
         return null;
      end if;

      if GtkAda_String_Quark = Glib.Unknown_Quark then
         GtkAda_String_Quark := Glib.Quark_From_String (GtkAda_String);
      end if;

      R := To_Object (Internal (Obj, GtkAda_String_Quark));

      if R = null then
         R := new GObject_Record'Class'(Stub);
         Set_Object (R, Obj);
      end if;

      return R;
   end Get_User_Data_Fast;

   ----------------
   -- Is_Created --
   ----------------

   function Is_Created (Object : GObject_Record'Class) return Boolean is
      use type System.Address;
   begin
      return Object.Ptr /= System.Null_Address;
   end Is_Created;

   ----------------
   -- Set_Object --
   ----------------

   procedure Set_Object
     (Object : access GObject_Record'Class;
      Value  : System.Address)
   is
      use type System.Address;

   begin
      Object.Ptr := Value;

      --  Sets a user data field for the C object associated with Obj.
      --  This field will be used so that it is possible, knowing a
      --  C object, to get the full ada object.

      if GtkAda_String_Quark = Glib.Unknown_Quark then
         GtkAda_String_Quark := Glib.Quark_From_String (GtkAda_String);
      end if;

      --  If the user_data was already set in C, gtk+ will automatically call
      --  the finalization on it, and thus indirectly destroy the Ada
      --  object. which is exactly what we want.

      --  Special case for Null_Address, since this means we are already
      --  destroying the widget, and Set_User_Data would be invalid.

      if Value /= System.Null_Address then
         Set_User_Data (Value, GtkAda_String_Quark,
                        Object.all'Address, Free_User_Data'Address);
      end if;
   end Set_Object;

   --------------------
   -- Unchecked_Cast --
   --------------------

   function Unchecked_Cast
     (Obj  : access GObject_Record'Class;
      Stub : GObject_Record'Class) return GObject
   is
      Result : constant GObject := new GObject_Record'Class'(Stub);

      procedure Set_User_Data
        (Obj     : System.Address;
         Quark   : Glib.GQuark;
         Data    : System.Address;
         Destroy : System.Address);
      pragma Import (C, Set_User_Data, "g_object_set_qdata_full");

   begin
      Result.Ptr := Obj.Ptr;
      Set_User_Data
        (Obj.Ptr, GtkAda_String_Quark, Result'Address, Free_User_Data'Address);
      Deallocate (Obj);
      return Result;
   end Unchecked_Cast;

   -----------------------------
   -- Initialize_Class_Record --
   -----------------------------

   procedure Initialize_Class_Record
     (Object       : access GObject_Record'Class;
      Signals      : Gtkada.Types.Chars_Ptr_Array;
      Class_Record : in out GObject_Class;
      Type_Name    : String;
      Parameters   : Signal_Parameter_Types := Null_Parameter_Types)
   is
      function Internal
        (Object         : System.Address;
         NSignals       : Gint;
         Signals        : System.Address;
         Parameters     : System.Address;
         Max_Parameters : Gint;
         Class_Record   : GObject_Class;
         Type_Name      : String;
         Num_Virtual    : Gint;
         Virtual        : System.Address) return GObject_Class;
      pragma Import (C, Internal, "ada_initialize_class_record");

      Default_Params : Signal_Parameter_Types (1 .. Signals'Length, 1 .. 0) :=
        (others => (others => GType_None));
      Pa  : System.Address := Default_Params'Address;
      Num : Gint := 0;

   begin
      if Parameters /= Null_Parameter_Types then
         pragma Assert (Parameters'Length (1) = Signals'Length);
         Pa := Parameters'Address;
         Num := Parameters'Length (2);
      end if;

      Class_Record := Internal
        (Get_Object (Object),
         Signals'Length,
         Signals'Address,
         Pa,
         Num,
         Class_Record,
         Type_Name & ASCII.NUL,
         0, System.Null_Address);
   end Initialize_Class_Record;

   --------------
   -- List_Ids --
   --------------

   function List_Ids (Typ : Glib.GType) return Signal_Id_Array is
      use Signal_Id_Arrays;
      function Internal
        (Typ : GType; N_Ids : access Guint) return Unbounded_Array_Access;
      pragma Import (C, Internal, "g_signal_list_ids");

      N      : aliased Guint;
      Output : constant Unbounded_Array_Access := Internal (Typ, N'Access);
      Result : constant Signal_Id_Array := To_Array (Output, N);

   begin
      G_Free (Output);
      return Result;
   end List_Ids;

   -----------------
   -- Signal_Name --
   -----------------

   function Signal_Name (Q : Signal_Query) return Glib.Signal_Name is
      function Internal
        (Q : Signal_Query) return Interfaces.C.Strings.chars_ptr;
      pragma Import (C, Internal, "ada_gsignal_query_signal_name");

   begin
      return Glib.Signal_Name
        (String'(Interfaces.C.Strings.Value (Internal (Q))));
   end Signal_Name;

   ------------
   -- Params --
   ------------

   function Params (Q : Signal_Query) return GType_Array is
      use GType_Arrays;
      function Internal
        (Q     : Signal_Query;
         N_Ids : access Guint) return Unbounded_Array_Access;
      pragma Import (C, Internal, "ada_gsignal_query_params");

      N      : aliased Guint;
      Output : constant Unbounded_Array_Access := Internal (Q, N'Access);
      Result : constant GType_Array := To_Array (Output, N);

   begin
      --  Do not free Output, it belongs to gtk+
      --  G_Free (Output);
      return Result;
   end Params;

   ------------
   -- Lookup --
   ------------

   function Lookup (Object : GType; Signal : String) return Glib.Signal_Id is
      function Internal (Signal : String; Object : GType) return Signal_Id;
      pragma Import (C, Internal, "g_signal_lookup");

   begin
      return Internal (Signal & ASCII.NUL, Object);
   end Lookup;

   ------------
   -- Notify --
   ------------

   procedure Notify
     (Object        : access GObject_Record;
      Property_Name : String)
   is
      procedure Internal (Object : System.Address; Name : String);
      pragma Import (C, Internal, "g_object_notify");

   begin
      Internal (Get_Object (Object), Property_Name & ASCII.NUL);
   end Notify;

   ---------
   -- Ref --
   ---------

   procedure Ref (Object : access GObject_Record) is
      procedure Internal (Object : System.Address);
      pragma Import (C, Internal, "g_object_ref");
   begin
      Internal (Get_Object (Object));
   end Ref;

   --------------
   -- Ref_Sink --
   --------------

   procedure Ref_Sink (Object : access GObject_Record) is
      procedure Internal (Object : System.Address);
      pragma Import (C, Internal, "g_object_ref_sink");
   begin
      Internal (Get_Object (Object));
   end Ref_Sink;

   -----------
   -- Unref --
   -----------

   procedure Unref (Object : access GObject_Record) is
      procedure Internal (Object : System.Address);
      pragma Import (C, Internal, "g_object_unref");
   begin
      Internal (Get_Object (Object));
   end Unref;

   ---------------
   -- User_Data --
   ---------------

   package body User_Data is
      type Data_Access is access all Data_Type;

      type Cb_Record is record
         Ptr          : Data_Access;
         On_Destroyed : On_Destroyed_Callback;
      end record;
      type Cb_Record_Access is access all Cb_Record;

      function Convert is new
        Unchecked_Conversion (System.Address, Cb_Record_Access);

      procedure Set_Data_Internal
        (Object  : System.Address;
         Key     : String;
         Data    : System.Address;
         Destroy : System.Address);
      pragma Import (C, Set_Data_Internal, "g_object_set_data_full");

      procedure Set_Data_Internal_Id
        (Object  : System.Address;
         Key     : Glib.GQuark;
         Data    : System.Address;
         Destroy : System.Address);
      pragma Import (C, Set_Data_Internal_Id, "g_object_set_qdata_full");

      function Get_Data_Internal
        (Object : System.Address;
         Key    : String) return System.Address;
      pragma Import (C, Get_Data_Internal, "g_object_get_data");

      function Get_Data_Internal_Id
        (Object : System.Address;
         Key    : Glib.GQuark) return System.Address;
      pragma Import (C, Get_Data_Internal_Id, "g_object_get_qdata");

      ----------
      -- Free --
      ----------

      procedure Free_Data (Data : System.Address) is
         procedure Internal is new
           Unchecked_Deallocation (Cb_Record, Cb_Record_Access);

         procedure Internal2 is new
           Unchecked_Deallocation (Data_Type, Data_Access);

         D : Cb_Record_Access := Convert (Data);

      begin
         if D.On_Destroyed /= null then
            D.On_Destroyed (D.Ptr.all);
         end if;
         Internal2 (D.Ptr);
         Internal (D);
      end Free_Data;

      ---------
      -- Get --
      ---------

      function Get
        (Object : access GObject_Record'Class;
         Id     : String := "user_data") return Data_Type
      is
         D : constant Cb_Record_Access :=
           Convert (Get_Data_Internal (Get_Object (Object), Id & ASCII.NUL));
      begin
         if D = null or else D.Ptr = null then
            raise Gtkada.Types.Data_Error;
         else
            return D.Ptr.all;
         end if;
      end Get;

      ---------
      -- Get --
      ---------

      function Get
        (Object  : access GObject_Record'Class;
         Id      : String := "user_data";
         Default : Data_Type) return Data_Type
      is
         D : constant Cb_Record_Access :=
           Convert (Get_Data_Internal (Get_Object (Object), Id & ASCII.NUL));
      begin
         if D = null or else D.Ptr = null then
            return Default;
         else
            return D.Ptr.all;
         end if;
      end Get;

      ---------
      -- Get --
      ---------

      function Get
        (Object : access GObject_Record'Class;
         Id     : Glib.GQuark) return Data_Type
      is
         D : constant Cb_Record_Access :=
           Convert (Get_Data_Internal_Id (Get_Object (Object), Id));
      begin
         if D = null or else D.Ptr = null then
            raise Gtkada.Types.Data_Error;
         else
            return D.Ptr.all;
         end if;
      end Get;

      ---------
      -- Get --
      ---------

      function Get
        (Object  : access GObject_Record'Class;
         Id      : Glib.GQuark;
         Default : Data_Type) return Data_Type
      is
         D : constant Cb_Record_Access :=
           Convert (Get_Data_Internal_Id (Get_Object (Object), Id));
      begin
         if D = null or else D.Ptr = null then
            return Default;
         else
            return D.Ptr.all;
         end if;
      end Get;

      ---------
      -- Set --
      ---------

      procedure Set
        (Object : access GObject_Record'Class;
         Data   : Data_Type;
         Id     : String := "user_data";
         On_Destroyed : On_Destroyed_Callback := null)
      is
         function Convert is new
           Unchecked_Conversion (Cb_Record_Access, System.Address);
         D : constant Cb_Record_Access :=
           new Cb_Record'(Ptr => new Data_Type'(Data),
                          On_Destroyed => On_Destroyed);

      begin
         Set_Data_Internal
           (Get_Object (Object),
            Id & ASCII.NUL,
            Convert (D),
            Free_Data'Address);
      end Set;

      ---------
      -- Set --
      ---------

      procedure Set
        (Object : access GObject_Record'Class;
         Data   : Data_Type;
         Id     : Glib.GQuark;
         On_Destroyed : On_Destroyed_Callback := null)
      is
         function Convert is new
           Unchecked_Conversion (Cb_Record_Access, System.Address);
         D : constant Cb_Record_Access :=
           new Cb_Record'(Ptr => new Data_Type'(Data),
                          On_Destroyed => On_Destroyed);
      begin
         Set_Data_Internal_Id
           (Get_Object (Object),
            Id,
            Convert (D),
            Free_Data'Address);
      end Set;

      ------------
      -- Remove --
      ------------

      procedure Remove
        (Object : access GObject_Record'Class;
         Id     : String := "user_data")
      is
         procedure Internal (Object : System.Address; Id : String);
         pragma Import (C, Internal, "g_object_steal_data");

      begin
         --  First make sure that the destroy callback is called, so that
         --  memory can be freed

         Set_Data_Internal
           (Get_Object (Object),
            Id & ASCII.NUL, System.Null_Address, System.Null_Address);
         Internal (Get_Object (Object), Id & ASCII.NUL);
      end Remove;

      ------------
      -- Remove --
      ------------

      procedure Remove
        (Object : access GObject_Record'Class;
         Id     : Glib.GQuark)
      is
         procedure Internal (Object : System.Address; Id : Glib.GQuark);
         pragma Import (C, Internal, "g_object_steal_qdata");

      begin
         --  First make sure that the destroy callback is called, so that
         --  memory can be freed

         Set_Data_Internal_Id
           (Get_Object (Object), Id, System.Null_Address, System.Null_Address);
         Internal (Get_Object (Object), Id);
      end Remove;
   end User_Data;

   -------------
   -- Convert --
   -------------

   function Convert (W : GObject) return System.Address is
   begin
      if W = null then
         return System.Null_Address;
      else
         return Get_Object (W);
      end if;
   end Convert;

   -------------
   -- Convert --
   -------------

   function Convert (W : System.Address) return GObject is
      Stub : GObject_Record;
   begin
      return Get_User_Data (W, Stub);
   end Convert;

   --------------
   -- Weak_Ref --
   --------------

   procedure Weak_Ref
     (Object : access GObject_Record'Class;
      Notify : Weak_Notify;
      Data   : System.Address := System.Null_Address)
   is
      procedure Internal (Object : System.Address;
                          Notify : Weak_Notify;
                          Data   : System.Address);
      pragma Import (C, Internal, "g_object_weak_ref");
   begin
      Internal (Get_Object (Object), Notify, Data);
   end Weak_Ref;

   ----------------
   -- Weak_Unref --
   ----------------

   procedure Weak_Unref
     (Object : access GObject_Record'Class;
      Notify : Weak_Notify;
      Data   : System.Address := System.Null_Address)
   is
      procedure Internal (Object : System.Address;
                          Notify : Weak_Notify;
                          Data   : System.Address);
      pragma Import (C, Internal, "g_object_weak_unref");
   begin
      Internal (Get_Object (Object), Notify, Data);
   end Weak_Unref;

   -------------------------------
   -- Interface_List_Properties --
   -------------------------------

   function Interface_List_Properties
     (Vtable : Interface_Vtable) return Glib.Param_Spec_Array
   is
      use Pspec_Arrays;
      function Internal
        (Vtable  : Interface_Vtable;
         N_Props : access Guint) return Unbounded_Array_Access;
      pragma Import (C, Internal, "g_object_interface_list_properties");

      N       : aliased Guint;
      Output  : constant Unbounded_Array_Access := Internal (Vtable, N'Access);
      Result  : constant Param_Spec_Array := To_Array (Output, Integer (N));

   begin
      --  Doc says we should free, but that results in double-deallocation...
--     G_Free (Output);
      return Result;
   end Interface_List_Properties;

   ---------------------------
   -- Class_List_Properties --
   ---------------------------

   function Class_List_Properties
     (Class : GObject_Class) return Glib.Param_Spec_Array
   is
      use Pspec_Arrays;
      function Internal
        (Class   : GObject_Class;
         N_Props : access Guint) return Unbounded_Array_Access;
      pragma Import (C, Internal, "g_object_class_list_properties");

      N      : aliased Guint;
      Output : constant Unbounded_Array_Access := Internal (Class, N'Access);
      Result : constant Param_Spec_Array := To_Array (Output, Integer (N));
   begin
      --  Doc says we should free, but that results in double-deallocation...
--      G_Free (Output);
      return Result;
   end Class_List_Properties;

end Glib.Object;