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