terminal_interface-curses-menus.adb

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

      pragma Import (C, Menu_Pad, "menu_pad");
   begin
      Pad := Character'Val (Menu_Pad (Men));
   end Pad_Character;
-------------------------------------------------------------------------------
   procedure Set_Spacing (Men   : in Menu;
                          Descr : in Column_Position := 0;
                          Row   : in Line_Position   := 0;
                          Col   : in Column_Position := 0)
   is
      function Set_Spacing (Men     : Menu;
                            D, R, C : C_Int) return C_Int;
      pragma Import (C, Set_Spacing, "set_menu_spacing");

      Res : constant Eti_Error := Set_Spacing (Men,
                                               C_Int (Descr),
                                               C_Int (Row),
                                               C_Int (Col));
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Spacing;

   procedure Spacing (Men   : in Menu;
                      Descr : out Column_Position;
                      Row   : out Line_Position;
                      Col   : out Column_Position)
   is
      type C_Int_Access is access all C_Int;
      function Get_Spacing (Men     : Menu;
                            D, R, C : C_Int_Access) return C_Int;
      pragma Import (C, Get_Spacing, "menu_spacing");

      D, R, C : aliased C_Int;
      Res : constant Eti_Error := Get_Spacing (Men,
                                               D'Access,
                                               R'Access,
                                               C'Access);
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      else
         Descr := Column_Position (D);
         Row   := Line_Position (R);
         Col   := Column_Position (C);
      end if;
   end Spacing;
-------------------------------------------------------------------------------
   function Set_Pattern (Men  : Menu;
                         Text : String) return Boolean
   is
      type Char_Ptr is access all Interfaces.C.char;
      function Set_Pattern (Men     : Menu;
                            Pattern : Char_Ptr) return C_Int;
      pragma Import (C, Set_Pattern, "set_menu_pattern");

      S   : char_array (0 .. Text'Length);
      L   : size_t;
      Res : Eti_Error;
   begin
      To_C (Text, S, L);
      Res := Set_Pattern (Men, S (S'First)'Access);
      case Res is
         when E_No_Match => return False;
         when E_Ok       => return True;
         when others =>
            Eti_Exception (Res);
            return False;
      end case;
   end Set_Pattern;

   procedure Pattern (Men  : in  Menu;
                      Text : out String)
   is
      function Get_Pattern (Men : Menu) return chars_ptr;
      pragma Import (C, Get_Pattern, "menu_pattern");
   begin
      Fill_String (Get_Pattern (Men), Text);
   end Pattern;
-------------------------------------------------------------------------------
   procedure Set_Format (Men     : in Menu;
                         Lines   : in Line_Count;
                         Columns : in Column_Count)
   is
      function Set_Menu_Fmt (Men : Menu;
                             Lin : C_Int;
                             Col : C_Int) return C_Int;
      pragma Import (C, Set_Menu_Fmt, "set_menu_format");

      Res : constant Eti_Error := Set_Menu_Fmt (Men,
                                                C_Int (Lines),
                                                C_Int (Columns));
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Format;

   procedure Format (Men     : in  Menu;
                     Lines   : out Line_Count;
                     Columns : out Column_Count)
   is
      type C_Int_Access is access all C_Int;
      function Menu_Fmt (Men  : Menu;
                         Y, X : C_Int_Access) return C_Int;
      pragma Import (C, Menu_Fmt, "menu_format");

      L, C : aliased C_Int;
      Res  : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access);
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      else
         Lines   := Line_Count (L);
         Columns := Column_Count (C);
      end if;
   end Format;
-------------------------------------------------------------------------------
   procedure Set_Item_Init_Hook (Men  : in Menu;
                                 Proc : in Menu_Hook_Function)
   is
      function Set_Item_Init (Men  : Menu;
                              Proc : Menu_Hook_Function) return C_Int;
      pragma Import (C, Set_Item_Init, "set_item_init");

      Res : constant Eti_Error := Set_Item_Init (Men, Proc);
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Item_Init_Hook;

   procedure Set_Item_Term_Hook (Men  : in Menu;
                                 Proc : in Menu_Hook_Function)
   is
      function Set_Item_Term (Men  : Menu;
                              Proc : Menu_Hook_Function) return C_Int;
      pragma Import (C, Set_Item_Term, "set_item_term");

      Res : constant Eti_Error := Set_Item_Term (Men, Proc);
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Item_Term_Hook;

   procedure Set_Menu_Init_Hook (Men  : in Menu;
                                 Proc : in Menu_Hook_Function)
   is
      function Set_Menu_Init (Men  : Menu;
                              Proc : Menu_Hook_Function) return C_Int;
      pragma Import (C, Set_Menu_Init, "set_menu_init");

      Res : constant Eti_Error := Set_Menu_Init (Men, Proc);
   begin
      if  Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Menu_Init_Hook;

   procedure Set_Menu_Term_Hook (Men  : in Menu;
                                 Proc : in Menu_Hook_Function)
   is
      function Set_Menu_Term (Men  : Menu;
                              Proc : Menu_Hook_Function) return C_Int;
      pragma Import (C, Set_Menu_Term, "set_menu_term");

      Res : constant Eti_Error := Set_Menu_Term (Men, Proc);
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
   end Set_Menu_Term_Hook;

   function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function
   is
      function Item_Init (Men : Menu) return Menu_Hook_Function;
      pragma Import (C, Item_Init, "item_init");
   begin
      return Item_Init (Men);
   end Get_Item_Init_Hook;

   function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function
   is
      function Item_Term (Men : Menu) return Menu_Hook_Function;
      pragma Import (C, Item_Term, "item_term");
   begin
      return Item_Term (Men);
   end Get_Item_Term_Hook;

   function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function
   is
      function Menu_Init (Men : Menu) return Menu_Hook_Function;
      pragma Import (C, Menu_Init, "menu_init");
   begin
      return Menu_Init (Men);
   end Get_Menu_Init_Hook;

   function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function
   is
      function Menu_Term (Men : Menu) return Menu_Hook_Function;
      pragma Import (C, Menu_Term, "menu_term");
   begin
      return Menu_Term (Men);
   end Get_Menu_Term_Hook;
-------------------------------------------------------------------------------
   procedure Redefine (Men   : in Menu;
                       Items : in Item_Array_Access)
   is
      function Set_Items (Men   : Menu;
                          Items : System.Address) return C_Int;
      pragma Import (C, Set_Items, "set_menu_items");

      Res : Eti_Error;
   begin
      pragma Assert (Items (Items'Last) = Null_Item);
      if Items (Items'Last) /= Null_Item then
         raise Menu_Exception;
      else
         Res := Set_Items (Men, Items.all'Address);
         if  Res /= E_Ok then
            Eti_Exception (Res);
         end if;
      end if;
   end Redefine;

   function Item_Count (Men : Menu) return Natural
   is
      function Count (Men : Menu) return C_Int;
      pragma Import (C, Count, "item_count");
   begin
      return Natural (Count (Men));
   end Item_Count;

   function Items (Men   : Menu;
                   Index : Positive) return Item
   is
      use I_Array;

      function C_Mitems (Men : Menu) return Pointer;
      pragma Import (C, C_Mitems, "menu_items");

      P : Pointer := C_Mitems (Men);
   begin
      if P = null or else Index not in 1 .. Item_Count (Men) then
         raise Menu_Exception;
      else
         P := P + ptrdiff_t (C_Int (Index) - 1);
         return P.all;
      end if;
   end Items;

-------------------------------------------------------------------------------
   function Create (Items : Item_Array_Access) return Menu
   is
      function Newmenu (Items : System.Address) return Menu;
      pragma Import (C, Newmenu, "new_menu");

      M   : Menu;
   begin
      pragma Assert (Items (Items'Last) = Null_Item);
      if Items (Items'Last) /= Null_Item then
         raise Menu_Exception;
      else
         M := Newmenu (Items.all'Address);
         if M = Null_Menu then
            raise Menu_Exception;
         end if;
         return M;
      end if;
   end Create;

   procedure Delete (Men : in out Menu)
   is
      function Free (Men : Menu) return C_Int;
      pragma Import (C, Free, "free_menu");

      Res : constant Eti_Error := Free (Men);
   begin
      if Res /= E_Ok then
         Eti_Exception (Res);
      end if;
      Men := Null_Menu;
   end Delete;

------------------------------------------------------------------------------
   function Driver (Men : Menu;
                    Key : Key_Code) return Driver_Result
   is
      function Driver (Men : Menu;
                       Key : C_Int) return C_Int;
      pragma Import (C, Driver, "menu_driver");

      R : constant Eti_Error := Driver (Men, C_Int (Key));
   begin
      if R /= E_Ok then
         case R is
            when E_Unknown_Command  => return Unknown_Request;
            when E_No_Match         => return No_Match;
            when E_Request_Denied |
                 E_Not_Selectable   => return Request_Denied;
            when others =>
               Eti_Exception (R);
         end case;
      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;
-------------------------------------------------------------------------------

end Terminal_Interface.Curses.Menus;