1-- -*- ada -*- 2define(`HTMLNAME',`terminal_interface-curses__adb.htm')dnl 3include(M4MACRO)------------------------------------------------------------------------------ 4-- -- 5-- GNAT ncurses Binding -- 6-- -- 7-- Terminal_Interface.Curses -- 8-- -- 9-- B O D Y -- 10-- -- 11------------------------------------------------------------------------------ 12-- Copyright 2018-2020,2024 Thomas E. Dickey -- 13-- Copyright 2007-2011,2014 Free Software Foundation, Inc. -- 14-- -- 15-- Permission is hereby granted, free of charge, to any person obtaining a -- 16-- copy of this software and associated documentation files (the -- 17-- "Software"), to deal in the Software without restriction, including -- 18-- without limitation the rights to use, copy, modify, merge, publish, -- 19-- distribute, distribute with modifications, sublicense, and/or sell -- 20-- copies of the Software, and to permit persons to whom the Software is -- 21-- furnished to do so, subject to the following conditions: -- 22-- -- 23-- The above copyright notice and this permission notice shall be included -- 24-- in all copies or substantial portions of the Software. -- 25-- -- 26-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- 27-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- 28-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- 29-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- 30-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- 31-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- 32-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- 33-- -- 34-- Except as contained in this notice, the name(s) of the above copyright -- 35-- holders shall not be used in advertising or otherwise to promote the -- 36-- sale, use or other dealings in this Software without prior written -- 37-- authorization. -- 38------------------------------------------------------------------------------ 39-- Author: Juergen Pfeifer, 1996 40-- Version Control: 41-- $Revision: 1.17 $ 42-- $Date: 2024/03/30 13:24:07 $ 43-- Binding Version 01.00 44------------------------------------------------------------------------------ 45with System; 46 47with Terminal_Interface.Curses.Aux; 48with Interfaces.C; use Interfaces.C; 49with Interfaces.C.Strings; use Interfaces.C.Strings; 50with Ada.Characters.Handling; use Ada.Characters.Handling; 51with Ada.Strings.Fixed; 52 53package body Terminal_Interface.Curses is 54 55 use Aux; 56 57 package ASF renames Ada.Strings.Fixed; 58 59 type chtype_array is array (size_t range <>) 60 of aliased Attributed_Character; 61 pragma Convention (C, chtype_array); 62 63------------------------------------------------------------------------------ 64 function Key_Name (Key : Real_Key_Code) return String 65 is 66 function Keyname (K : C_Int) return chars_ptr; 67 pragma Import (C, Keyname, "keyname"); 68 69 Ch : Character; 70 begin 71 if Key <= Character'Pos (Character'Last) then 72 Ch := Character'Val (Key); 73 if Is_Control (Ch) then 74 return Un_Control (Attributed_Character'(Ch => Ch, 75 Color => Color_Pair'First, 76 Attr => Normal_Video)); 77 elsif Is_Graphic (Ch) then 78 declare 79 S : String (1 .. 1); 80 begin 81 S (1) := Ch; 82 return S; 83 end; 84 else 85 return ""; 86 end if; 87 else 88 return Fill_String (Keyname (C_Int (Key))); 89 end if; 90 end Key_Name; 91 92 procedure Key_Name (Key : Real_Key_Code; 93 Name : out String) 94 is 95 begin 96 ASF.Move (Key_Name (Key), Name); 97 end Key_Name; 98 99------------------------------------------------------------------------------ 100 procedure Init_Screen 101 is 102 function Initscr return Window; 103 pragma Import (C, Initscr, "initscr"); 104 105 W : Window; 106 begin 107 W := Initscr; 108 if W = Null_Window then 109 raise Curses_Exception; 110 end if; 111 end Init_Screen; 112 113 procedure End_Windows 114 is 115 function Endwin return C_Int; 116 pragma Import (C, Endwin, "endwin"); 117 begin 118 if Endwin = Curses_Err then 119 raise Curses_Exception; 120 end if; 121 end End_Windows; 122 123 function Is_End_Window return Boolean 124 is 125 function Isendwin return Curses_Bool; 126 pragma Import (C, Isendwin, "isendwin"); 127 begin 128 if Isendwin = Curses_Bool_False then 129 return False; 130 else 131 return True; 132 end if; 133 end Is_End_Window; 134------------------------------------------------------------------------------ 135 procedure Move_Cursor (Win : Window := Standard_Window; 136 Line : Line_Position; 137 Column : Column_Position) 138 is 139 function Wmove (Win : Window; 140 Line : C_Int; 141 Column : C_Int 142 ) return C_Int; 143 pragma Import (C, Wmove, "wmove"); 144 begin 145 if Wmove (Win, C_Int (Line), C_Int (Column)) = Curses_Err then 146 raise Curses_Exception; 147 end if; 148 end Move_Cursor; 149------------------------------------------------------------------------------ 150 procedure Add (Win : Window := Standard_Window; 151 Ch : Attributed_Character) 152 is 153 function Waddch (W : Window; 154 Ch : Attributed_Character) return C_Int; 155 pragma Import (C, Waddch, "waddch"); 156 begin 157 if Waddch (Win, Ch) = Curses_Err then 158 raise Curses_Exception; 159 end if; 160 end Add; 161 162 procedure Add (Win : Window := Standard_Window; 163 Ch : Character) 164 is 165 begin 166 Add (Win, 167 Attributed_Character'(Ch => Ch, 168 Color => Color_Pair'First, 169 Attr => Normal_Video)); 170 end Add; 171 172 procedure Add 173 (Win : Window := Standard_Window; 174 Line : Line_Position; 175 Column : Column_Position; 176 Ch : Attributed_Character) 177 is 178 function mvwaddch (W : Window; 179 Y : C_Int; 180 X : C_Int; 181 Ch : Attributed_Character) return C_Int; 182 pragma Import (C, mvwaddch, "mvwaddch"); 183 begin 184 if mvwaddch (Win, C_Int (Line), 185 C_Int (Column), 186 Ch) = Curses_Err 187 then 188 raise Curses_Exception; 189 end if; 190 end Add; 191 192 procedure Add 193 (Win : Window := Standard_Window; 194 Line : Line_Position; 195 Column : Column_Position; 196 Ch : Character) 197 is 198 begin 199 Add (Win, 200 Line, 201 Column, 202 Attributed_Character'(Ch => Ch, 203 Color => Color_Pair'First, 204 Attr => Normal_Video)); 205 end Add; 206 207 procedure Add_With_Immediate_Echo 208 (Win : Window := Standard_Window; 209 Ch : Attributed_Character) 210 is 211 function Wechochar (W : Window; 212 Ch : Attributed_Character) return C_Int; 213 pragma Import (C, Wechochar, "wechochar"); 214 begin 215 if Wechochar (Win, Ch) = Curses_Err then 216 raise Curses_Exception; 217 end if; 218 end Add_With_Immediate_Echo; 219 220 procedure Add_With_Immediate_Echo 221 (Win : Window := Standard_Window; 222 Ch : Character) 223 is 224 begin 225 Add_With_Immediate_Echo 226 (Win, 227 Attributed_Character'(Ch => Ch, 228 Color => Color_Pair'First, 229 Attr => Normal_Video)); 230 end Add_With_Immediate_Echo; 231------------------------------------------------------------------------------ 232 function Create (Number_Of_Lines : Line_Count; 233 Number_Of_Columns : Column_Count; 234 First_Line_Position : Line_Position; 235 First_Column_Position : Column_Position) return Window 236 is 237 function Newwin (Number_Of_Lines : C_Int; 238 Number_Of_Columns : C_Int; 239 First_Line_Position : C_Int; 240 First_Column_Position : C_Int) return Window; 241 pragma Import (C, Newwin, "newwin"); 242 243 W : Window; 244 begin 245 W := Newwin (C_Int (Number_Of_Lines), 246 C_Int (Number_Of_Columns), 247 C_Int (First_Line_Position), 248 C_Int (First_Column_Position)); 249 if W = Null_Window then 250 raise Curses_Exception; 251 end if; 252 return W; 253 end Create; 254 255 procedure Delete (Win : in out Window) 256 is 257 function Wdelwin (W : Window) return C_Int; 258 pragma Import (C, Wdelwin, "delwin"); 259 begin 260 if Wdelwin (Win) = Curses_Err then 261 raise Curses_Exception; 262 end if; 263 Win := Null_Window; 264 end Delete; 265 266 function Sub_Window 267 (Win : Window := Standard_Window; 268 Number_Of_Lines : Line_Count; 269 Number_Of_Columns : Column_Count; 270 First_Line_Position : Line_Position; 271 First_Column_Position : Column_Position) return Window 272 is 273 function Subwin 274 (Win : Window; 275 Number_Of_Lines : C_Int; 276 Number_Of_Columns : C_Int; 277 First_Line_Position : C_Int; 278 First_Column_Position : C_Int) return Window; 279 pragma Import (C, Subwin, "subwin"); 280 281 W : Window; 282 begin 283 W := Subwin (Win, 284 C_Int (Number_Of_Lines), 285 C_Int (Number_Of_Columns), 286 C_Int (First_Line_Position), 287 C_Int (First_Column_Position)); 288 if W = Null_Window then 289 raise Curses_Exception; 290 end if; 291 return W; 292 end Sub_Window; 293 294 function Derived_Window 295 (Win : Window := Standard_Window; 296 Number_Of_Lines : Line_Count; 297 Number_Of_Columns : Column_Count; 298 First_Line_Position : Line_Position; 299 First_Column_Position : Column_Position) return Window 300 is 301 function Derwin 302 (Win : Window; 303 Number_Of_Lines : C_Int; 304 Number_Of_Columns : C_Int; 305 First_Line_Position : C_Int; 306 First_Column_Position : C_Int) return Window; 307 pragma Import (C, Derwin, "derwin"); 308 309 W : Window; 310 begin 311 W := Derwin (Win, 312 C_Int (Number_Of_Lines), 313 C_Int (Number_Of_Columns), 314 C_Int (First_Line_Position), 315 C_Int (First_Column_Position)); 316 if W = Null_Window then 317 raise Curses_Exception; 318 end if; 319 return W; 320 end Derived_Window; 321 322 function Duplicate (Win : Window) return Window 323 is 324 function Dupwin (Win : Window) return Window; 325 pragma Import (C, Dupwin, "dupwin"); 326 327 W : constant Window := Dupwin (Win); 328 begin 329 if W = Null_Window then 330 raise Curses_Exception; 331 end if; 332 return W; 333 end Duplicate; 334 335 procedure Move_Window (Win : Window; 336 Line : Line_Position; 337 Column : Column_Position) 338 is 339 function Mvwin (Win : Window; 340 Line : C_Int; 341 Column : C_Int) return C_Int; 342 pragma Import (C, Mvwin, "mvwin"); 343 begin 344 if Mvwin (Win, C_Int (Line), C_Int (Column)) = Curses_Err then 345 raise Curses_Exception; 346 end if; 347 end Move_Window; 348 349 procedure Move_Derived_Window (Win : Window; 350 Line : Line_Position; 351 Column : Column_Position) 352 is 353 function Mvderwin (Win : Window; 354 Line : C_Int; 355 Column : C_Int) return C_Int; 356 pragma Import (C, Mvderwin, "mvderwin"); 357 begin 358 if Mvderwin (Win, C_Int (Line), C_Int (Column)) = Curses_Err then 359 raise Curses_Exception; 360 end if; 361 end Move_Derived_Window; 362 363 procedure Set_Synch_Mode (Win : Window := Standard_Window; 364 Mode : Boolean := False) 365 is 366 function Syncok (Win : Window; 367 Mode : Curses_Bool) return C_Int; 368 pragma Import (C, Syncok, "syncok"); 369 begin 370 if Syncok (Win, Curses_Bool (Boolean'Pos (Mode))) = Curses_Err then 371 raise Curses_Exception; 372 end if; 373 end Set_Synch_Mode; 374------------------------------------------------------------------------------ 375 procedure Add (Win : Window := Standard_Window; 376 Str : String; 377 Len : Integer := -1) 378 is 379 function Waddnstr (Win : Window; 380 Str : char_array; 381 Len : C_Int := -1) return C_Int; 382 pragma Import (C, Waddnstr, "waddnstr"); 383 384 Txt : char_array (0 .. Str'Length); 385 Length : size_t; 386 begin 387 To_C (Str, Txt, Length); 388 if Waddnstr (Win, Txt, C_Int (Len)) = Curses_Err then 389 raise Curses_Exception; 390 end if; 391 end Add; 392 393 procedure Add 394 (Win : Window := Standard_Window; 395 Line : Line_Position; 396 Column : Column_Position; 397 Str : String; 398 Len : Integer := -1) 399 is 400 begin 401 Move_Cursor (Win, Line, Column); 402 Add (Win, Str, Len); 403 end Add; 404------------------------------------------------------------------------------ 405 procedure Add 406 (Win : Window := Standard_Window; 407 Str : Attributed_String; 408 Len : Integer := -1) 409 is 410 function Waddchnstr (Win : Window; 411 Str : chtype_array; 412 Len : C_Int := -1) return C_Int; 413 pragma Import (C, Waddchnstr, "waddchnstr"); 414 415 Txt : chtype_array (0 .. Str'Length); 416 begin 417 for Length in 1 .. size_t (Str'Length) loop 418 Txt (Length - 1) := Str (Natural (Length)); 419 end loop; 420 Txt (Str'Length) := Default_Character; 421 if Waddchnstr (Win, 422 Txt, 423 C_Int (Len)) = Curses_Err 424 then 425 raise Curses_Exception; 426 end if; 427 end Add; 428 429 procedure Add 430 (Win : Window := Standard_Window; 431 Line : Line_Position; 432 Column : Column_Position; 433 Str : Attributed_String; 434 Len : Integer := -1) 435 is 436 begin 437 Move_Cursor (Win, Line, Column); 438 Add (Win, Str, Len); 439 end Add; 440------------------------------------------------------------------------------ 441 procedure Border 442 (Win : Window := Standard_Window; 443 Left_Side_Symbol : Attributed_Character := Default_Character; 444 Right_Side_Symbol : Attributed_Character := Default_Character; 445 Top_Side_Symbol : Attributed_Character := Default_Character; 446 Bottom_Side_Symbol : Attributed_Character := Default_Character; 447 Upper_Left_Corner_Symbol : Attributed_Character := Default_Character; 448 Upper_Right_Corner_Symbol : Attributed_Character := Default_Character; 449 Lower_Left_Corner_Symbol : Attributed_Character := Default_Character; 450 Lower_Right_Corner_Symbol : Attributed_Character := Default_Character) 451 is 452 function Wborder (W : Window; 453 LS : Attributed_Character; 454 RS : Attributed_Character; 455 TS : Attributed_Character; 456 BS : Attributed_Character; 457 ULC : Attributed_Character; 458 URC : Attributed_Character; 459 LLC : Attributed_Character; 460 LRC : Attributed_Character) return C_Int; 461 pragma Import (C, Wborder, "wborder"); 462 begin 463 if Wborder (Win, 464 Left_Side_Symbol, 465 Right_Side_Symbol, 466 Top_Side_Symbol, 467 Bottom_Side_Symbol, 468 Upper_Left_Corner_Symbol, 469 Upper_Right_Corner_Symbol, 470 Lower_Left_Corner_Symbol, 471 Lower_Right_Corner_Symbol) = Curses_Err 472 then 473 raise Curses_Exception; 474 end if; 475 end Border; 476 477 procedure Box 478 (Win : Window := Standard_Window; 479 Vertical_Symbol : Attributed_Character := Default_Character; 480 Horizontal_Symbol : Attributed_Character := Default_Character) 481 is 482 begin 483 Border (Win, 484 Vertical_Symbol, Vertical_Symbol, 485 Horizontal_Symbol, Horizontal_Symbol); 486 end Box; 487 488 procedure Horizontal_Line 489 (Win : Window := Standard_Window; 490 Line_Size : Natural; 491 Line_Symbol : Attributed_Character := Default_Character) 492 is 493 function Whline (W : Window; 494 Ch : Attributed_Character; 495 Len : C_Int) return C_Int; 496 pragma Import (C, Whline, "whline"); 497 begin 498 if Whline (Win, 499 Line_Symbol, 500 C_Int (Line_Size)) = Curses_Err 501 then 502 raise Curses_Exception; 503 end if; 504 end Horizontal_Line; 505 506 procedure Vertical_Line 507 (Win : Window := Standard_Window; 508 Line_Size : Natural; 509 Line_Symbol : Attributed_Character := Default_Character) 510 is 511 function Wvline (W : Window; 512 Ch : Attributed_Character; 513 Len : C_Int) return C_Int; 514 pragma Import (C, Wvline, "wvline"); 515 begin 516 if Wvline (Win, 517 Line_Symbol, 518 C_Int (Line_Size)) = Curses_Err 519 then 520 raise Curses_Exception; 521 end if; 522 end Vertical_Line; 523 524------------------------------------------------------------------------------ 525 function Get_Keystroke (Win : Window := Standard_Window) 526 return Real_Key_Code 527 is 528 function Wgetch (W : Window) return C_Int; 529 pragma Import (C, Wgetch, "wgetch"); 530 531 C : constant C_Int := Wgetch (Win); 532 begin 533 if C = Curses_Err then 534 return Key_None; 535 else 536 return Real_Key_Code (C); 537 end if; 538 end Get_Keystroke; 539 540 procedure Undo_Keystroke (Key : Real_Key_Code) 541 is 542 function Ungetch (Ch : C_Int) return C_Int; 543 pragma Import (C, Ungetch, "ungetch"); 544 begin 545 if Ungetch (C_Int (Key)) = Curses_Err then 546 raise Curses_Exception; 547 end if; 548 end Undo_Keystroke; 549 550 function Has_Key (Key : Special_Key_Code) return Boolean 551 is 552 function Haskey (Key : C_Int) return C_Int; 553 pragma Import (C, Haskey, "has_key"); 554 begin 555 if Haskey (C_Int (Key)) = Curses_False then 556 return False; 557 else 558 return True; 559 end if; 560 end Has_Key; 561 562 function Is_Function_Key (Key : Special_Key_Code) return Boolean 563 is 564 L : constant Special_Key_Code := Special_Key_Code (Natural (Key_F0) + 565 Natural (Function_Key_Number'Last)); 566 begin 567 if Key >= Key_F0 and then Key <= L then 568 return True; 569 else 570 return False; 571 end if; 572 end Is_Function_Key; 573 574 function Function_Key (Key : Real_Key_Code) 575 return Function_Key_Number 576 is 577 begin 578 if Is_Function_Key (Key) then 579 return Function_Key_Number (Key - Key_F0); 580 else 581 raise Constraint_Error; 582 end if; 583 end Function_Key; 584 585 function Function_Key_Code (Key : Function_Key_Number) return Real_Key_Code 586 is 587 begin 588 return Real_Key_Code (Natural (Key_F0) + Natural (Key)); 589 end Function_Key_Code; 590------------------------------------------------------------------------------ 591 procedure Standout (Win : Window := Standard_Window; 592 On : Boolean := True) 593 is 594 function wstandout (Win : Window) return C_Int; 595 pragma Import (C, wstandout, "wstandout"); 596 function wstandend (Win : Window) return C_Int; 597 pragma Import (C, wstandend, "wstandend"); 598 599 Err : C_Int; 600 begin 601 if On then 602 Err := wstandout (Win); 603 else 604 Err := wstandend (Win); 605 end if; 606 if Err = Curses_Err then 607 raise Curses_Exception; 608 end if; 609 end Standout; 610 611 procedure Switch_Character_Attribute 612 (Win : Window := Standard_Window; 613 Attr : Character_Attribute_Set := Normal_Video; 614 On : Boolean := True) 615 is 616 function Wattron (Win : Window; 617 C_Attr : Attributed_Character) return C_Int; 618 pragma Import (C, Wattron, "wattr_on"); 619 function Wattroff (Win : Window; 620 C_Attr : Attributed_Character) return C_Int; 621 pragma Import (C, Wattroff, "wattr_off"); 622 -- In Ada we use the On Boolean to control whether or not we want to 623 -- switch on or off the attributes in the set. 624 Err : C_Int; 625 AC : constant Attributed_Character := (Ch => Character'First, 626 Color => Color_Pair'First, 627 Attr => Attr); 628 begin 629 if On then 630 Err := Wattron (Win, AC); 631 else 632 Err := Wattroff (Win, AC); 633 end if; 634 if Err = Curses_Err then 635 raise Curses_Exception; 636 end if; 637 end Switch_Character_Attribute; 638 639 procedure Set_Character_Attributes 640 (Win : Window := Standard_Window; 641 Attr : Character_Attribute_Set := Normal_Video; 642 Color : Color_Pair := Color_Pair'First) 643 is 644 function Wattrset (Win : Window; 645 C_Attr : Attributed_Character) return C_Int; 646 pragma Import (C, Wattrset, "wattrset"); -- ??? wattr_set 647 begin 648 if Wattrset (Win, (Ch => Character'First, 649 Color => Color, 650 Attr => Attr)) = Curses_Err 651 then 652 raise Curses_Exception; 653 end if; 654 end Set_Character_Attributes; 655 656 function Get_Character_Attribute (Win : Window := Standard_Window) 657 return Character_Attribute_Set 658 is 659 function Wattrget (Win : Window; 660 Atr : access Attributed_Character; 661 Col : access C_Short; 662 Opt : System.Address) return C_Int; 663 pragma Import (C, Wattrget, "wattr_get"); 664 665 Attr : aliased Attributed_Character; 666 Col : aliased C_Short; 667 Res : constant C_Int := Wattrget (Win, Attr'Access, Col'Access, 668 System.Null_Address); 669 begin 670 if Res = Curses_Ok then 671 return Attr.Attr; 672 else 673 raise Curses_Exception; 674 end if; 675 end Get_Character_Attribute; 676 677 function Get_Character_Attribute (Win : Window := Standard_Window) 678 return Color_Pair 679 is 680 function Wattrget (Win : Window; 681 Atr : access Attributed_Character; 682 Col : access C_Short; 683 Opt : System.Address) return C_Int; 684 pragma Import (C, Wattrget, "wattr_get"); 685 686 Attr : aliased Attributed_Character; 687 Col : aliased C_Short; 688 Res : constant C_Int := Wattrget (Win, Attr'Access, Col'Access, 689 System.Null_Address); 690 begin 691 if Res = Curses_Ok then 692 return Attr.Color; 693 else 694 raise Curses_Exception; 695 end if; 696 end Get_Character_Attribute; 697 698 procedure Set_Color (Win : Window := Standard_Window; 699 Pair : Color_Pair) 700 is 701 function Wset_Color (Win : Window; 702 Color : C_Short; 703 Opts : C_Void_Ptr) return C_Int; 704 pragma Import (C, Wset_Color, "wcolor_set"); 705 begin 706 if Wset_Color (Win, 707 C_Short (Pair), 708 C_Void_Ptr (System.Null_Address)) = Curses_Err 709 then 710 raise Curses_Exception; 711 end if; 712 end Set_Color; 713 714 procedure Change_Attributes 715 (Win : Window := Standard_Window; 716 Count : Integer := -1; 717 Attr : Character_Attribute_Set := Normal_Video; 718 Color : Color_Pair := Color_Pair'First) 719 is 720 function Wchgat (Win : Window; 721 Cnt : C_Int; 722 Attr : Attributed_Character; 723 Color : C_Short; 724 Opts : System.Address := System.Null_Address) 725 return C_Int; 726 pragma Import (C, Wchgat, "wchgat"); 727 begin 728 if Wchgat (Win, 729 C_Int (Count), 730 (Ch => Character'First, 731 Color => Color_Pair'First, 732 Attr => Attr), 733 C_Short (Color)) = Curses_Err 734 then 735 raise Curses_Exception; 736 end if; 737 end Change_Attributes; 738 739 procedure Change_Attributes 740 (Win : Window := Standard_Window; 741 Line : Line_Position := Line_Position'First; 742 Column : Column_Position := Column_Position'First; 743 Count : Integer := -1; 744 Attr : Character_Attribute_Set := Normal_Video; 745 Color : Color_Pair := Color_Pair'First) 746 is 747 begin 748 Move_Cursor (Win, Line, Column); 749 Change_Attributes (Win, Count, Attr, Color); 750 end Change_Attributes; 751------------------------------------------------------------------------------ 752 procedure Beep 753 is 754 function Beeper return C_Int; 755 pragma Import (C, Beeper, "beep"); 756 begin 757 if Beeper = Curses_Err then 758 raise Curses_Exception; 759 end if; 760 end Beep; 761 762 procedure Flash_Screen 763 is 764 function Flash return C_Int; 765 pragma Import (C, Flash, "flash"); 766 begin 767 if Flash = Curses_Err then 768 raise Curses_Exception; 769 end if; 770 end Flash_Screen; 771------------------------------------------------------------------------------ 772 procedure Set_Cbreak_Mode (SwitchOn : Boolean := True) 773 is 774 function Cbreak return C_Int; 775 pragma Import (C, Cbreak, "cbreak"); 776 function NoCbreak return C_Int; 777 pragma Import (C, NoCbreak, "nocbreak"); 778 779 Err : C_Int; 780 begin 781 if SwitchOn then 782 Err := Cbreak; 783 else 784 Err := NoCbreak; 785 end if; 786 if Err = Curses_Err then 787 raise Curses_Exception; 788 end if; 789 end Set_Cbreak_Mode; 790 791 procedure Set_Raw_Mode (SwitchOn : Boolean := True) 792 is 793 function Raw return C_Int; 794 pragma Import (C, Raw, "raw"); 795 function NoRaw return C_Int; 796 pragma Import (C, NoRaw, "noraw"); 797 798 Err : C_Int; 799 begin 800 if SwitchOn then 801 Err := Raw; 802 else 803 Err := NoRaw; 804 end if; 805 if Err = Curses_Err then 806 raise Curses_Exception; 807 end if; 808 end Set_Raw_Mode; 809 810 procedure Set_Echo_Mode (SwitchOn : Boolean := True) 811 is 812 function Echo return C_Int; 813 pragma Import (C, Echo, "echo"); 814 function NoEcho return C_Int; 815 pragma Import (C, NoEcho, "noecho"); 816 817 Err : C_Int; 818 begin 819 if SwitchOn then 820 Err := Echo; 821 else 822 Err := NoEcho; 823 end if; 824 if Err = Curses_Err then 825 raise Curses_Exception; 826 end if; 827 end Set_Echo_Mode; 828 829 procedure Set_Meta_Mode (Win : Window := Standard_Window; 830 SwitchOn : Boolean := True) 831 is 832 function Meta (W : Window; Mode : Curses_Bool) return C_Int; 833 pragma Import (C, Meta, "meta"); 834 begin 835 if Meta (Win, Curses_Bool (Boolean'Pos (SwitchOn))) = Curses_Err then 836 raise Curses_Exception; 837 end if; 838 end Set_Meta_Mode; 839 840 procedure Set_KeyPad_Mode (Win : Window := Standard_Window; 841 SwitchOn : Boolean := True) 842 is 843 function Keypad (W : Window; Mode : Curses_Bool) return C_Int; 844 pragma Import (C, Keypad, "keypad"); 845 begin 846 if Keypad (Win, Curses_Bool (Boolean'Pos (SwitchOn))) = Curses_Err then 847 raise Curses_Exception; 848 end if; 849 end Set_KeyPad_Mode; 850 851 function Get_KeyPad_Mode (Win : Window := Standard_Window) 852 return Boolean 853 is 854 function Is_Keypad (W : Window) return Curses_Bool; 855 pragma Import (C, Is_Keypad, "is_keypad"); 856 begin 857 return (Is_Keypad (Win) /= Curses_Bool_False); 858 end Get_KeyPad_Mode; 859 860 procedure Half_Delay (Amount : Half_Delay_Amount) 861 is 862 function Halfdelay (Amount : C_Int) return C_Int; 863 pragma Import (C, Halfdelay, "halfdelay"); 864 begin 865 if Halfdelay (C_Int (Amount)) = Curses_Err then 866 raise Curses_Exception; 867 end if; 868 end Half_Delay; 869 870 procedure Set_Flush_On_Interrupt_Mode 871 (Win : Window := Standard_Window; 872 Mode : Boolean := True) 873 is 874 function Intrflush (Win : Window; Mode : Curses_Bool) return C_Int; 875 pragma Import (C, Intrflush, "intrflush"); 876 begin 877 if Intrflush (Win, Curses_Bool (Boolean'Pos (Mode))) = Curses_Err then 878 raise Curses_Exception; 879 end if; 880 end Set_Flush_On_Interrupt_Mode; 881 882 procedure Set_Queue_Interrupt_Mode 883 (Win : Window := Standard_Window; 884 Flush : Boolean := True) 885 is 886 procedure Qiflush; 887 pragma Import (C, Qiflush, "qiflush"); 888 procedure No_Qiflush; 889 pragma Import (C, No_Qiflush, "noqiflush"); 890 begin 891 if Win = Null_Window then 892 raise Curses_Exception; 893 end if; 894 if Flush then 895 Qiflush; 896 else 897 No_Qiflush; 898 end if; 899 end Set_Queue_Interrupt_Mode; 900 901 procedure Set_NoDelay_Mode 902 (Win : Window := Standard_Window; 903 Mode : Boolean := False) 904 is 905 function Nodelay (Win : Window; Mode : Curses_Bool) return C_Int; 906 pragma Import (C, Nodelay, "nodelay"); 907 begin 908 if Nodelay (Win, Curses_Bool (Boolean'Pos (Mode))) = Curses_Err then 909 raise Curses_Exception; 910 end if; 911 end Set_NoDelay_Mode; 912 913 procedure Set_Timeout_Mode (Win : Window := Standard_Window; 914 Mode : Timeout_Mode; 915 Amount : Natural) 916 is 917 procedure Wtimeout (Win : Window; Amount : C_Int); 918 pragma Import (C, Wtimeout, "wtimeout"); 919 920 Time : C_Int; 921 begin 922 case Mode is 923 when Blocking => Time := -1; 924 when Non_Blocking => Time := 0; 925 when Delayed => 926 if Amount = 0 then 927 raise Constraint_Error; 928 end if; 929 Time := C_Int (Amount); 930 end case; 931 Wtimeout (Win, Time); 932 end Set_Timeout_Mode; 933 934 procedure Set_Escape_Timer_Mode 935 (Win : Window := Standard_Window; 936 Timer_Off : Boolean := False) 937 is 938 function Notimeout (Win : Window; Mode : Curses_Bool) return C_Int; 939 pragma Import (C, Notimeout, "notimeout"); 940 begin 941 if Notimeout (Win, Curses_Bool (Boolean'Pos (Timer_Off))) 942 = Curses_Err 943 then 944 raise Curses_Exception; 945 end if; 946 end Set_Escape_Timer_Mode; 947 948------------------------------------------------------------------------------ 949 procedure Set_NL_Mode (SwitchOn : Boolean := True) 950 is 951 function NL return C_Int; 952 pragma Import (C, NL, "nl"); 953 function NoNL return C_Int; 954 pragma Import (C, NoNL, "nonl"); 955 956 Err : C_Int; 957 begin 958 if SwitchOn then 959 Err := NL; 960 else 961 Err := NoNL; 962 end if; 963 if Err = Curses_Err then 964 raise Curses_Exception; 965 end if; 966 end Set_NL_Mode; 967 968 procedure Clear_On_Next_Update 969 (Win : Window := Standard_Window; 970 Do_Clear : Boolean := True) 971 is 972 function Clear_Ok (W : Window; Flag : Curses_Bool) return C_Int; 973 pragma Import (C, Clear_Ok, "clearok"); 974 begin 975 if Clear_Ok (Win, Curses_Bool (Boolean'Pos (Do_Clear))) = Curses_Err then 976 raise Curses_Exception; 977 end if; 978 end Clear_On_Next_Update; 979 980 procedure Use_Insert_Delete_Line 981 (Win : Window := Standard_Window; 982 Do_Idl : Boolean := True) 983 is 984 function IDL_Ok (W : Window; Flag : Curses_Bool) return C_Int; 985 pragma Import (C, IDL_Ok, "idlok"); 986 begin 987 if IDL_Ok (Win, Curses_Bool (Boolean'Pos (Do_Idl))) = Curses_Err then 988 raise Curses_Exception; 989 end if; 990 end Use_Insert_Delete_Line; 991 992 procedure Use_Insert_Delete_Character 993 (Win : Window := Standard_Window; 994 Do_Idc : Boolean := True) 995 is 996 procedure IDC_Ok (W : Window; Flag : Curses_Bool); 997 pragma Import (C, IDC_Ok, "idcok"); 998 begin 999 IDC_Ok (Win, Curses_Bool (Boolean'Pos (Do_Idc))); 1000 end Use_Insert_Delete_Character; 1001 1002 procedure Leave_Cursor_After_Update 1003 (Win : Window := Standard_Window; 1004 Do_Leave : Boolean := True) 1005 is 1006 function Leave_Ok (W : Window; Flag : Curses_Bool) return C_Int; 1007 pragma Import (C, Leave_Ok, "leaveok"); 1008 begin 1009 if Leave_Ok (Win, Curses_Bool (Boolean'Pos (Do_Leave))) = Curses_Err then 1010 raise Curses_Exception; 1011 end if; 1012 end Leave_Cursor_After_Update; 1013 1014 procedure Immediate_Update_Mode 1015 (Win : Window := Standard_Window; 1016 Mode : Boolean := False) 1017 is 1018 procedure Immedok (Win : Window; Mode : Curses_Bool); 1019 pragma Import (C, Immedok, "immedok"); 1020 begin 1021 Immedok (Win, Curses_Bool (Boolean'Pos (Mode))); 1022 end Immediate_Update_Mode; 1023 1024 procedure Allow_Scrolling 1025 (Win : Window := Standard_Window; 1026 Mode : Boolean := False) 1027 is 1028 function Scrollok (Win : Window; Mode : Curses_Bool) return C_Int; 1029 pragma Import (C, Scrollok, "scrollok"); 1030 begin 1031 if Scrollok (Win, Curses_Bool (Boolean'Pos (Mode))) = Curses_Err then 1032 raise Curses_Exception; 1033 end if; 1034 end Allow_Scrolling; 1035 1036 function Scrolling_Allowed (Win : Window := Standard_Window) 1037 return Boolean 1038 is 1039 function Is_Scroll_Ok (W : Window) return Curses_Bool; 1040 pragma Import (C, Is_Scroll_Ok, "is_scrollok"); 1041 begin 1042 return (Is_Scroll_Ok (Win) /= Curses_Bool_False); 1043 end Scrolling_Allowed; 1044 1045 procedure Set_Scroll_Region 1046 (Win : Window := Standard_Window; 1047 Top_Line : Line_Position; 1048 Bottom_Line : Line_Position) 1049 is 1050 function Wsetscrreg (Win : Window; 1051 Lin : C_Int; 1052 Col : C_Int) return C_Int; 1053 pragma Import (C, Wsetscrreg, "wsetscrreg"); 1054 begin 1055 if Wsetscrreg (Win, C_Int (Top_Line), C_Int (Bottom_Line)) 1056 = Curses_Err 1057 then 1058 raise Curses_Exception; 1059 end if; 1060 end Set_Scroll_Region; 1061------------------------------------------------------------------------------ 1062 procedure Update_Screen 1063 is 1064 function Do_Update return C_Int; 1065 pragma Import (C, Do_Update, "doupdate"); 1066 begin 1067 if Do_Update = Curses_Err then 1068 raise Curses_Exception; 1069 end if; 1070 end Update_Screen; 1071 1072 procedure Refresh (Win : Window := Standard_Window) 1073 is 1074 function Wrefresh (W : Window) return C_Int; 1075 pragma Import (C, Wrefresh, "wrefresh"); 1076 begin 1077 if Wrefresh (Win) = Curses_Err then 1078 raise Curses_Exception; 1079 end if; 1080 end Refresh; 1081 1082 procedure Refresh_Without_Update 1083 (Win : Window := Standard_Window) 1084 is 1085 function Wnoutrefresh (W : Window) return C_Int; 1086 pragma Import (C, Wnoutrefresh, "wnoutrefresh"); 1087 begin 1088 if Wnoutrefresh (Win) = Curses_Err then 1089 raise Curses_Exception; 1090 end if; 1091 end Refresh_Without_Update; 1092 1093 procedure Redraw (Win : Window := Standard_Window) 1094 is 1095 function Redrawwin (Win : Window) return C_Int; 1096 pragma Import (C, Redrawwin, "redrawwin"); 1097 begin 1098 if Redrawwin (Win) = Curses_Err then 1099 raise Curses_Exception; 1100 end if; 1101 end Redraw; 1102 1103 procedure Redraw 1104 (Win : Window := Standard_Window; 1105 Begin_Line : Line_Position; 1106 Line_Count : Positive) 1107 is 1108 function Wredrawln (Win : Window; First : C_Int; Cnt : C_Int) 1109 return C_Int; 1110 pragma Import (C, Wredrawln, "wredrawln"); 1111 begin 1112 if Wredrawln (Win, 1113 C_Int (Begin_Line), 1114 C_Int (Line_Count)) = Curses_Err 1115 then 1116 raise Curses_Exception; 1117 end if; 1118 end Redraw; 1119 1120------------------------------------------------------------------------------ 1121 procedure Erase (Win : Window := Standard_Window) 1122 is 1123 function Werase (W : Window) return C_Int; 1124 pragma Import (C, Werase, "werase"); 1125 begin 1126 if Werase (Win) = Curses_Err then 1127 raise Curses_Exception; 1128 end if; 1129 end Erase; 1130 1131 procedure Clear (Win : Window := Standard_Window) 1132 is 1133 function Wclear (W : Window) return C_Int; 1134 pragma Import (C, Wclear, "wclear"); 1135 begin 1136 if Wclear (Win) = Curses_Err then 1137 raise Curses_Exception; 1138 end if; 1139 end Clear; 1140 1141 procedure Clear_To_End_Of_Screen (Win : Window := Standard_Window) 1142 is 1143 function Wclearbot (W : Window) return C_Int; 1144 pragma Import (C, Wclearbot, "wclrtobot"); 1145 begin 1146 if Wclearbot (Win) = Curses_Err then 1147 raise Curses_Exception; 1148 end if; 1149 end Clear_To_End_Of_Screen; 1150 1151 procedure Clear_To_End_Of_Line (Win : Window := Standard_Window) 1152 is 1153 function Wcleareol (W : Window) return C_Int; 1154 pragma Import (C, Wcleareol, "wclrtoeol"); 1155 begin 1156 if Wcleareol (Win) = Curses_Err then 1157 raise Curses_Exception; 1158 end if; 1159 end Clear_To_End_Of_Line; 1160------------------------------------------------------------------------------ 1161 procedure Set_Background 1162 (Win : Window := Standard_Window; 1163 Ch : Attributed_Character) 1164 is 1165 procedure WBackground (W : Window; Ch : Attributed_Character); 1166 pragma Import (C, WBackground, "wbkgdset"); 1167 begin 1168 WBackground (Win, Ch); 1169 end Set_Background; 1170 1171 procedure Change_Background 1172 (Win : Window := Standard_Window; 1173 Ch : Attributed_Character) 1174 is 1175 function WChangeBkgd (W : Window; Ch : Attributed_Character) 1176 return C_Int; 1177 pragma Import (C, WChangeBkgd, "wbkgd"); 1178 begin 1179 if WChangeBkgd (Win, Ch) = Curses_Err then 1180 raise Curses_Exception; 1181 end if; 1182 end Change_Background; 1183 1184 function Get_Background (Win : Window := Standard_Window) 1185 return Attributed_Character 1186 is 1187 function Wgetbkgd (Win : Window) return Attributed_Character; 1188 pragma Import (C, Wgetbkgd, "getbkgd"); 1189 begin 1190 return Wgetbkgd (Win); 1191 end Get_Background; 1192------------------------------------------------------------------------------ 1193 procedure Change_Lines_Status (Win : Window := Standard_Window; 1194 Start : Line_Position; 1195 Count : Positive; 1196 State : Boolean) 1197 is 1198 function Wtouchln (Win : Window; 1199 Sta : C_Int; 1200 Cnt : C_Int; 1201 Chg : C_Int) return C_Int; 1202 pragma Import (C, Wtouchln, "wtouchln"); 1203 begin 1204 if Wtouchln (Win, C_Int (Start), C_Int (Count), 1205 C_Int (Boolean'Pos (State))) = Curses_Err 1206 then 1207 raise Curses_Exception; 1208 end if; 1209 end Change_Lines_Status; 1210 1211 procedure Touch (Win : Window := Standard_Window) 1212 is 1213 Y : Line_Position; 1214 X : Column_Position; 1215 begin 1216 Get_Size (Win, Y, X); 1217 pragma Warnings (Off, X); -- unreferenced 1218 Change_Lines_Status (Win, 0, Positive (Y), True); 1219 end Touch; 1220 1221 procedure Untouch (Win : Window := Standard_Window) 1222 is 1223 Y : Line_Position; 1224 X : Column_Position; 1225 begin 1226 Get_Size (Win, Y, X); 1227 pragma Warnings (Off, X); -- unreferenced 1228 Change_Lines_Status (Win, 0, Positive (Y), False); 1229 end Untouch; 1230 1231 procedure Touch (Win : Window := Standard_Window; 1232 Start : Line_Position; 1233 Count : Positive) 1234 is 1235 begin 1236 Change_Lines_Status (Win, Start, Count, True); 1237 end Touch; 1238 1239 function Is_Touched 1240 (Win : Window := Standard_Window; 1241 Line : Line_Position) return Boolean 1242 is 1243 function WLineTouched (W : Window; L : C_Int) return Curses_Bool; 1244 pragma Import (C, WLineTouched, "is_linetouched"); 1245 begin 1246 if WLineTouched (Win, C_Int (Line)) = Curses_Bool_False then 1247 return False; 1248 else 1249 return True; 1250 end if; 1251 end Is_Touched; 1252 1253 function Is_Touched 1254 (Win : Window := Standard_Window) return Boolean 1255 is 1256 function WWinTouched (W : Window) return Curses_Bool; 1257 pragma Import (C, WWinTouched, "is_wintouched"); 1258 begin 1259 if WWinTouched (Win) = Curses_Bool_False then 1260 return False; 1261 else 1262 return True; 1263 end if; 1264 end Is_Touched; 1265------------------------------------------------------------------------------ 1266 procedure Copy 1267 (Source_Window : Window; 1268 Destination_Window : Window; 1269 Source_Top_Row : Line_Position; 1270 Source_Left_Column : Column_Position; 1271 Destination_Top_Row : Line_Position; 1272 Destination_Left_Column : Column_Position; 1273 Destination_Bottom_Row : Line_Position; 1274 Destination_Right_Column : Column_Position; 1275 Non_Destructive_Mode : Boolean := True) 1276 is 1277 function Copywin (Src : Window; 1278 Dst : Window; 1279 Str : C_Int; 1280 Slc : C_Int; 1281 Dtr : C_Int; 1282 Dlc : C_Int; 1283 Dbr : C_Int; 1284 Drc : C_Int; 1285 Ndm : C_Int) return C_Int; 1286 pragma Import (C, Copywin, "copywin"); 1287 begin 1288 if Copywin (Source_Window, 1289 Destination_Window, 1290 C_Int (Source_Top_Row), 1291 C_Int (Source_Left_Column), 1292 C_Int (Destination_Top_Row), 1293 C_Int (Destination_Left_Column), 1294 C_Int (Destination_Bottom_Row), 1295 C_Int (Destination_Right_Column), 1296 Boolean'Pos (Non_Destructive_Mode) 1297 ) = Curses_Err 1298 then 1299 raise Curses_Exception; 1300 end if; 1301 end Copy; 1302 1303 procedure Overwrite 1304 (Source_Window : Window; 1305 Destination_Window : Window) 1306 is 1307 function Overwrite (Src : Window; Dst : Window) return C_Int; 1308 pragma Import (C, Overwrite, "overwrite"); 1309 begin 1310 if Overwrite (Source_Window, Destination_Window) = Curses_Err then 1311 raise Curses_Exception; 1312 end if; 1313 end Overwrite; 1314 1315 procedure Overlay 1316 (Source_Window : Window; 1317 Destination_Window : Window) 1318 is 1319 function Overlay (Src : Window; Dst : Window) return C_Int; 1320 pragma Import (C, Overlay, "overlay"); 1321 begin 1322 if Overlay (Source_Window, Destination_Window) = Curses_Err then 1323 raise Curses_Exception; 1324 end if; 1325 end Overlay; 1326 1327------------------------------------------------------------------------------ 1328 procedure Insert_Delete_Lines 1329 (Win : Window := Standard_Window; 1330 Lines : Integer := 1) -- default is to insert one line above 1331 is 1332 function Winsdelln (W : Window; N : C_Int) return C_Int; 1333 pragma Import (C, Winsdelln, "winsdelln"); 1334 begin 1335 if Winsdelln (Win, C_Int (Lines)) = Curses_Err then 1336 raise Curses_Exception; 1337 end if; 1338 end Insert_Delete_Lines; 1339 1340 procedure Delete_Line (Win : Window := Standard_Window) 1341 is 1342 begin 1343 Insert_Delete_Lines (Win, -1); 1344 end Delete_Line; 1345 1346 procedure Insert_Line (Win : Window := Standard_Window) 1347 is 1348 begin 1349 Insert_Delete_Lines (Win, 1); 1350 end Insert_Line; 1351------------------------------------------------------------------------------ 1352 1353 procedure Get_Size 1354 (Win : Window := Standard_Window; 1355 Number_Of_Lines : out Line_Count; 1356 Number_Of_Columns : out Column_Count) 1357 is 1358 function GetMaxY (W : Window) return C_Int; 1359 pragma Import (C, GetMaxY, "getmaxy"); 1360 1361 function GetMaxX (W : Window) return C_Int; 1362 pragma Import (C, GetMaxX, "getmaxx"); 1363 1364 Y : constant C_Int := GetMaxY (Win); 1365 X : constant C_Int := GetMaxX (Win); 1366 begin 1367 Number_Of_Lines := Line_Count (Y); 1368 Number_Of_Columns := Column_Count (X); 1369 end Get_Size; 1370 1371 procedure Get_Window_Position 1372 (Win : Window := Standard_Window; 1373 Top_Left_Line : out Line_Position; 1374 Top_Left_Column : out Column_Position) 1375 is 1376 function GetBegY (W : Window) return C_Int; 1377 pragma Import (C, GetBegY, "getbegy"); 1378 1379 function GetBegX (W : Window) return C_Int; 1380 pragma Import (C, GetBegX, "getbegx"); 1381 1382 Y : constant C_Short := C_Short (GetBegY (Win)); 1383 X : constant C_Short := C_Short (GetBegX (Win)); 1384 begin 1385 Top_Left_Line := Line_Position (Y); 1386 Top_Left_Column := Column_Position (X); 1387 end Get_Window_Position; 1388 1389 procedure Get_Cursor_Position 1390 (Win : Window := Standard_Window; 1391 Line : out Line_Position; 1392 Column : out Column_Position) 1393 is 1394 function GetCurY (W : Window) return C_Int; 1395 pragma Import (C, GetCurY, "getcury"); 1396 1397 function GetCurX (W : Window) return C_Int; 1398 pragma Import (C, GetCurX, "getcurx"); 1399 1400 Y : constant C_Short := C_Short (GetCurY (Win)); 1401 X : constant C_Short := C_Short (GetCurX (Win)); 1402 begin 1403 Line := Line_Position (Y); 1404 Column := Column_Position (X); 1405 end Get_Cursor_Position; 1406 1407 procedure Get_Origin_Relative_To_Parent 1408 (Win : Window; 1409 Top_Left_Line : out Line_Position; 1410 Top_Left_Column : out Column_Position; 1411 Is_Not_A_Subwindow : out Boolean) 1412 is 1413 function GetParY (W : Window) return C_Int; 1414 pragma Import (C, GetParY, "getpary"); 1415 1416 function GetParX (W : Window) return C_Int; 1417 pragma Import (C, GetParX, "getparx"); 1418 1419 Y : constant C_Int := GetParY (Win); 1420 X : constant C_Int := GetParX (Win); 1421 begin 1422 if Y = -1 then 1423 Top_Left_Line := Line_Position'Last; 1424 Top_Left_Column := Column_Position'Last; 1425 Is_Not_A_Subwindow := True; 1426 else 1427 Top_Left_Line := Line_Position (Y); 1428 Top_Left_Column := Column_Position (X); 1429 Is_Not_A_Subwindow := False; 1430 end if; 1431 end Get_Origin_Relative_To_Parent; 1432------------------------------------------------------------------------------ 1433 function New_Pad (Lines : Line_Count; 1434 Columns : Column_Count) return Window 1435 is 1436 function Newpad (Lines : C_Int; Columns : C_Int) return Window; 1437 pragma Import (C, Newpad, "newpad"); 1438 1439 W : Window; 1440 begin 1441 W := Newpad (C_Int (Lines), C_Int (Columns)); 1442 if W = Null_Window then 1443 raise Curses_Exception; 1444 end if; 1445 return W; 1446 end New_Pad; 1447 1448 function Sub_Pad 1449 (Pad : Window; 1450 Number_Of_Lines : Line_Count; 1451 Number_Of_Columns : Column_Count; 1452 First_Line_Position : Line_Position; 1453 First_Column_Position : Column_Position) return Window 1454 is 1455 function Subpad 1456 (Pad : Window; 1457 Number_Of_Lines : C_Int; 1458 Number_Of_Columns : C_Int; 1459 First_Line_Position : C_Int; 1460 First_Column_Position : C_Int) return Window; 1461 pragma Import (C, Subpad, "subpad"); 1462 1463 W : Window; 1464 begin 1465 W := Subpad (Pad, 1466 C_Int (Number_Of_Lines), 1467 C_Int (Number_Of_Columns), 1468 C_Int (First_Line_Position), 1469 C_Int (First_Column_Position)); 1470 if W = Null_Window then 1471 raise Curses_Exception; 1472 end if; 1473 return W; 1474 end Sub_Pad; 1475 1476 procedure Refresh 1477 (Pad : Window; 1478 Source_Top_Row : Line_Position; 1479 Source_Left_Column : Column_Position; 1480 Destination_Top_Row : Line_Position; 1481 Destination_Left_Column : Column_Position; 1482 Destination_Bottom_Row : Line_Position; 1483 Destination_Right_Column : Column_Position) 1484 is 1485 function Prefresh 1486 (Pad : Window; 1487 Source_Top_Row : C_Int; 1488 Source_Left_Column : C_Int; 1489 Destination_Top_Row : C_Int; 1490 Destination_Left_Column : C_Int; 1491 Destination_Bottom_Row : C_Int; 1492 Destination_Right_Column : C_Int) return C_Int; 1493 pragma Import (C, Prefresh, "prefresh"); 1494 begin 1495 if Prefresh (Pad, 1496 C_Int (Source_Top_Row), 1497 C_Int (Source_Left_Column), 1498 C_Int (Destination_Top_Row), 1499 C_Int (Destination_Left_Column), 1500 C_Int (Destination_Bottom_Row), 1501 C_Int (Destination_Right_Column)) = Curses_Err 1502 then 1503 raise Curses_Exception; 1504 end if; 1505 end Refresh; 1506 1507 procedure Refresh_Without_Update 1508 (Pad : Window; 1509 Source_Top_Row : Line_Position; 1510 Source_Left_Column : Column_Position; 1511 Destination_Top_Row : Line_Position; 1512 Destination_Left_Column : Column_Position; 1513 Destination_Bottom_Row : Line_Position; 1514 Destination_Right_Column : Column_Position) 1515 is 1516 function Pnoutrefresh 1517 (Pad : Window; 1518 Source_Top_Row : C_Int; 1519 Source_Left_Column : C_Int; 1520 Destination_Top_Row : C_Int; 1521 Destination_Left_Column : C_Int; 1522 Destination_Bottom_Row : C_Int; 1523 Destination_Right_Column : C_Int) return C_Int; 1524 pragma Import (C, Pnoutrefresh, "pnoutrefresh"); 1525 begin 1526 if Pnoutrefresh (Pad, 1527 C_Int (Source_Top_Row), 1528 C_Int (Source_Left_Column), 1529 C_Int (Destination_Top_Row), 1530 C_Int (Destination_Left_Column), 1531 C_Int (Destination_Bottom_Row), 1532 C_Int (Destination_Right_Column)) = Curses_Err 1533 then 1534 raise Curses_Exception; 1535 end if; 1536 end Refresh_Without_Update; 1537 1538 procedure Add_Character_To_Pad_And_Echo_It 1539 (Pad : Window; 1540 Ch : Attributed_Character) 1541 is 1542 function Pechochar (Pad : Window; Ch : Attributed_Character) 1543 return C_Int; 1544 pragma Import (C, Pechochar, "pechochar"); 1545 begin 1546 if Pechochar (Pad, Ch) = Curses_Err then 1547 raise Curses_Exception; 1548 end if; 1549 end Add_Character_To_Pad_And_Echo_It; 1550 1551 procedure Add_Character_To_Pad_And_Echo_It 1552 (Pad : Window; 1553 Ch : Character) 1554 is 1555 begin 1556 Add_Character_To_Pad_And_Echo_It 1557 (Pad, 1558 Attributed_Character'(Ch => Ch, 1559 Color => Color_Pair'First, 1560 Attr => Normal_Video)); 1561 end Add_Character_To_Pad_And_Echo_It; 1562------------------------------------------------------------------------------ 1563 procedure Scroll (Win : Window := Standard_Window; 1564 Amount : Integer := 1) 1565 is 1566 function Wscrl (Win : Window; N : C_Int) return C_Int; 1567 pragma Import (C, Wscrl, "wscrl"); 1568 1569 begin 1570 if Wscrl (Win, C_Int (Amount)) = Curses_Err then 1571 raise Curses_Exception; 1572 end if; 1573 end Scroll; 1574 1575------------------------------------------------------------------------------ 1576 procedure Delete_Character (Win : Window := Standard_Window) 1577 is 1578 function Wdelch (Win : Window) return C_Int; 1579 pragma Import (C, Wdelch, "wdelch"); 1580 begin 1581 if Wdelch (Win) = Curses_Err then 1582 raise Curses_Exception; 1583 end if; 1584 end Delete_Character; 1585 1586 procedure Delete_Character 1587 (Win : Window := Standard_Window; 1588 Line : Line_Position; 1589 Column : Column_Position) 1590 is 1591 function Mvwdelch (Win : Window; 1592 Lin : C_Int; 1593 Col : C_Int) return C_Int; 1594 pragma Import (C, Mvwdelch, "mvwdelch"); 1595 begin 1596 if Mvwdelch (Win, C_Int (Line), C_Int (Column)) = Curses_Err then 1597 raise Curses_Exception; 1598 end if; 1599 end Delete_Character; 1600------------------------------------------------------------------------------ 1601 function Peek (Win : Window := Standard_Window) 1602 return Attributed_Character 1603 is 1604 function Winch (Win : Window) return Attributed_Character; 1605 pragma Import (C, Winch, "winch"); 1606 begin 1607 return Winch (Win); 1608 end Peek; 1609 1610 function Peek 1611 (Win : Window := Standard_Window; 1612 Line : Line_Position; 1613 Column : Column_Position) return Attributed_Character 1614 is 1615 function Mvwinch (Win : Window; 1616 Lin : C_Int; 1617 Col : C_Int) return Attributed_Character; 1618 pragma Import (C, Mvwinch, "mvwinch"); 1619 begin 1620 return Mvwinch (Win, C_Int (Line), C_Int (Column)); 1621 end Peek; 1622------------------------------------------------------------------------------ 1623 procedure Insert (Win : Window := Standard_Window; 1624 Ch : Attributed_Character) 1625 is 1626 function Winsch (Win : Window; Ch : Attributed_Character) return C_Int; 1627 pragma Import (C, Winsch, "winsch"); 1628 begin 1629 if Winsch (Win, Ch) = Curses_Err then 1630 raise Curses_Exception; 1631 end if; 1632 end Insert; 1633 1634 procedure Insert 1635 (Win : Window := Standard_Window; 1636 Line : Line_Position; 1637 Column : Column_Position; 1638 Ch : Attributed_Character) 1639 is 1640 function Mvwinsch (Win : Window; 1641 Lin : C_Int; 1642 Col : C_Int; 1643 Ch : Attributed_Character) return C_Int; 1644 pragma Import (C, Mvwinsch, "mvwinsch"); 1645 begin 1646 if Mvwinsch (Win, 1647 C_Int (Line), 1648 C_Int (Column), 1649 Ch) = Curses_Err 1650 then 1651 raise Curses_Exception; 1652 end if; 1653 end Insert; 1654------------------------------------------------------------------------------ 1655 procedure Insert (Win : Window := Standard_Window; 1656 Str : String; 1657 Len : Integer := -1) 1658 is 1659 function Winsnstr (Win : Window; 1660 Str : char_array; 1661 Len : Integer := -1) return C_Int; 1662 pragma Import (C, Winsnstr, "winsnstr"); 1663 1664 Txt : char_array (0 .. Str'Length); 1665 Length : size_t; 1666 begin 1667 To_C (Str, Txt, Length); 1668 if Winsnstr (Win, Txt, Len) = Curses_Err then 1669 raise Curses_Exception; 1670 end if; 1671 end Insert; 1672 1673 procedure Insert 1674 (Win : Window := Standard_Window; 1675 Line : Line_Position; 1676 Column : Column_Position; 1677 Str : String; 1678 Len : Integer := -1) 1679 is 1680 function Mvwinsnstr (Win : Window; 1681 Line : C_Int; 1682 Column : C_Int; 1683 Str : char_array; 1684 Len : C_Int) return C_Int; 1685 pragma Import (C, Mvwinsnstr, "mvwinsnstr"); 1686 1687 Txt : char_array (0 .. Str'Length); 1688 Length : size_t; 1689 begin 1690 To_C (Str, Txt, Length); 1691 if Mvwinsnstr (Win, C_Int (Line), C_Int (Column), Txt, C_Int (Len)) 1692 = Curses_Err 1693 then 1694 raise Curses_Exception; 1695 end if; 1696 end Insert; 1697------------------------------------------------------------------------------ 1698 procedure Peek (Win : Window := Standard_Window; 1699 Str : out String; 1700 Len : Integer := -1) 1701 is 1702 function Winnstr (Win : Window; 1703 Str : char_array; 1704 Len : C_Int) return C_Int; 1705 pragma Import (C, Winnstr, "winnstr"); 1706 1707 N : Integer := Len; 1708 Txt : char_array (0 .. Str'Length); 1709 Cnt : Natural; 1710 begin 1711 if N < 0 then 1712 N := Str'Length; 1713 end if; 1714 if N > Str'Length then 1715 raise Constraint_Error; 1716 end if; 1717 Txt (0) := Interfaces.C.char'First; 1718 if Winnstr (Win, Txt, C_Int (N)) = Curses_Err then 1719 raise Curses_Exception; 1720 end if; 1721 To_Ada (Txt, Str, Cnt, True); 1722 if Cnt < Str'Length then 1723 Str ((Str'First + Cnt) .. Str'Last) := (others => ' '); 1724 end if; 1725 end Peek; 1726 1727 procedure Peek 1728 (Win : Window := Standard_Window; 1729 Line : Line_Position; 1730 Column : Column_Position; 1731 Str : out String; 1732 Len : Integer := -1) 1733 is 1734 begin 1735 Move_Cursor (Win, Line, Column); 1736 Peek (Win, Str, Len); 1737 end Peek; 1738------------------------------------------------------------------------------ 1739 procedure Peek 1740 (Win : Window := Standard_Window; 1741 Str : out Attributed_String; 1742 Len : Integer := -1) 1743 is 1744 function Winchnstr (Win : Window; 1745 Str : chtype_array; -- out 1746 Len : C_Int) return C_Int; 1747 pragma Import (C, Winchnstr, "winchnstr"); 1748 1749 N : Integer := Len; 1750 Txt : constant chtype_array (0 .. Str'Length) 1751 := (0 => Default_Character); 1752 Cnt : Natural := 0; 1753 begin 1754 if N < 0 then 1755 N := Str'Length; 1756 end if; 1757 if N > Str'Length then 1758 raise Constraint_Error; 1759 end if; 1760 if Winchnstr (Win, Txt, C_Int (N)) = Curses_Err then 1761 raise Curses_Exception; 1762 end if; 1763 for To in Str'Range loop 1764 exit when Txt (size_t (Cnt)) = Default_Character; 1765 Str (To) := Txt (size_t (Cnt)); 1766 Cnt := Cnt + 1; 1767 end loop; 1768 if Cnt < Str'Length then 1769 Str ((Str'First + Cnt) .. Str'Last) := 1770 (others => (Ch => ' ', 1771 Color => Color_Pair'First, 1772 Attr => Normal_Video)); 1773 end if; 1774 end Peek; 1775 1776 procedure Peek 1777 (Win : Window := Standard_Window; 1778 Line : Line_Position; 1779 Column : Column_Position; 1780 Str : out Attributed_String; 1781 Len : Integer := -1) 1782 is 1783 begin 1784 Move_Cursor (Win, Line, Column); 1785 Peek (Win, Str, Len); 1786 end Peek; 1787------------------------------------------------------------------------------ 1788 procedure Get (Win : Window := Standard_Window; 1789 Str : out String; 1790 Len : Integer := -1) 1791 is 1792 function Wgetnstr (Win : Window; 1793 Str : char_array; 1794 Len : C_Int) return C_Int; 1795 pragma Import (C, Wgetnstr, "wgetnstr"); 1796 1797 N : Integer := Len; 1798 Txt : char_array (0 .. Str'Length); 1799 Cnt : Natural; 1800 begin 1801 if N < 0 then 1802 N := Str'Length; 1803 end if; 1804 if N > Str'Length then 1805 raise Constraint_Error; 1806 end if; 1807 Txt (0) := Interfaces.C.char'First; 1808 if Wgetnstr (Win, Txt, C_Int (N)) = Curses_Err then 1809 raise Curses_Exception; 1810 end if; 1811 To_Ada (Txt, Str, Cnt, True); 1812 if Cnt < Str'Length then 1813 Str ((Str'First + Cnt) .. Str'Last) := (others => ' '); 1814 end if; 1815 end Get; 1816 1817 procedure Get 1818 (Win : Window := Standard_Window; 1819 Line : Line_Position; 1820 Column : Column_Position; 1821 Str : out String; 1822 Len : Integer := -1) 1823 is 1824 begin 1825 Move_Cursor (Win, Line, Column); 1826 Get (Win, Str, Len); 1827 end Get; 1828------------------------------------------------------------------------------ 1829 procedure Init_Soft_Label_Keys 1830 (Format : Soft_Label_Key_Format := Three_Two_Three) 1831 is 1832 function Slk_Init (Fmt : C_Int) return C_Int; 1833 pragma Import (C, Slk_Init, "slk_init"); 1834 begin 1835 if Slk_Init (Soft_Label_Key_Format'Pos (Format)) = Curses_Err then 1836 raise Curses_Exception; 1837 end if; 1838 end Init_Soft_Label_Keys; 1839 1840 procedure Set_Soft_Label_Key (Label : Label_Number; 1841 Text : String; 1842 Fmt : Label_Justification := Left) 1843 is 1844 function Slk_Set (Label : C_Int; 1845 Txt : char_array; 1846 Fmt : C_Int) return C_Int; 1847 pragma Import (C, Slk_Set, "slk_set"); 1848 1849 Txt : char_array (0 .. Text'Length); 1850 Len : size_t; 1851 begin 1852 To_C (Text, Txt, Len); 1853 if Slk_Set (C_Int (Label), Txt, 1854 C_Int (Label_Justification'Pos (Fmt))) = Curses_Err 1855 then 1856 raise Curses_Exception; 1857 end if; 1858 end Set_Soft_Label_Key; 1859 1860 procedure Refresh_Soft_Label_Keys 1861 is 1862 function Slk_Refresh return C_Int; 1863 pragma Import (C, Slk_Refresh, "slk_refresh"); 1864 begin 1865 if Slk_Refresh = Curses_Err then 1866 raise Curses_Exception; 1867 end if; 1868 end Refresh_Soft_Label_Keys; 1869 1870 procedure Refresh_Soft_Label_Keys_Without_Update 1871 is 1872 function Slk_Noutrefresh return C_Int; 1873 pragma Import (C, Slk_Noutrefresh, "slk_noutrefresh"); 1874 begin 1875 if Slk_Noutrefresh = Curses_Err then 1876 raise Curses_Exception; 1877 end if; 1878 end Refresh_Soft_Label_Keys_Without_Update; 1879 1880 procedure Get_Soft_Label_Key (Label : Label_Number; 1881 Text : out String) 1882 is 1883 function Slk_Label (Label : C_Int) return chars_ptr; 1884 pragma Import (C, Slk_Label, "slk_label"); 1885 begin 1886 Fill_String (Slk_Label (C_Int (Label)), Text); 1887 end Get_Soft_Label_Key; 1888 1889 function Get_Soft_Label_Key (Label : Label_Number) return String 1890 is 1891 function Slk_Label (Label : C_Int) return chars_ptr; 1892 pragma Import (C, Slk_Label, "slk_label"); 1893 begin 1894 return Fill_String (Slk_Label (C_Int (Label))); 1895 end Get_Soft_Label_Key; 1896 1897 procedure Clear_Soft_Label_Keys 1898 is 1899 function Slk_Clear return C_Int; 1900 pragma Import (C, Slk_Clear, "slk_clear"); 1901 begin 1902 if Slk_Clear = Curses_Err then 1903 raise Curses_Exception; 1904 end if; 1905 end Clear_Soft_Label_Keys; 1906 1907 procedure Restore_Soft_Label_Keys 1908 is 1909 function Slk_Restore return C_Int; 1910 pragma Import (C, Slk_Restore, "slk_restore"); 1911 begin 1912 if Slk_Restore = Curses_Err then 1913 raise Curses_Exception; 1914 end if; 1915 end Restore_Soft_Label_Keys; 1916 1917 procedure Touch_Soft_Label_Keys 1918 is 1919 function Slk_Touch return C_Int; 1920 pragma Import (C, Slk_Touch, "slk_touch"); 1921 begin 1922 if Slk_Touch = Curses_Err then 1923 raise Curses_Exception; 1924 end if; 1925 end Touch_Soft_Label_Keys; 1926 1927 procedure Switch_Soft_Label_Key_Attributes 1928 (Attr : Character_Attribute_Set; 1929 On : Boolean := True) 1930 is 1931 function Slk_Attron (Ch : Attributed_Character) return C_Int; 1932 pragma Import (C, Slk_Attron, "slk_attron"); 1933 function Slk_Attroff (Ch : Attributed_Character) return C_Int; 1934 pragma Import (C, Slk_Attroff, "slk_attroff"); 1935 1936 Err : C_Int; 1937 Ch : constant Attributed_Character := (Ch => Character'First, 1938 Attr => Attr, 1939 Color => Color_Pair'First); 1940 begin 1941 if On then 1942 Err := Slk_Attron (Ch); 1943 else 1944 Err := Slk_Attroff (Ch); 1945 end if; 1946 if Err = Curses_Err then 1947 raise Curses_Exception; 1948 end if; 1949 end Switch_Soft_Label_Key_Attributes; 1950 1951 procedure Set_Soft_Label_Key_Attributes 1952 (Attr : Character_Attribute_Set := Normal_Video; 1953 Color : Color_Pair := Color_Pair'First) 1954 is 1955 function Slk_Attrset (Ch : Attributed_Character) return C_Int; 1956 pragma Import (C, Slk_Attrset, "slk_attrset"); 1957 1958 Ch : constant Attributed_Character := (Ch => Character'First, 1959 Attr => Attr, 1960 Color => Color); 1961 begin 1962 if Slk_Attrset (Ch) = Curses_Err then 1963 raise Curses_Exception; 1964 end if; 1965 end Set_Soft_Label_Key_Attributes; 1966 1967 function Get_Soft_Label_Key_Attributes return Character_Attribute_Set 1968 is 1969 function Slk_Attr return Attributed_Character; 1970 pragma Import (C, Slk_Attr, "slk_attr"); 1971 1972 Attr : constant Attributed_Character := Slk_Attr; 1973 begin 1974 return Attr.Attr; 1975 end Get_Soft_Label_Key_Attributes; 1976 1977 function Get_Soft_Label_Key_Attributes return Color_Pair 1978 is 1979 function Slk_Attr return Attributed_Character; 1980 pragma Import (C, Slk_Attr, "slk_attr"); 1981 1982 Attr : constant Attributed_Character := Slk_Attr; 1983 begin 1984 return Attr.Color; 1985 end Get_Soft_Label_Key_Attributes; 1986 1987 procedure Set_Soft_Label_Key_Color (Pair : Color_Pair) 1988 is 1989 function Slk_Color (Color : C_Short) return C_Int; 1990 pragma Import (C, Slk_Color, "slk_color"); 1991 begin 1992 if Slk_Color (C_Short (Pair)) = Curses_Err then 1993 raise Curses_Exception; 1994 end if; 1995 end Set_Soft_Label_Key_Color; 1996 1997------------------------------------------------------------------------------ 1998 procedure Enable_Key (Key : Special_Key_Code; 1999 Enable : Boolean := True) 2000 is 2001 function Keyok (Keycode : C_Int; 2002 On_Off : Curses_Bool) return C_Int; 2003 pragma Import (C, Keyok, "keyok"); 2004 begin 2005 if Keyok (C_Int (Key), Curses_Bool (Boolean'Pos (Enable))) 2006 = Curses_Err 2007 then 2008 raise Curses_Exception; 2009 end if; 2010 end Enable_Key; 2011------------------------------------------------------------------------------ 2012 procedure Define_Key (Definition : String; 2013 Key : Special_Key_Code) 2014 is 2015 function Defkey (Def : char_array; 2016 Key : C_Int) return C_Int; 2017 pragma Import (C, Defkey, "define_key"); 2018 2019 Txt : char_array (0 .. Definition'Length); 2020 Length : size_t; 2021 begin 2022 To_C (Definition, Txt, Length); 2023 if Defkey (Txt, C_Int (Key)) = Curses_Err then 2024 raise Curses_Exception; 2025 end if; 2026 end Define_Key; 2027------------------------------------------------------------------------------ 2028 procedure Un_Control (Ch : Attributed_Character; 2029 Str : out String) 2030 is 2031 function Unctrl (Ch : Attributed_Character) return chars_ptr; 2032 pragma Import (C, Unctrl, "unctrl"); 2033 begin 2034 Fill_String (Unctrl (Ch), Str); 2035 end Un_Control; 2036 2037 function Un_Control (Ch : Attributed_Character) return String 2038 is 2039 function Unctrl (Ch : Attributed_Character) return chars_ptr; 2040 pragma Import (C, Unctrl, "unctrl"); 2041 begin 2042 return Fill_String (Unctrl (Ch)); 2043 end Un_Control; 2044 2045 procedure Delay_Output (Msecs : Natural) 2046 is 2047 function Delayoutput (Msecs : C_Int) return C_Int; 2048 pragma Import (C, Delayoutput, "delay_output"); 2049 begin 2050 if Delayoutput (C_Int (Msecs)) = Curses_Err then 2051 raise Curses_Exception; 2052 end if; 2053 end Delay_Output; 2054 2055 procedure Flush_Input 2056 is 2057 function Flushinp return C_Int; 2058 pragma Import (C, Flushinp, "flushinp"); 2059 begin 2060 if Flushinp = Curses_Err then -- docu says that never happens, but... 2061 raise Curses_Exception; 2062 end if; 2063 end Flush_Input; 2064------------------------------------------------------------------------------ 2065 function Baudrate return Natural 2066 is 2067 function Baud return C_Int; 2068 pragma Import (C, Baud, "baudrate"); 2069 begin 2070 return Natural (Baud); 2071 end Baudrate; 2072 2073 function Erase_Character return Character 2074 is 2075 function Erasechar return C_Int; 2076 pragma Import (C, Erasechar, "erasechar"); 2077 begin 2078 return Character'Val (Erasechar); 2079 end Erase_Character; 2080 2081 function Kill_Character return Character 2082 is 2083 function Killchar return C_Int; 2084 pragma Import (C, Killchar, "killchar"); 2085 begin 2086 return Character'Val (Killchar); 2087 end Kill_Character; 2088 2089 function Has_Insert_Character return Boolean 2090 is 2091 function Has_Ic return Curses_Bool; 2092 pragma Import (C, Has_Ic, "has_ic"); 2093 begin 2094 if Has_Ic = Curses_Bool_False then 2095 return False; 2096 else 2097 return True; 2098 end if; 2099 end Has_Insert_Character; 2100 2101 function Has_Insert_Line return Boolean 2102 is 2103 function Has_Il return Curses_Bool; 2104 pragma Import (C, Has_Il, "has_il"); 2105 begin 2106 if Has_Il = Curses_Bool_False then 2107 return False; 2108 else 2109 return True; 2110 end if; 2111 end Has_Insert_Line; 2112 2113 function Supported_Attributes return Character_Attribute_Set 2114 is 2115 function Termattrs return Attributed_Character; 2116 pragma Import (C, Termattrs, "termattrs"); 2117 2118 Ch : constant Attributed_Character := Termattrs; 2119 begin 2120 return Ch.Attr; 2121 end Supported_Attributes; 2122 2123 procedure Long_Name (Name : out String) 2124 is 2125 function Longname return chars_ptr; 2126 pragma Import (C, Longname, "longname"); 2127 begin 2128 Fill_String (Longname, Name); 2129 end Long_Name; 2130 2131 function Long_Name return String 2132 is 2133 function Longname return chars_ptr; 2134 pragma Import (C, Longname, "longname"); 2135 begin 2136 return Fill_String (Longname); 2137 end Long_Name; 2138 2139 procedure Terminal_Name (Name : out String) 2140 is 2141 function Termname return chars_ptr; 2142 pragma Import (C, Termname, "termname"); 2143 begin 2144 Fill_String (Termname, Name); 2145 end Terminal_Name; 2146 2147 function Terminal_Name return String 2148 is 2149 function Termname return chars_ptr; 2150 pragma Import (C, Termname, "termname"); 2151 begin 2152 return Fill_String (Termname); 2153 end Terminal_Name; 2154------------------------------------------------------------------------------ 2155 procedure Init_Pair (Pair : Redefinable_Color_Pair; 2156 Fore : Color_Number; 2157 Back : Color_Number) 2158 is 2159 function Initpair (Pair : C_Short; 2160 Fore : C_Short; 2161 Back : C_Short) return C_Int; 2162 pragma Import (C, Initpair, "init_pair"); 2163 begin 2164 if Integer (Pair) >= Number_Of_Color_Pairs then 2165 raise Constraint_Error; 2166 end if; 2167 if Integer (Fore) >= Number_Of_Colors or else 2168 Integer (Back) >= Number_Of_Colors 2169 then 2170 raise Constraint_Error; 2171 end if; 2172 if Initpair (C_Short (Pair), C_Short (Fore), C_Short (Back)) 2173 = Curses_Err 2174 then 2175 raise Curses_Exception; 2176 end if; 2177 end Init_Pair; 2178 2179 procedure Pair_Content (Pair : Color_Pair; 2180 Fore : out Color_Number; 2181 Back : out Color_Number) 2182 is 2183 type C_Short_Access is access all C_Short; 2184 function Paircontent (Pair : C_Short; 2185 Fp : C_Short_Access; 2186 Bp : C_Short_Access) return C_Int; 2187 pragma Import (C, Paircontent, "pair_content"); 2188 2189 F, B : aliased C_Short; 2190 begin 2191 if Paircontent (C_Short (Pair), F'Access, B'Access) = Curses_Err then 2192 raise Curses_Exception; 2193 else 2194 Fore := Color_Number (F); 2195 Back := Color_Number (B); 2196 end if; 2197 end Pair_Content; 2198 2199 function Has_Colors return Boolean 2200 is 2201 function Hascolors return Curses_Bool; 2202 pragma Import (C, Hascolors, "has_colors"); 2203 begin 2204 if Hascolors = Curses_Bool_False then 2205 return False; 2206 else 2207 return True; 2208 end if; 2209 end Has_Colors; 2210 2211 procedure Init_Color (Color : Color_Number; 2212 Red : RGB_Value; 2213 Green : RGB_Value; 2214 Blue : RGB_Value) 2215 is 2216 function Initcolor (Col : C_Short; 2217 Red : C_Short; 2218 Green : C_Short; 2219 Blue : C_Short) return C_Int; 2220 pragma Import (C, Initcolor, "init_color"); 2221 begin 2222 if Initcolor (C_Short (Color), C_Short (Red), C_Short (Green), 2223 C_Short (Blue)) = Curses_Err 2224 then 2225 raise Curses_Exception; 2226 end if; 2227 end Init_Color; 2228 2229 function Can_Change_Color return Boolean 2230 is 2231 function Canchangecolor return Curses_Bool; 2232 pragma Import (C, Canchangecolor, "can_change_color"); 2233 begin 2234 if Canchangecolor = Curses_Bool_False then 2235 return False; 2236 else 2237 return True; 2238 end if; 2239 end Can_Change_Color; 2240 2241 procedure Color_Content (Color : Color_Number; 2242 Red : out RGB_Value; 2243 Green : out RGB_Value; 2244 Blue : out RGB_Value) 2245 is 2246 type C_Short_Access is access all C_Short; 2247 2248 function Colorcontent (Color : C_Short; R, G, B : C_Short_Access) 2249 return C_Int; 2250 pragma Import (C, Colorcontent, "color_content"); 2251 2252 R, G, B : aliased C_Short; 2253 begin 2254 if Colorcontent (C_Short (Color), R'Access, G'Access, B'Access) = 2255 Curses_Err 2256 then 2257 raise Curses_Exception; 2258 else 2259 Red := RGB_Value (R); 2260 Green := RGB_Value (G); 2261 Blue := RGB_Value (B); 2262 end if; 2263 end Color_Content; 2264 2265------------------------------------------------------------------------------ 2266 procedure Save_Curses_Mode (Mode : Curses_Mode) 2267 is 2268 function Def_Prog_Mode return C_Int; 2269 pragma Import (C, Def_Prog_Mode, "def_prog_mode"); 2270 function Def_Shell_Mode return C_Int; 2271 pragma Import (C, Def_Shell_Mode, "def_shell_mode"); 2272 2273 Err : C_Int; 2274 begin 2275 case Mode is 2276 when Curses => Err := Def_Prog_Mode; 2277 when Shell => Err := Def_Shell_Mode; 2278 end case; 2279 if Err = Curses_Err then 2280 raise Curses_Exception; 2281 end if; 2282 end Save_Curses_Mode; 2283 2284 procedure Reset_Curses_Mode (Mode : Curses_Mode) 2285 is 2286 function Reset_Prog_Mode return C_Int; 2287 pragma Import (C, Reset_Prog_Mode, "reset_prog_mode"); 2288 function Reset_Shell_Mode return C_Int; 2289 pragma Import (C, Reset_Shell_Mode, "reset_shell_mode"); 2290 2291 Err : C_Int; 2292 begin 2293 case Mode is 2294 when Curses => Err := Reset_Prog_Mode; 2295 when Shell => Err := Reset_Shell_Mode; 2296 end case; 2297 if Err = Curses_Err then 2298 raise Curses_Exception; 2299 end if; 2300 end Reset_Curses_Mode; 2301 2302 procedure Save_Terminal_State 2303 is 2304 function Savetty return C_Int; 2305 pragma Import (C, Savetty, "savetty"); 2306 begin 2307 if Savetty = Curses_Err then 2308 raise Curses_Exception; 2309 end if; 2310 end Save_Terminal_State; 2311 2312 procedure Reset_Terminal_State 2313 is 2314 function Resetty return C_Int; 2315 pragma Import (C, Resetty, "resetty"); 2316 begin 2317 if Resetty = Curses_Err then 2318 raise Curses_Exception; 2319 end if; 2320 end Reset_Terminal_State; 2321 2322 procedure Rip_Off_Lines (Lines : Integer; 2323 Proc : Stdscr_Init_Proc) 2324 is 2325 function Ripoffline (Lines : C_Int; 2326 Proc : Stdscr_Init_Proc) return C_Int; 2327 pragma Import (C, Ripoffline, "_nc_ripoffline"); 2328 begin 2329 if Ripoffline (C_Int (Lines), Proc) = Curses_Err then 2330 raise Curses_Exception; 2331 end if; 2332 end Rip_Off_Lines; 2333 2334 procedure Set_Cursor_Visibility (Visibility : in out Cursor_Visibility) 2335 is 2336 function Curs_Set (Curs : C_Int) return C_Int; 2337 pragma Import (C, Curs_Set, "curs_set"); 2338 2339 Res : C_Int; 2340 begin 2341 Res := Curs_Set (Cursor_Visibility'Pos (Visibility)); 2342 if Res /= Curses_Err then 2343 Visibility := Cursor_Visibility'Val (Res); 2344 end if; 2345 end Set_Cursor_Visibility; 2346 2347 procedure Nap_Milli_Seconds (Ms : Natural) 2348 is 2349 function Napms (Ms : C_Int) return C_Int; 2350 pragma Import (C, Napms, "napms"); 2351 begin 2352 if Napms (C_Int (Ms)) = Curses_Err then 2353 raise Curses_Exception; 2354 end if; 2355 end Nap_Milli_Seconds; 2356------------------------------------------------------------------------------ 2357 function Lines return Line_Count 2358 is 2359 function LINES_As_Function return Interfaces.C.int; 2360 pragma Import (C, LINES_As_Function, "LINES_as_function"); 2361 begin 2362 return Line_Count (LINES_As_Function); 2363 end Lines; 2364 2365 function Columns return Column_Count 2366 is 2367 function COLS_As_Function return Interfaces.C.int; 2368 pragma Import (C, COLS_As_Function, "COLS_as_function"); 2369 begin 2370 return Column_Count (COLS_As_Function); 2371 end Columns; 2372 2373 function Tab_Size return Natural 2374 is 2375 function TABSIZE_As_Function return Interfaces.C.int; 2376 pragma Import (C, TABSIZE_As_Function, "TABSIZE_as_function"); 2377 2378 begin 2379 return Natural (TABSIZE_As_Function); 2380 end Tab_Size; 2381 2382 function Number_Of_Colors return Natural 2383 is 2384 function COLORS_As_Function return Interfaces.C.int; 2385 pragma Import (C, COLORS_As_Function, "COLORS_as_function"); 2386 begin 2387 return Natural (COLORS_As_Function); 2388 end Number_Of_Colors; 2389 2390 function Number_Of_Color_Pairs return Natural 2391 is 2392 function COLOR_PAIRS_As_Function return Interfaces.C.int; 2393 pragma Import (C, COLOR_PAIRS_As_Function, "COLOR_PAIRS_as_function"); 2394 begin 2395 return Natural (COLOR_PAIRS_As_Function); 2396 end Number_Of_Color_Pairs; 2397------------------------------------------------------------------------------ 2398 procedure Transform_Coordinates 2399 (W : Window := Standard_Window; 2400 Line : in out Line_Position; 2401 Column : in out Column_Position; 2402 Dir : Transform_Direction := From_Screen) 2403 is 2404 type Int_Access is access all C_Int; 2405 function Transform (W : Window; 2406 Y, X : Int_Access; 2407 Dir : Curses_Bool) return C_Int; 2408 pragma Import (C, Transform, "wmouse_trafo"); 2409 2410 X : aliased C_Int := C_Int (Column); 2411 Y : aliased C_Int := C_Int (Line); 2412 D : Curses_Bool := Curses_Bool_False; 2413 R : C_Int; 2414 begin 2415 if Dir = To_Screen then 2416 D := 1; 2417 end if; 2418 R := Transform (W, Y'Access, X'Access, D); 2419 if R = Curses_False then 2420 raise Curses_Exception; 2421 else 2422 Line := Line_Position (Y); 2423 Column := Column_Position (X); 2424 end if; 2425 end Transform_Coordinates; 2426------------------------------------------------------------------------------ 2427 procedure Use_Default_Colors is 2428 function C_Use_Default_Colors return C_Int; 2429 pragma Import (C, C_Use_Default_Colors, "use_default_colors"); 2430 Err : constant C_Int := C_Use_Default_Colors; 2431 begin 2432 if Err = Curses_Err then 2433 raise Curses_Exception; 2434 end if; 2435 end Use_Default_Colors; 2436 2437 procedure Assume_Default_Colors (Fore : Color_Number := Default_Color; 2438 Back : Color_Number := Default_Color) 2439 is 2440 function C_Assume_Default_Colors (Fore : C_Int; 2441 Back : C_Int) return C_Int; 2442 pragma Import (C, C_Assume_Default_Colors, "assume_default_colors"); 2443 2444 Err : constant C_Int := C_Assume_Default_Colors (C_Int (Fore), 2445 C_Int (Back)); 2446 begin 2447 if Err = Curses_Err then 2448 raise Curses_Exception; 2449 end if; 2450 end Assume_Default_Colors; 2451------------------------------------------------------------------------------ 2452 function Curses_Version return String 2453 is 2454 function curses_versionC return chars_ptr; 2455 pragma Import (C, curses_versionC, "curses_version"); 2456 Result : constant chars_ptr := curses_versionC; 2457 begin 2458 return Fill_String (Result); 2459 end Curses_Version; 2460------------------------------------------------------------------------------ 2461 procedure Curses_Free_All is 2462 procedure curses_freeall; 2463 pragma Import (C, curses_freeall, "_nc_freeall"); 2464 begin 2465 -- Use this only for testing: you cannot use curses after calling it, 2466 -- so it has to be the "last" thing done before exiting the program. 2467 -- This will not really free ALL of memory used by curses. That is 2468 -- because it cannot free the memory used for stdout's setbuf. The 2469 -- _nc_free_and_exit() procedure can do that, but it can be invoked 2470 -- safely only from C - and again, that only as the "last" thing done 2471 -- before exiting the program. 2472 curses_freeall; 2473 end Curses_Free_All; 2474------------------------------------------------------------------------------ 2475 function Use_Extended_Names (Enable : Boolean) return Boolean 2476 is 2477 function use_extended_namesC (e : Curses_Bool) return C_Int; 2478 pragma Import (C, use_extended_namesC, "use_extended_names"); 2479 2480 Res : constant C_Int := 2481 use_extended_namesC (Curses_Bool (Boolean'Pos (Enable))); 2482 begin 2483 if Res = C_Int (Curses_Bool_False) then 2484 return False; 2485 else 2486 return True; 2487 end if; 2488 end Use_Extended_Names; 2489------------------------------------------------------------------------------ 2490 procedure Screen_Dump_To_File (Filename : String) 2491 is 2492 function scr_dump (f : char_array) return C_Int; 2493 pragma Import (C, scr_dump, "scr_dump"); 2494 Txt : char_array (0 .. Filename'Length); 2495 Length : size_t; 2496 begin 2497 To_C (Filename, Txt, Length); 2498 if Curses_Err = scr_dump (Txt) then 2499 raise Curses_Exception; 2500 end if; 2501 end Screen_Dump_To_File; 2502 2503 procedure Screen_Restore_From_File (Filename : String) 2504 is 2505 function scr_restore (f : char_array) return C_Int; 2506 pragma Import (C, scr_restore, "scr_restore"); 2507 Txt : char_array (0 .. Filename'Length); 2508 Length : size_t; 2509 begin 2510 To_C (Filename, Txt, Length); 2511 if Curses_Err = scr_restore (Txt) then 2512 raise Curses_Exception; 2513 end if; 2514 end Screen_Restore_From_File; 2515 2516 procedure Screen_Init_From_File (Filename : String) 2517 is 2518 function scr_init (f : char_array) return C_Int; 2519 pragma Import (C, scr_init, "scr_init"); 2520 Txt : char_array (0 .. Filename'Length); 2521 Length : size_t; 2522 begin 2523 To_C (Filename, Txt, Length); 2524 if Curses_Err = scr_init (Txt) then 2525 raise Curses_Exception; 2526 end if; 2527 end Screen_Init_From_File; 2528 2529 procedure Screen_Set_File (Filename : String) 2530 is 2531 function scr_set (f : char_array) return C_Int; 2532 pragma Import (C, scr_set, "scr_set"); 2533 Txt : char_array (0 .. Filename'Length); 2534 Length : size_t; 2535 begin 2536 To_C (Filename, Txt, Length); 2537 if Curses_Err = scr_set (Txt) then 2538 raise Curses_Exception; 2539 end if; 2540 end Screen_Set_File; 2541------------------------------------------------------------------------------ 2542 procedure Resize (Win : Window := Standard_Window; 2543 Number_Of_Lines : Line_Count; 2544 Number_Of_Columns : Column_Count) is 2545 function wresize (win : Window; 2546 lines : C_Int; 2547 columns : C_Int) return C_Int; 2548 pragma Import (C, wresize); 2549 begin 2550 if wresize (Win, 2551 C_Int (Number_Of_Lines), 2552 C_Int (Number_Of_Columns)) = Curses_Err 2553 then 2554 raise Curses_Exception; 2555 end if; 2556 end Resize; 2557------------------------------------------------------------------------------ 2558 2559end Terminal_Interface.Curses; 2560