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