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