--------------------------------------------------------------------------------                                                                          ----                           GNAT ncurses Binding                           ----                                                                          ----                      Terminal_Interface.Curses.Menus                     ----                                                                          ----                                 B O D Y                                  ----                                                                          ---------------------------------------------------------------------------------- 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 above copyright notice and this permission notice shall be included  ---- in all copies or substantial portions of the Software.                   ----                                                                          ---- 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.                               ----                                                                          ---- 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.22 $--  Binding Version 01.00------------------------------------------------------------------------------with Ada.Unchecked_Deallocation;with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;with Interfaces.C; use Interfaces.C;with Interfaces.C.Strings; use Interfaces.C.Strings;with Interfaces.C.Pointers;with Ada.Unchecked_Conversion;package body Terminal_Interface.Curses.Menus is   type C_Item_Array is array (Natural range <>) of aliased Item;   package I_Array is new     Interfaces.C.Pointers (Natural, Item, C_Item_Array, Null_Item);   use type System.Bit_Order;   subtype chars_ptr is Interfaces.C.Strings.chars_ptr;   function MOS_2_CInt is new     Ada.Unchecked_Conversion (Menu_Option_Set,                               C_Int);   function CInt_2_MOS is new     Ada.Unchecked_Conversion (C_Int,                               Menu_Option_Set);   function IOS_2_CInt is new     Ada.Unchecked_Conversion (Item_Option_Set,                               C_Int);   function CInt_2_IOS is new     Ada.Unchecked_Conversion (C_Int,                               Item_Option_Set);------------------------------------------------------------------------------   procedure Request_Name (Key  : in Menu_Request_Code;                           Name : out String)   is      function Request_Name (Key : C_Int) return chars_ptr;      pragma Import (C, Request_Name, "menu_request_name");   begin      Fill_String (Request_Name (C_Int (Key)), Name);   end Request_Name;   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      type Char_Ptr is access all Interfaces.C.char;      function Newitem (Name, Desc : Char_Ptr) return Item;      pragma Import (C, Newitem, "new_item");      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.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;      return Result;   end Create;   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 : 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;      Itm := Null_Item;   end Delete;-------------------------------------------------------------------------------   procedure Set_Value (Itm   : in Item;                        Value : in Boolean := True)   is      function Set_Item_Val (Itm : Item;                             Val : C_Int) return C_Int;      pragma Import (C, Set_Item_Val, "set_item_value");      Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value));   begin      if  Res /= E_Ok then         Eti_Exception (Res);      end if;   end Set_Value;   function Value (Itm : Item) return Boolean   is      function Item_Val (Itm : Item) return C_Int;      pragma Import (C, Item_Val, "item_value");   begin      if Item_Val (Itm) = Curses_False then         return False;      else         return True;      end if;   end Value;-------------------------------------------------------------------------------   function Visible (Itm : Item) return Boolean   is      function Item_Vis (Itm : Item) return C_Int;      pragma Import (C, Item_Vis, "item_visible");   begin      if Item_Vis (Itm) = Curses_False then         return False;      else         return True;      end if;   end Visible;-------------------------------------------------------------------------------   procedure Set_Options (Itm     : in Item;                          Options : in Item_Option_Set)   is      function Set_Item_Opts (Itm : Item;                              Opt : C_Int) return C_Int;      pragma Import (C, Set_Item_Opts, "set_item_opts");      Opt : C_Int := IOS_2_CInt (Options);      Res : Eti_Error;   begin      Res := Set_Item_Opts (Itm, Opt);      if Res /= E_Ok then         Eti_Exception (Res);      end if;   end Set_Options;   procedure Switch_Options (Itm     : in Item;                             Options : in Item_Option_Set;                             On      : Boolean := True)   is      function Item_Opts_On (Itm : Item;                             Opt : C_Int) return C_Int;      pragma Import (C, Item_Opts_On, "item_opts_on");      function Item_Opts_Off (Itm : Item;                              Opt : C_Int) return C_Int;      pragma Import (C, Item_Opts_Off, "item_opts_off");      Opt : C_Int := IOS_2_CInt (Options);      Err : Eti_Error;   begin      if On then         Err := Item_Opts_On (Itm, Opt);      else         Err := Item_Opts_Off (Itm, Opt);      end if;      if Err /= E_Ok then         Eti_Exception (Err);      end if;   end Switch_Options;   procedure Get_Options (Itm     : in  Item;                          Options : out Item_Option_Set)   is      function Item_Opts (Itm : Item) return C_Int;      pragma Import (C, Item_Opts, "item_opts");      Res : C_Int := Item_Opts (Itm);   begin      Options := CInt_2_IOS (Res);   end Get_Options;   function Get_Options (Itm : Item := Null_Item) return Item_Option_Set   is      Ios : Item_Option_Set;   begin      Get_Options (Itm, Ios);      return Ios;   end Get_Options;-------------------------------------------------------------------------------   procedure Name (Itm  : in Item;                   Name : out String)   is      function Itemname (Itm : Item) return chars_ptr;      pragma Import (C, Itemname, "item_name");   begin      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      function Descname (Itm  : Item) return chars_ptr;      pragma Import (C, Descname, "item_description");   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)   is      function Set_Curr_Item (Men : Menu;                              Itm : Item) return C_Int;      pragma Import (C, Set_Curr_Item, "set_current_item");      Res : constant Eti_Error := Set_Curr_Item (Men, Itm);   begin      if Res /= E_Ok then         Eti_Exception (Res);      end if;   end Set_Current;   function Current (Men : Menu) return Item   is      function Curr_Item (Men : Menu) return Item;      pragma Import (C, Curr_Item, "current_item");      Res : constant Item := Curr_Item (Men);   begin      if Res = Null_Item then         raise Menu_Exception;      end if;      return Res;   end Current;   procedure Set_Top_Row (Men  : in Menu;                          Line : in Line_Position)   is      function Set_Toprow (Men  : Menu;                           Line : C_Int) return C_Int;      pragma Import (C, Set_Toprow, "set_top_row");      Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line));   begin      if  Res /= E_Ok then         Eti_Exception (Res);      end if;   end Set_Top_Row;   function Top_Row (Men : Menu) return Line_Position   is      function Toprow (Men : Menu) return C_Int;      pragma Import (C, Toprow, "top_row");      Res : constant C_Int := Toprow (Men);   begin      if Res = Curses_Err then         raise Menu_Exception;      end if;      return Line_Position (Res);   end Top_Row;   function Get_Index (Itm : Item) return Positive   is      function Get_Itemindex (Itm : Item) return C_Int;      pragma Import (C, Get_Itemindex, "item_index");