-- --
-- 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 <Juergen.Pfeifer@T-Online.de> 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
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");
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
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;
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;
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
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)
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;
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");
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;
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;
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;
projects / ncurses.git / blobdiff