1----------------------------------------------------------------------- 2-- GtkAda - Ada95 binding for Gtk+/Gnome -- 3-- -- 4-- Copyright (C) 1998-2000 E. Briot, J. Brobecker and A. Charlet -- 5-- Copyright (C) 2000-2013, AdaCore -- 6-- -- 7-- This library is free software; you can redistribute it and/or -- 8-- modify it under the terms of the GNU General Public -- 9-- License as published by the Free Software Foundation; either -- 10-- version 2 of the License, or (at your option) any later version. -- 11-- -- 12-- This library is distributed in the hope that it will be useful, -- 13-- but WITHOUT ANY WARRANTY; without even the implied warranty of -- 14-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- 15-- General Public License for more details. -- 16-- -- 17-- You should have received a copy of the GNU General Public -- 18-- License along with this library; if not, write to the -- 19-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, -- 20-- Boston, MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from -- 23-- this unit, or you link this unit with other files to produce an -- 24-- executable, this unit does not by itself cause the resulting -- 25-- executable to be covered by the GNU General Public License. This -- 26-- exception does not however invalidate any other reasons why the -- 27-- executable file might be covered by the GNU Public License. -- 28----------------------------------------------------------------------- 29 30with Interfaces.C.Strings; use Interfaces.C.Strings; 31with System; 32with Ada.Unchecked_Conversion; 33with Ada.Unchecked_Deallocation; 34 35with Glib.Type_Conversion_Hooks; 36pragma Elaborate_All (Glib.Type_Conversion_Hooks); 37with Gtk.Menu_Shell; use Gtk.Menu_Shell; 38with Gtk.Widget; use Gtk.Widget; 39 40package body Gtk.Menu is 41 42 package Type_Conversion is new Glib.Type_Conversion_Hooks.Hook_Registrator 43 (Get_Type'Access, Gtk_Menu_Record); 44 pragma Warnings (Off, Type_Conversion); 45 -- This package is used to implement a minimal automated type conversion 46 -- without having to drag the whole Gtk.Type_Conversion package for the 47 -- most common widgets. 48 49 procedure Internal_Menu_Position_Func 50 (Menu : System.Address; 51 X : out Gint; 52 Y : out Gint; 53 Push_In : out Gboolean; 54 Data : System.Address); 55 pragma Convention (C, Internal_Menu_Position_Func); 56 -- Wrapper function passed to C. 57 58 ---------------------- 59 -- Attach_To_Widget -- 60 ---------------------- 61 62 procedure Attach_To_Widget 63 (Menu : access Gtk_Menu_Record; 64 Attach_Widget : access Gtk.Widget.Gtk_Widget_Record'Class; 65 Detacher : Gtk_Menu_Detach_Func) 66 is 67 procedure Internal 68 (Menu : System.Address; 69 Attach_Widget : System.Address; 70 Detacher : Gtk_Menu_Detach_Func); 71 pragma Import (C, Internal, "gtk_menu_attach_to_widget"); 72 73 begin 74 Internal (Get_Object (Menu), Get_Object (Attach_Widget), Detacher); 75 end Attach_To_Widget; 76 77 ------------ 78 -- Detach -- 79 ------------ 80 81 procedure Detach (Menu : access Gtk_Menu_Record) is 82 procedure Internal (Menu : System.Address); 83 pragma Import (C, Internal, "gtk_menu_detach"); 84 85 begin 86 Internal (Get_Object (Menu)); 87 end Detach; 88 89 --------------------- 90 -- Get_Accel_Group -- 91 --------------------- 92 93 function Get_Accel_Group 94 (Menu : access Gtk_Menu_Record) return Accel_Group.Gtk_Accel_Group 95 is 96 function Internal 97 (Menu : System.Address) return System.Address; 98 pragma Import (C, Internal, "gtk_menu_get_accel_group"); 99 100 Stub : Accel_Group.Gtk_Accel_Group_Record; 101 102 begin 103 return Accel_Group.Gtk_Accel_Group 104 (Get_User_Data_Fast (Internal (Get_Object (Menu)), Stub)); 105 end Get_Accel_Group; 106 107 -------------------- 108 -- Get_Accel_Path -- 109 -------------------- 110 111 function Get_Accel_Path (Menu : access Gtk_Menu_Record) return String is 112 function Internal (Menu : System.Address) 113 return Interfaces.C.Strings.chars_ptr; 114 pragma Import (C, Internal, "gtk_menu_get_accel_path"); 115 begin 116 return Value (Internal (Get_Object (Menu))); 117 end Get_Accel_Path; 118 119 ---------------- 120 -- Get_Active -- 121 ---------------- 122 123 function Get_Active 124 (Menu : access Gtk_Menu_Record) return Gtk.Menu_Item.Gtk_Menu_Item 125 is 126 function Internal (Menu : System.Address) return System.Address; 127 pragma Import (C, Internal, "gtk_menu_get_active"); 128 129 Stub : Gtk.Menu_Item.Gtk_Menu_Item_Record; 130 131 begin 132 return Gtk.Menu_Item.Gtk_Menu_Item 133 (Get_User_Data (Internal (Get_Object (Menu)), Stub)); 134 end Get_Active; 135 136 ----------------------- 137 -- Get_Attach_Widget -- 138 ----------------------- 139 140 function Get_Attach_Widget 141 (Menu : access Gtk_Menu_Record) return Gtk.Widget.Gtk_Widget 142 is 143 function Internal (Menu : System.Address) return System.Address; 144 pragma Import (C, Internal, "gtk_menu_get_attach_widget"); 145 146 begin 147 return Gtk.Widget.Convert (Internal (Get_Object (Menu))); 148 end Get_Attach_Widget; 149 150 ----------------- 151 -- Get_Monitor -- 152 ----------------- 153 154 function Get_Monitor (Menu : access Gtk_Menu_Record) return Gint is 155 function Internal (Menu : System.Address) return Gint; 156 pragma Import (C, Internal, "gtk_menu_get_monitor"); 157 begin 158 return Internal (Get_Object (Menu)); 159 end Get_Monitor; 160 161 ----------------------- 162 -- Get_Tearoff_State -- 163 ----------------------- 164 165 function Get_Tearoff_State (Menu : access Gtk_Menu_Record) return Boolean is 166 function Internal (Menu : System.Address) return Gboolean; 167 pragma Import (C, Internal, "gtk_menu_get_tearoff_state"); 168 169 begin 170 return Internal (Get_Object (Menu)) /= 0; 171 end Get_Tearoff_State; 172 173 --------------- 174 -- Get_Title -- 175 --------------- 176 177 function Get_Title (Menu : access Gtk_Menu_Record) return UTF8_String is 178 function Internal (Menu : System.Address) return chars_ptr; 179 pragma Import (C, Internal, "gtk_menu_get_title"); 180 181 begin 182 return Value (Internal (Get_Object (Menu))); 183 end Get_Title; 184 185 ------------- 186 -- Gtk_New -- 187 ------------- 188 189 procedure Gtk_New (Widget : out Gtk_Menu) is 190 begin 191 Widget := new Gtk_Menu_Record; 192 Gtk.Menu.Initialize (Widget); 193 end Gtk_New; 194 195 ---------------- 196 -- Initialize -- 197 ---------------- 198 199 procedure Initialize (Widget : access Gtk_Menu_Record'Class) is 200 function Internal return System.Address; 201 pragma Import (C, Internal, "gtk_menu_new"); 202 203 begin 204 Set_Object (Widget, Internal); 205 end Initialize; 206 207 ------------- 208 -- Popdown -- 209 ------------- 210 211 procedure Popdown (Menu : access Gtk_Menu_Record) is 212 procedure Internal (Menu : System.Address); 213 pragma Import (C, Internal, "gtk_menu_popdown"); 214 215 begin 216 Internal (Get_Object (Menu)); 217 end Popdown; 218 219 ------------------- 220 -- Reorder_Child -- 221 ------------------- 222 223 procedure Reorder_Child 224 (Menu : access Gtk_Menu_Record; 225 Child : access Gtk.Widget.Gtk_Widget_Record'Class; 226 Position : Gint) 227 is 228 procedure Internal 229 (Menu : System.Address; 230 Child : System.Address; 231 Position : Gint); 232 pragma Import (C, Internal, "gtk_menu_reorder_child"); 233 234 begin 235 Internal (Get_Object (Menu), Get_Object (Child), Position); 236 end Reorder_Child; 237 238 ---------------- 239 -- Reposition -- 240 ---------------- 241 242 procedure Reposition (Menu : access Gtk_Menu_Record) is 243 procedure Internal (Menu : System.Address); 244 pragma Import (C, Internal, "gtk_menu_reposition"); 245 246 begin 247 Internal (Get_Object (Menu)); 248 end Reposition; 249 250 --------------------- 251 -- Set_Accel_Group -- 252 --------------------- 253 254 procedure Set_Accel_Group 255 (Menu : access Gtk_Menu_Record; 256 Accel : Gtk.Accel_Group.Gtk_Accel_Group) 257 is 258 procedure Internal 259 (Menu : System.Address; 260 Accel_Group : System.Address); 261 pragma Import (C, Internal, "gtk_menu_set_accel_group"); 262 263 begin 264 Internal (Get_Object (Menu), Get_Object (Accel)); 265 end Set_Accel_Group; 266 267 -------------------- 268 -- Set_Accel_Path -- 269 -------------------- 270 271 procedure Set_Accel_Path 272 (Menu : access Gtk_Menu_Record; 273 Accel_Path : UTF8_String) 274 is 275 procedure Internal (Menu : System.Address; Accel_Path : UTF8_String); 276 pragma Import (C, Internal, "gtk_menu_set_accel_path"); 277 278 begin 279 Internal (Get_Object (Menu), Accel_Path & ASCII.NUL); 280 end Set_Accel_Path; 281 282 ---------------- 283 -- Set_Active -- 284 ---------------- 285 286 procedure Set_Active (Menu : access Gtk_Menu_Record; Index : Guint) is 287 procedure Internal (Menu : System.Address; Index : Guint); 288 pragma Import (C, Internal, "gtk_menu_set_active"); 289 290 begin 291 Internal (Get_Object (Menu), Index); 292 end Set_Active; 293 294 --------------- 295 -- Set_Title -- 296 --------------- 297 298 procedure Set_Title (Menu : access Gtk_Menu_Record; Title : UTF8_String) is 299 procedure Internal (Menu : System.Address; Title : UTF8_String); 300 pragma Import (C, Internal, "gtk_menu_set_title"); 301 302 begin 303 Internal (Get_Object (Menu), Title & ASCII.NUL); 304 end Set_Title; 305 306 ----------------------- 307 -- Set_Tearoff_State -- 308 ----------------------- 309 310 procedure Set_Tearoff_State 311 (Menu : access Gtk_Menu_Record; 312 Torn_Off : Boolean) 313 is 314 procedure Internal (Menu : System.Address; Torn_Off : Gboolean); 315 pragma Import (C, Internal, "gtk_menu_set_tearoff_state"); 316 317 begin 318 Internal (Get_Object (Menu), Boolean'Pos (Torn_Off)); 319 end Set_Tearoff_State; 320 321 ----------- 322 -- Popup -- 323 ----------- 324 325 procedure Popup 326 (Menu : access Gtk_Menu_Record; 327 Parent_Menu_Shell : Gtk.Menu_Shell.Gtk_Menu_Shell := null; 328 Parent_Menu_Item : Gtk.Menu_Item.Gtk_Menu_Item := null; 329 Func : C_Gtk_Menu_Position_Func := null; 330 User_Data : System.Address; 331 Button : Guint := 1; 332 Activate_Time : Guint32 := 0) 333 is 334 procedure Internal 335 (Menu : System.Address; 336 Parent_M : System.Address; 337 Parent_I : System.Address; 338 Func : System.Address; 339 Data : System.Address; 340 Button : Guint; 341 Activate_Time : Guint32); 342 pragma Import (C, Internal, "gtk_menu_popup"); 343 344 Parent_Shell : System.Address := System.Null_Address; 345 Parent_Item : System.Address := System.Null_Address; 346 347 begin 348 if Parent_Menu_Shell /= null then 349 Parent_Shell := Get_Object (Parent_Menu_Shell); 350 end if; 351 352 if Parent_Menu_Item /= null then 353 Parent_Item := Get_Object (Parent_Menu_Item); 354 end if; 355 356 if Func = null then 357 Internal 358 (Get_Object (Menu), Parent_Shell, Parent_Item, 359 System.Null_Address, 360 System.Null_Address, Button, Activate_Time); 361 else 362 Internal 363 (Get_Object (Menu), Parent_Shell, Parent_Item, 364 Func.all'Address, User_Data, Button, Activate_Time); 365 end if; 366 end Popup; 367 368 --------------------------------- 369 -- Internal_Menu_Position_Func -- 370 --------------------------------- 371 372 procedure Internal_Menu_Position_Func 373 (Menu : System.Address; 374 X : out Gint; 375 Y : out Gint; 376 Push_In : out Gboolean; 377 Data : System.Address) 378 is 379 function Convert is 380 new Ada.Unchecked_Conversion (System.Address, Gtk_Menu_Position_Func); 381 Func : constant Gtk_Menu_Position_Func := Convert (Data); 382 383 M : Gtk_Menu; 384 Stub : Gtk_Menu_Record; 385 begin 386 M := Gtk_Menu (Get_User_Data (Menu, Stub)); 387 Func.all (M, X, Y); 388 389 -- Always place popup at our specified coordinates regardless of 390 -- whether it may be outside the visible area. 391 Push_In := Boolean'Pos (False); 392 end Internal_Menu_Position_Func; 393 394 ----------- 395 -- Popup -- 396 ----------- 397 398 procedure Popup 399 (Menu : access Gtk_Menu_Record; 400 Parent_Menu_Shell : Gtk.Menu_Shell.Gtk_Menu_Shell := null; 401 Parent_Menu_Item : Gtk.Menu_Item.Gtk_Menu_Item := null; 402 Func : Gtk_Menu_Position_Func := null; 403 Button : Guint := 1; 404 Activate_Time : Guint32 := 0) 405 is 406 F : C_Gtk_Menu_Position_Func := null; 407 D : System.Address := System.Null_Address; 408 begin 409 if Func /= null then 410 F := Internal_Menu_Position_Func'Access; 411 D := Func.all'Address; 412 end if; 413 414 Popup 415 (Menu, 416 Parent_Menu_Shell, 417 Parent_Menu_Item, 418 F, 419 D, 420 Button, 421 Activate_Time); 422 end Popup; 423 424 --------------------------------------- 425 -- User_Menu_Popup (generic package) -- 426 --------------------------------------- 427 428 package body User_Menu_Popup is 429 430 type Data_Access is access Data_Type; 431 432 procedure Unchecked_Free is new Ada.Unchecked_Deallocation 433 (Data_Type, Data_Access); 434 435 type Data_And_Cb is record 436 Data : Data_Access; 437 Cb : Gtk_Menu_Position_Func; 438 end record; 439 440 type Data_And_Cb_Access is access Data_And_Cb; 441 442 procedure Unchecked_Free is new Ada.Unchecked_Deallocation 443 (Data_And_Cb, Data_And_Cb_Access); 444 function Convert is 445 new Ada.Unchecked_Conversion (System.Address, Data_And_Cb_Access); 446 function Convert is 447 new Ada.Unchecked_Conversion (Data_And_Cb_Access, System.Address); 448 449 ------------------------------------------- 450 -- Internal_Menu_Position_Func_With_Data -- 451 ------------------------------------------- 452 453 procedure Internal_Menu_Position_Func_With_Data 454 (Menu : System.Address; 455 X : out Gint; 456 Y : out Gint; 457 Push_In : out Gboolean; 458 User_Data : System.Address) 459 is 460 Data : Data_And_Cb_Access := Convert (User_Data); 461 M : Gtk_Menu; 462 Stub : Gtk_Menu_Record; 463 begin 464 M := Gtk_Menu (Get_User_Data (Menu, Stub)); 465 Data.Cb (M, X, Y, Data.Data); 466 467 -- Always place popup at our specified coordinates regardless of 468 -- whether it may be outside the visible area. 469 Push_In := Boolean'Pos (False); 470 471 Unchecked_Free (Data.Data); 472 Unchecked_Free (Data); 473 end Internal_Menu_Position_Func_With_Data; 474 475 ----------- 476 -- Popup -- 477 ----------- 478 479 procedure Popup 480 (Menu : access Gtk_Menu_Record'Class; 481 Data : access Data_Type; 482 Parent_Menu_Shell : Gtk.Menu_Shell.Gtk_Menu_Shell := null; 483 Parent_Menu_Item : Gtk.Menu_Item.Gtk_Menu_Item := null; 484 Func : Gtk_Menu_Position_Func := null; 485 Button : Guint := 1; 486 Activate_Time : Guint32 := 0) 487 is 488 The_Data : Data_And_Cb_Access; 489 F : C_Gtk_Menu_Position_Func := null; 490 D : System.Address := System.Null_Address; 491 begin 492 if Func /= null then 493 The_Data := new Data_And_Cb'(new Data_Type'(Data.all), Func); 494 F := Internal_Menu_Position_Func_With_Data_Access; 495 D := Convert (The_Data); 496 end if; 497 498 Popup 499 (Menu, 500 Parent_Menu_Shell, 501 Parent_Menu_Item, 502 F, 503 D, 504 Button, 505 Activate_Time); 506 end Popup; 507 end User_Menu_Popup; 508 509 ------------ 510 -- Attach -- 511 ------------ 512 513 procedure Attach 514 (Menu : access Gtk_Menu_Record; 515 Child : access Gtk_Menu_Item_Record'Class; 516 Left_Attach : Guint; 517 Right_Attach : Guint; 518 Top_Attach : Guint; 519 Bottom_Attach : Guint) 520 is 521 procedure Internal 522 (Menu : System.Address; 523 Child : System.Address; 524 Left_Attach : Guint; 525 Right_Attach : Guint; 526 Top_Attach : Guint; 527 Bottom_Attach : Guint); 528 pragma Import (C, Internal, "gtk_menu_attach"); 529 begin 530 Internal (Get_Object (Menu), Get_Object (Child), Left_Attach, 531 Right_Attach, Top_Attach, Bottom_Attach); 532 end Attach; 533 534 --------------------------- 535 -- Get_For_Attach_Widget -- 536 --------------------------- 537 538 function Get_For_Attach_Widget 539 (Widget : access Gtk_Widget_Record'Class) 540 return Widget_List.Glist 541 is 542 function Internal (Widget : System.Address) return System.Address; 543 pragma Import (C, Internal, "gtk_menu_get_for_attach_widget"); 544 List : Widget_List.Glist; 545 begin 546 Widget_List.Set_Object (List, Internal (Get_Object (Widget))); 547 return List; 548 end Get_For_Attach_Widget; 549 550 ----------------- 551 -- Set_Monitor -- 552 ----------------- 553 554 procedure Set_Monitor 555 (Menu : access Gtk_Menu_Record; 556 Monitor_Num : Gint) 557 is 558 procedure Internal (Menu : System.Address; Monitor_Num : Gint); 559 pragma Import (C, Internal, "gtk_menu_set_monitor"); 560 begin 561 Internal (Get_Object (Menu), Monitor_Num); 562 end Set_Monitor; 563 564 ---------------- 565 -- Set_Screen -- 566 ---------------- 567 568 procedure Set_Screen 569 (Menu : access Gtk_Menu_Record; 570 Screen : access Gdk.Screen.Gdk_Screen_Record'Class) 571 is 572 procedure Internal 573 (Menu : System.Address; 574 Screen : System.Address); 575 pragma Import (C, Internal, "gtk_menu_set_screen"); 576 begin 577 Internal (Get_Object (Menu), Get_Object (Screen)); 578 end Set_Screen; 579 580end Gtk.Menu; 581