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------------------------------------------------------------------------------ 43with Ada.Unchecked_Deallocation; 44with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; 45 46with Interfaces.C; use Interfaces.C; 47with Interfaces.C.Strings; use Interfaces.C.Strings; 48with Interfaces.C.Pointers; 49 50package 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 904end Terminal_Interface.Curses.Menus; 905