ncurses 6.2 - patch 20210508
[ncurses.git] / Ada95 / samples / ncurses2-getch_test.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                       GNAT ncurses Binding Samples                       --
4 --                                                                          --
5 --                                 ncurses                                  --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 ------------------------------------------------------------------------------
10 -- Copyright 2020 Thomas E. Dickey                                          --
11 -- Copyright 2000-2009,2014 Free Software Foundation, Inc.                  --
12 --                                                                          --
13 -- Permission is hereby granted, free of charge, to any person obtaining a  --
14 -- copy of this software and associated documentation files (the            --
15 -- "Software"), to deal in the Software without restriction, including      --
16 -- without limitation the rights to use, copy, modify, merge, publish,      --
17 -- distribute, distribute with modifications, sublicense, and/or sell       --
18 -- copies of the Software, and to permit persons to whom the Software is    --
19 -- furnished to do so, subject to the following conditions:                 --
20 --                                                                          --
21 -- The above copyright notice and this permission notice shall be included  --
22 -- in all copies or substantial portions of the Software.                   --
23 --                                                                          --
24 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
25 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
26 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
27 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
28 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
29 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
30 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
31 --                                                                          --
32 -- Except as contained in this notice, the name(s) of the above copyright   --
33 -- holders shall not be used in advertising or otherwise to promote the     --
34 -- sale, use or other dealings in this Software without prior written       --
35 -- authorization.                                                           --
36 ------------------------------------------------------------------------------
37 --  Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
38 --  Version Control
39 --  $Revision: 1.10 $
40 --  $Date: 2020/02/02 23:34:34 $
41 --  Binding Version 01.00
42 ------------------------------------------------------------------------------
43 --  Character input test
44 --  test the keypad feature
45
46 with ncurses2.util; use ncurses2.util;
47
48 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
49 with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
50 with Ada.Characters.Handling;
51 with Ada.Strings.Bounded;
52
53 with ncurses2.genericPuts;
54
55 procedure ncurses2.getch_test is
56    use Int_IO;
57
58    function mouse_decode (ep : Mouse_Event) return String;
59
60    function mouse_decode (ep : Mouse_Event) return String is
61       Y      : Line_Position;
62       X      : Column_Position;
63       Button : Mouse_Button;
64       State  : Button_State;
65       package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (200);
66       use BS;
67       buf : Bounded_String := To_Bounded_String ("");
68    begin
69       --  Note that these bindings do not allow
70       --  two button states,
71       --  The C version can print {click-1, click-3} for example.
72       --  They also don't have the 'id' or z coordinate.
73       Get_Event (ep, Y, X, Button, State);
74
75       --  TODO Append (buf, "id "); from C version
76       Append (buf, "at (");
77       Append (buf, Column_Position'Image (X));
78       Append (buf, ", ");
79       Append (buf, Line_Position'Image (Y));
80       Append (buf, ") state");
81       Append (buf, Mouse_Button'Image (Button));
82
83       Append (buf, " = ");
84       Append (buf, Button_State'Image (State));
85       return To_String (buf);
86    end mouse_decode;
87
88    buf : String (1 .. 1024); --  TODO was BUFSIZE
89    n : Integer;
90    c : Key_Code;
91    blockflag : Timeout_Mode := Blocking;
92    firsttime : Boolean := True;
93    tmp2  : Event_Mask;
94    tmp6 : String (1 .. 6);
95    tmp20 : String (1 .. 20);
96    x : Column_Position;
97    y : Line_Position;
98    tmpx : Integer;
99    incount : Integer := 0;
100
101 begin
102    Refresh;
103    tmp2 := Start_Mouse (All_Events);
104    Add (Str => "Delay in 10ths of a second (<CR> for blocking input)? ");
105    Set_Echo_Mode (SwitchOn => True);
106    Get (Str => buf);
107
108    Set_Echo_Mode (SwitchOn => False);
109    Set_NL_Mode (SwitchOn => False);
110
111    if Ada.Characters.Handling.Is_Digit (buf (1)) then
112       Get (Item => n, From => buf, Last => tmpx);
113       Set_Timeout_Mode (Mode => Delayed, Amount => n * 100);
114       blockflag := Delayed;
115    end if;
116
117    c := Character'Pos ('?');
118    Set_Raw_Mode (SwitchOn => True);
119    loop
120       if not firsttime then
121          Add (Str => "Key pressed: ");
122          Put (tmp6, Integer (c), 8);
123          Add (Str => tmp6);
124          Add (Ch => ' ');
125          if c = Key_Mouse then
126             declare
127                event : Mouse_Event;
128             begin
129                event := Get_Mouse;
130                Add (Str => "KEY_MOUSE, ");
131                Add (Str => mouse_decode (event));
132                Add (Ch => newl);
133             end;
134          elsif c >= Key_Min then
135             Key_Name (c, tmp20);
136             Add (Str => tmp20);
137             --  I used tmp and got bitten by the length problem:->
138             Add (Ch => newl);
139          elsif c > 16#80# then --  TODO fix, use constant if possible
140             declare
141                c2 : constant Character := Character'Val (c mod 16#80#);
142             begin
143                if Ada.Characters.Handling.Is_Graphic (c2) then
144                   Add (Str => "M-");
145                   Add (Ch => c2);
146                else
147                   Add (Str => "M-");
148                   Add (Str => Un_Control ((Ch => c2,
149                                            Color => Color_Pair'First,
150                                            Attr => Normal_Video)));
151                end if;
152                Add (Str => " (high-half character)");
153                Add (Ch => newl);
154             end;
155          else
156             declare
157                c2 : constant Character := Character'Val (c mod 16#80#);
158             begin
159                if Ada.Characters.Handling.Is_Graphic (c2) then
160                   Add (Ch => c2);
161                   Add (Str => " (ASCII printable character)");
162                   Add (Ch => newl);
163                else
164                   Add (Str => Un_Control ((Ch => c2,
165                                           Color => Color_Pair'First,
166                                           Attr => Normal_Video)));
167                   Add (Str => " (ASCII control character)");
168                   Add (Ch => newl);
169                end if;
170             end;
171          end if;
172          --  TODO I am not sure why this was in the C version
173          --  the delay statement scroll anyway.
174          Get_Cursor_Position (Line => y, Column => x);
175          if y >= Lines - 1 then
176             Move_Cursor (Line => 0, Column => 0);
177          end if;
178          Clear_To_End_Of_Line;
179       end if;
180
181       firsttime := False;
182       if c = Character'Pos ('g') then
183          declare
184             package p is new ncurses2.genericPuts (1024);
185             use p;
186             use p.BS;
187             timedout : Boolean := False;
188             boundedbuf : Bounded_String;
189          begin
190             Add (Str => "getstr test: ");
191             Set_Echo_Mode (SwitchOn => True);
192             --  Note that if delay mode is set
193             --  Get can raise an exception.
194             --  The C version would print the string it had so far
195             --  also TODO get longer length string, like the C version
196             declare begin
197                myGet (Str => boundedbuf);
198             exception when Curses_Exception =>
199                Add (Str => "Timed out.");
200                Add (Ch => newl);
201                timedout := True;
202             end;
203             --  note that the Ada Get will stop reading at 1024.
204             if not timedout then
205                Set_Echo_Mode (SwitchOn => False);
206                Add (Str => " I saw '");
207                myAdd (Str => boundedbuf);
208                Add (Str => "'.");
209                Add (Ch => newl);
210             end if;
211          end;
212       elsif c = Character'Pos ('s') then
213          ShellOut (True);
214       elsif c = Character'Pos ('x') or
215             c = Character'Pos ('q') or
216            (c = Key_None and blockflag = Blocking)
217       then
218          exit;
219       elsif c = Character'Pos ('?') then
220          Add (Str => "Type any key to see its keypad value.  Also:");
221          Add (Ch => newl);
222          Add (Str => "g -- triggers a getstr test");
223          Add (Ch => newl);
224          Add (Str => "s -- shell out");
225          Add (Ch => newl);
226          Add (Str => "q -- quit");
227          Add (Ch => newl);
228          Add (Str => "? -- repeats this help message");
229          Add (Ch => newl);
230       end if;
231
232       loop
233          c := Getchar;
234          exit when c /= Key_None;
235          if blockflag /= Blocking then
236             Put (tmp6, incount); --  argh string length!
237             Add (Str => tmp6);
238             Add (Str => ": input timed out");
239             Add (Ch => newl);
240          else
241             Put (tmp6, incount);
242             Add (Str => tmp6);
243             Add (Str => ": input error");
244             Add (Ch => newl);
245             exit;
246          end if;
247          incount := incount + 1;
248       end loop;
249    end loop;
250
251    End_Mouse (tmp2);
252    Set_Timeout_Mode (Mode => Blocking, Amount => 0); --  amount is ignored
253    Set_Raw_Mode (SwitchOn => False);
254    Set_NL_Mode (SwitchOn => True);
255    Erase;
256    End_Windows;
257 end ncurses2.getch_test;