blob: 75ddb962f0d18ca93960711202b02d1e5242286f [file] [log] [blame]
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +05301-- -*- 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;