terminal_interface-curses-menus.adb

ncurses 库 可能有用酒用 没用就算了 我觉得还可以用

------------------------------------------------------------------------------
--                                                                          --
--                           GNAT ncurses Binding                           --
--                                                                          --
--                      Terminal_Interface.Curses.Menus                     --
--                                                                          --
--                                 B O D Y                                  --
--                                                                          --
------------------------------------------------------------------------------
-- Copyright (c) 1998,2004 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.25 $
--  $Date: 2004/08/21 21:37:00 $
--  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 : constant Name_String_Ptr := new Name_String;
      Desc_Str : constant 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 : constant 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 : constant 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 : constant 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");