------------------------------------------------------------------------------ -- -- -- XVIEW ADA LIBRARY COMPONENTS -- -- -- -- XV_MENU_PACKAGE -- -- -- -- B o d y -- -- -- -- Copyright (c) 1995 Andreas Almroth, All Rights Reserved -- -- -- -- The XVIEW ADA library is free software; you can redistribute it and/or -- -- modify it under terms of the GNU Library General Public License as -- -- published by the Free Software Foundation; either version 2, or (at your -- -- option) any later version. The XVIEW ADA 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 Library General Public License for more details. -- -- You should have received a copy of the GNU Library General Public -- -- License along with the XVIEW ADA library; see the file COPYING.LIB. If -- -- not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, -- -- MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Lots of bindings to XView C functions needs the Interfaces.C package. with Interfaces.C,Text_Io; use Text_Io; package body Xv_Menu_Package is MENU_NOTIFY_PROC : constant := 1409682017; MENU_STRINGS : constant := 1420331361; MENU_STRING : constant := 1420101985; MENU_APPEND_ITEM : constant := 1409878529; MENU_NITEMS : constant := 1416366624; MENU_NTH_ITEM : constant := 1416759297; MENU_INSERT_ITEM : constant := 1414793218; MENU_INSERT : constant := 1414596610; MENU_REMOVE : constant := 1418921985; MENU_REMOVE_ITEM : constant := 1419119105; MENU_RELEASE : constant := 1418529312; MENU_SELECTED_ITEM : constant := 1419905537; MENU_PULLRIGHT : constant := 1417742849; MENU_DEFAULT_ITEM : constant := 1410861569; function xv_set (owner : Xv_opaque; cmd : Integer; data : Interfaces.C.char_array; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Menu_item; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data1 : Interfaces.C.char_array; term2 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data2: Integer; data : Interfaces.C.char_array; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data1 : Integer; data : Menu_item; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Menu; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; func : callback_menu_ptr; term:Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Boolean; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data1 : Integer; data2 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); ----------------------------------------------------------------------------- function xv_get (owner : Xv_opaque; cmd : Integer; term : Integer) return Integer; pragma import (C,xv_get,"xv_get"); function xv_get (owner : Xv_opaque; cmd : Integer; data : Integer; term : Integer) return Menu_item; pragma import (C,xv_get,"xv_get"); function xv_get (owner : Xv_opaque; cmd : Integer; term : Integer) return Menu_item; pragma import (C,xv_get,"xv_get"); function xv_get2 (owner : Xv_opaque; cmd : Integer; term : Integer) return Xv_object; pragma import (C,xv_get2,"xv_get"); function xv_get (owner : Xv_opaque; cmd : Integer; term : Integer) return Interfaces.C.char_array; pragma import (C,xv_get,"xv_get"); ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- xv_menu ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- procedure Set_Choices (V : in Xv_Menu; Choices : Strings) is Menuitem : Xv_Menu_Item_Ptr; Items : Integer; begin Items := Xv_Get(Xv_Opaque(V.Base),MENU_NITEMS,0); if Items > 0 then for I in 1..Items loop Remove_Menu_Item(V,1); end loop; end if; for i in Choices'range loop Menuitem := new Xv_Menu_Item; Set_Choice(Menuitem.all,Choices(I).all); Append_Menu_Item(V,Menuitem.Base); end loop; end Set_Choices; ----------------------------------------------------------------------------- function Get_Choosen (V : in Menu_Item) return String is begin return Interfaces.C.To_Ada(Xv_Get(Xv_Opaque(V),MENU_STRING,0)); end Get_Choosen; ----------------------------------------------------------------------------- function Get_Default_Item (V : in Xv_Menu) return String is Item : Menu_Item; begin Item := Xv_Get(Xv_Opaque(V.Base),MENU_DEFAULT_ITEM,0); return Interfaces.C.To_Ada(Xv_Get(Xv_Opaque(Item),MENU_STRING,0)); end Get_Default_Item; ----------------------------------------------------------------------------- procedure Set_Callback(V : in Xv_Menu; Func : Callback_Menu_Ptr) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),MENU_NOTIFY_PROC,Func,0); end Set_Callback; ----------------------------------------------------------------------------- function Get_Menu (V : in Xv_Menu) return Menu is begin return V.Base; end Get_Menu; ----------------------------------------------------------------------------- procedure Initialize (V : in out Xv_Menu) is function Xv_Create (Owner : Xv_Opaque; Pkg : Xv_Pkg_Ptr; Term : Integer) return Menu; pragma import (C,Xv_Create,"xv_create"); Xv_Command_Menu_Pkg : Xv_Pkg_Ptr; pragma import (C,Xv_Command_Menu_Pkg,"my_xv_command_menu_pkg"); begin V.Base := Xv_Create(0,Xv_Command_Menu_Pkg,0); if V.Base = 0 then raise NO_OBJECT_CREATED; end if; end Initialize; ----------------------------------------------------------------------------- procedure Append_Menu_Item (V : in Xv_Menu; Item : Menu_Item) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),MENU_APPEND_ITEM,Item,0); end Append_Menu_Item; ----------------------------------------------------------------------------- procedure Insert_Menu_Item (V : in Xv_Menu; Item : Menu_Item; Where : Integer) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),MENU_INSERT,Where,Item,0); end Insert_Menu_Item; ----------------------------------------------------------------------------- procedure Remove_Menu_Item (V : in Xv_Menu; Where : Integer) is Item : Menu_Item; Xv_Rc : Xv_Object; begin Item := Xv_Get(Xv_Opaque(V.Base),MENU_NTH_ITEM,Where,0); Xv_Rc := Xv_Set(Xv_Opaque(V.Base),MENU_REMOVE_ITEM,Item,0); end Remove_Menu_Item; ----------------------------------------------------------------------------- procedure Finalize (V : in out Xv_Menu) is procedure Xv_Destroy_Safe (Object : Xv_Opaque); pragma import (C,Xv_Destroy_Safe,"xv_destroy_safe"); begin Xv_Destroy_Safe(Xv_Opaque(V.Base)); end Finalize; ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- xv_menu_item ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- procedure Set_PullRight_Menu (V : in Xv_Menu_Item; Item : Menu) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),MENU_PULLRIGHT,Item,0); end Set_PullRight_Menu; ----------------------------------------------------------------------------- procedure Set_Choice (V : in Xv_Menu_Item; Choice : String) is Xv_Rc : Xv_Object; type Char_Array_Ptr is access all Interfaces.C.Char_Array; Work : Char_Array_Ptr; begin Work := new Interfaces.C.Char_Array'(Interfaces.C.To_C(Choice)); Xv_Rc := Xv_Set(Xv_Opaque(V.Base),MENU_STRING,Work.all,0,0); end Set_Choice; ----------------------------------------------------------------------------- procedure Set_Callback(V : in Xv_Menu_Item; Func : Callback_Menu_Ptr) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),MENU_NOTIFY_PROC,Func,0); end Set_Callback; ----------------------------------------------------------------------------- function Get_Menu_Item (V : in Xv_Menu_Item) return Menu_item is begin return V.Base; end Get_Menu_Item; ----------------------------------------------------------------------------- procedure Initialize (V : in out Xv_Menu_item) is function Xv_Create (Owner : Xv_Opaque; Pkg : Xv_Pkg_Ptr; Term : Integer) return Menu_Item; pragma import (C,Xv_Create,"xv_create"); Xv_Menu_Item_Pkg : Xv_Pkg_Ptr; pragma import (C,Xv_Menu_Item_Pkg,"my_xv_menu_item_pkg"); begin V.Base := Xv_Create(0,Xv_Menu_Item_Pkg,0); if V.Base = 0 then raise NO_OBJECT_CREATED; end if; end Initialize; ----------------------------------------------------------------------------- procedure Finalize (V : in out Xv_Menu_Item) is procedure Xv_Destroy_Safe (Object : Xv_Opaque); pragma import (C,Xv_Destroy_Safe,"xv_destroy"); begin Xv_Destroy_Safe(Xv_Opaque(V.Base)); end Finalize; end Xv_Menu_Package;