diff options
Diffstat (limited to 'ncurses-5.2/Ada95/src/terminal_interface-curses-menus.adb')
| -rw-r--r-- | ncurses-5.2/Ada95/src/terminal_interface-curses-menus.adb | 1021 |
1 files changed, 0 insertions, 1021 deletions
diff --git a/ncurses-5.2/Ada95/src/terminal_interface-curses-menus.adb b/ncurses-5.2/Ada95/src/terminal_interface-curses-menus.adb deleted file mode 100644 index 3d70de3..0000000 --- a/ncurses-5.2/Ada95/src/terminal_interface-curses-menus.adb +++ /dev/null @@ -1,1021 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 <juergen.pfeifer@gmx.net> 1996 --- Version Control: --- $Revision$ --- 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"); - - Res : constant C_Int := Get_Itemindex (Itm); - begin - if Res = Curses_Err then - raise Menu_Exception; - end if; - return Positive (Natural (Res) + Positive'First); - end Get_Index; -------------------------------------------------------------------------------- - procedure Post (Men : in Menu; - Post : in Boolean := True) - is - function M_Post (Men : Menu) return C_Int; - pragma Import (C, M_Post, "post_menu"); - function M_Unpost (Men : Menu) return C_Int; - pragma Import (C, M_Unpost, "unpost_menu"); - - Res : Eti_Error; - begin - if Post then - Res := M_Post (Men); - else - Res := M_Unpost (Men); - end if; - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Post; -------------------------------------------------------------------------------- - procedure Set_Options (Men : in Menu; - Options : in Menu_Option_Set) - is - function Set_Menu_Opts (Men : Menu; - Opt : C_Int) return C_Int; - pragma Import (C, Set_Menu_Opts, "set_menu_opts"); - - Opt : C_Int := MOS_2_CInt (Options); - Res : Eti_Error; - begin - Res := Set_Menu_Opts (Men, Opt); - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Options; - - procedure Switch_Options (Men : in Menu; - Options : in Menu_Option_Set; - On : in Boolean := True) - is - function Menu_Opts_On (Men : Menu; - Opt : C_Int) return C_Int; - pragma Import (C, Menu_Opts_On, "menu_opts_on"); - function Menu_Opts_Off (Men : Menu; - Opt : C_Int) return C_Int; - pragma Import (C, Menu_Opts_Off, "menu_opts_off"); - - Opt : C_Int := MOS_2_CInt (Options); - Err : Eti_Error; - begin - if On then - Err := Menu_Opts_On (Men, Opt); - else - Err := Menu_Opts_Off (Men, Opt); - end if; - if Err /= E_Ok then - Eti_Exception (Err); - end if; - end Switch_Options; - - procedure Get_Options (Men : in Menu; - Options : out Menu_Option_Set) - is - function Menu_Opts (Men : Menu) return C_Int; - pragma Import (C, Menu_Opts, "menu_opts"); - - Res : C_Int := Menu_Opts (Men); - begin - Options := CInt_2_MOS (Res); - end Get_Options; - - function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set - is - Mos : Menu_Option_Set; - begin - Get_Options (Men, Mos); - return Mos; - end Get_Options; -------------------------------------------------------------------------------- - procedure Set_Window (Men : in Menu; - Win : in Window) - is - function Set_Menu_Win (Men : Menu; - Win : Window) return C_Int; - pragma Import (C, Set_Menu_Win, "set_menu_win"); - - Res : constant Eti_Error := Set_Menu_Win (Men, Win); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Window; - - function Get_Window (Men : Menu) return Window - is - function Menu_Win (Men : Menu) return Window; - pragma Import (C, Menu_Win, "menu_win"); - - W : constant Window := Menu_Win (Men); - begin - return W; - end Get_Window; - - procedure Set_Sub_Window (Men : in Menu; - Win : in Window) - is - function Set_Menu_Sub (Men : Menu; - Win : Window) return C_Int; - pragma Import (C, Set_Menu_Sub, "set_menu_sub"); - - Res : constant Eti_Error := Set_Menu_Sub (Men, Win); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Sub_Window; - - function Get_Sub_Window (Men : Menu) return Window - is - function Menu_Sub (Men : Menu) return Window; - pragma Import (C, Menu_Sub, "menu_sub"); - - W : constant Window := Menu_Sub (Men); - begin - return W; - end Get_Sub_Window; - - procedure Scale (Men : in Menu; - Lines : out Line_Count; - Columns : out Column_Count) - is - type C_Int_Access is access all C_Int; - function M_Scale (Men : Menu; - Yp, Xp : C_Int_Access) return C_Int; - pragma Import (C, M_Scale, "scale_menu"); - - X, Y : aliased C_Int; - Res : constant Eti_Error := M_Scale (Men, Y'Access, X'Access); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - Lines := Line_Count (Y); - Columns := Column_Count (X); - end Scale; -------------------------------------------------------------------------------- - procedure Position_Cursor (Men : Menu) - is - function Pos_Menu_Cursor (Men : Menu) return C_Int; - pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor"); - - Res : constant Eti_Error := Pos_Menu_Cursor (Men); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Position_Cursor; - -------------------------------------------------------------------------------- - procedure Set_Mark (Men : in Menu; - Mark : in String) - is - type Char_Ptr is access all Interfaces.C.char; - function Set_Mark (Men : Menu; - Mark : Char_Ptr) return C_Int; - pragma Import (C, Set_Mark, "set_menu_mark"); - - Txt : char_array (0 .. Mark'Length); - Len : size_t; - Res : Eti_Error; - begin - To_C (Mark, Txt, Len); - Res := Set_Mark (Men, Txt (Txt'First)'Access); - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Mark; - - procedure Mark (Men : in Menu; - Mark : out String) - is - function Get_Menu_Mark (Men : Menu) return chars_ptr; - pragma Import (C, Get_Menu_Mark, "menu_mark"); - begin - 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; - Fore : in Character_Attribute_Set := Normal_Video; - Color : in Color_Pair := Color_Pair'First) - is - function Set_Menu_Fore (Men : Menu; - Attr : C_Chtype) return C_Int; - pragma Import (C, Set_Menu_Fore, "set_menu_fore"); - - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Fore); - Res : constant Eti_Error := Set_Menu_Fore (Men, AttrChar_To_Chtype (Ch)); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Foreground; - - procedure Foreground (Men : in Menu; - Fore : out Character_Attribute_Set) - is - function Menu_Fore (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Fore, "menu_fore"); - begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; - end Foreground; - - procedure Foreground (Men : in Menu; - Fore : out Character_Attribute_Set; - Color : out Color_Pair) - is - function Menu_Fore (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Fore, "menu_fore"); - begin - Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color; - end Foreground; - - procedure Set_Background - (Men : in Menu; - Back : in Character_Attribute_Set := Normal_Video; - Color : in Color_Pair := Color_Pair'First) - is - function Set_Menu_Back (Men : Menu; - Attr : C_Chtype) return C_Int; - pragma Import (C, Set_Menu_Back, "set_menu_back"); - - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Back); - Res : constant Eti_Error := Set_Menu_Back (Men, AttrChar_To_Chtype (Ch)); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Background; - - procedure Background (Men : in Menu; - Back : out Character_Attribute_Set) - is - function Menu_Back (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Back, "menu_back"); - begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; - end Background; - - procedure Background (Men : in Menu; - Back : out Character_Attribute_Set; - Color : out Color_Pair) - is - function Menu_Back (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Back, "menu_back"); - begin - Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Back (Men)).Color; - end Background; - - procedure Set_Grey (Men : in Menu; - Grey : in Character_Attribute_Set := Normal_Video; - Color : in Color_Pair := Color_Pair'First) - is - function Set_Menu_Grey (Men : Menu; - Attr : C_Chtype) return C_Int; - pragma Import (C, Set_Menu_Grey, "set_menu_grey"); - - Ch : constant Attributed_Character := (Ch => Character'First, - Color => Color, - Attr => Grey); - - Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch)); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Grey; - - procedure Grey (Men : in Menu; - Grey : out Character_Attribute_Set) - is - function Menu_Grey (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Grey, "menu_grey"); - begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; - end Grey; - - procedure Grey (Men : in Menu; - Grey : out Character_Attribute_Set; - Color : out Color_Pair) - is - function Menu_Grey (Men : Menu) return C_Chtype; - pragma Import (C, Menu_Grey, "menu_grey"); - begin - Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr; - Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color; - end Grey; - - procedure Set_Pad_Character (Men : in Menu; - Pad : in Character := Space) - is - function Set_Menu_Pad (Men : Menu; - Ch : C_Int) return C_Int; - pragma Import (C, Set_Menu_Pad, "set_menu_pad"); - - Res : constant Eti_Error := Set_Menu_Pad (Men, - C_Int (Character'Pos (Pad))); - begin - if Res /= E_Ok then - Eti_Exception (Res); - end if; - end Set_Pad_Character; - - procedure Pad_Character (Men : in Menu; - Pad : out Character) - is - function Menu_Pad (Men : Menu) return C_Int; - 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 : 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; |