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