----------------------------------------------------------------------- -- 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 System; with System.Assertions; use System.Assertions; with Unchecked_Deallocation; with Glib.Values; use Glib.Values; package body Gtk.Handlers is function Count_Arguments (Object : access GObject_Record'Class; Signal : Glib.Signal_Name) return Guint; -- Convenience function that returns the number of arguments for this -- signal function Do_Signal_Connect (Object : Glib.Object.GObject; Name : Glib.Signal_Name; Marshaller : System.Address; Handler : System.Address; Func_Data : System.Address; Destroy : System.Address; After : Boolean; Slot_Object : System.Address := System.Null_Address; Expect_Return_Value : Boolean) return Handler_Id; -- Internal function used to connect the signal. -- Expect_Return_Value should be true if the user is connecting a function -- to the signal, False if he is connecting a procedure function G_Signal_Parse_Name (Detailed_Signal : Glib.Signal_Name; Itype : GType; Signal_Id_P : access Signal_Id; Detail_P : access GQuark; Force_Detail_Quark : Gboolean) return Gboolean; pragma Import (C, G_Signal_Parse_Name, "g_signal_parse_name"); -- Internal function to parse a signal name into its signal_id and -- detail quark. -- Detailed_Signal is a string of the form "signal-name::detail". -- Itype is the interface or instance that introduce "signal-name". -- Force_Detail_Quark, if True, forces the creation of a GQuark for the -- detail. -- This function returns true if the signal name could successfully be -- parsed, and Signal_Id_P and Detail_P contain valid return values. procedure Disconnect_Internal (Obj : System.Address; Id : Gulong); pragma Import (C, Disconnect_Internal, "g_signal_handler_disconnect"); -- Internal version of Disconnect function Signal_Lookup (Name : Glib.Signal_Name; IType : GType) return Signal_Id; pragma Import (C, Signal_Lookup, "g_signal_lookup"); procedure Set_Value (Value : GValue; Val : System.Address); pragma Import (C, Set_Value, "ada_gvalue_set"); -- Function used internally to specify the value returned by a callback. -------------------------------- -- Glib.Closure small binding -- -------------------------------- function CClosure_New (Callback : System.Address; User_Data : System.Address; Destroy : System.Address) return GClosure; pragma Import (C, CClosure_New, "g_cclosure_new"); procedure Set_Marshal (Closure : GClosure; Marshaller : System.Address); pragma Import (C, Set_Marshal, "g_closure_set_marshal"); function Get_Data (Closure : GClosure) return System.Address; pragma Import (C, Get_Data, "ada_gclosure_get_data"); procedure Watch_Closure (Object : System.Address; Closure : GClosure); pragma Import (C, Watch_Closure, "g_object_watch_closure"); -- The closure will be destroyed when Object is destroyed. --------------------- -- Count_Arguments -- --------------------- function Count_Arguments (Object : access GObject_Record'Class; Signal : Glib.Signal_Name) return Guint is Q : Signal_Query; Id : constant Signal_Id := Lookup (Get_Type (Object), String (Signal) & ASCII.NUL); begin if Id = Invalid_Signal_Id then return 0; else Query (Id, Q); return Params (Q)'Length; end if; end Count_Arguments; ----------------------- -- Do_Signal_Connect -- ----------------------- function Do_Signal_Connect (Object : Glib.Object.GObject; Name : Glib.Signal_Name; Marshaller : System.Address; Handler : System.Address; Func_Data : System.Address; Destroy : System.Address; After : Boolean; Slot_Object : System.Address := System.Null_Address; Expect_Return_Value : Boolean) return Handler_Id is function Internal (Instance : System.Address; Id : Signal_Id; Detail : GQuark; Closure : GClosure; After : Gint := 0) return Gulong; pragma Import (C, Internal, "g_signal_connect_closure_by_id"); use type System.Address; Id : Handler_Id; Signal : aliased Signal_Id; Detail : aliased GQuark; Success : Gboolean; Q : Signal_Query; begin -- When the handler is destroyed, for instance because Object is -- destroyed, then the closure is destroyed as well, and Destroy gets -- called. -- The closure is invoked when the signal is emitted. As a result, -- Handler is called, with Func_Data as a parameter. Success := G_Signal_Parse_Name (Detailed_Signal => Name & ASCII.NUL, Itype => Get_Type (Object), Signal_Id_P => Signal'Access, Detail_P => Detail'Access, Force_Detail_Quark => 0); if Success = 0 or else Signal = Invalid_Signal_Id then Raise_Assert_Failure ("Trying to connect to unknown signal (""" & String (Name) & """) on type " & Type_Name (Get_Type (Object))); end if; Query (Signal, Q); if Expect_Return_Value then if Return_Type (Q) = GType_None then Raise_Assert_Failure ("Handlers for """ & String (Name) & """ on a " & Type_Name (Get_Type (Object)) & " should be procedures"); end if; else if Return_Type (Q) /= GType_None then Raise_Assert_Failure ("Handlers for """ & String (Name) & """ on a " & Type_Name (Get_Type (Object)) & " should be functions"); end if; end if; Id.Closure := CClosure_New (Handler, Func_Data, Destroy); Set_Marshal (Id.Closure, Marshaller); Id.Id := Internal (Get_Object (Object), Id => Signal, Detail => Detail, Closure => Id.Closure, After => Boolean'Pos (After)); -- If we have connected with Object_Connect, we want to automatically -- disconnect the signal as well. if Slot_Object /= System.Null_Address then Watch_Closure (Slot_Object, Id.Closure); end if; return Id; end Do_Signal_Connect; --------------- -- Add_Watch -- --------------- procedure Add_Watch (Id : Handler_Id; Object : access Glib.Object.GObject_Record'Class) is begin pragma Assert (Id.Closure /= null); Watch_Closure (Get_Object (Object), Id.Closure); end Add_Watch; --------------------- -- Return_Callback -- --------------------- package body Return_Callback is function To_Handler is new Unchecked_Conversion (Gtk.Marshallers.General_Handler, Handler); function To_General_Handler is new Unchecked_Conversion (Handler, Gtk.Marshallers.General_Handler); function To_Address is new Unchecked_Conversion (Handler, System.Address); function To_Address is new Unchecked_Conversion (Marshallers.Handler_Proxy, System.Address); ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Marsh, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Marsh, Slot_Object, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Cb, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Cb, Slot_Object, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; Slot_Object : access Widget_Type'Class; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), Slot_Object, After); end Object_Connect; --------------- -- Free_Data -- --------------- procedure Free_Data (Data : Data_Type_Access) is procedure Internal is new Unchecked_Deallocation (Data_Type_Record, Data_Type_Access); D : Data_Type_Access := Data; begin Internal (D); end Free_Data; ---------------------- -- First_Marshaller -- ---------------------- procedure First_Marshaller (Closure : GClosure; Return_Value : GValue; N_Params : Guint; Params : System.Address; Invocation_Hint : System.Address; User_Data : System.Address) is pragma Unreferenced (Invocation_Hint, User_Data); use type Marshallers.Handler_Proxy; Data : constant Data_Type_Access := Convert (Get_Data (Closure)); Stub : Widget_Type; pragma Warnings (Off, Stub); Value : aliased Return_Type; Values : GValues; begin if Data.Func = null then return; end if; Values := Make_Values (N_Params, Params); if Data.Object = null then if Data.Proxy /= null then Value := Data.Proxy (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values, To_General_Handler (Data.Func)); else Value := Data.Func (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values); end if; else if Data.Proxy /= null then Value := Data.Proxy (Data.Object, Values, To_General_Handler (Data.Func)); else Value := Data.Func (Data.Object, Values); end if; end if; Set_Value (Return_Value, Value'Address); end First_Marshaller; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Expect_Return_Value => True); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => True); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => Cb, Proxy => null, Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Expect_Return_Value => True); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => Cb, Proxy => null, Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => True); end Object_Connect; ------------------ -- Emit_By_Name -- ------------------ function Emit_By_Name (Object : access Widget_Type'Class; Name : Glib.Signal_Name; Param : Gdk.Event.Gdk_Event) return Return_Type is procedure Internal (Object : System.Address; Name : Glib.Signal_Name; Param : System.Address; Ret : out Gint); pragma Import (C, Internal, "ada_g_signal_emit_by_name_ptr_ptr"); B : Gint; begin pragma Assert (Count_Arguments (Object, Name) = 1); Internal (Get_Object (Object), Name & ASCII.NUL, Gdk.Event.To_Address (Param), B); return Return_Type'Val (B); end Emit_By_Name; end Return_Callback; -------------------------- -- User_Return_Callback -- -------------------------- package body User_Return_Callback is function To_Handler is new Unchecked_Conversion (Gtk.Marshallers.General_Handler, Handler); function To_General_Handler is new Unchecked_Conversion (Handler, Gtk.Marshallers.General_Handler); function To_Address is new Unchecked_Conversion (Handler, System.Address); function To_Address is new Unchecked_Conversion (Marshallers.Handler_Proxy, System.Address); --------------- -- Free_Data -- --------------- procedure Free_Data (Data : Data_Type_Access) is procedure Internal is new Unchecked_Deallocation (Data_Type_Record, Data_Type_Access); procedure Internal2 is new Unchecked_Deallocation (User_Type, User_Access); D : Data_Type_Access := Data; begin Internal2 (D.User); Internal (D); end Free_Data; ---------------------- -- First_Marshaller -- ---------------------- procedure First_Marshaller (Closure : GClosure; Return_Value : GValue; N_Params : Guint; Params : System.Address; Invocation_Hint : System.Address; User_Data : System.Address) is pragma Unreferenced (Invocation_Hint, User_Data); use type Marshallers.Handler_Proxy; Data : constant Data_Type_Access := Convert (Get_Data (Closure)); Stub : Widget_Type; pragma Warnings (Off, Stub); Value : aliased Return_Type; Values : GValues; begin if Data.Func = null then return; end if; Values := Make_Values (N_Params, Params); if Data.Object /= null then if Data.Proxy /= null then Value := Data.Proxy (Data.Object, Values, To_General_Handler (Data.Func), Data.User.all); else Value := Data.Func (Data.Object, Values, Data.User.all); end if; elsif Data.Proxy /= null then Value := Data.Proxy (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values, To_General_Handler (Data.Func), Data.User.all); else Value := Data.Func (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values, Data.User.all); end if; Set_Value (Return_Value, Value'Address); end First_Marshaller; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Marsh, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Marsh, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Cb, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Cb, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, User => new User_Type'(User_Data), Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Expect_Return_Value => True); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, User => new User_Type'(User_Data), Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => True); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => Cb, Proxy => null, User => new User_Type'(User_Data), Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Expect_Return_Value => True); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => Cb, Proxy => null, User => new User_Type'(User_Data), Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => True); end Object_Connect; ------------------ -- Emit_By_Name -- ------------------ function Emit_By_Name (Object : access Widget_Type'Class; Name : Glib.Signal_Name; Param : Gdk.Event.Gdk_Event) return Return_Type is procedure Internal (Object : System.Address; Name : Glib.Signal_Name; Param : System.Address; Ret : out Gint); pragma Import (C, Internal, "ada_g_signal_emit_by_name_ptr_ptr"); B : Gint; begin pragma Assert (Count_Arguments (Object, Name) = 1); Internal (Get_Object (Object), Name & ASCII.NUL, Gdk.Event.To_Address (Param), B); return Return_Type'Val (B); end Emit_By_Name; end User_Return_Callback; -------------- -- Callback -- -------------- package body Callback is function To_Handler is new Unchecked_Conversion (Gtk.Marshallers.General_Handler, Handler); function To_General_Handler is new Unchecked_Conversion (Handler, Gtk.Marshallers.General_Handler); function To_Address is new Unchecked_Conversion (Handler, System.Address); function To_Address is new Unchecked_Conversion (Marshallers.Handler_Proxy, System.Address); --------------- -- Free_Data -- --------------- procedure Free_Data (Data : Data_Type_Access) is procedure Internal is new Unchecked_Deallocation (Data_Type_Record, Data_Type_Access); D : Data_Type_Access := Data; begin Internal (D); end Free_Data; ---------------------- -- First_Marshaller -- ---------------------- procedure First_Marshaller (Closure : GClosure; Return_Value : GValue; N_Params : Guint; Params : System.Address; Invocation_Hint : System.Address; User_Data : System.Address) is pragma Unreferenced (Invocation_Hint, User_Data, Return_Value); use type Marshallers.Handler_Proxy; Data : constant Data_Type_Access := Convert (Get_Data (Closure)); Stub : Widget_Type; pragma Warnings (Off, Stub); Values : GValues; begin if Data.Func = null then return; end if; Values := Make_Values (N_Params, Params); if Data.Object = null then if Data.Proxy /= null then Data.Proxy (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values, To_General_Handler (Data.Func)); else Data.Func (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values); end if; else if Data.Proxy /= null then Data.Proxy (Data.Object, Values, To_General_Handler (Data.Func)); else Data.Func (Data.Object, Values); end if; end if; end First_Marshaller; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Marsh, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Marsh, Slot_Object, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Cb, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Cb, Slot_Object, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; Slot_Object : access Widget_Type'Class; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), Slot_Object, After); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Expect_Return_Value => False); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => False); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record'(Func => Cb, Proxy => null, Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Expect_Return_Value => False); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => Cb, Proxy => null, Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => False); end Object_Connect; ------------------ -- Emit_By_Name -- ------------------ procedure Emit_By_Name (Object : access Widget_Type'Class; Name : Glib.Signal_Name; Param : Gdk.Event.Gdk_Event) is procedure Internal (Object : System.Address; Name : Glib.Signal_Name; Param : System.Address); pragma Import (C, Internal, "ada_g_signal_emit_by_name_ptr"); begin pragma Assert (Count_Arguments (Object, Name) = 1); Internal (Get_Object (Object), Name & ASCII.NUL, Gdk.Event.To_Address (Param)); end Emit_By_Name; end Callback; ------------------- -- User_Callback -- ------------------- package body User_Callback is function To_Handler is new Unchecked_Conversion (Gtk.Marshallers.General_Handler, Handler); function To_General_Handler is new Unchecked_Conversion (Handler, Gtk.Marshallers.General_Handler); function To_Address is new Unchecked_Conversion (Handler, System.Address); function To_Address is new Unchecked_Conversion (Marshallers.Handler_Proxy, System.Address); --------------- -- Free_Data -- --------------- procedure Free_Data (Data : Data_Type_Access) is procedure Internal is new Unchecked_Deallocation (Data_Type_Record, Data_Type_Access); procedure Internal2 is new Unchecked_Deallocation (User_Type, User_Access); D : Data_Type_Access := Data; begin Internal2 (D.User); Internal (D); end Free_Data; ---------------------- -- First_Marshaller -- ---------------------- procedure First_Marshaller (Closure : GClosure; Return_Value : GValue; N_Params : Guint; Params : System.Address; Invocation_Hint : System.Address; User_Data : System.Address) is pragma Unreferenced (Invocation_Hint, User_Data, Return_Value); use type Marshallers.Handler_Proxy; Data : constant Data_Type_Access := Convert (Get_Data (Closure)); Stub : Widget_Type; pragma Warnings (Off, Stub); Values : GValues; begin if Data.Func = null then return; end if; Values := Make_Values (N_Params, Params); if Data.Object /= null then if Data.Proxy /= null then Data.Proxy (Data.Object, Values, To_General_Handler (Data.Func), Data.User.all); else Data.Func (Data.Object, Values, Data.User.all); end if; elsif Data.Proxy /= null then Data.Proxy (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values, To_General_Handler (Data.Func), Data.User.all); else Data.Func (Acc (Get_User_Data (Get_Address (Nth (Values, 0)), Stub)), Values, Data.User.all); end if; end First_Marshaller; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Marsh, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Marsh, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Cb, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Cb, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, User => new User_Type'(User_Data), Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Expect_Return_Value => False); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => To_Handler (Marsh.Func), Proxy => Marsh.Proxy, User => new User_Type'(User_Data), Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Marsh.Proxy), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => False); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => Cb, Proxy => null, User => new User_Type'(User_Data), Object => null); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Expect_Return_Value => False); end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is D : constant Data_Type_Access := new Data_Type_Record' (Func => Cb, Proxy => null, User => new User_Type'(User_Data), Object => Acc (Slot_Object)); begin return Do_Signal_Connect (Glib.Object.GObject (Widget), Name, First_Marshaller'Address, To_Address (Cb), Convert (D), Free_Data'Address, After, Get_Object (Slot_Object), Expect_Return_Value => False); end Object_Connect; ------------------ -- Emit_By_Name -- ------------------ procedure Emit_By_Name (Object : access Widget_Type'Class; Name : Glib.Signal_Name; Param : Gdk.Event.Gdk_Event) is procedure Internal (Object : System.Address; Name : Glib.Signal_Name; Param : System.Address); pragma Import (C, Internal, "ada_g_signal_emit_by_name_ptr"); begin pragma Assert (Count_Arguments (Object, Name) = 1); Internal (Get_Object (Object), Name & ASCII.NUL, Gdk.Event.To_Address (Param)); end Emit_By_Name; end User_Callback; ------------------------------------- -- User_Return_Callback_With_Setup -- ------------------------------------- package body User_Return_Callback_With_Setup is ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Marsh, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Marsh, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Cb, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Cb, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Connect (Widget, Name, Marsh, User_Data, After); begin Setup (User_Data, Id); return Id; end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Object_Connect (Widget, Name, Marsh, Slot_Object, User_Data, After); begin Setup (User_Data, Id); return Id; end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Connect (Widget, Name, Cb, User_Data, After); begin Setup (User_Data, Id); return Id; end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Object_Connect (Widget, Name, Cb, Slot_Object, User_Data, After); begin Setup (User_Data, Id); return Id; end Object_Connect; end User_Return_Callback_With_Setup; ------------------------------ -- User_Callback_With_Setup -- ------------------------------ package body User_Callback_With_Setup is ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Marsh, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Marsh, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, Cb, User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, Cb, Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- procedure Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), User_Data, After); end Connect; -------------------- -- Object_Connect -- -------------------- procedure Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Simple_Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) is Id : Handler_Id; pragma Warnings (Off, Id); begin Id := Object_Connect (Widget, Name, To_Marshaller (Marshallers.Void_Marshaller.Handler (Cb)), Slot_Object, User_Data, After); end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Connect (Widget, Name, Marsh, User_Data, After); begin Setup (User_Data, Id); return Id; end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Marsh : Internal_Cb.Marshallers.Marshaller; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Object_Connect (Widget, Name, Marsh, Slot_Object, User_Data, After); begin Setup (User_Data, Id); return Id; end Object_Connect; ------------- -- Connect -- ------------- function Connect (Widget : access Widget_Type'Class; Name : Glib.Signal_Name; Cb : Handler; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Connect (Widget, Name, Cb, User_Data, After); begin Setup (User_Data, Id); return Id; end Connect; -------------------- -- Object_Connect -- -------------------- function Object_Connect (Widget : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name; Cb : Handler; Slot_Object : access Widget_Type'Class; User_Data : User_Type; After : Boolean := False) return Handler_Id is Id : constant Handler_Id := Internal_Cb.Object_Connect (Widget, Name, Cb, Slot_Object, User_Data, After); begin Setup (User_Data, Id); return Id; end Object_Connect; end User_Callback_With_Setup; ---------------- -- Disconnect -- ---------------- procedure Disconnect (Object : access Glib.Object.GObject_Record'Class; Id : in out Handler_Id) is begin if Id.Id /= Null_Handler_Id then Disconnect_Internal (Obj => Get_Object (Object), Id => Id.Id); Id.Id := Null_Handler_Id; end if; end Disconnect; ----------------------- -- Emit_Stop_By_Name -- ----------------------- procedure Emit_Stop_By_Name (Object : access Glib.Object.GObject_Record'Class; Name : Glib.Signal_Name) is procedure Internal (Object : System.Address; Id : Signal_Id; Detail : GQuark := Unknown_Quark); pragma Import (C, Internal, "g_signal_stop_emission"); begin Internal (Get_Object (Object), Signal_Lookup (Name & ASCII.NUL, Get_Type (Object))); end Emit_Stop_By_Name; ------------------- -- Handler_Block -- ------------------- procedure Handler_Block (Obj : access Glib.Object.GObject_Record'Class; Id : Handler_Id) is procedure Internal (Obj : System.Address; Id : Gulong); pragma Import (C, Internal, "g_signal_handler_block"); begin Internal (Obj => Get_Object (Obj), Id => Id.Id); end Handler_Block; ---------------------- -- Handlers_Destroy -- ---------------------- procedure Handlers_Destroy (Obj : access Glib.Object.GObject_Record'Class) is procedure Internal (Obj : System.Address); pragma Import (C, Internal, "g_signal_handlers_destroy"); begin Internal (Obj => Get_Object (Obj)); end Handlers_Destroy; --------------------- -- Handler_Unblock -- --------------------- procedure Handler_Unblock (Obj : access Glib.Object.GObject_Record'Class; Id : Handler_Id) is procedure Internal (Obj : System.Address; Id : Gulong); pragma Import (C, Internal, "g_signal_handler_unblock"); begin Internal (Obj => Get_Object (Obj), Id => Id.Id); end Handler_Unblock; end Gtk.Handlers; -- Design of the package: -- -- The callback package should accomodate the following: -- * Sometimes, the user does not want to get the handler_id. Thus, we give -- the two versions of Connect, either as a procedure or a function. -- * Some gtk+ signals expect a handler that returns a value, whereas others -- return nothing. The simplest here is to have two kinds of packages, one -- for each case. The standard gtk+ signals (up to 1.2) have the following -- possible return values: gboolean, gchar*, gint, guint, void -- * The first argument to a handler is always a Gtk Object. since GtkAda is -- full object oriented, we could simply have the first parameter be a -- GObject'Class, but this would require in most cases an explicit cast -- from the user. It is nice to give the opportunity to have a specific -- type. -- * The standard callbacks can have any number of arguments (or even -- none). These arguments depend on the signal type, and the widget type. -- The only possibility to cover all the cases is to pass these arguments as -- an array. The package Marshallers provides a convenient interface between -- these general callbacks and a more usual implementation. -- * The user can specify some Data to be passed to the handler. Or there -- can be none. Once again, we create two versions of the standard packages. -- -- How the callbacks work: -- -------- -------------------- --------------------- -- | Gtk+ | -> | First_Marshaller | -> | User's Marshaller | -- -------- -------------------- --------------------- -- \ | -- \ or V -- \ ------------------- -- \---> | User's Callback | -- ------------------- -- -- First_Marshaller is an internal function defined in this package. It -- creates its own user data to memorize both the User's Marshaller (if any), -- User's Callback, and the User's Data (if any). It then calls the -- appropriate function in the user's code. -- The user_data of First_Marshaller is automatically deallocated when the -- callback is disconnected or the widget is killed, using some capabilities -- of gtk+ itself.