| 1 | ------------------------------------------------------------------------------
|
|---|
| 2 | -- --
|
|---|
| 3 | -- GNAT ncurses Binding --
|
|---|
| 4 | -- --
|
|---|
| 5 | -- Terminal_Interface.Curses.Menus --
|
|---|
| 6 | -- --
|
|---|
| 7 | -- B O D Y --
|
|---|
| 8 | -- --
|
|---|
| 9 | ------------------------------------------------------------------------------
|
|---|
| 10 | -- Copyright (c) 1998,2004 Free Software Foundation, Inc. --
|
|---|
| 11 | -- --
|
|---|
| 12 | -- Permission is hereby granted, free of charge, to any person obtaining a --
|
|---|
| 13 | -- copy of this software and associated documentation files (the --
|
|---|
| 14 | -- "Software"), to deal in the Software without restriction, including --
|
|---|
| 15 | -- without limitation the rights to use, copy, modify, merge, publish, --
|
|---|
| 16 | -- distribute, distribute with modifications, sublicense, and/or sell --
|
|---|
| 17 | -- copies of the Software, and to permit persons to whom the Software is --
|
|---|
| 18 | -- furnished to do so, subject to the following conditions: --
|
|---|
| 19 | -- --
|
|---|
| 20 | -- The above copyright notice and this permission notice shall be included --
|
|---|
| 21 | -- in all copies or substantial portions of the Software. --
|
|---|
| 22 | -- --
|
|---|
| 23 | -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
|
|---|
| 24 | -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
|
|---|
| 25 | -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
|
|---|
| 26 | -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
|
|---|
| 27 | -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
|
|---|
| 28 | -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
|
|---|
| 29 | -- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
|
|---|
| 30 | -- --
|
|---|
| 31 | -- Except as contained in this notice, the name(s) of the above copyright --
|
|---|
| 32 | -- holders shall not be used in advertising or otherwise to promote the --
|
|---|
| 33 | -- sale, use or other dealings in this Software without prior written --
|
|---|
| 34 | -- authorization. --
|
|---|
| 35 | ------------------------------------------------------------------------------
|
|---|
| 36 | -- Author: Juergen Pfeifer, 1996
|
|---|
| 37 | -- Version Control:
|
|---|
| 38 | -- $Revision: 1.25 $
|
|---|
| 39 | -- $Date: 2004/08/21 21:37:00 $
|
|---|
| 40 | -- Binding Version 01.00
|
|---|
| 41 | ------------------------------------------------------------------------------
|
|---|
| 42 | with Ada.Unchecked_Deallocation;
|
|---|
| 43 | with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
|
|---|
| 44 |
|
|---|
| 45 | with Interfaces.C; use Interfaces.C;
|
|---|
| 46 | with Interfaces.C.Strings; use Interfaces.C.Strings;
|
|---|
| 47 | with Interfaces.C.Pointers;
|
|---|
| 48 |
|
|---|
| 49 | with Ada.Unchecked_Conversion;
|
|---|
| 50 |
|
|---|
| 51 | package body Terminal_Interface.Curses.Menus is
|
|---|
| 52 |
|
|---|
| 53 | type C_Item_Array is array (Natural range <>) of aliased Item;
|
|---|
| 54 | package I_Array is new
|
|---|
| 55 | Interfaces.C.Pointers (Natural, Item, C_Item_Array, Null_Item);
|
|---|
| 56 |
|
|---|
| 57 | use type System.Bit_Order;
|
|---|
| 58 | subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
|
|---|
| 59 |
|
|---|
| 60 | function MOS_2_CInt is new
|
|---|
| 61 | Ada.Unchecked_Conversion (Menu_Option_Set,
|
|---|
| 62 | C_Int);
|
|---|
| 63 |
|
|---|
| 64 | function CInt_2_MOS is new
|
|---|
| 65 | Ada.Unchecked_Conversion (C_Int,
|
|---|
| 66 | Menu_Option_Set);
|
|---|
| 67 |
|
|---|
| 68 | function IOS_2_CInt is new
|
|---|
| 69 | Ada.Unchecked_Conversion (Item_Option_Set,
|
|---|
| 70 | C_Int);
|
|---|
| 71 |
|
|---|
| 72 | function CInt_2_IOS is new
|
|---|
| 73 | Ada.Unchecked_Conversion (C_Int,
|
|---|
| 74 | Item_Option_Set);
|
|---|
| 75 |
|
|---|
| 76 | ------------------------------------------------------------------------------
|
|---|
| 77 | procedure Request_Name (Key : in Menu_Request_Code;
|
|---|
| 78 | Name : out String)
|
|---|
| 79 | is
|
|---|
| 80 | function Request_Name (Key : C_Int) return chars_ptr;
|
|---|
| 81 | pragma Import (C, Request_Name, "menu_request_name");
|
|---|
| 82 | begin
|
|---|
| 83 | Fill_String (Request_Name (C_Int (Key)), Name);
|
|---|
| 84 | end Request_Name;
|
|---|
| 85 |
|
|---|
| 86 | function Request_Name (Key : Menu_Request_Code) return String
|
|---|
| 87 | is
|
|---|
| 88 | function Request_Name (Key : C_Int) return chars_ptr;
|
|---|
| 89 | pragma Import (C, Request_Name, "menu_request_name");
|
|---|
| 90 | begin
|
|---|
| 91 | return Fill_String (Request_Name (C_Int (Key)));
|
|---|
| 92 | end Request_Name;
|
|---|
| 93 |
|
|---|
| 94 | function Create (Name : String;
|
|---|
| 95 | Description : String := "") return Item
|
|---|
| 96 | is
|
|---|
| 97 | type Char_Ptr is access all Interfaces.C.char;
|
|---|
| 98 | function Newitem (Name, Desc : Char_Ptr) return Item;
|
|---|
| 99 | pragma Import (C, Newitem, "new_item");
|
|---|
| 100 |
|
|---|
| 101 | type Name_String is new char_array (0 .. Name'Length);
|
|---|
| 102 | type Name_String_Ptr is access Name_String;
|
|---|
| 103 | pragma Controlled (Name_String_Ptr);
|
|---|
| 104 |
|
|---|
| 105 | type Desc_String is new char_array (0 .. Description'Length);
|
|---|
| 106 | type Desc_String_Ptr is access Desc_String;
|
|---|
| 107 | pragma Controlled (Desc_String_Ptr);
|
|---|
| 108 |
|
|---|
| 109 | Name_Str : constant Name_String_Ptr := new Name_String;
|
|---|
| 110 | Desc_Str : constant Desc_String_Ptr := new Desc_String;
|
|---|
| 111 | Name_Len, Desc_Len : size_t;
|
|---|
| 112 | Result : Item;
|
|---|
| 113 | begin
|
|---|
| 114 | To_C (Name, Name_Str.all, Name_Len);
|
|---|
| 115 | To_C (Description, Desc_Str.all, Desc_Len);
|
|---|
| 116 | Result := Newitem (Name_Str.all (Name_Str.all'First)'Access,
|
|---|
| 117 | Desc_Str.all (Desc_Str.all'First)'Access);
|
|---|
| 118 | if Result = Null_Item then
|
|---|
| 119 | raise Eti_System_Error;
|
|---|
| 120 | end if;
|
|---|
| 121 | return Result;
|
|---|
| 122 | end Create;
|
|---|
| 123 |
|
|---|
| 124 | procedure Delete (Itm : in out Item)
|
|---|
| 125 | is
|
|---|
| 126 | function Descname (Itm : Item) return chars_ptr;
|
|---|
| 127 | pragma Import (C, Descname, "item_description");
|
|---|
| 128 | function Itemname (Itm : Item) return chars_ptr;
|
|---|
| 129 | pragma Import (C, Itemname, "item_name");
|
|---|
| 130 |
|
|---|
| 131 | function Freeitem (Itm : Item) return C_Int;
|
|---|
| 132 | pragma Import (C, Freeitem, "free_item");
|
|---|
| 133 |
|
|---|
| 134 | Res : Eti_Error;
|
|---|
| 135 | Ptr : chars_ptr;
|
|---|
| 136 | begin
|
|---|
| 137 | Ptr := Descname (Itm);
|
|---|
| 138 | if Ptr /= Null_Ptr then
|
|---|
| 139 | Interfaces.C.Strings.Free (Ptr);
|
|---|
| 140 | end if;
|
|---|
| 141 | Ptr := Itemname (Itm);
|
|---|
| 142 | if Ptr /= Null_Ptr then
|
|---|
| 143 | Interfaces.C.Strings.Free (Ptr);
|
|---|
| 144 | end if;
|
|---|
| 145 | Res := Freeitem (Itm);
|
|---|
| 146 | if Res /= E_Ok then
|
|---|
| 147 | Eti_Exception (Res);
|
|---|
| 148 | end if;
|
|---|
| 149 | Itm := Null_Item;
|
|---|
| 150 | end Delete;
|
|---|
| 151 | -------------------------------------------------------------------------------
|
|---|
| 152 | procedure Set_Value (Itm : in Item;
|
|---|
| 153 | Value : in Boolean := True)
|
|---|
| 154 | is
|
|---|
| 155 | function Set_Item_Val (Itm : Item;
|
|---|
| 156 | Val : C_Int) return C_Int;
|
|---|
| 157 | pragma Import (C, Set_Item_Val, "set_item_value");
|
|---|
| 158 |
|
|---|
| 159 | Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value));
|
|---|
| 160 | begin
|
|---|
| 161 | if Res /= E_Ok then
|
|---|
| 162 | Eti_Exception (Res);
|
|---|
| 163 | end if;
|
|---|
| 164 | end Set_Value;
|
|---|
| 165 |
|
|---|
| 166 | function Value (Itm : Item) return Boolean
|
|---|
| 167 | is
|
|---|
| 168 | function Item_Val (Itm : Item) return C_Int;
|
|---|
| 169 | pragma Import (C, Item_Val, "item_value");
|
|---|
| 170 | begin
|
|---|
| 171 | if Item_Val (Itm) = Curses_False then
|
|---|
| 172 | return False;
|
|---|
| 173 | else
|
|---|
| 174 | return True;
|
|---|
| 175 | end if;
|
|---|
| 176 | end Value;
|
|---|
| 177 |
|
|---|
| 178 | -------------------------------------------------------------------------------
|
|---|
| 179 | function Visible (Itm : Item) return Boolean
|
|---|
| 180 | is
|
|---|
| 181 | function Item_Vis (Itm : Item) return C_Int;
|
|---|
| 182 | pragma Import (C, Item_Vis, "item_visible");
|
|---|
| 183 | begin
|
|---|
| 184 | if Item_Vis (Itm) = Curses_False then
|
|---|
| 185 | return False;
|
|---|
| 186 | else
|
|---|
| 187 | return True;
|
|---|
| 188 | end if;
|
|---|
| 189 | end Visible;
|
|---|
| 190 | -------------------------------------------------------------------------------
|
|---|
| 191 | procedure Set_Options (Itm : in Item;
|
|---|
| 192 | Options : in Item_Option_Set)
|
|---|
| 193 | is
|
|---|
| 194 | function Set_Item_Opts (Itm : Item;
|
|---|
| 195 | Opt : C_Int) return C_Int;
|
|---|
| 196 | pragma Import (C, Set_Item_Opts, "set_item_opts");
|
|---|
| 197 |
|
|---|
| 198 | Opt : constant C_Int := IOS_2_CInt (Options);
|
|---|
| 199 | Res : Eti_Error;
|
|---|
| 200 | begin
|
|---|
| 201 | Res := Set_Item_Opts (Itm, Opt);
|
|---|
| 202 | if Res /= E_Ok then
|
|---|
| 203 | Eti_Exception (Res);
|
|---|
| 204 | end if;
|
|---|
| 205 | end Set_Options;
|
|---|
| 206 |
|
|---|
| 207 | procedure Switch_Options (Itm : in Item;
|
|---|
| 208 | Options : in Item_Option_Set;
|
|---|
| 209 | On : Boolean := True)
|
|---|
| 210 | is
|
|---|
| 211 | function Item_Opts_On (Itm : Item;
|
|---|
| 212 | Opt : C_Int) return C_Int;
|
|---|
| 213 | pragma Import (C, Item_Opts_On, "item_opts_on");
|
|---|
| 214 | function Item_Opts_Off (Itm : Item;
|
|---|
| 215 | Opt : C_Int) return C_Int;
|
|---|
| 216 | pragma Import (C, Item_Opts_Off, "item_opts_off");
|
|---|
| 217 |
|
|---|
| 218 | Opt : constant C_Int := IOS_2_CInt (Options);
|
|---|
| 219 | Err : Eti_Error;
|
|---|
| 220 | begin
|
|---|
| 221 | if On then
|
|---|
| 222 | Err := Item_Opts_On (Itm, Opt);
|
|---|
| 223 | else
|
|---|
| 224 | Err := Item_Opts_Off (Itm, Opt);
|
|---|
| 225 | end if;
|
|---|
| 226 | if Err /= E_Ok then
|
|---|
| 227 | Eti_Exception (Err);
|
|---|
| 228 | end if;
|
|---|
| 229 | end Switch_Options;
|
|---|
| 230 |
|
|---|
| 231 | procedure Get_Options (Itm : in Item;
|
|---|
| 232 | Options : out Item_Option_Set)
|
|---|
| 233 | is
|
|---|
| 234 | function Item_Opts (Itm : Item) return C_Int;
|
|---|
| 235 | pragma Import (C, Item_Opts, "item_opts");
|
|---|
| 236 |
|
|---|
| 237 | Res : constant C_Int := Item_Opts (Itm);
|
|---|
| 238 | begin
|
|---|
| 239 | Options := CInt_2_IOS (Res);
|
|---|
| 240 | end Get_Options;
|
|---|
| 241 |
|
|---|
| 242 | function Get_Options (Itm : Item := Null_Item) return Item_Option_Set
|
|---|
| 243 | is
|
|---|
| 244 | Ios : Item_Option_Set;
|
|---|
| 245 | begin
|
|---|
| 246 | Get_Options (Itm, Ios);
|
|---|
| 247 | return Ios;
|
|---|
| 248 | end Get_Options;
|
|---|
| 249 | -------------------------------------------------------------------------------
|
|---|
| 250 | procedure Name (Itm : in Item;
|
|---|
| 251 | Name : out String)
|
|---|
| 252 | is
|
|---|
| 253 | function Itemname (Itm : Item) return chars_ptr;
|
|---|
| 254 | pragma Import (C, Itemname, "item_name");
|
|---|
| 255 | begin
|
|---|
| 256 | Fill_String (Itemname (Itm), Name);
|
|---|
| 257 | end Name;
|
|---|
| 258 |
|
|---|
| 259 | function Name (Itm : in Item) return String
|
|---|
| 260 | is
|
|---|
| 261 | function Itemname (Itm : Item) return chars_ptr;
|
|---|
| 262 | pragma Import (C, Itemname, "item_name");
|
|---|
| 263 | begin
|
|---|
| 264 | return Fill_String (Itemname (Itm));
|
|---|
| 265 | end Name;
|
|---|
| 266 |
|
|---|
| 267 | procedure Description (Itm : in Item;
|
|---|
| 268 | Description : out String)
|
|---|
| 269 | is
|
|---|
| 270 | function Descname (Itm : Item) return chars_ptr;
|
|---|
| 271 | pragma Import (C, Descname, "item_description");
|
|---|
| 272 | begin
|
|---|
| 273 | Fill_String (Descname (Itm), Description);
|
|---|
| 274 | end Description;
|
|---|
| 275 |
|
|---|
| 276 | function Description (Itm : in Item) return String
|
|---|
| 277 | is
|
|---|
| 278 | function Descname (Itm : Item) return chars_ptr;
|
|---|
| 279 | pragma Import (C, Descname, "item_description");
|
|---|
| 280 | begin
|
|---|
| 281 | return Fill_String (Descname (Itm));
|
|---|
| 282 | end Description;
|
|---|
| 283 | -------------------------------------------------------------------------------
|
|---|
| 284 | procedure Set_Current (Men : in Menu;
|
|---|
| 285 | Itm : in Item)
|
|---|
| 286 | is
|
|---|
| 287 | function Set_Curr_Item (Men : Menu;
|
|---|
| 288 | Itm : Item) return C_Int;
|
|---|
| 289 | pragma Import (C, Set_Curr_Item, "set_current_item");
|
|---|
| 290 |
|
|---|
| 291 | Res : constant Eti_Error := Set_Curr_Item (Men, Itm);
|
|---|
| 292 | begin
|
|---|
| 293 | if Res /= E_Ok then
|
|---|
| 294 | Eti_Exception (Res);
|
|---|
| 295 | end if;
|
|---|
| 296 | end Set_Current;
|
|---|
| 297 |
|
|---|
| 298 | function Current (Men : Menu) return Item
|
|---|
| 299 | is
|
|---|
| 300 | function Curr_Item (Men : Menu) return Item;
|
|---|
| 301 | pragma Import (C, Curr_Item, "current_item");
|
|---|
| 302 |
|
|---|
| 303 | Res : constant Item := Curr_Item (Men);
|
|---|
| 304 | begin
|
|---|
| 305 | if Res = Null_Item then
|
|---|
| 306 | raise Menu_Exception;
|
|---|
| 307 | end if;
|
|---|
| 308 | return Res;
|
|---|
| 309 | end Current;
|
|---|
| 310 |
|
|---|
| 311 | procedure Set_Top_Row (Men : in Menu;
|
|---|
| 312 | Line : in Line_Position)
|
|---|
| 313 | is
|
|---|
| 314 | function Set_Toprow (Men : Menu;
|
|---|
| 315 | Line : C_Int) return C_Int;
|
|---|
| 316 | pragma Import (C, Set_Toprow, "set_top_row");
|
|---|
| 317 |
|
|---|
| 318 | Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line));
|
|---|
| 319 | begin
|
|---|
| 320 | if Res /= E_Ok then
|
|---|
| 321 | Eti_Exception (Res);
|
|---|
| 322 | end if;
|
|---|
| 323 | end Set_Top_Row;
|
|---|
| 324 |
|
|---|
| 325 | function Top_Row (Men : Menu) return Line_Position
|
|---|
| 326 | is
|
|---|
| 327 | function Toprow (Men : Menu) return C_Int;
|
|---|
| 328 | pragma Import (C, Toprow, "top_row");
|
|---|
| 329 |
|
|---|
| 330 | Res : constant C_Int := Toprow (Men);
|
|---|
| 331 | begin
|
|---|
| 332 | if Res = Curses_Err then
|
|---|
| 333 | raise Menu_Exception;
|
|---|
| 334 | end if;
|
|---|
| 335 | return Line_Position (Res);
|
|---|
| 336 | end Top_Row;
|
|---|
| 337 |
|
|---|
| 338 | function Get_Index (Itm : Item) return Positive
|
|---|
| 339 | is
|
|---|
| 340 | function Get_Itemindex (Itm : Item) return C_Int;
|
|---|
| 341 | pragma Import (C, Get_Itemindex, "item_index");
|
|---|
| 342 |
|
|---|
| 343 | Res : constant C_Int := Get_Itemindex (Itm);
|
|---|
| 344 | begin
|
|---|
| 345 | if Res = Curses_Err then
|
|---|
| 346 | raise Menu_Exception;
|
|---|
| 347 | end if;
|
|---|
| 348 | return Positive (Natural (Res) + Positive'First);
|
|---|
| 349 | end Get_Index;
|
|---|
| 350 | -------------------------------------------------------------------------------
|
|---|
| 351 | procedure Post (Men : in Menu;
|
|---|
| 352 | Post : in Boolean := True)
|
|---|
| 353 | is
|
|---|
| 354 | function M_Post (Men : Menu) return C_Int;
|
|---|
| 355 | pragma Import (C, M_Post, "post_menu");
|
|---|
| 356 | function M_Unpost (Men : Menu) return C_Int;
|
|---|
| 357 | pragma Import (C, M_Unpost, "unpost_menu");
|
|---|
| 358 |
|
|---|
| 359 | Res : Eti_Error;
|
|---|
| 360 | begin
|
|---|
| 361 | if Post then
|
|---|
| 362 | Res := M_Post (Men);
|
|---|
| 363 | else
|
|---|
| 364 | Res := M_Unpost (Men);
|
|---|
| 365 | end if;
|
|---|
| 366 | if Res /= E_Ok then
|
|---|
| 367 | Eti_Exception (Res);
|
|---|
| 368 | end if;
|
|---|
| 369 | end Post;
|
|---|
| 370 | -------------------------------------------------------------------------------
|
|---|
| 371 | procedure Set_Options (Men : in Menu;
|
|---|
| 372 | Options : in Menu_Option_Set)
|
|---|
| 373 | is
|
|---|
| 374 | function Set_Menu_Opts (Men : Menu;
|
|---|
| 375 | Opt : C_Int) return C_Int;
|
|---|
| 376 | pragma Import (C, Set_Menu_Opts, "set_menu_opts");
|
|---|
| 377 |
|
|---|
| 378 | Opt : constant C_Int := MOS_2_CInt (Options);
|
|---|
| 379 | Res : Eti_Error;
|
|---|
| 380 | begin
|
|---|
| 381 | Res := Set_Menu_Opts (Men, Opt);
|
|---|
| 382 | if Res /= E_Ok then
|
|---|
| 383 | Eti_Exception (Res);
|
|---|
| 384 | end if;
|
|---|
| 385 | end Set_Options;
|
|---|
| 386 |
|
|---|
| 387 | procedure Switch_Options (Men : in Menu;
|
|---|
| 388 | Options : in Menu_Option_Set;
|
|---|
| 389 | On : in Boolean := True)
|
|---|
| 390 | is
|
|---|
| 391 | function Menu_Opts_On (Men : Menu;
|
|---|
| 392 | Opt : C_Int) return C_Int;
|
|---|
| 393 | pragma Import (C, Menu_Opts_On, "menu_opts_on");
|
|---|
| 394 | function Menu_Opts_Off (Men : Menu;
|
|---|
| 395 | Opt : C_Int) return C_Int;
|
|---|
| 396 | pragma Import (C, Menu_Opts_Off, "menu_opts_off");
|
|---|
| 397 |
|
|---|
| 398 | Opt : constant C_Int := MOS_2_CInt (Options);
|
|---|
| 399 | Err : Eti_Error;
|
|---|
| 400 | begin
|
|---|
| 401 | if On then
|
|---|
| 402 | Err := Menu_Opts_On (Men, Opt);
|
|---|
| 403 | else
|
|---|
| 404 | Err := Menu_Opts_Off (Men, Opt);
|
|---|
| 405 | end if;
|
|---|
| 406 | if Err /= E_Ok then
|
|---|
| 407 | Eti_Exception (Err);
|
|---|
| 408 | end if;
|
|---|
| 409 | end Switch_Options;
|
|---|
| 410 |
|
|---|
| 411 | procedure Get_Options (Men : in Menu;
|
|---|
| 412 | Options : out Menu_Option_Set)
|
|---|
| 413 | is
|
|---|
| 414 | function Menu_Opts (Men : Menu) return C_Int;
|
|---|
| 415 | pragma Import (C, Menu_Opts, "menu_opts");
|
|---|
| 416 |
|
|---|
| 417 | Res : constant C_Int := Menu_Opts (Men);
|
|---|
| 418 | begin
|
|---|
| 419 | Options := CInt_2_MOS (Res);
|
|---|
| 420 | end Get_Options;
|
|---|
| 421 |
|
|---|
| 422 | function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set
|
|---|
| 423 | is
|
|---|
| 424 | Mos : Menu_Option_Set;
|
|---|
| 425 | begin
|
|---|
| 426 | Get_Options (Men, Mos);
|
|---|
| 427 | return Mos;
|
|---|
| 428 | end Get_Options;
|
|---|
| 429 | -------------------------------------------------------------------------------
|
|---|
| 430 | procedure Set_Window (Men : in Menu;
|
|---|
| 431 | Win : in Window)
|
|---|
| 432 | is
|
|---|
| 433 | function Set_Menu_Win (Men : Menu;
|
|---|
| 434 | Win : Window) return C_Int;
|
|---|
| 435 | pragma Import (C, Set_Menu_Win, "set_menu_win");
|
|---|
| 436 |
|
|---|
| 437 | Res : constant Eti_Error := Set_Menu_Win (Men, Win);
|
|---|
| 438 | begin
|
|---|
| 439 | if Res /= E_Ok then
|
|---|
| 440 | Eti_Exception (Res);
|
|---|
| 441 | end if;
|
|---|
| 442 | end Set_Window;
|
|---|
| 443 |
|
|---|
| 444 | function Get_Window (Men : Menu) return Window
|
|---|
| 445 | is
|
|---|
| 446 | function Menu_Win (Men : Menu) return Window;
|
|---|
| 447 | pragma Import (C, Menu_Win, "menu_win");
|
|---|
| 448 |
|
|---|
| 449 | W : constant Window := Menu_Win (Men);
|
|---|
| 450 | begin
|
|---|
| 451 | return W;
|
|---|
| 452 | end Get_Window;
|
|---|
| 453 |
|
|---|
| 454 | procedure Set_Sub_Window (Men : in Menu;
|
|---|
| 455 | Win : in Window)
|
|---|
| 456 | is
|
|---|
| 457 | function Set_Menu_Sub (Men : Menu;
|
|---|
| 458 | Win : Window) return C_Int;
|
|---|
| 459 | pragma Import (C, Set_Menu_Sub, "set_menu_sub");
|
|---|
| 460 |
|
|---|
| 461 | Res : constant Eti_Error := Set_Menu_Sub (Men, Win);
|
|---|
| 462 | begin
|
|---|
| 463 | if Res /= E_Ok then
|
|---|
| 464 | Eti_Exception (Res);
|
|---|
| 465 | end if;
|
|---|
| 466 | end Set_Sub_Window;
|
|---|
| 467 |
|
|---|
| 468 | function Get_Sub_Window (Men : Menu) return Window
|
|---|
| 469 | is
|
|---|
| 470 | function Menu_Sub (Men : Menu) return Window;
|
|---|
| 471 | pragma Import (C, Menu_Sub, "menu_sub");
|
|---|
| 472 |
|
|---|
| 473 | W : constant Window := Menu_Sub (Men);
|
|---|
| 474 | begin
|
|---|
| 475 | return W;
|
|---|
| 476 | end Get_Sub_Window;
|
|---|
| 477 |
|
|---|
| 478 | procedure Scale (Men : in Menu;
|
|---|
| 479 | Lines : out Line_Count;
|
|---|
| 480 | Columns : out Column_Count)
|
|---|
| 481 | is
|
|---|
| 482 | type C_Int_Access is access all C_Int;
|
|---|
| 483 | function M_Scale (Men : Menu;
|
|---|
| 484 | Yp, Xp : C_Int_Access) return C_Int;
|
|---|
| 485 | pragma Import (C, M_Scale, "scale_menu");
|
|---|
| 486 |
|
|---|
| 487 | X, Y : aliased C_Int;
|
|---|
| 488 | Res : constant Eti_Error := M_Scale (Men, Y'Access, X'Access);
|
|---|
| 489 | begin
|
|---|
| 490 | if Res /= E_Ok then
|
|---|
| 491 | Eti_Exception (Res);
|
|---|
| 492 | end if;
|
|---|
| 493 | Lines := Line_Count (Y);
|
|---|
| 494 | Columns := Column_Count (X);
|
|---|
| 495 | end Scale;
|
|---|
| 496 | -------------------------------------------------------------------------------
|
|---|
| 497 | procedure Position_Cursor (Men : Menu)
|
|---|
| 498 | is
|
|---|
| 499 | function Pos_Menu_Cursor (Men : Menu) return C_Int;
|
|---|
| 500 | pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor");
|
|---|
| 501 |
|
|---|
| 502 | Res : constant Eti_Error := Pos_Menu_Cursor (Men);
|
|---|
| 503 | begin
|
|---|
| 504 | if Res /= E_Ok then
|
|---|
| 505 | Eti_Exception (Res);
|
|---|
| 506 | end if;
|
|---|
| 507 | end Position_Cursor;
|
|---|
| 508 |
|
|---|
| 509 | -------------------------------------------------------------------------------
|
|---|
| 510 | procedure Set_Mark (Men : in Menu;
|
|---|
| 511 | Mark : in String)
|
|---|
| 512 | is
|
|---|
| 513 | type Char_Ptr is access all Interfaces.C.char;
|
|---|
| 514 | function Set_Mark (Men : Menu;
|
|---|
| 515 | Mark : Char_Ptr) return C_Int;
|
|---|
| 516 | pragma Import (C, Set_Mark, "set_menu_mark");
|
|---|
| 517 |
|
|---|
| 518 | Txt : char_array (0 .. Mark'Length);
|
|---|
| 519 | Len : size_t;
|
|---|
| 520 | Res : Eti_Error;
|
|---|
| 521 | begin
|
|---|
| 522 | To_C (Mark, Txt, Len);
|
|---|
| 523 | Res := Set_Mark (Men, Txt (Txt'First)'Access);
|
|---|
| 524 | if Res /= E_Ok then
|
|---|
| 525 | Eti_Exception (Res);
|
|---|
| 526 | end if;
|
|---|
| 527 | end Set_Mark;
|
|---|
| 528 |
|
|---|
| 529 | procedure Mark (Men : in Menu;
|
|---|
| 530 | Mark : out String)
|
|---|
| 531 | is
|
|---|
| 532 | function Get_Menu_Mark (Men : Menu) return chars_ptr;
|
|---|
| 533 | pragma Import (C, Get_Menu_Mark, "menu_mark");
|
|---|
| 534 | begin
|
|---|
| 535 | Fill_String (Get_Menu_Mark (Men), Mark);
|
|---|
| 536 | end Mark;
|
|---|
| 537 |
|
|---|
| 538 | function Mark (Men : Menu) return String
|
|---|
| 539 | is
|
|---|
| 540 | function Get_Menu_Mark (Men : Menu) return chars_ptr;
|
|---|
| 541 | pragma Import (C, Get_Menu_Mark, "menu_mark");
|
|---|
| 542 | begin
|
|---|
| 543 | return Fill_String (Get_Menu_Mark (Men));
|
|---|
| 544 | end Mark;
|
|---|
| 545 |
|
|---|
| 546 | -------------------------------------------------------------------------------
|
|---|
| 547 | procedure Set_Foreground
|
|---|
| 548 | (Men : in Menu;
|
|---|
| 549 | Fore : in Character_Attribute_Set := Normal_Video;
|
|---|
| 550 | Color : in Color_Pair := Color_Pair'First)
|
|---|
| 551 | is
|
|---|
| 552 | function Set_Menu_Fore (Men : Menu;
|
|---|
| 553 | Attr : C_Chtype) return C_Int;
|
|---|
| 554 | pragma Import (C, Set_Menu_Fore, "set_menu_fore");
|
|---|
| 555 |
|
|---|
| 556 | Ch : constant Attributed_Character := (Ch => Character'First,
|
|---|
| 557 | Color => Color,
|
|---|
| 558 | Attr => Fore);
|
|---|
| 559 | Res : constant Eti_Error := Set_Menu_Fore (Men, AttrChar_To_Chtype (Ch));
|
|---|
| 560 | begin
|
|---|
| 561 | if Res /= E_Ok then
|
|---|
| 562 | Eti_Exception (Res);
|
|---|
| 563 | end if;
|
|---|
| 564 | end Set_Foreground;
|
|---|
| 565 |
|
|---|
| 566 | procedure Foreground (Men : in Menu;
|
|---|
| 567 | Fore : out Character_Attribute_Set)
|
|---|
| 568 | is
|
|---|
| 569 | function Menu_Fore (Men : Menu) return C_Chtype;
|
|---|
| 570 | pragma Import (C, Menu_Fore, "menu_fore");
|
|---|
| 571 | begin
|
|---|
| 572 | Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr;
|
|---|
| 573 | end Foreground;
|
|---|
| 574 |
|
|---|
| 575 | procedure Foreground (Men : in Menu;
|
|---|
| 576 | Fore : out Character_Attribute_Set;
|
|---|
| 577 | Color : out Color_Pair)
|
|---|
| 578 | is
|
|---|
| 579 | function Menu_Fore (Men : Menu) return C_Chtype;
|
|---|
| 580 | pragma Import (C, Menu_Fore, "menu_fore");
|
|---|
| 581 | begin
|
|---|
| 582 | Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr;
|
|---|
| 583 | Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color;
|
|---|
| 584 | end Foreground;
|
|---|
| 585 |
|
|---|
| 586 | procedure Set_Background
|
|---|
| 587 | (Men : in Menu;
|
|---|
| 588 | Back : in Character_Attribute_Set := Normal_Video;
|
|---|
| 589 | Color : in Color_Pair := Color_Pair'First)
|
|---|
| 590 | is
|
|---|
| 591 | function Set_Menu_Back (Men : Menu;
|
|---|
| 592 | Attr : C_Chtype) return C_Int;
|
|---|
| 593 | pragma Import (C, Set_Menu_Back, "set_menu_back");
|
|---|
| 594 |
|
|---|
| 595 | Ch : constant Attributed_Character := (Ch => Character'First,
|
|---|
| 596 | Color => Color,
|
|---|
| 597 | Attr => Back);
|
|---|
| 598 | Res : constant Eti_Error := Set_Menu_Back (Men, AttrChar_To_Chtype (Ch));
|
|---|
| 599 | begin
|
|---|
| 600 | if Res /= E_Ok then
|
|---|
| 601 | Eti_Exception (Res);
|
|---|
| 602 | end if;
|
|---|
| 603 | end Set_Background;
|
|---|
| 604 |
|
|---|
| 605 | procedure Background (Men : in Menu;
|
|---|
| 606 | Back : out Character_Attribute_Set)
|
|---|
| 607 | is
|
|---|
| 608 | function Menu_Back (Men : Menu) return C_Chtype;
|
|---|
| 609 | pragma Import (C, Menu_Back, "menu_back");
|
|---|
| 610 | begin
|
|---|
| 611 | Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr;
|
|---|
| 612 | end Background;
|
|---|
| 613 |
|
|---|
| 614 | procedure Background (Men : in Menu;
|
|---|
| 615 | Back : out Character_Attribute_Set;
|
|---|
| 616 | Color : out Color_Pair)
|
|---|
| 617 | is
|
|---|
| 618 | function Menu_Back (Men : Menu) return C_Chtype;
|
|---|
| 619 | pragma Import (C, Menu_Back, "menu_back");
|
|---|
| 620 | begin
|
|---|
| 621 | Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr;
|
|---|
| 622 | Color := Chtype_To_AttrChar (Menu_Back (Men)).Color;
|
|---|
| 623 | end Background;
|
|---|
| 624 |
|
|---|
| 625 | procedure Set_Grey (Men : in Menu;
|
|---|
| 626 | Grey : in Character_Attribute_Set := Normal_Video;
|
|---|
| 627 | Color : in Color_Pair := Color_Pair'First)
|
|---|
| 628 | is
|
|---|
| 629 | function Set_Menu_Grey (Men : Menu;
|
|---|
| 630 | Attr : C_Chtype) return C_Int;
|
|---|
| 631 | pragma Import (C, Set_Menu_Grey, "set_menu_grey");
|
|---|
| 632 |
|
|---|
| 633 | Ch : constant Attributed_Character := (Ch => Character'First,
|
|---|
| 634 | Color => Color,
|
|---|
| 635 | Attr => Grey);
|
|---|
| 636 |
|
|---|
| 637 | Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch));
|
|---|
| 638 | begin
|
|---|
| 639 | if Res /= E_Ok then
|
|---|
| 640 | Eti_Exception (Res);
|
|---|
| 641 | end if;
|
|---|
| 642 | end Set_Grey;
|
|---|
| 643 |
|
|---|
| 644 | procedure Grey (Men : in Menu;
|
|---|
| 645 | Grey : out Character_Attribute_Set)
|
|---|
| 646 | is
|
|---|
| 647 | function Menu_Grey (Men : Menu) return C_Chtype;
|
|---|
| 648 | pragma Import (C, Menu_Grey, "menu_grey");
|
|---|
| 649 | begin
|
|---|
| 650 | Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr;
|
|---|
| 651 | end Grey;
|
|---|
| 652 |
|
|---|
| 653 | procedure Grey (Men : in Menu;
|
|---|
| 654 | Grey : out Character_Attribute_Set;
|
|---|
| 655 | Color : out Color_Pair)
|
|---|
| 656 | is
|
|---|
| 657 | function Menu_Grey (Men : Menu) return C_Chtype;
|
|---|
| 658 | pragma Import (C, Menu_Grey, "menu_grey");
|
|---|
| 659 | begin
|
|---|
| 660 | Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr;
|
|---|
| 661 | Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color;
|
|---|
| 662 | end Grey;
|
|---|
| 663 |
|
|---|
| 664 | procedure Set_Pad_Character (Men : in Menu;
|
|---|
| 665 | Pad : in Character := Space)
|
|---|
| 666 | is
|
|---|
| 667 | function Set_Menu_Pad (Men : Menu;
|
|---|
| 668 | Ch : C_Int) return C_Int;
|
|---|
| 669 | pragma Import (C, Set_Menu_Pad, "set_menu_pad");
|
|---|
| 670 |
|
|---|
| 671 | Res : constant Eti_Error := Set_Menu_Pad (Men,
|
|---|
| 672 | C_Int (Character'Pos (Pad)));
|
|---|
| 673 | begin
|
|---|
| 674 | if Res /= E_Ok then
|
|---|
| 675 | Eti_Exception (Res);
|
|---|
| 676 | end if;
|
|---|
| 677 | end Set_Pad_Character;
|
|---|
| 678 |
|
|---|
| 679 | procedure Pad_Character (Men : in Menu;
|
|---|
| 680 | Pad : out Character)
|
|---|
| 681 | is
|
|---|
| 682 | function Menu_Pad (Men : Menu) return C_Int;
|
|---|
| 683 | pragma Import (C, Menu_Pad, "menu_pad");
|
|---|
| 684 | begin
|
|---|
| 685 | Pad := Character'Val (Menu_Pad (Men));
|
|---|
| 686 | end Pad_Character;
|
|---|
| 687 | -------------------------------------------------------------------------------
|
|---|
| 688 | procedure Set_Spacing (Men : in Menu;
|
|---|
| 689 | Descr : in Column_Position := 0;
|
|---|
| 690 | Row : in Line_Position := 0;
|
|---|
| 691 | Col : in Column_Position := 0)
|
|---|
| 692 | is
|
|---|
| 693 | function Set_Spacing (Men : Menu;
|
|---|
| 694 | D, R, C : C_Int) return C_Int;
|
|---|
| 695 | pragma Import (C, Set_Spacing, "set_menu_spacing");
|
|---|
| 696 |
|
|---|
| 697 | Res : constant Eti_Error := Set_Spacing (Men,
|
|---|
| 698 | C_Int (Descr),
|
|---|
| 699 | C_Int (Row),
|
|---|
| 700 | C_Int (Col));
|
|---|
| 701 | begin
|
|---|
| 702 | if Res /= E_Ok then
|
|---|
| 703 | Eti_Exception (Res);
|
|---|
| 704 | end if;
|
|---|
| 705 | end Set_Spacing;
|
|---|
| 706 |
|
|---|
| 707 | procedure Spacing (Men : in Menu;
|
|---|
| 708 | Descr : out Column_Position;
|
|---|
| 709 | Row : out Line_Position;
|
|---|
| 710 | Col : out Column_Position)
|
|---|
| 711 | is
|
|---|
| 712 | type C_Int_Access is access all C_Int;
|
|---|
| 713 | function Get_Spacing (Men : Menu;
|
|---|
| 714 | D, R, C : C_Int_Access) return C_Int;
|
|---|
| 715 | pragma Import (C, Get_Spacing, "menu_spacing");
|
|---|
| 716 |
|
|---|
| 717 | D, R, C : aliased C_Int;
|
|---|
| 718 | Res : constant Eti_Error := Get_Spacing (Men,
|
|---|
| 719 | D'Access,
|
|---|
| 720 | R'Access,
|
|---|
| 721 | C'Access);
|
|---|
| 722 | begin
|
|---|
| 723 | if Res /= E_Ok then
|
|---|
| 724 | Eti_Exception (Res);
|
|---|
| 725 | else
|
|---|
| 726 | Descr := Column_Position (D);
|
|---|
| 727 | Row := Line_Position (R);
|
|---|
| 728 | Col := Column_Position (C);
|
|---|
| 729 | end if;
|
|---|
| 730 | end Spacing;
|
|---|
| 731 | -------------------------------------------------------------------------------
|
|---|
| 732 | function Set_Pattern (Men : Menu;
|
|---|
| 733 | Text : String) return Boolean
|
|---|
| 734 | is
|
|---|
| 735 | type Char_Ptr is access all Interfaces.C.char;
|
|---|
| 736 | function Set_Pattern (Men : Menu;
|
|---|
| 737 | Pattern : Char_Ptr) return C_Int;
|
|---|
| 738 | pragma Import (C, Set_Pattern, "set_menu_pattern");
|
|---|
| 739 |
|
|---|
| 740 | S : char_array (0 .. Text'Length);
|
|---|
| 741 | L : size_t;
|
|---|
| 742 | Res : Eti_Error;
|
|---|
| 743 | begin
|
|---|
| 744 | To_C (Text, S, L);
|
|---|
| 745 | Res := Set_Pattern (Men, S (S'First)'Access);
|
|---|
| 746 | case Res is
|
|---|
| 747 | when E_No_Match => return False;
|
|---|
| 748 | when E_Ok => return True;
|
|---|
| 749 | when others =>
|
|---|
| 750 | Eti_Exception (Res);
|
|---|
| 751 | return False;
|
|---|
| 752 | end case;
|
|---|
| 753 | end Set_Pattern;
|
|---|
| 754 |
|
|---|
| 755 | procedure Pattern (Men : in Menu;
|
|---|
| 756 | Text : out String)
|
|---|
| 757 | is
|
|---|
| 758 | function Get_Pattern (Men : Menu) return chars_ptr;
|
|---|
| 759 | pragma Import (C, Get_Pattern, "menu_pattern");
|
|---|
| 760 | begin
|
|---|
| 761 | Fill_String (Get_Pattern (Men), Text);
|
|---|
| 762 | end Pattern;
|
|---|
| 763 | -------------------------------------------------------------------------------
|
|---|
| 764 | procedure Set_Format (Men : in Menu;
|
|---|
| 765 | Lines : in Line_Count;
|
|---|
| 766 | Columns : in Column_Count)
|
|---|
| 767 | is
|
|---|
| 768 | function Set_Menu_Fmt (Men : Menu;
|
|---|
| 769 | Lin : C_Int;
|
|---|
| 770 | Col : C_Int) return C_Int;
|
|---|
| 771 | pragma Import (C, Set_Menu_Fmt, "set_menu_format");
|
|---|
| 772 |
|
|---|
| 773 | Res : constant Eti_Error := Set_Menu_Fmt (Men,
|
|---|
| 774 | C_Int (Lines),
|
|---|
| 775 | C_Int (Columns));
|
|---|
| 776 | begin
|
|---|
| 777 | if Res /= E_Ok then
|
|---|
| 778 | Eti_Exception (Res);
|
|---|
| 779 | end if;
|
|---|
| 780 | end Set_Format;
|
|---|
| 781 |
|
|---|
| 782 | procedure Format (Men : in Menu;
|
|---|
| 783 | Lines : out Line_Count;
|
|---|
| 784 | Columns : out Column_Count)
|
|---|
| 785 | is
|
|---|
| 786 | type C_Int_Access is access all C_Int;
|
|---|
| 787 | function Menu_Fmt (Men : Menu;
|
|---|
| 788 | Y, X : C_Int_Access) return C_Int;
|
|---|
| 789 | pragma Import (C, Menu_Fmt, "menu_format");
|
|---|
| 790 |
|
|---|
| 791 | L, C : aliased C_Int;
|
|---|
| 792 | Res : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access);
|
|---|
| 793 | begin
|
|---|
| 794 | if Res /= E_Ok then
|
|---|
| 795 | Eti_Exception (Res);
|
|---|
| 796 | else
|
|---|
| 797 | Lines := Line_Count (L);
|
|---|
| 798 | Columns := Column_Count (C);
|
|---|
| 799 | end if;
|
|---|
| 800 | end Format;
|
|---|
| 801 | -------------------------------------------------------------------------------
|
|---|
| 802 | procedure Set_Item_Init_Hook (Men : in Menu;
|
|---|
| 803 | Proc : in Menu_Hook_Function)
|
|---|
| 804 | is
|
|---|
| 805 | function Set_Item_Init (Men : Menu;
|
|---|
| 806 | Proc : Menu_Hook_Function) return C_Int;
|
|---|
| 807 | pragma Import (C, Set_Item_Init, "set_item_init");
|
|---|
| 808 |
|
|---|
| 809 | Res : constant Eti_Error := Set_Item_Init (Men, Proc);
|
|---|
| 810 | begin
|
|---|
| 811 | if Res /= E_Ok then
|
|---|
| 812 | Eti_Exception (Res);
|
|---|
| 813 | end if;
|
|---|
| 814 | end Set_Item_Init_Hook;
|
|---|
| 815 |
|
|---|
| 816 | procedure Set_Item_Term_Hook (Men : in Menu;
|
|---|
| 817 | Proc : in Menu_Hook_Function)
|
|---|
| 818 | is
|
|---|
| 819 | function Set_Item_Term (Men : Menu;
|
|---|
| 820 | Proc : Menu_Hook_Function) return C_Int;
|
|---|
| 821 | pragma Import (C, Set_Item_Term, "set_item_term");
|
|---|
| 822 |
|
|---|
| 823 | Res : constant Eti_Error := Set_Item_Term (Men, Proc);
|
|---|
| 824 | begin
|
|---|
| 825 | if Res /= E_Ok then
|
|---|
| 826 | Eti_Exception (Res);
|
|---|
| 827 | end if;
|
|---|
| 828 | end Set_Item_Term_Hook;
|
|---|
| 829 |
|
|---|
| 830 | procedure Set_Menu_Init_Hook (Men : in Menu;
|
|---|
| 831 | Proc : in Menu_Hook_Function)
|
|---|
| 832 | is
|
|---|
| 833 | function Set_Menu_Init (Men : Menu;
|
|---|
| 834 | Proc : Menu_Hook_Function) return C_Int;
|
|---|
| 835 | pragma Import (C, Set_Menu_Init, "set_menu_init");
|
|---|
| 836 |
|
|---|
| 837 | Res : constant Eti_Error := Set_Menu_Init (Men, Proc);
|
|---|
| 838 | begin
|
|---|
| 839 | if Res /= E_Ok then
|
|---|
| 840 | Eti_Exception (Res);
|
|---|
| 841 | end if;
|
|---|
| 842 | end Set_Menu_Init_Hook;
|
|---|
| 843 |
|
|---|
| 844 | procedure Set_Menu_Term_Hook (Men : in Menu;
|
|---|
| 845 | Proc : in Menu_Hook_Function)
|
|---|
| 846 | is
|
|---|
| 847 | function Set_Menu_Term (Men : Menu;
|
|---|
| 848 | Proc : Menu_Hook_Function) return C_Int;
|
|---|
| 849 | pragma Import (C, Set_Menu_Term, "set_menu_term");
|
|---|
| 850 |
|
|---|
| 851 | Res : constant Eti_Error := Set_Menu_Term (Men, Proc);
|
|---|
| 852 | begin
|
|---|
| 853 | if Res /= E_Ok then
|
|---|
| 854 | Eti_Exception (Res);
|
|---|
| 855 | end if;
|
|---|
| 856 | end Set_Menu_Term_Hook;
|
|---|
| 857 |
|
|---|
| 858 | function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function
|
|---|
| 859 | is
|
|---|
| 860 | function Item_Init (Men : Menu) return Menu_Hook_Function;
|
|---|
| 861 | pragma Import (C, Item_Init, "item_init");
|
|---|
| 862 | begin
|
|---|
| 863 | return Item_Init (Men);
|
|---|
| 864 | end Get_Item_Init_Hook;
|
|---|
| 865 |
|
|---|
| 866 | function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function
|
|---|
| 867 | is
|
|---|
| 868 | function Item_Term (Men : Menu) return Menu_Hook_Function;
|
|---|
| 869 | pragma Import (C, Item_Term, "item_term");
|
|---|
| 870 | begin
|
|---|
| 871 | return Item_Term (Men);
|
|---|
| 872 | end Get_Item_Term_Hook;
|
|---|
| 873 |
|
|---|
| 874 | function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function
|
|---|
| 875 | is
|
|---|
| 876 | function Menu_Init (Men : Menu) return Menu_Hook_Function;
|
|---|
| 877 | pragma Import (C, Menu_Init, "menu_init");
|
|---|
| 878 | begin
|
|---|
| 879 | return Menu_Init (Men);
|
|---|
| 880 | end Get_Menu_Init_Hook;
|
|---|
| 881 |
|
|---|
| 882 | function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function
|
|---|
| 883 | is
|
|---|
| 884 | function Menu_Term (Men : Menu) return Menu_Hook_Function;
|
|---|
| 885 | pragma Import (C, Menu_Term, "menu_term");
|
|---|
| 886 | begin
|
|---|
| 887 | return Menu_Term (Men);
|
|---|
| 888 | end Get_Menu_Term_Hook;
|
|---|
| 889 | -------------------------------------------------------------------------------
|
|---|
| 890 | procedure Redefine (Men : in Menu;
|
|---|
| 891 | Items : in Item_Array_Access)
|
|---|
| 892 | is
|
|---|
| 893 | function Set_Items (Men : Menu;
|
|---|
| 894 | Items : System.Address) return C_Int;
|
|---|
| 895 | pragma Import (C, Set_Items, "set_menu_items");
|
|---|
| 896 |
|
|---|
| 897 | Res : Eti_Error;
|
|---|
| 898 | begin
|
|---|
| 899 | pragma Assert (Items (Items'Last) = Null_Item);
|
|---|
| 900 | if Items (Items'Last) /= Null_Item then
|
|---|
| 901 | raise Menu_Exception;
|
|---|
| 902 | else
|
|---|
| 903 | Res := Set_Items (Men, Items.all'Address);
|
|---|
| 904 | if Res /= E_Ok then
|
|---|
| 905 | Eti_Exception (Res);
|
|---|
| 906 | end if;
|
|---|
| 907 | end if;
|
|---|
| 908 | end Redefine;
|
|---|
| 909 |
|
|---|
| 910 | function Item_Count (Men : Menu) return Natural
|
|---|
| 911 | is
|
|---|
| 912 | function Count (Men : Menu) return C_Int;
|
|---|
| 913 | pragma Import (C, Count, "item_count");
|
|---|
| 914 | begin
|
|---|
| 915 | return Natural (Count (Men));
|
|---|
| 916 | end Item_Count;
|
|---|
| 917 |
|
|---|
| 918 | function Items (Men : Menu;
|
|---|
| 919 | Index : Positive) return Item
|
|---|
| 920 | is
|
|---|
| 921 | use I_Array;
|
|---|
| 922 |
|
|---|
| 923 | function C_Mitems (Men : Menu) return Pointer;
|
|---|
| 924 | pragma Import (C, C_Mitems, "menu_items");
|
|---|
| 925 |
|
|---|
| 926 | P : Pointer := C_Mitems (Men);
|
|---|
| 927 | begin
|
|---|
| 928 | if P = null or else Index not in 1 .. Item_Count (Men) then
|
|---|
| 929 | raise Menu_Exception;
|
|---|
| 930 | else
|
|---|
| 931 | P := P + ptrdiff_t (C_Int (Index) - 1);
|
|---|
| 932 | return P.all;
|
|---|
| 933 | end if;
|
|---|
| 934 | end Items;
|
|---|
| 935 |
|
|---|
| 936 | -------------------------------------------------------------------------------
|
|---|
| 937 | function Create (Items : Item_Array_Access) return Menu
|
|---|
| 938 | is
|
|---|
| 939 | function Newmenu (Items : System.Address) return Menu;
|
|---|
| 940 | pragma Import (C, Newmenu, "new_menu");
|
|---|
| 941 |
|
|---|
| 942 | M : Menu;
|
|---|
| 943 | begin
|
|---|
| 944 | pragma Assert (Items (Items'Last) = Null_Item);
|
|---|
| 945 | if Items (Items'Last) /= Null_Item then
|
|---|
| 946 | raise Menu_Exception;
|
|---|
| 947 | else
|
|---|
| 948 | M := Newmenu (Items.all'Address);
|
|---|
| 949 | if M = Null_Menu then
|
|---|
| 950 | raise Menu_Exception;
|
|---|
| 951 | end if;
|
|---|
| 952 | return M;
|
|---|
| 953 | end if;
|
|---|
| 954 | end Create;
|
|---|
| 955 |
|
|---|
| 956 | procedure Delete (Men : in out Menu)
|
|---|
| 957 | is
|
|---|
| 958 | function Free (Men : Menu) return C_Int;
|
|---|
| 959 | pragma Import (C, Free, "free_menu");
|
|---|
| 960 |
|
|---|
| 961 | Res : constant Eti_Error := Free (Men);
|
|---|
| 962 | begin
|
|---|
| 963 | if Res /= E_Ok then
|
|---|
| 964 | Eti_Exception (Res);
|
|---|
| 965 | end if;
|
|---|
| 966 | Men := Null_Menu;
|
|---|
| 967 | end Delete;
|
|---|
| 968 |
|
|---|
| 969 | ------------------------------------------------------------------------------
|
|---|
| 970 | function Driver (Men : Menu;
|
|---|
| 971 | Key : Key_Code) return Driver_Result
|
|---|
| 972 | is
|
|---|
| 973 | function Driver (Men : Menu;
|
|---|
| 974 | Key : C_Int) return C_Int;
|
|---|
| 975 | pragma Import (C, Driver, "menu_driver");
|
|---|
| 976 |
|
|---|
| 977 | R : constant Eti_Error := Driver (Men, C_Int (Key));
|
|---|
| 978 | begin
|
|---|
| 979 | if R /= E_Ok then
|
|---|
| 980 | case R is
|
|---|
| 981 | when E_Unknown_Command => return Unknown_Request;
|
|---|
| 982 | when E_No_Match => return No_Match;
|
|---|
| 983 | when E_Request_Denied |
|
|---|
| 984 | E_Not_Selectable => return Request_Denied;
|
|---|
| 985 | when others =>
|
|---|
| 986 | Eti_Exception (R);
|
|---|
| 987 | end case;
|
|---|
| 988 | end if;
|
|---|
| 989 | return Menu_Ok;
|
|---|
| 990 | end Driver;
|
|---|
| 991 |
|
|---|
| 992 | procedure Free (IA : in out Item_Array_Access;
|
|---|
| 993 | Free_Items : in Boolean := False)
|
|---|
| 994 | is
|
|---|
| 995 | procedure Release is new Ada.Unchecked_Deallocation
|
|---|
| 996 | (Item_Array, Item_Array_Access);
|
|---|
| 997 | begin
|
|---|
| 998 | if IA /= null and then Free_Items then
|
|---|
| 999 | for I in IA'First .. (IA'Last - 1) loop
|
|---|
| 1000 | if IA (I) /= Null_Item then
|
|---|
| 1001 | Delete (IA (I));
|
|---|
| 1002 | end if;
|
|---|
| 1003 | end loop;
|
|---|
| 1004 | end if;
|
|---|
| 1005 | Release (IA);
|
|---|
| 1006 | end Free;
|
|---|
| 1007 |
|
|---|
| 1008 | -------------------------------------------------------------------------------
|
|---|
| 1009 | function Default_Menu_Options return Menu_Option_Set
|
|---|
| 1010 | is
|
|---|
| 1011 | begin
|
|---|
| 1012 | return Get_Options (Null_Menu);
|
|---|
| 1013 | end Default_Menu_Options;
|
|---|
| 1014 |
|
|---|
| 1015 | function Default_Item_Options return Item_Option_Set
|
|---|
| 1016 | is
|
|---|
| 1017 | begin
|
|---|
| 1018 | return Get_Options (Null_Item);
|
|---|
| 1019 | end Default_Item_Options;
|
|---|
| 1020 | -------------------------------------------------------------------------------
|
|---|
| 1021 |
|
|---|
| 1022 | end Terminal_Interface.Curses.Menus;
|
|---|
