1-----------------------------------------------------------------------
2--               GtkAda - Ada95 binding for Gtk+/Gnome               --
3--                                                                   --
4--                    Copyright (C) 2011-2013, AdaCore               --
5--                                                                   --
6-- This library is free software; you can redistribute it and/or     --
7-- modify it under the terms of the GNU General Public               --
8-- License as published by the Free Software Foundation; either      --
9-- version 2 of the License, or (at your option) any later version.  --
10--                                                                   --
11-- This library is distributed in the hope that it will be useful,   --
12-- but WITHOUT ANY WARRANTY; without even the implied warranty of    --
13-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU --
14-- General Public License for more details.                          --
15--                                                                   --
16-- You should have received a copy of the GNU General Public         --
17-- License along with this library; if not, write to the             --
18-- Free Software Foundation, Inc., 59 Temple Place - Suite 330,      --
19-- Boston, MA 02111-1307, USA.                                       --
20--                                                                   --
21-- As a special exception, if other files instantiate generics from  --
22-- this unit, or you link this unit with other files to produce an   --
23-- executable, this  unit  does not  by itself cause  the resulting  --
24-- executable to be covered by the GNU General Public License. This  --
25-- exception does not however invalidate any other reasons why the   --
26-- executable file  might be covered by the  GNU Public License.     --
27-----------------------------------------------------------------------
28
29with Interfaces.C.Strings; use Interfaces.C.Strings;
30with System;               use System;
31with System.Assertions;    use System.Assertions;
32
33with Ada.Exceptions;
34with Ada.Text_IO;
35with Ada.Unchecked_Deallocation;
36
37with Glib;        use Glib;
38
39with Gtk.Handlers;    use Gtk.Handlers;
40with Gtkada.Handlers; use Gtkada.Handlers;
41
42package body Gtkada.Builder is
43
44   use Handlers_Map;
45
46   package Builder_Callback is new Gtk.Handlers.Callback
47     (Gtkada_Builder_Record);
48   package Builder_Return_Callback is new Gtk.Handlers.Return_Callback
49     (Gtkada_Builder_Record, Boolean);
50
51   procedure Wrapper_Callback
52     (C_Builder        : System.Address;
53      C_Object         : System.Address;
54      C_Signal_Name    : Interfaces.C.Strings.chars_ptr;
55      C_Handler_Name   : Interfaces.C.Strings.chars_ptr;
56      C_Connect_Object : System.Address;
57      Flags            : Glib.G_Connect_Flags;
58      User_Data        : System.Address);
59   pragma Convention (C, Wrapper_Callback);
60   --  Low-level subprogram to perform signal connections.
61
62   procedure Connect
63     (Handler_Name : String;
64      Handler      : Universal_Marshaller;
65      Base_Object  : GObject;
66      Signal       : Glib.Signal_Name;
67      After        : Boolean;
68      The_Builder  : Gtkada_Builder;
69      Slot_Object  : GObject);
70   --  Connect object to handler
71
72   procedure Free (Builder : access Gtkada_Builder_Record'Class);
73   --  Called when the Builder is destroyed
74
75   procedure On_Destroy
76     (Data         : System.Address;
77      Builder_Addr : System.Address);
78   pragma Convention (C, On_Destroy);
79
80   -------------
81   -- Connect --
82   -------------
83
84   procedure Connect
85     (Handler_Name : String;
86      Handler      : Universal_Marshaller;
87      Base_Object  : GObject;
88      Signal       : Glib.Signal_Name;
89      After        : Boolean;
90      The_Builder  : Gtkada_Builder;
91      Slot_Object  : GObject) is
92   begin
93      --  Sanity checks
94
95      case Handler.T is
96         when Object | Object_Return =>
97            if Slot_Object = null then
98               Raise_Assert_Failure
99                 ("Error when connecting handler """ & Handler_Name & """:"
100                  & ASCII.LF
101                  & " attempting to connect a callback of type """ &
102                  Handler_Type'Image (Handler.T)
103                  & """, but no User_Data was specified in glade-3");
104            end if;
105
106         when Builder | Builder_Return =>
107            null;
108      end case;
109
110      --  Do the connect
111      case Handler.T is
112         when Object =>
113            Object_Callback.Object_Connect
114              (Widget      => Base_Object,
115               Name        => Signal,
116               Marsh       => Object_Callback.To_Marshaller
117                 (Object_Callback.Marshallers.Void_Marshaller.Handler
118                    (Handler.The_Object_Handler)),
119               Slot_Object => Slot_Object,
120               After       => After);
121
122         when Object_Return =>
123            Object_Return_Callback.Object_Connect
124              (Widget      => Base_Object,
125               Name        => Signal,
126               Marsh       => Object_Return_Callback.To_Marshaller
127                 (Object_Return_Callback.Marshallers.Void_Marshaller.Handler
128                    (Handler.The_Object_Return_Handler)),
129               Slot_Object => Slot_Object,
130               After       => After);
131
132         when Builder =>
133            Builder_Callback.Object_Connect
134              (Widget      => Base_Object,
135               Name        => Signal,
136               Marsh       => Builder_Callback.To_Marshaller
137                 (Builder_Callback.Marshallers.Void_Marshaller.Handler
138                    (Handler.The_Builder_Handler)),
139               Slot_Object => The_Builder,
140               After       => After);
141
142         when Builder_Return =>
143            Builder_Return_Callback.Object_Connect
144              (Widget      => Base_Object,
145               Name        => Signal,
146               Marsh       => Builder_Return_Callback.To_Marshaller
147                 (Builder_Return_Callback.Marshallers.Void_Marshaller.Handler
148                    (Handler.The_Builder_Return_Handler)),
149               Slot_Object => The_Builder,
150               After       => After);
151
152      end case;
153   end Connect;
154
155   ----------------------
156   -- Wrapper_Callback --
157   ----------------------
158
159   procedure Wrapper_Callback
160     (C_Builder        : System.Address;
161      C_Object         : System.Address;
162      C_Signal_Name    : Interfaces.C.Strings.chars_ptr;
163      C_Handler_Name   : Interfaces.C.Strings.chars_ptr;
164      C_Connect_Object : System.Address;
165      Flags            : Glib.G_Connect_Flags;
166      User_Data        : System.Address)
167   is
168      pragma Unreferenced (User_Data);
169      Object      : constant GObject := Convert (C_Object);
170      Signal_Name : constant String := Value (C_Signal_Name);
171      After       : constant Boolean := (Flags and G_Connect_After) /= 0;
172      Builder     : constant Gtkada_Builder :=
173        Gtkada_Builder (Convert (C_Builder));
174
175      The_Marshaller : Universal_Marshaller_Access;
176      --  The universal marshaller
177
178      Handler_Name  : constant String := Value (C_Handler_Name);
179
180      C : Cursor;
181   begin
182      --  Find the marshaller corresponding to the handler name.
183
184      C := Find (Builder.Handlers, To_Unbounded_String (Handler_Name));
185
186      if C = No_Element then
187         Raise_Assert_Failure
188           ("Attempting to connect a callback to a handler ("""
189            & Handler_Name
190            & ")"" for which no callback has been registered.");
191      end if;
192
193      The_Marshaller := Element (C);
194
195      --  Now do the actual connect
196
197         Connect (Handler_Name => Handler_Name,
198                  Handler     => The_Marshaller.all,
199                  Base_Object => Object,
200                  Signal      => Glib.Signal_Name (Signal_Name),
201                  After       => After,
202                  The_Builder => Builder,
203                  Slot_Object => Convert (C_Connect_Object));
204
205   end Wrapper_Callback;
206
207   ----------------------
208   -- Register_Handler --
209   ----------------------
210
211   procedure Register_Handler
212     (Builder      : access Gtkada_Builder_Record'Class;
213      Handler_Name : String;
214      Handler      : Object_Handler)
215   is
216      Item : Universal_Marshaller_Access;
217   begin
218      Item := new Universal_Marshaller (Object);
219      Item.The_Object_Handler := Handler;
220      Insert
221        (Builder.Handlers,
222         Key      => To_Unbounded_String (Handler_Name),
223         New_Item => Item);
224   end Register_Handler;
225
226   ----------------------
227   -- Register_Handler --
228   ----------------------
229
230   procedure Register_Handler
231     (Builder      : access Gtkada_Builder_Record'Class;
232      Handler_Name : String;
233      Handler      : Object_Return_Handler)
234   is
235      Item : Universal_Marshaller_Access;
236   begin
237      Item := new Universal_Marshaller (Object_Return);
238      Item.The_Object_Return_Handler := Handler;
239      Insert
240        (Builder.Handlers,
241         Key      => To_Unbounded_String (Handler_Name),
242         New_Item => Item);
243   end Register_Handler;
244
245   ----------------------
246   -- Register_Handler --
247   ----------------------
248
249   procedure Register_Handler
250     (Builder      : access Gtkada_Builder_Record'Class;
251      Handler_Name : String;
252      Handler      : Builder_Handler)
253   is
254      Item : Universal_Marshaller_Access;
255   begin
256      Item := new Universal_Marshaller (Gtkada.Builder.Builder);
257      Item.The_Builder_Handler := Handler;
258      Insert
259        (Builder.Handlers,
260         Key      => To_Unbounded_String (Handler_Name),
261         New_Item => Item);
262   end Register_Handler;
263
264   ----------------------
265   -- Register_Handler --
266   ----------------------
267
268   procedure Register_Handler
269     (Builder      : access Gtkada_Builder_Record'Class;
270      Handler_Name : String;
271      Handler      : Builder_Return_Handler)
272   is
273      Item : Universal_Marshaller_Access;
274   begin
275      Item := new Universal_Marshaller (Builder_Return);
276      Item.The_Builder_Return_Handler := Handler;
277      Insert
278        (Builder.Handlers,
279         Key      => To_Unbounded_String (Handler_Name),
280         New_Item => Item);
281   end Register_Handler;
282
283   ----------------
284   -- Do_Connect --
285   ----------------
286
287   procedure Do_Connect (Builder : access Gtkada_Builder_Record'Class) is
288   begin
289      Connect_Signals_Full
290        (Builder,
291         Wrapper_Callback'Access,
292         User_Data => Glib.Object.Get_Object (Builder));
293   end Do_Connect;
294
295   ----------------
296   -- On_Destroy --
297   ----------------
298
299   procedure Free (Builder : access Gtkada_Builder_Record'Class) is
300      C : Cursor;
301      E : Universal_Marshaller_Access;
302
303      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
304        (Universal_Marshaller, Universal_Marshaller_Access);
305
306   begin
307      --  Free memory associated to handlers
308
309      C := First (Builder.Handlers);
310
311      while Has_Element (C) loop
312         E := Element (C);
313         Unchecked_Free (E);
314         Next (C);
315      end loop;
316
317   exception
318      when E : others =>
319         Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
320   end Free;
321
322   -------------
323   -- Gtk_New --
324   -------------
325
326   procedure Gtk_New (Builder : out Gtkada_Builder) is
327   begin
328      Builder := new Gtkada_Builder_Record;
329      Gtkada.Builder.Initialize (Builder);
330   end Gtk_New;
331
332   ----------------
333   -- On_Destroy --
334   ----------------
335
336   procedure On_Destroy
337     (Data         : System.Address;
338      Builder_Addr : System.Address)
339   is
340      pragma Unreferenced (Data);
341
342      Stub : Gtkada_Builder_Record;
343      Builder : constant Gtkada_Builder := Gtkada_Builder
344        (Get_User_Data (Builder_Addr, Stub));
345
346   begin
347      Free (Builder);
348   end On_Destroy;
349
350   ----------------
351   -- Initialize --
352   ----------------
353
354   procedure Initialize (Builder : access Gtkada_Builder_Record'Class) is
355   begin
356      Gtk.Builder.Initialize (Builder);
357      Weak_Ref (Builder, On_Destroy'Access);
358   end Initialize;
359
360end Gtkada.Builder;
361