1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding -- 4-- -- 5-- Terminal_Interface.Curses.Forms -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright 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.33 $ 40-- $Date: 2020/02/02 23:34:34 $ 41-- Binding Version 01.00 42------------------------------------------------------------------------------ 43with Ada.Unchecked_Deallocation; 44 45with Interfaces.C; use Interfaces.C; 46with Interfaces.C.Strings; use Interfaces.C.Strings; 47with Interfaces.C.Pointers; 48 49with Terminal_Interface.Curses.Aux; 50 51package body Terminal_Interface.Curses.Forms is 52 53 use Terminal_Interface.Curses.Aux; 54 55 type C_Field_Array is array (Natural range <>) of aliased Field; 56 package F_Array is new 57 Interfaces.C.Pointers (Natural, Field, C_Field_Array, Null_Field); 58 59------------------------------------------------------------------------------ 60 -- | 61 -- | 62 -- | 63 -- subtype chars_ptr is Interfaces.C.Strings.chars_ptr; 64 65 procedure Request_Name (Key : Form_Request_Code; 66 Name : out String) 67 is 68 function Form_Request_Name (Key : C_Int) return chars_ptr; 69 pragma Import (C, Form_Request_Name, "form_request_name"); 70 begin 71 Fill_String (Form_Request_Name (C_Int (Key)), Name); 72 end Request_Name; 73 74 function Request_Name (Key : Form_Request_Code) return String 75 is 76 function Form_Request_Name (Key : C_Int) return chars_ptr; 77 pragma Import (C, Form_Request_Name, "form_request_name"); 78 begin 79 return Fill_String (Form_Request_Name (C_Int (Key))); 80 end Request_Name; 81------------------------------------------------------------------------------ 82 -- | 83 -- | 84 -- | 85 -- | 86 -- |===================================================================== 87 -- | man page form_field_new.3x 88 -- |===================================================================== 89 -- | 90 -- | 91 -- | 92 function Create (Height : Line_Count; 93 Width : Column_Count; 94 Top : Line_Position; 95 Left : Column_Position; 96 Off_Screen : Natural := 0; 97 More_Buffers : Buffer_Number := Buffer_Number'First) 98 return Field 99 is 100 function Newfield (H, W, T, L, O, M : C_Int) return Field; 101 pragma Import (C, Newfield, "new_field"); 102 Fld : constant Field := Newfield (C_Int (Height), C_Int (Width), 103 C_Int (Top), C_Int (Left), 104 C_Int (Off_Screen), 105 C_Int (More_Buffers)); 106 begin 107 if Fld = Null_Field then 108 raise Form_Exception; 109 end if; 110 return Fld; 111 end Create; 112-- | 113-- | 114-- | 115 procedure Delete (Fld : in out Field) 116 is 117 function Free_Field (Fld : Field) return Eti_Error; 118 pragma Import (C, Free_Field, "free_field"); 119 120 begin 121 Eti_Exception (Free_Field (Fld)); 122 Fld := Null_Field; 123 end Delete; 124 -- | 125 -- | 126 -- | 127 function Duplicate (Fld : Field; 128 Top : Line_Position; 129 Left : Column_Position) return Field 130 is 131 function Dup_Field (Fld : Field; 132 Top : C_Int; 133 Left : C_Int) return Field; 134 pragma Import (C, Dup_Field, "dup_field"); 135 136 F : constant Field := Dup_Field (Fld, 137 C_Int (Top), 138 C_Int (Left)); 139 begin 140 if F = Null_Field then 141 raise Form_Exception; 142 end if; 143 return F; 144 end Duplicate; 145 -- | 146 -- | 147 -- | 148 function Link (Fld : Field; 149 Top : Line_Position; 150 Left : Column_Position) return Field 151 is 152 function Lnk_Field (Fld : Field; 153 Top : C_Int; 154 Left : C_Int) return Field; 155 pragma Import (C, Lnk_Field, "link_field"); 156 157 F : constant Field := Lnk_Field (Fld, 158 C_Int (Top), 159 C_Int (Left)); 160 begin 161 if F = Null_Field then 162 raise Form_Exception; 163 end if; 164 return F; 165 end Link; 166 -- | 167 -- |===================================================================== 168 -- | man page form_field_just.3x 169 -- |===================================================================== 170 -- | 171 -- | 172 -- | 173 procedure Set_Justification (Fld : Field; 174 Just : Field_Justification := None) 175 is 176 function Set_Field_Just (Fld : Field; 177 Just : C_Int) return Eti_Error; 178 pragma Import (C, Set_Field_Just, "set_field_just"); 179 180 begin 181 Eti_Exception (Set_Field_Just (Fld, 182 C_Int (Field_Justification'Pos (Just)))); 183 end Set_Justification; 184 -- | 185 -- | 186 -- | 187 function Get_Justification (Fld : Field) return Field_Justification 188 is 189 function Field_Just (Fld : Field) return C_Int; 190 pragma Import (C, Field_Just, "field_just"); 191 begin 192 return Field_Justification'Val (Field_Just (Fld)); 193 end Get_Justification; 194 -- | 195 -- |===================================================================== 196 -- | man page form_field_buffer.3x 197 -- |===================================================================== 198 -- | 199 -- | 200 -- | 201 procedure Set_Buffer 202 (Fld : Field; 203 Buffer : Buffer_Number := Buffer_Number'First; 204 Str : String) 205 is 206 function Set_Fld_Buffer (Fld : Field; 207 Bufnum : C_Int; 208 S : char_array) 209 return Eti_Error; 210 pragma Import (C, Set_Fld_Buffer, "set_field_buffer"); 211 212 begin 213 Eti_Exception (Set_Fld_Buffer (Fld, C_Int (Buffer), To_C (Str))); 214 end Set_Buffer; 215 -- | 216 -- | 217 -- | 218 procedure Get_Buffer 219 (Fld : Field; 220 Buffer : Buffer_Number := Buffer_Number'First; 221 Str : out String) 222 is 223 function Field_Buffer (Fld : Field; 224 B : C_Int) return chars_ptr; 225 pragma Import (C, Field_Buffer, "field_buffer"); 226 begin 227 Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str); 228 end Get_Buffer; 229 230 function Get_Buffer 231 (Fld : Field; 232 Buffer : Buffer_Number := Buffer_Number'First) return String 233 is 234 function Field_Buffer (Fld : Field; 235 B : C_Int) return chars_ptr; 236 pragma Import (C, Field_Buffer, "field_buffer"); 237 begin 238 return Fill_String (Field_Buffer (Fld, C_Int (Buffer))); 239 end Get_Buffer; 240 -- | 241 -- | 242 -- | 243 procedure Set_Status (Fld : Field; 244 Status : Boolean := True) 245 is 246 function Set_Fld_Status (Fld : Field; 247 St : C_Int) return Eti_Error; 248 pragma Import (C, Set_Fld_Status, "set_field_status"); 249 250 begin 251 if Set_Fld_Status (Fld, Boolean'Pos (Status)) /= E_Ok then 252 raise Form_Exception; 253 end if; 254 end Set_Status; 255 -- | 256 -- | 257 -- | 258 function Changed (Fld : Field) return Boolean 259 is 260 function Field_Status (Fld : Field) return C_Int; 261 pragma Import (C, Field_Status, "field_status"); 262 263 Res : constant C_Int := Field_Status (Fld); 264 begin 265 if Res = Curses_False then 266 return False; 267 else 268 return True; 269 end if; 270 end Changed; 271 -- | 272 -- | 273 -- | 274 procedure Set_Maximum_Size (Fld : Field; 275 Max : Natural := 0) 276 is 277 function Set_Field_Max (Fld : Field; 278 M : C_Int) return Eti_Error; 279 pragma Import (C, Set_Field_Max, "set_max_field"); 280 281 begin 282 Eti_Exception (Set_Field_Max (Fld, C_Int (Max))); 283 end Set_Maximum_Size; 284 -- | 285 -- |===================================================================== 286 -- | man page form_field_opts.3x 287 -- |===================================================================== 288 -- | 289 -- | 290 -- | 291 procedure Set_Options (Fld : Field; 292 Options : Field_Option_Set) 293 is 294 function Set_Field_Opts (Fld : Field; 295 Opt : Field_Option_Set) return Eti_Error; 296 pragma Import (C, Set_Field_Opts, "set_field_opts"); 297 298 begin 299 Eti_Exception (Set_Field_Opts (Fld, Options)); 300 end Set_Options; 301 -- | 302 -- | 303 -- | 304 procedure Switch_Options (Fld : Field; 305 Options : Field_Option_Set; 306 On : Boolean := True) 307 is 308 function Field_Opts_On (Fld : Field; 309 Opt : Field_Option_Set) return Eti_Error; 310 pragma Import (C, Field_Opts_On, "field_opts_on"); 311 function Field_Opts_Off (Fld : Field; 312 Opt : Field_Option_Set) return Eti_Error; 313 pragma Import (C, Field_Opts_Off, "field_opts_off"); 314 315 begin 316 if On then 317 Eti_Exception (Field_Opts_On (Fld, Options)); 318 else 319 Eti_Exception (Field_Opts_Off (Fld, Options)); 320 end if; 321 end Switch_Options; 322 -- | 323 -- | 324 -- | 325 procedure Get_Options (Fld : Field; 326 Options : out Field_Option_Set) 327 is 328 function Field_Opts (Fld : Field) return Field_Option_Set; 329 pragma Import (C, Field_Opts, "field_opts"); 330 331 begin 332 Options := Field_Opts (Fld); 333 end Get_Options; 334 -- | 335 -- | 336 -- | 337 function Get_Options (Fld : Field := Null_Field) 338 return Field_Option_Set 339 is 340 Fos : Field_Option_Set; 341 begin 342 Get_Options (Fld, Fos); 343 return Fos; 344 end Get_Options; 345 -- | 346 -- |===================================================================== 347 -- | man page form_field_attributes.3x 348 -- |===================================================================== 349 -- | 350 -- | 351 -- | 352 procedure Set_Foreground 353 (Fld : Field; 354 Fore : Character_Attribute_Set := Normal_Video; 355 Color : Color_Pair := Color_Pair'First) 356 is 357 function Set_Field_Fore (Fld : Field; 358 Attr : Attributed_Character) return Eti_Error; 359 pragma Import (C, Set_Field_Fore, "set_field_fore"); 360 361 begin 362 Eti_Exception (Set_Field_Fore (Fld, (Ch => Character'First, 363 Color => Color, 364 Attr => Fore))); 365 end Set_Foreground; 366 -- | 367 -- | 368 -- | 369 procedure Foreground (Fld : Field; 370 Fore : out Character_Attribute_Set) 371 is 372 function Field_Fore (Fld : Field) return Attributed_Character; 373 pragma Import (C, Field_Fore, "field_fore"); 374 begin 375 Fore := Field_Fore (Fld).Attr; 376 end Foreground; 377 378 procedure Foreground (Fld : Field; 379 Fore : out Character_Attribute_Set; 380 Color : out Color_Pair) 381 is 382 function Field_Fore (Fld : Field) return Attributed_Character; 383 pragma Import (C, Field_Fore, "field_fore"); 384 begin 385 Fore := Field_Fore (Fld).Attr; 386 Color := Field_Fore (Fld).Color; 387 end Foreground; 388 -- | 389 -- | 390 -- | 391 procedure Set_Background 392 (Fld : Field; 393 Back : Character_Attribute_Set := Normal_Video; 394 Color : Color_Pair := Color_Pair'First) 395 is 396 function Set_Field_Back (Fld : Field; 397 Attr : Attributed_Character) return Eti_Error; 398 pragma Import (C, Set_Field_Back, "set_field_back"); 399 400 begin 401 Eti_Exception (Set_Field_Back (Fld, (Ch => Character'First, 402 Color => Color, 403 Attr => Back))); 404 end Set_Background; 405 -- | 406 -- | 407 -- | 408 procedure Background (Fld : Field; 409 Back : out Character_Attribute_Set) 410 is 411 function Field_Back (Fld : Field) return Attributed_Character; 412 pragma Import (C, Field_Back, "field_back"); 413 begin 414 Back := Field_Back (Fld).Attr; 415 end Background; 416 417 procedure Background (Fld : Field; 418 Back : out Character_Attribute_Set; 419 Color : out Color_Pair) 420 is 421 function Field_Back (Fld : Field) return Attributed_Character; 422 pragma Import (C, Field_Back, "field_back"); 423 begin 424 Back := Field_Back (Fld).Attr; 425 Color := Field_Back (Fld).Color; 426 end Background; 427 -- | 428 -- | 429 -- | 430 procedure Set_Pad_Character (Fld : Field; 431 Pad : Character := Space) 432 is 433 function Set_Field_Pad (Fld : Field; 434 Ch : C_Int) return Eti_Error; 435 pragma Import (C, Set_Field_Pad, "set_field_pad"); 436 437 begin 438 Eti_Exception (Set_Field_Pad (Fld, 439 C_Int (Character'Pos (Pad)))); 440 end Set_Pad_Character; 441 -- | 442 -- | 443 -- | 444 procedure Pad_Character (Fld : Field; 445 Pad : out Character) 446 is 447 function Field_Pad (Fld : Field) return C_Int; 448 pragma Import (C, Field_Pad, "field_pad"); 449 begin 450 Pad := Character'Val (Field_Pad (Fld)); 451 end Pad_Character; 452 -- | 453 -- |===================================================================== 454 -- | man page form_field_info.3x 455 -- |===================================================================== 456 -- | 457 -- | 458 -- | 459 procedure Info (Fld : Field; 460 Lines : out Line_Count; 461 Columns : out Column_Count; 462 First_Row : out Line_Position; 463 First_Column : out Column_Position; 464 Off_Screen : out Natural; 465 Additional_Buffers : out Buffer_Number) 466 is 467 type C_Int_Access is access all C_Int; 468 function Fld_Info (Fld : Field; 469 L, C, Fr, Fc, Os, Ab : C_Int_Access) 470 return Eti_Error; 471 pragma Import (C, Fld_Info, "field_info"); 472 473 L, C, Fr, Fc, Os, Ab : aliased C_Int; 474 begin 475 Eti_Exception (Fld_Info (Fld, 476 L'Access, C'Access, 477 Fr'Access, Fc'Access, 478 Os'Access, Ab'Access)); 479 Lines := Line_Count (L); 480 Columns := Column_Count (C); 481 First_Row := Line_Position (Fr); 482 First_Column := Column_Position (Fc); 483 Off_Screen := Natural (Os); 484 Additional_Buffers := Buffer_Number (Ab); 485 end Info; 486-- | 487-- | 488-- | 489 procedure Dynamic_Info (Fld : Field; 490 Lines : out Line_Count; 491 Columns : out Column_Count; 492 Max : out Natural) 493 is 494 type C_Int_Access is access all C_Int; 495 function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return Eti_Error; 496 pragma Import (C, Dyn_Info, "dynamic_field_info"); 497 498 L, C, M : aliased C_Int; 499 begin 500 Eti_Exception (Dyn_Info (Fld, 501 L'Access, C'Access, 502 M'Access)); 503 Lines := Line_Count (L); 504 Columns := Column_Count (C); 505 Max := Natural (M); 506 end Dynamic_Info; 507 -- | 508 -- |===================================================================== 509 -- | man page form_win.3x 510 -- |===================================================================== 511 -- | 512 -- | 513 -- | 514 procedure Set_Window (Frm : Form; 515 Win : Window) 516 is 517 function Set_Form_Win (Frm : Form; 518 Win : Window) return Eti_Error; 519 pragma Import (C, Set_Form_Win, "set_form_win"); 520 521 begin 522 Eti_Exception (Set_Form_Win (Frm, Win)); 523 end Set_Window; 524 -- | 525 -- | 526 -- | 527 function Get_Window (Frm : Form) return Window 528 is 529 function Form_Win (Frm : Form) return Window; 530 pragma Import (C, Form_Win, "form_win"); 531 532 W : constant Window := Form_Win (Frm); 533 begin 534 return W; 535 end Get_Window; 536 -- | 537 -- | 538 -- | 539 procedure Set_Sub_Window (Frm : Form; 540 Win : Window) 541 is 542 function Set_Form_Sub (Frm : Form; 543 Win : Window) return Eti_Error; 544 pragma Import (C, Set_Form_Sub, "set_form_sub"); 545 546 begin 547 Eti_Exception (Set_Form_Sub (Frm, Win)); 548 end Set_Sub_Window; 549 -- | 550 -- | 551 -- | 552 function Get_Sub_Window (Frm : Form) return Window 553 is 554 function Form_Sub (Frm : Form) return Window; 555 pragma Import (C, Form_Sub, "form_sub"); 556 557 W : constant Window := Form_Sub (Frm); 558 begin 559 return W; 560 end Get_Sub_Window; 561 -- | 562 -- | 563 -- | 564 procedure Scale (Frm : Form; 565 Lines : out Line_Count; 566 Columns : out Column_Count) 567 is 568 type C_Int_Access is access all C_Int; 569 function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return Eti_Error; 570 pragma Import (C, M_Scale, "scale_form"); 571 572 X, Y : aliased C_Int; 573 begin 574 Eti_Exception (M_Scale (Frm, Y'Access, X'Access)); 575 Lines := Line_Count (Y); 576 Columns := Column_Count (X); 577 end Scale; 578 -- | 579 -- |===================================================================== 580 -- | man page menu_hook.3x 581 -- |===================================================================== 582 -- | 583 -- | 584 -- | 585 procedure Set_Field_Init_Hook (Frm : Form; 586 Proc : Form_Hook_Function) 587 is 588 function Set_Field_Init (Frm : Form; 589 Proc : Form_Hook_Function) return Eti_Error; 590 pragma Import (C, Set_Field_Init, "set_field_init"); 591 592 begin 593 Eti_Exception (Set_Field_Init (Frm, Proc)); 594 end Set_Field_Init_Hook; 595 -- | 596 -- | 597 -- | 598 procedure Set_Field_Term_Hook (Frm : Form; 599 Proc : Form_Hook_Function) 600 is 601 function Set_Field_Term (Frm : Form; 602 Proc : Form_Hook_Function) return Eti_Error; 603 pragma Import (C, Set_Field_Term, "set_field_term"); 604 605 begin 606 Eti_Exception (Set_Field_Term (Frm, Proc)); 607 end Set_Field_Term_Hook; 608 -- | 609 -- | 610 -- | 611 procedure Set_Form_Init_Hook (Frm : Form; 612 Proc : Form_Hook_Function) 613 is 614 function Set_Form_Init (Frm : Form; 615 Proc : Form_Hook_Function) return Eti_Error; 616 pragma Import (C, Set_Form_Init, "set_form_init"); 617 618 begin 619 Eti_Exception (Set_Form_Init (Frm, Proc)); 620 end Set_Form_Init_Hook; 621 -- | 622 -- | 623 -- | 624 procedure Set_Form_Term_Hook (Frm : Form; 625 Proc : Form_Hook_Function) 626 is 627 function Set_Form_Term (Frm : Form; 628 Proc : Form_Hook_Function) return Eti_Error; 629 pragma Import (C, Set_Form_Term, "set_form_term"); 630 631 begin 632 Eti_Exception (Set_Form_Term (Frm, Proc)); 633 end Set_Form_Term_Hook; 634 -- | 635 -- |===================================================================== 636 -- | man page form_fields.3x 637 -- |===================================================================== 638 -- | 639 -- | 640 -- | 641 procedure Redefine (Frm : Form; 642 Flds : Field_Array_Access) 643 is 644 function Set_Frm_Fields (Frm : Form; 645 Items : System.Address) return Eti_Error; 646 pragma Import (C, Set_Frm_Fields, "set_form_fields"); 647 648 begin 649 pragma Assert (Flds.all (Flds'Last) = Null_Field); 650 if Flds.all (Flds'Last) /= Null_Field then 651 raise Form_Exception; 652 else 653 Eti_Exception (Set_Frm_Fields (Frm, Flds.all (Flds'First)'Address)); 654 end if; 655 end Redefine; 656 -- | 657 -- | 658 -- | 659 function Fields (Frm : Form; 660 Index : Positive) return Field 661 is 662 use F_Array; 663 664 function C_Fields (Frm : Form) return Pointer; 665 pragma Import (C, C_Fields, "form_fields"); 666 667 P : Pointer := C_Fields (Frm); 668 begin 669 if P = null or else Index > Field_Count (Frm) then 670 raise Form_Exception; 671 else 672 P := P + ptrdiff_t (C_Int (Index) - 1); 673 return P.all; 674 end if; 675 end Fields; 676 -- | 677 -- | 678 -- | 679 function Field_Count (Frm : Form) return Natural 680 is 681 function Count (Frm : Form) return C_Int; 682 pragma Import (C, Count, "field_count"); 683 begin 684 return Natural (Count (Frm)); 685 end Field_Count; 686 -- | 687 -- | 688 -- | 689 procedure Move (Fld : Field; 690 Line : Line_Position; 691 Column : Column_Position) 692 is 693 function Move (Fld : Field; L, C : C_Int) return Eti_Error; 694 pragma Import (C, Move, "move_field"); 695 696 begin 697 Eti_Exception (Move (Fld, C_Int (Line), C_Int (Column))); 698 end Move; 699 -- | 700 -- |===================================================================== 701 -- | man page form_new.3x 702 -- |===================================================================== 703 -- | 704 -- | 705 -- | 706 function Create (Fields : Field_Array_Access) return Form 707 is 708 function NewForm (Fields : System.Address) return Form; 709 pragma Import (C, NewForm, "new_form"); 710 711 M : Form; 712 begin 713 pragma Assert (Fields.all (Fields'Last) = Null_Field); 714 if Fields.all (Fields'Last) /= Null_Field then 715 raise Form_Exception; 716 else 717 M := NewForm (Fields.all (Fields'First)'Address); 718 if M = Null_Form then 719 raise Form_Exception; 720 end if; 721 return M; 722 end if; 723 end Create; 724 -- | 725 -- | 726 -- | 727 procedure Delete (Frm : in out Form) 728 is 729 function Free (Frm : Form) return Eti_Error; 730 pragma Import (C, Free, "free_form"); 731 732 begin 733 Eti_Exception (Free (Frm)); 734 Frm := Null_Form; 735 end Delete; 736 -- | 737 -- |===================================================================== 738 -- | man page form_opts.3x 739 -- |===================================================================== 740 -- | 741 -- | 742 -- | 743 procedure Set_Options (Frm : Form; 744 Options : Form_Option_Set) 745 is 746 function Set_Form_Opts (Frm : Form; 747 Opt : Form_Option_Set) return Eti_Error; 748 pragma Import (C, Set_Form_Opts, "set_form_opts"); 749 750 begin 751 Eti_Exception (Set_Form_Opts (Frm, Options)); 752 end Set_Options; 753 -- | 754 -- | 755 -- | 756 procedure Switch_Options (Frm : Form; 757 Options : Form_Option_Set; 758 On : Boolean := True) 759 is 760 function Form_Opts_On (Frm : Form; 761 Opt : Form_Option_Set) return Eti_Error; 762 pragma Import (C, Form_Opts_On, "form_opts_on"); 763 function Form_Opts_Off (Frm : Form; 764 Opt : Form_Option_Set) return Eti_Error; 765 pragma Import (C, Form_Opts_Off, "form_opts_off"); 766 767 begin 768 if On then 769 Eti_Exception (Form_Opts_On (Frm, Options)); 770 else 771 Eti_Exception (Form_Opts_Off (Frm, Options)); 772 end if; 773 end Switch_Options; 774 -- | 775 -- | 776 -- | 777 procedure Get_Options (Frm : Form; 778 Options : out Form_Option_Set) 779 is 780 function Form_Opts (Frm : Form) return Form_Option_Set; 781 pragma Import (C, Form_Opts, "form_opts"); 782 783 begin 784 Options := Form_Opts (Frm); 785 end Get_Options; 786 -- | 787 -- | 788 -- | 789 function Get_Options (Frm : Form := Null_Form) return Form_Option_Set 790 is 791 Fos : Form_Option_Set; 792 begin 793 Get_Options (Frm, Fos); 794 return Fos; 795 end Get_Options; 796 -- | 797 -- |===================================================================== 798 -- | man page form_post.3x 799 -- |===================================================================== 800 -- | 801 -- | 802 -- | 803 procedure Post (Frm : Form; 804 Post : Boolean := True) 805 is 806 function M_Post (Frm : Form) return Eti_Error; 807 pragma Import (C, M_Post, "post_form"); 808 function M_Unpost (Frm : Form) return Eti_Error; 809 pragma Import (C, M_Unpost, "unpost_form"); 810 811 begin 812 if Post then 813 Eti_Exception (M_Post (Frm)); 814 else 815 Eti_Exception (M_Unpost (Frm)); 816 end if; 817 end Post; 818 -- | 819 -- |===================================================================== 820 -- | man page form_cursor.3x 821 -- |===================================================================== 822 -- | 823 -- | 824 -- | 825 procedure Position_Cursor (Frm : Form) 826 is 827 function Pos_Form_Cursor (Frm : Form) return Eti_Error; 828 pragma Import (C, Pos_Form_Cursor, "pos_form_cursor"); 829 830 begin 831 Eti_Exception (Pos_Form_Cursor (Frm)); 832 end Position_Cursor; 833 -- | 834 -- |===================================================================== 835 -- | man page form_data.3x 836 -- |===================================================================== 837 -- | 838 -- | 839 -- | 840 function Data_Ahead (Frm : Form) return Boolean 841 is 842 function Ahead (Frm : Form) return C_Int; 843 pragma Import (C, Ahead, "data_ahead"); 844 845 Res : constant C_Int := Ahead (Frm); 846 begin 847 if Res = Curses_False then 848 return False; 849 else 850 return True; 851 end if; 852 end Data_Ahead; 853 -- | 854 -- | 855 -- | 856 function Data_Behind (Frm : Form) return Boolean 857 is 858 function Behind (Frm : Form) return C_Int; 859 pragma Import (C, Behind, "data_behind"); 860 861 Res : constant C_Int := Behind (Frm); 862 begin 863 if Res = Curses_False then 864 return False; 865 else 866 return True; 867 end if; 868 end Data_Behind; 869 -- | 870 -- |===================================================================== 871 -- | man page form_driver.3x 872 -- |===================================================================== 873 -- | 874 -- | 875 -- | 876 function Driver (Frm : Form; 877 Key : Key_Code) return Driver_Result 878 is 879 function Frm_Driver (Frm : Form; Key : C_Int) return Eti_Error; 880 pragma Import (C, Frm_Driver, "form_driver"); 881 882 R : constant Eti_Error := Frm_Driver (Frm, C_Int (Key)); 883 begin 884 case R is 885 when E_Unknown_Command => 886 return Unknown_Request; 887 when E_Invalid_Field => 888 return Invalid_Field; 889 when E_Request_Denied => 890 return Request_Denied; 891 when others => 892 Eti_Exception (R); 893 return Form_Ok; 894 end case; 895 end Driver; 896 -- | 897 -- |===================================================================== 898 -- | man page form_page.3x 899 -- |===================================================================== 900 -- | 901 -- | 902 -- | 903 procedure Set_Current (Frm : Form; 904 Fld : Field) 905 is 906 function Set_Current_Fld (Frm : Form; Fld : Field) return Eti_Error; 907 pragma Import (C, Set_Current_Fld, "set_current_field"); 908 909 begin 910 Eti_Exception (Set_Current_Fld (Frm, Fld)); 911 end Set_Current; 912 -- | 913 -- | 914 -- | 915 function Current (Frm : Form) return Field 916 is 917 function Current_Fld (Frm : Form) return Field; 918 pragma Import (C, Current_Fld, "current_field"); 919 920 Fld : constant Field := Current_Fld (Frm); 921 begin 922 if Fld = Null_Field then 923 raise Form_Exception; 924 end if; 925 return Fld; 926 end Current; 927 -- | 928 -- | 929 -- | 930 procedure Set_Page (Frm : Form; 931 Page : Page_Number := Page_Number'First) 932 is 933 function Set_Frm_Page (Frm : Form; Pg : C_Int) return Eti_Error; 934 pragma Import (C, Set_Frm_Page, "set_form_page"); 935 936 begin 937 Eti_Exception (Set_Frm_Page (Frm, C_Int (Page))); 938 end Set_Page; 939 -- | 940 -- | 941 -- | 942 function Page (Frm : Form) return Page_Number 943 is 944 function Get_Page (Frm : Form) return C_Int; 945 pragma Import (C, Get_Page, "form_page"); 946 947 P : constant C_Int := Get_Page (Frm); 948 begin 949 if P < 0 then 950 raise Form_Exception; 951 else 952 return Page_Number (P); 953 end if; 954 end Page; 955 956 function Get_Index (Fld : Field) return Positive 957 is 958 function Get_Fieldindex (Fld : Field) return C_Int; 959 pragma Import (C, Get_Fieldindex, "field_index"); 960 961 Res : constant C_Int := Get_Fieldindex (Fld); 962 begin 963 if Res = Curses_Err then 964 raise Form_Exception; 965 end if; 966 return Positive (Natural (Res) + Positive'First); 967 end Get_Index; 968 969 -- | 970 -- |===================================================================== 971 -- | man page form_new_page.3x 972 -- |===================================================================== 973 -- | 974 -- | 975 -- | 976 procedure Set_New_Page (Fld : Field; 977 New_Page : Boolean := True) 978 is 979 function Set_Page (Fld : Field; Flg : C_Int) return Eti_Error; 980 pragma Import (C, Set_Page, "set_new_page"); 981 982 begin 983 Eti_Exception (Set_Page (Fld, Boolean'Pos (New_Page))); 984 end Set_New_Page; 985 -- | 986 -- | 987 -- | 988 function Is_New_Page (Fld : Field) return Boolean 989 is 990 function Is_New (Fld : Field) return C_Int; 991 pragma Import (C, Is_New, "new_page"); 992 993 Res : constant C_Int := Is_New (Fld); 994 begin 995 if Res = Curses_False then 996 return False; 997 else 998 return True; 999 end if; 1000 end Is_New_Page; 1001 1002 procedure Free (FA : in out Field_Array_Access; 1003 Free_Fields : Boolean := False) 1004 is 1005 procedure Release is new Ada.Unchecked_Deallocation 1006 (Field_Array, Field_Array_Access); 1007 begin 1008 if FA /= null and then Free_Fields then 1009 for I in FA'First .. (FA'Last - 1) loop 1010 if FA.all (I) /= Null_Field then 1011 Delete (FA.all (I)); 1012 end if; 1013 end loop; 1014 end if; 1015 Release (FA); 1016 end Free; 1017 1018 -- |===================================================================== 1019 1020 function Default_Field_Options return Field_Option_Set 1021 is 1022 begin 1023 return Get_Options (Null_Field); 1024 end Default_Field_Options; 1025 1026 function Default_Form_Options return Form_Option_Set 1027 is 1028 begin 1029 return Get_Options (Null_Form); 1030 end Default_Form_Options; 1031 1032end Terminal_Interface.Curses.Forms; 1033