X-Git-Url: http://ncurses.scripts.mit.edu/?p=ncurses.git;a=blobdiff_plain;f=Ada95%2Fada_include%2Fterminal_interface-curses-menus.adb;h=2df514ec4bcd415a1c90f7fde7d2af44cafea377;hp=33f066034a5dbc1f33bc439bfb14bc764734aa98;hb=661078ddbde3ce0f3b06e95642fbb9b5fef7dca1;hpb=3a9b6a3bf0269231bef7de74757a910dedd04e0c diff --git a/Ada95/ada_include/terminal_interface-curses-menus.adb b/Ada95/ada_include/terminal_interface-curses-menus.adb index 33f06603..2df514ec 100644 --- a/Ada95/ada_include/terminal_interface-curses-menus.adb +++ b/Ada95/ada_include/terminal_interface-curses-menus.adb @@ -6,31 +6,45 @@ -- -- -- B O D Y -- -- -- --- Version 00.92 -- +------------------------------------------------------------------------------ +-- Copyright (c) 1998 Free Software Foundation, Inc. -- +-- -- +-- Permission is hereby granted, free of charge, to any person obtaining a -- +-- copy of this software and associated documentation files (the -- +-- "Software"), to deal in the Software without restriction, including -- +-- without limitation the rights to use, copy, modify, merge, publish, -- +-- distribute, distribute with modifications, sublicense, and/or sell -- +-- copies of the Software, and to permit persons to whom the Software is -- +-- furnished to do so, subject to the following conditions: -- -- -- --- The ncurses Ada95 binding is copyrighted 1996 by -- --- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de -- +-- The above copyright notice and this permission notice shall be included -- +-- in all copies or substantial portions of the Software. -- -- -- --- Permission is hereby granted to reproduce and distribute this -- --- binding by any means and for any fee, whether alone or as part -- --- of a larger distribution, in source or in binary form, PROVIDED -- --- this notice is included with any such distribution, and is not -- --- removed from any of its header files. Mention of ncurses and the -- --- author of this binding in any applications linked with it is -- --- highly appreciated. -- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- +-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- +-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- -- -- --- This binding comes AS IS with no warranty, implied or expressed. -- +-- Except as contained in this notice, the name(s) of the above copyright -- +-- holders shall not be used in advertising or otherwise to promote the -- +-- sale, use or other dealings in this Software without prior written -- +-- authorization. -- ------------------------------------------------------------------------------ +-- Author: Juergen Pfeifer 1996 -- Version Control: --- $Revision: 1.7 $ +-- $Revision: 1.13 $ +-- Binding Version 00.93 ------------------------------------------------------------------------------ +with Ada.Unchecked_Deallocation; with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; with Interfaces.C; use Interfaces.C; -with Interfaces.C.Strings; +with Interfaces.C.Strings; use Interfaces.C.Strings; with Terminal_Interface.Curses; -with Ada.Unchecked_Deallocation; with Unchecked_Conversion; package body Terminal_Interface.Curses.Menus is @@ -54,17 +68,9 @@ package body Terminal_Interface.Curses.Menus is Unchecked_Conversion (C_Int, Item_Option_Set); ------------------------------------------------------------------------------- - procedure Free_Allocated_Items is - new Ada.Unchecked_Deallocation (Item_Array, Item_Array_Access); - - procedure Free_User_Wrapper is - new Ada.Unchecked_Deallocation (Ada_User_Wrapper, - Ada_User_Wrapper_Access); - ------------------------------------------------------------------------------ procedure Request_Name (Key : in Menu_Request_Code; - Name : out String) + Name : out String) is function Request_Name (Key : C_Int) return chars_ptr; pragma Import (C, Request_Name, "menu_request_name"); @@ -72,13 +78,14 @@ package body Terminal_Interface.Curses.Menus is Fill_String (Request_Name (C_Int (Key)), Name); end Request_Name; - -- !!! W A R N I N G !!! - -- If you want to port this binding to a non ncurses version of the - -- ETI, this must be rewritten. In ncurses the menu items and - -- descriptions may be automatic variables, because ncurses copies - -- the parameters into private allocated internal structures. - -- Other implementations don't do that usually, so depending on - -- scopes you may see unexpected results. + function Request_Name (Key : Menu_Request_Code) return String + is + function Request_Name (Key : C_Int) return chars_ptr; + pragma Import (C, Request_Name, "menu_request_name"); + begin + return Fill_String (Request_Name (C_Int (Key))); + end Request_Name; + function Create (Name : String; Description : String := "") return Item is @@ -86,15 +93,23 @@ package body Terminal_Interface.Curses.Menus is function Newitem (Name, Desc : Char_Ptr) return Item; pragma Import (C, Newitem, "new_item"); - Name_Str : char_array (0 .. Name'Length); - Desc_Str : char_array (0 .. Description'Length); + type Name_String is new char_array (0 .. Name'Length); + type Name_String_Ptr is access Name_String; + pragma Controlled (Name_String_Ptr); + + type Desc_String is new char_array (0 .. Description'Length); + type Desc_String_Ptr is access Desc_String; + pragma Controlled (Desc_String_Ptr); + + Name_Str : Name_String_Ptr := new Name_String; + Desc_Str : Desc_String_Ptr := new Desc_String; Name_Len, Desc_Len : size_t; Result : Item; begin - To_C (Name, Name_Str, Name_Len); - To_C (Description, Desc_Str, Desc_Len); - Result := Newitem (Name_Str (Name_Str'First)'Access, - Desc_Str (Desc_Str'First)'Access); + To_C (Name, Name_Str.all, Name_Len); + To_C (Description, Desc_Str.all, Desc_Len); + Result := Newitem (Name_Str.all (Name_Str.all'First)'Access, + Desc_Str.all (Desc_Str.all'First)'Access); if Result = Null_Item then raise Eti_System_Error; end if; @@ -103,11 +118,26 @@ package body Terminal_Interface.Curses.Menus is procedure Delete (Itm : in out Item) is + function Descname (Itm : Item) return chars_ptr; + pragma Import (C, Descname, "item_description"); + function Itemname (Itm : Item) return chars_ptr; + pragma Import (C, Itemname, "item_name"); + function Freeitem (Itm : Item) return C_Int; pragma Import (C, Freeitem, "free_item"); - Res : constant Eti_Error := Freeitem (Itm); + Res : Eti_Error; + Ptr : chars_ptr; begin + Ptr := Descname (Itm); + if Ptr /= Null_Ptr then + Interfaces.C.Strings.Free (Ptr); + end if; + Ptr := Itemname (Itm); + if Ptr /= Null_Ptr then + Interfaces.C.Strings.Free (Ptr); + end if; + Res := Freeitem (Itm); if Res /= E_Ok then Eti_Exception (Res); end if; @@ -227,6 +257,14 @@ package body Terminal_Interface.Curses.Menus is Fill_String (Itemname (Itm), Name); end Name; + function Name (Itm : in Item) return String + is + function Itemname (Itm : Item) return chars_ptr; + pragma Import (C, Itemname, "item_name"); + begin + return Fill_String (Itemname (Itm)); + end Name; + procedure Description (Itm : in Item; Description : out String) is @@ -235,6 +273,14 @@ package body Terminal_Interface.Curses.Menus is begin Fill_String (Descname (Itm), Description); end Description; + + function Description (Itm : in Item) return String + is + function Descname (Itm : Item) return chars_ptr; + pragma Import (C, Descname, "item_description"); + begin + return Fill_String (Descname (Itm)); + end Description; ------------------------------------------------------------------------------- procedure Set_Current (Men : in Menu; Itm : in Item) @@ -496,6 +542,14 @@ package body Terminal_Interface.Curses.Menus is Fill_String (Get_Menu_Mark (Men), Mark); end Mark; + function Mark (Men : Menu) return String + is + function Get_Menu_Mark (Men : Menu) return chars_ptr; + pragma Import (C, Get_Menu_Mark, "menu_mark"); + begin + return Fill_String (Get_Menu_Mark (Men)); + end Mark; + ------------------------------------------------------------------------------- procedure Set_Foreground (Men : in Menu; @@ -706,7 +760,7 @@ package body Terminal_Interface.Curses.Menus is end Set_Pattern; procedure Pattern (Men : in Menu; - Text : out String) + Text : out String) is function Get_Pattern (Men : Menu) return chars_ptr; pragma Import (C, Get_Pattern, "menu_pattern"); @@ -840,43 +894,22 @@ package body Terminal_Interface.Curses.Menus is return Menu_Term (Men); end Get_Menu_Term_Hook; ------------------------------------------------------------------------------- - -- This is a bit delicate if we want to manipulate an Ada created menu - -- from C routines or vice versa. - -- In Ada created menus we use the low level user pointer to maintain - -- binding internal additional informations about the menu. This - -- internal information contains a hook for the Ada provided user pointer. - -- Unless you understand this implementation, the safest way in mixed - -- language programs to deal with user pointers is, that only the language - -- that created the menu should also manipulate the user pointer for that - -- menu. procedure Redefine (Men : in Menu; - Items : in Item_Array) + Items : in Item_Array_Access) is function Set_Items (Men : Menu; - Items : Item_Array_Access) return C_Int; + Items : System.Address) return C_Int; pragma Import (C, Set_Items, "set_menu_items"); - function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access; - pragma Import (C, Menu_Userptr, "menu_userptr"); - - U : Ada_User_Wrapper_Access := Menu_Userptr (Men); - I : Item_Array_Access; Res : Eti_Error; begin - if U = null or else U.I = null then raise Menu_Exception; + pragma Assert (Items (Items'Last) = Null_Item); + if Items (Items'Last) /= Null_Item then + raise Menu_Exception; else - -- create internally an array of items that contains an - -- additional place for the terminating null item. - I := new Item_Array (1 .. (Items'Length + 1)); - I.all (1 .. Items'Length) := Items (Items'First .. Items'Last); - I.all (Items'Length + 1) := Null_Item; - Res := Set_Items (Men, I); + Res := Set_Items (Men, Items (Items'First)'Address); if Res /= E_Ok then - Free_Allocated_Items (I); Eti_Exception (Res); - else - Free_Allocated_Items (U.I); - U.I := I; end if; end if; end Redefine; @@ -889,65 +922,51 @@ package body Terminal_Interface.Curses.Menus is return Natural (Count (Men)); end Item_Count; - function Items (Men : Menu) return Item_Array_Access + function Items (Men : Menu; + Index : Positive) return Item is - function M_Items (Men : Menu) return Item_Array_Access; - pragma Import (C, M_Items, "menu_items"); + function M_Items (Men : Menu; + Idx : C_Int) return Item; + pragma Import (C, M_Items, "_nc_get_item"); begin - return M_Items (Men); + if Men = Null_Menu or else Index not in 1 .. Item_Count (Men) then + raise Menu_Exception; + else + return M_Items (Men, C_Int (Index) - 1); + end if; end Items; ------------------------------------------------------------------------------- - function Create (Items : Item_Array) return Menu + function Create (Items : Item_Array_Access) return Menu is - function Newmenu (Items : Item_Array_Access) return Menu; + function Newmenu (Items : System.Address) return Menu; pragma Import (C, Newmenu, "new_menu"); - function Set_Menu_Userptr (Men : Menu; - Addr : Ada_User_Wrapper_Access) return C_Int; - pragma Import (C, Set_Menu_Userptr, "set_menu_userptr"); - M : Menu; I : Item_Array_Access; - U : Ada_User_Wrapper_Access; - Res : Eti_Error; begin - I := new Item_Array (1 .. (Items'Length + 1)); - I.all (1 .. Items'Length) := Items (Items'First .. Items'Last); - I.all (Items'Length + 1) := Null_Item; - M := Newmenu (I); - if M = Null_Menu then - Free_Allocated_Items (I); + pragma Assert (Items (Items'Last) = Null_Item); + if Items (Items'Last) /= Null_Item then raise Menu_Exception; + else + M := Newmenu (Items (Items'First)'Address); + if M = Null_Menu then + raise Menu_Exception; + end if; + return M; end if; - U := new Ada_User_Wrapper' (System.Null_Address, I); - Res := Set_Menu_Userptr (M, U); - if Res /= E_Ok then - Free_Allocated_Items (I); - Free_User_Wrapper (U); - Eti_Exception (Res); - end if; - return M; end Create; procedure Delete (Men : in out Menu) is function Free (Men : Menu) return C_Int; pragma Import (C, Free, "free_menu"); - function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access; - pragma Import (C, Menu_Userptr, "menu_userptr"); - U : Ada_User_Wrapper_Access := Menu_Userptr (Men); Res : constant Eti_Error := Free (Men); begin if Res /= E_Ok then Eti_Exception (Res); end if; - if U = null or else U.I = null then - raise Menu_Exception; - end if; - Free_Allocated_Items (U.I); - Free_User_Wrapper (U); Men := Null_Menu; end Delete; @@ -973,12 +992,35 @@ package body Terminal_Interface.Curses.Menus is end if; return Menu_Ok; end Driver; + + procedure Free (IA : in out Item_Array_Access; + Free_Items : in Boolean := False) + is + procedure Release is new Ada.Unchecked_Deallocation + (Item_Array, Item_Array_Access); + begin + if IA /= null and then Free_Items then + for I in IA'First .. (IA'Last - 1) loop + if (IA (I) /= Null_Item) then + Delete (IA (I)); + end if; + end loop; + end if; + Release (IA); + end Free; + +------------------------------------------------------------------------------- + function Default_Menu_Options return Menu_Option_Set + is + begin + return Get_Options (Null_Menu); + end Default_Menu_Options; + + function Default_Item_Options return Item_Option_Set + is + begin + return Get_Options (Null_Item); + end Default_Item_Options; ------------------------------------------------------------------------------- -begin - if Generation_Bit_Order /= System.Default_Bit_Order then - raise Constraint_Error; - end if; - Default_Menu_Options := Get_Options (Null_Menu); - Default_Item_Options := Get_Options (Null_Item); end Terminal_Interface.Curses.Menus;