----------------------------------------------------------------------- -- GtkAda - Ada95 binding for Gtk+/Gnome -- -- -- -- Copyright (C) 1998-2000 E. Briot, J. Brobecker and A. Charlet -- -- Copyright (C) 2000-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 Gtkada.Bindings; use Gtkada.Bindings; with System; use System; with Glib.Values; use Glib.Values; with Gtk.Adjustment; use Gtk.Adjustment; with Gtk.Enums; use Gtk.Enums; with Gtk.Widget; use Gtk.Widget; with Glib.Type_Conversion_Hooks; package body Gtk.Container is package Type_Conversion is new Glib.Type_Conversion_Hooks.Hook_Registrator (Get_Type'Access, Gtk_Container_Record); pragma Warnings (Off, Type_Conversion); procedure Internal_Gtk_Callback (Widget : System.Address; Data : Gtk_Callback); pragma Convention (C, Internal_Gtk_Callback); -- Proxy for a Gtk callback --------- -- Add -- --------- procedure Add (Container : access Gtk_Container_Record; Widget : access Gtk.Widget.Gtk_Widget_Record'Class) is procedure Internal (Container : System.Address; Widget : System.Address); pragma Import (C, Internal, "gtk_container_add"); begin Internal (Get_Object (Container), Get_Object (Widget)); end Add; ------------------ -- Check_Resize -- ------------------ procedure Check_Resize (Container : access Gtk_Container_Record) is procedure Internal (Container : System.Address); pragma Import (C, Internal, "gtk_container_check_resize"); begin Internal (Get_Object (Container)); end Check_Resize; ---------------- -- Child_Type -- ---------------- function Child_Type (Container : access Gtk_Container_Record) return Gtk.Gtk_Type is function Internal (Container : System.Address) return Gtk.Gtk_Type; pragma Import (C, Internal, "gtk_container_child_type"); begin return Internal (Get_Object (Container)); end Child_Type; --------------------------- -- Internal_Gtk_Callback -- --------------------------- procedure Internal_Gtk_Callback (Widget : System.Address; Data : Gtk_Callback) is Stub : Gtk_Widget_Record; begin Data (Gtk_Widget (Get_User_Data (Widget, Stub))); end Internal_Gtk_Callback; ------------ -- Forall -- ------------ procedure Forall (Container : access Gtk_Container_Record; Func : Gtk_Callback) is procedure Internal (Container : System.Address; Func : System.Address; Data : System.Address); pragma Import (C, Internal, "gtk_container_forall"); begin Internal (Get_Object (Container), Internal_Gtk_Callback'Address, Func.all'Address); end Forall; ------------- -- Foreach -- ------------- procedure Foreach (Container : access Gtk_Container_Record; Func : Gtk_Callback) is procedure Internal (Container : System.Address; Func : System.Address; Data : System.Address); pragma Import (C, Internal, "gtk_container_foreach"); begin Internal (Get_Object (Container), Internal_Gtk_Callback'Address, Func.all'Address); end Foreach; ------------- -- For_Pkg -- ------------- package body For_Pkg is type Data_Type_Access is access all Data_Type; type Internal_Data is record Data : Data_Type_Access; Func : Gtk_Callback; end record; type Internal_Data_Access is access all Internal_Data; procedure Internal_Func (Widget : System.Address; Data : Internal_Data_Access); pragma Convention (C, Internal_Func); ------------------- -- Internal_Func -- ------------------- procedure Internal_Func (Widget : System.Address; Data : Internal_Data_Access) is Stub : Gtk_Widget_Record; begin Data.Func (Gtk_Widget (Get_User_Data (Widget, Stub)), Data.Data.all); end Internal_Func; ------------ -- Forall -- ------------ procedure Forall (Container : access Gtk_Container_Record; Func : Gtk_Callback; Data : Data_Type) is procedure Internal (Container : System.Address; Func : System.Address; Data : System.Address); pragma Import (C, Internal, "gtk_container_forall"); Local : aliased Data_Type := Data; D : aliased Internal_Data := (Local'Unchecked_Access, Func); begin Internal (Get_Object (Container), Internal_Func'Address, D'Address); end Forall; ------------- -- Foreach -- ------------- procedure Foreach (Container : access Gtk_Container_Record; Func : Gtk_Callback; Data : Data_Type) is procedure Internal (Container : System.Address; Func : System.Address; Data : System.Address); pragma Import (C, Internal, "gtk_container_foreach"); Local : aliased Data_Type := Data; D : aliased Internal_Data := (Local'Unchecked_Access, Func); begin Internal (Get_Object (Container), Internal_Func'Address, D'Address); end Foreach; end For_Pkg; ---------------------- -- Get_Border_Width -- ---------------------- function Get_Border_Width (Container : access Gtk_Container_Record) return Guint is function Internal (Container : System.Address) return Guint; pragma Import (C, Internal, "gtk_container_get_border_width"); begin return Internal (Get_Object (Container)); end Get_Border_Width; ------------------ -- Get_Children -- ------------------ function Get_Children (Container : access Gtk_Container_Record) return Gtk.Widget.Widget_List.Glist is function Internal (Container : System.Address) return System.Address; pragma Import (C, Internal, "gtk_container_get_children"); List : Gtk.Widget.Widget_List.Glist; begin Gtk.Widget.Widget_List.Set_Object (List, Internal (Get_Object (Container))); return List; end Get_Children; --------------------- -- Get_Resize_Mode -- --------------------- function Get_Resize_Mode (Container : access Gtk_Container_Record) return Gtk_Resize_Mode is function Internal (Container : System.Address) return Gtk_Resize_Mode; pragma Import (C, Internal, "gtk_container_get_resize_mode"); begin return Internal (Get_Object (Container)); end Get_Resize_Mode; ---------------------- -- Propagate_Expose -- ---------------------- procedure Propagate_Expose (Container : access Gtk_Container_Record; Child : access Gtk.Widget.Gtk_Widget_Record'Class; Event : Gdk.Event.Gdk_Event_Expose) is procedure Internal (Container : System.Address; Child : System.Address; Event : Gdk.Event.Gdk_Event_Expose); pragma Import (C, Internal, "gtk_container_propagate_expose"); begin Internal (Get_Object (Container), Get_Object (Child), Event); end Propagate_Expose; ------------ -- Remove -- ------------ procedure Remove (Container : access Gtk_Container_Record; Widget : access Gtk.Widget.Gtk_Widget_Record'Class) is procedure Internal (Container : System.Address; Widget : System.Address); pragma Import (C, Internal, "gtk_container_remove"); begin Internal (Get_Object (Container), Get_Object (Widget)); end Remove; --------------------- -- Resize_Children -- --------------------- procedure Resize_Children (Container : access Gtk_Container_Record) is procedure Internal (Container : System.Address); pragma Import (C, Internal, "gtk_container_resize_children"); begin Internal (Get_Object (Container)); end Resize_Children; ---------------------- -- Set_Border_Width -- ---------------------- procedure Set_Border_Width (Container : access Gtk_Container_Record; Border_Width : Guint) is procedure Internal (Container : System.Address; Border_Widget : Guint); pragma Import (C, Internal, "gtk_container_set_border_width"); begin Internal (Get_Object (Container), Border_Width); end Set_Border_Width; --------------------- -- Set_Focus_Chain -- --------------------- procedure Set_Focus_Chain (Container : access Gtk_Container_Record; Focusable_Widgets : Gtk.Widget.Widget_List.Glist) is procedure Internal (Container : System.Address; Focusable_Widgets : System.Address); pragma Import (C, Internal, "gtk_container_set_focus_chain"); use Gtk.Widget.Widget_List; begin Internal (Get_Object (Container), Get_Object (Focusable_Widgets)); end Set_Focus_Chain; --------------------- -- Get_Focus_Chain -- --------------------- procedure Get_Focus_Chain (Container : access Gtk_Container_Record; Focusable_Widgets : out Gtk.Widget.Widget_List.Glist; Success : out Boolean) is use Widget_List; function Internal (Container : System.Address; List : access System.Address) return Gboolean; pragma Import (C, Internal, "gtk_container_get_focus_chain"); L : aliased System.Address; begin Success := Boolean'Val (Internal (Get_Object (Container), L'Access)); Set_Object (Focusable_Widgets, L); end Get_Focus_Chain; --------------------- -- Set_Focus_Child -- --------------------- procedure Set_Focus_Child (Container : access Gtk_Container_Record; Child : access Gtk.Widget.Gtk_Widget_Record'Class) is procedure Internal (Container : System.Address; Child : System.Address); pragma Import (C, Internal, "gtk_container_set_focus_child"); begin Internal (Get_Object (Container), Get_Object (Child)); end Set_Focus_Child; --------------------------- -- Set_Focus_Hadjustment -- --------------------------- procedure Set_Focus_Hadjustment (Container : access Gtk_Container_Record; Adjustment : Gtk.Adjustment.Gtk_Adjustment) is procedure Internal (Container : System.Address; Adjustment : System.Address); pragma Import (C, Internal, "gtk_container_set_focus_hadjustment"); begin if Adjustment = null then Internal (Get_Object (Container), System.Null_Address); else Internal (Get_Object (Container), Get_Object (Adjustment)); end if; end Set_Focus_Hadjustment; --------------------------- -- Set_Focus_Vadjustment -- --------------------------- procedure Set_Focus_Vadjustment (Container : access Gtk_Container_Record; Adjustment : Gtk.Adjustment.Gtk_Adjustment) is procedure Internal (Container : System.Address; Adjustment : System.Address); pragma Import (C, Internal, "gtk_container_set_focus_vadjustment"); begin if Adjustment = null then Internal (Get_Object (Container), System.Null_Address); else Internal (Get_Object (Container), Get_Object (Adjustment)); end if; end Set_Focus_Vadjustment; ---------------------------- -- Set_Reallocate_Redraws -- ---------------------------- procedure Set_Reallocate_Redraws (Container : access Gtk_Container_Record; Needs_Redraws : Boolean := False) is procedure Internal (Container : System.Address; Needs_Redraws : Gint); pragma Import (C, Internal, "gtk_container_set_reallocate_redraws"); begin Internal (Get_Object (Container), Boolean'Pos (Needs_Redraws)); end Set_Reallocate_Redraws; --------------------- -- Set_Resize_Mode -- --------------------- procedure Set_Resize_Mode (Container : access Gtk_Container_Record; Resize_Mode : Gtk_Resize_Mode) is procedure Internal (Container : System.Address; Mode : Gtk_Resize_Mode); pragma Import (C, Internal, "gtk_container_set_resize_mode"); begin Internal (Get_Object (Container), Resize_Mode); end Set_Resize_Mode; ----------------------- -- Unset_Focus_Chain -- ----------------------- procedure Unset_Focus_Chain (Container : access Gtk_Container_Record) is procedure Internal (Container : System.Address); pragma Import (C, Internal, "gtk_container_unset_focus_chain"); begin Internal (Get_Object (Container)); end Unset_Focus_Chain; --------------------- -- Get_Focus_Child -- --------------------- function Get_Focus_Child (Container : access Gtk_Container_Record) return Gtk.Widget.Gtk_Widget is function Internal (Container : System.Address) return System.Address; pragma Import (C, Internal, "ada_gtk_container_get_focus_child"); Child : constant System.Address := Internal (Get_Object (Container)); begin if Child = System.Null_Address then return null; else return Convert (Child); end if; end Get_Focus_Child; --------------------------- -- Get_Focus_Hadjustment -- --------------------------- function Get_Focus_Hadjustment (Container : access Gtk_Container_Record) return Gtk_Adjustment is function Internal (Container : System.Address) return System.Address; pragma Import (C, Internal, "gtk_container_get_focus_hadjustment"); Stub : Gtk_Adjustment_Record; begin return Gtk_Adjustment (Get_User_Data (Internal (Get_Object (Container)), Stub)); end Get_Focus_Hadjustment; --------------------------- -- Get_Focus_Vadjustment -- --------------------------- function Get_Focus_Vadjustment (Container : access Gtk_Container_Record) return Gtk_Adjustment is function Internal (Container : System.Address) return System.Address; pragma Import (C, Internal, "gtk_container_get_focus_vadjustment"); Stub : Gtk_Adjustment_Record; begin return Gtk_Adjustment (Get_User_Data (Internal (Get_Object (Container)), Stub)); end Get_Focus_Vadjustment; ------------------------------- -- Class_Find_Child_Property -- ------------------------------- function Class_Find_Child_Property (Cclass : GObject_Class; Property_Name : String) return Glib.Param_Spec is function Internal (Cclass : GObject_Class; Property_Name : String) return Param_Spec; pragma Import (C, Internal, "gtk_container_class_find_child_property"); begin return Internal (Cclass, Property_Name & ASCII.NUL); end Class_Find_Child_Property; ---------------------------------- -- Class_Install_Child_Property -- ---------------------------------- procedure Class_Install_Child_Property (Cclass : GObject_Class; Property_Id : Guint; Pspec : Param_Spec) is procedure Internal (Cclass : GObject_Class; Property_Id : Guint; Pspec : Param_Spec); pragma Import (C, Internal, "gtk_container_class_install_child_property"); begin Internal (Cclass, Property_Id, Pspec); end Class_Install_Child_Property; ------------------------ -- Child_Get_Property -- ------------------------ procedure Child_Get_Property (Container : access Gtk_Container_Record; Child : access Gtk_Widget_Record'Class; Property_Name : String; Value : out GValue) is procedure Internal (Container : System.Address; Child : System.Address; Property_Name : String; Value : out GValue); pragma Import (C, Internal, "gtk_container_child_get_property"); begin Internal (Get_Object (Container), Get_Object (Child), Property_Name & ASCII.NUL, Value); end Child_Get_Property; ------------------------ -- Child_Set_Property -- ------------------------ procedure Child_Set_Property (Container : access Gtk_Container_Record; Child : access Gtk_Widget_Record'Class; Property_Name : String; Value : GValue) is procedure Internal (Container : System.Address; Child : System.Address; Property_Name : String; Value : GValue); pragma Import (C, Internal, "gtk_container_child_set_property"); begin Internal (Get_Object (Container), Get_Object (Child), Property_Name & ASCII.NUL, Value); end Child_Set_Property; --------------------------------- -- Class_List_Child_Properties -- --------------------------------- function Class_List_Child_Properties (Cclass : GObject_Class) return Param_Spec_Array is use Pspec_Arrays; function Internal (Cclass : GObject_Class; N_Properties : access Guint) return Unbounded_Array_Access; pragma Import (C, Internal, "gtk_container_class_list_child_properties"); Num : aliased Guint; C_Array : constant Unbounded_Array_Access := Internal (Cclass, Num'Access); Result : constant Param_Spec_Array := To_Array (C_Array, Integer (Num)); begin -- Do says we should free, but doing so results in double-deallocation -- G_Free (C_Array); return Result; end Class_List_Child_Properties; end Gtk.Container;