ncurses 4.2
[ncurses.git] / Ada95 / ada_include / terminal_interface-curses-menus.adb
index 33f066034a5dbc1f33bc439bfb14bc764734aa98..2df514ec4bcd415a1c90f7fde7d2af44cafea377 100644 (file)
@@ -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 <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
@@ -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;