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