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