File : terminal_interface-curses-menus.adb
------------------------------------------------------------------------------
-- --
-- GNAT ncurses Binding --
-- --
-- Terminal_Interface.Curses.Menus --
-- --
-- B O D Y --
-- --
------------------------------------------------------------------------------
-- Copyright (c) 1998-2004,2008 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.26 @
-- @Date: 2008/07/26 18:50:58 @
-- 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");
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 : constant 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 : constant 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 : constant 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 > 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;