----------------------------------------------------------------------- -- GtkAda - Ada95 binding for Gtk+/Gnome -- -- -- -- Copyright (C) 2001-2008, 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 Glib.Object; use Glib.Object; with Glib.Values; use Glib.Values; with Unchecked_Conversion; with System; use System; -- Can't with because of elaboration order issues -- with Glib.Properties; package body Glib.Generic_Properties is type Byte is range 0 .. 255; for Byte'Size use 8; function C_Enum_Value_Size return Natural; pragma Import (C, C_Enum_Value_Size, "ada_c_enum_value_size"); type C_Enum_Value is array (1 .. C_Enum_Value_Size) of Byte; pragma Pack (C_Enum_Value); type Enum_Value_Array is array (Guint range <>) of C_Enum_Value; type Enum_Value_Array_Access is access all Enum_Value_Array; procedure C_Create_Enum_Value (Value : Gint; Name, Nick : System.Address; Enum : out C_Enum_Value); pragma Import (C, C_Create_Enum_Value, "ada_genum_create_enum_value"); -- The strings Name and Nick are duplicated. function C_Register_Static (Name : String; Static_Values : System.Address) return GType; pragma Import (C, C_Register_Static, "g_enum_register_static"); ---------------------------------- -- Generic_Enumeration_Property -- ---------------------------------- package body Generic_Enumeration_Property is function Conv is new Unchecked_Conversion (Enumeration, Gint); -- Note: this will raise a warning at compilation-time if no -- representation clause has been defined for Enumeration. As -- documented, Set_Property will not work anyway, so a warning -- is even a good thing! -------------- -- Get_Type -- -------------- function Get_Type return GType is Arr : Enum_Value_Array_Access; -- The memory for Arr is voluntarily not freed, since we need -- to use if at any time in the life of the GtkAda application. J : Guint := 1; begin if The_Type /= GType_Invalid then return The_Type; end if; Arr := new Enum_Value_Array (1 .. Enumeration'Pos (Enumeration'Last) + 2); for E in Enumeration'Range loop declare S : aliased String := Enumeration'Image (E) & ASCII.NUL; begin C_Create_Enum_Value (Conv (E), S'Address, S'Address, Arr (J)); end; J := J + 1; end loop; C_Create_Enum_Value (0, System.Null_Address, System.Null_Address, Arr (Arr'Last)); The_Type := C_Register_Static (Name & ASCII.NUL, Arr.all'Address); return The_Type; end Get_Type; --------------- -- Gnew_Enum -- --------------- function Gnew_Enum (Name, Nick, Blurb : String; Default : Enumeration := Enumeration'First; Flags : Param_Flags := Param_Readable or Param_Writable) return Param_Spec is function Internal (Name, Nick, Blurb : String; Enum_Type : GType; Default : Enumeration; Flags : Param_Flags) return Param_Spec; pragma Import (C, Internal, "g_param_spec_enum"); begin return Internal (Name & ASCII.NUL, Nick & ASCII.NUL, Blurb & ASCII.NUL, Enum_Type => Get_Type, Default => Default, Flags => Flags); end Gnew_Enum; -------------- -- Set_Enum -- -------------- procedure Set_Enum (Value : in out GValue; Enum : Enumeration) is procedure Internal (Value : in out GValue; Enum : Enumeration); pragma Import (C, Internal, "g_value_set_enum"); begin Init (Value, Get_Type); Internal (Value, Enum); end Set_Enum; end Generic_Enumeration_Property; ---------------------------------------- -- Generic_Internal_Discrete_Property -- ---------------------------------------- package body Generic_Internal_Discrete_Property is ------------------ -- Get_Property -- ------------------ function Get_Property (Object : access Glib.Object.GObject_Record'Class; Name : Property_RO) return Discrete_Type is procedure Get (Object : System.Address; Name : Property; Value : out Gulong); pragma Import (C, Get, "ada_g_object_get_ulong"); pragma Warnings (Off); function To_Discrete_Type is new Ada.Unchecked_Conversion (Gulong, Discrete_Type); pragma Warnings (On); Ret : Gulong; begin Get (Get_Object (Object), Property (Name), Ret); return To_Discrete_Type (Ret); end Get_Property; ------------------ -- Get_Property -- ------------------ function Get_Property (Object : access Glib.Object.GObject_Record'Class; Name : Property) return Discrete_Type is begin return Get_Property (Object, Property_RO (Name)); end Get_Property; ------------------ -- Set_Property -- ------------------ procedure Set_Property (Object : access Glib.Object.GObject_Record'Class; Name : Property; Value : Discrete_Type) is procedure Internal (Object : System.Address; Name : Property; Value : Gulong); pragma Import (C, Internal, "ada_g_object_set_ulong"); pragma Warnings (Off); function To_Gulong is new Ada.Unchecked_Conversion (Discrete_Type, Gulong); pragma Warnings (On); begin Internal (Get_Object (Object), Name, To_Gulong (Value)); end Set_Property; end Generic_Internal_Discrete_Property; ------------------------------------- -- Generic_Internal_Boxed_Property -- ------------------------------------- package body Generic_Internal_Boxed_Property is type Boxed_Access is access all Boxed_Type; function Conv is new Unchecked_Conversion (System.Address, Boxed_Access); --------------- -- Set_Value -- --------------- procedure Set_Value (Value : out Glib.Values.GValue; Val : Boxed_Type) is V : constant System.Address := To_Address (Val, Val'Address); begin -- Do not do an actual copy with gdk_color_copy, or -- pango_font_description_copy: it is in fact done -- automatically by gdk, when it defines (in gdkcolor.c) the type as -- g_boxed_type_register_static -- ("GdkColor",(GBoxedCopyFunc)gdk_color_copy, -- (GBoxedFreeFunc)gdk_color_free); Init (Value, Get_Type); Set_Boxed (Value, V); end Set_Value; --------------- -- Get_Value -- --------------- function Get_Value (Value : Glib.Values.GValue) return Boxed_Type is Boxed : constant Boxed_Access := Conv (Get_Boxed (Value)); begin if Boxed = null then raise Unset_Value; else return Boxed.all; end if; end Get_Value; ------------------ -- Set_Property -- ------------------ procedure Set_Property (Object : access Glib.Object.GObject_Record'Class; Name : Property; Value : Boxed_Type) is procedure Internal (Object : System.Address; Name : String; Value : in out GValue); pragma Import (C, Internal, "g_object_set_property"); -- Internal function to set the properties (can't use the one from -- glib.properties because of elaboration order issues Val : GValue; begin Set_Value (Value => Val, Val => Value); Internal (Get_Object (Object), Property_Name (Name) & ASCII.NUL, Val); Unset (Val); end Set_Property; ------------------ -- Get_Property -- ------------------ function Get_Property (Object : access Glib.Object.GObject_Record'Class; Name : Property) return Boxed_Type is begin return Get_Property (Object, Property_RO (Name)); end Get_Property; ------------------ -- Get_Property -- ------------------ function Get_Property (Object : access Glib.Object.GObject_Record'Class; Name : Property_RO) return Boxed_Type is procedure Internal (Object : System.Address; Name : Property_RO; Value : in out GValue); pragma Import (C, Internal, "g_object_get_property"); Value : GValue; Result : Boxed_Type; begin Init (Value, Get_Type); Internal (Get_Object (Object), Name, Value); Result := Get_Value (Value); Unset (Value); return Result; end Get_Property; end Generic_Internal_Boxed_Property; end Glib.Generic_Properties;