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