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