Ada95/src/terminal_interface-curses-menus.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                           GNAT ncurses Binding                           --
   4 --                                                                          --
   5 --                      Terminal_Interface.Curses.Menus                     --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright (c) 1998-2009,2011 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.28 $
  39 --  $Date: 2011/03/22 23:38:12 $
  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  : 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   : Item;
 153                         Value : 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     : Item;
 192                           Options : 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     : Item;
 208                              Options : 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     : 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  : 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 : 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         : 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 : 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 : Menu;
 285                           Itm : 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  : Menu;
 312                           Line : 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  : Menu;
 352                    Post : 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     : Menu;
 372                           Options : 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     : Menu;
 388                              Options : Menu_Option_Set;
 389                              On      : 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     : 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 : Menu;
 431                          Win : 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 : Menu;
 455                              Win : 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     : 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  : Menu;
 511                        Mark : 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  : 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   : Menu;
 549       Fore  : Character_Attribute_Set := Normal_Video;
 550       Color : 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  : 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   : 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   : Menu;
 588       Back  : Character_Attribute_Set := Normal_Video;
 589       Color : 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  : 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   : 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   : Menu;
 626                        Grey  : Character_Attribute_Set := Normal_Video;
 627                        Color : 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  : 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  : 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 : Menu;
 665                                 Pad : 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 : 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   : Menu;
 689                           Descr : Column_Position := 0;
 690                           Row   : Line_Position   := 0;
 691                           Col   : 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   : 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  : 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     : Menu;
 765                          Lines   : Line_Count;
 766                          Columns : 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     : 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  : Menu;
 803                                  Proc : 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  : Menu;
 817                                  Proc : 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  : Menu;
 831                                  Proc : 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  : Menu;
 845                                  Proc : 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   : Menu;
 891                        Items : 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.all (Items'Last) = Null_Item);
 900       if Items.all (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 > 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.all (Items'Last) = Null_Item);
 945       if Items.all (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 : 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.all (I) /= Null_Item then
1001                Delete (IA.all (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;