ncurses 5.9 - patch 20140913
[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 (c) 2000-2009,2014 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: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
37 --  Version Control
38 --  $Revision: 1.9 $
39 --  $Date: 2014/09/13 19:10:18 $
40 --  Binding Version 01.00
41 ------------------------------------------------------------------------------
42 --  Character input test
43 --  test the keypad feature
44
45 with ncurses2.util; use ncurses2.util;
46
47 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
48 with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
49 with Ada.Characters.Handling;
50 with Ada.Strings.Bounded;
51
52 with ncurses2.genericPuts;
53
54 procedure ncurses2.getch_test is
55    use Int_IO;
56
57    function mouse_decode (ep : Mouse_Event) return String;
58
59    function mouse_decode (ep : Mouse_Event) return String is
60       Y      : Line_Position;
61       X      : Column_Position;
62       Button : Mouse_Button;
63       State  : Button_State;
64       package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (200);
65       use BS;
66       buf : Bounded_String := To_Bounded_String ("");
67    begin
68       --  Note that these bindings do not allow
69       --  two button states,
70       --  The C version can print {click-1, click-3} for example.
71       --  They also don't have the 'id' or z coordinate.
72       Get_Event (ep, Y, X, Button, State);
73
74       --  TODO Append (buf, "id "); from C version
75       Append (buf, "at (");
76       Append (buf, Column_Position'Image (X));
77       Append (buf, ", ");
78       Append (buf, Line_Position'Image (Y));
79       Append (buf, ") state");
80       Append (buf, Mouse_Button'Image (Button));
81
82       Append (buf, " = ");
83       Append (buf, Button_State'Image (State));
84       return To_String (buf);
85    end mouse_decode;
86
87    buf : String (1 .. 1024); --  TODO was BUFSIZE
88    n : Integer;
89    c : Key_Code;
90    blockflag : Timeout_Mode := Blocking;
91    firsttime : Boolean := True;
92    tmp2  : Event_Mask;
93    tmp6 : String (1 .. 6);
94    tmp20 : String (1 .. 20);
95    x : Column_Position;
96    y : Line_Position;
97    tmpx : Integer;
98    incount : Integer := 0;
99
100 begin
101    Refresh;
102    tmp2 := Start_Mouse (All_Events);
103    Add (Str => "Delay in 10ths of a second (<CR> for blocking input)? ");
104    Set_Echo_Mode (SwitchOn => True);
105    Get (Str => buf);
106
107    Set_Echo_Mode (SwitchOn => False);
108    Set_NL_Mode (SwitchOn => False);
109
110    if Ada.Characters.Handling.Is_Digit (buf (1)) then
111       Get (Item => n, From => buf, Last => tmpx);
112       Set_Timeout_Mode (Mode => Delayed, Amount => n * 100);
113       blockflag := Delayed;
114    end if;
115
116    c := Character'Pos ('?');
117    Set_Raw_Mode (SwitchOn => True);
118    loop
119       if not firsttime then
120          Add (Str => "Key pressed: ");
121          Put (tmp6, Integer (c), 8);
122          Add (Str => tmp6);
123          Add (Ch => ' ');
124          if c = Key_Mouse then
125             declare
126                event : Mouse_Event;
127             begin
128                event := Get_Mouse;
129                Add (Str => "KEY_MOUSE, ");
130                Add (Str => mouse_decode (event));
131                Add (Ch => newl);
132             end;
133          elsif c >= Key_Min then
134             Key_Name (c, tmp20);
135             Add (Str => tmp20);
136             --  I used tmp and got bitten by the length problem:->
137             Add (Ch => newl);
138          elsif c > 16#80# then --  TODO fix, use constant if possible
139             declare
140                c2 : constant Character := Character'Val (c mod 16#80#);
141             begin
142                if Ada.Characters.Handling.Is_Graphic (c2) then
143                   Add (Str => "M-");
144                   Add (Ch => c2);
145                else
146                   Add (Str => "M-");
147                   Add (Str => Un_Control ((Ch => c2,
148                                            Color => Color_Pair'First,
149                                            Attr => Normal_Video)));
150                end if;
151                Add (Str => " (high-half character)");
152                Add (Ch => newl);
153             end;
154          else
155             declare
156                c2 : constant Character := Character'Val (c mod 16#80#);
157             begin
158                if Ada.Characters.Handling.Is_Graphic (c2) then
159                   Add (Ch => c2);
160                   Add (Str => " (ASCII printable character)");
161                   Add (Ch => newl);
162                else
163                   Add (Str => Un_Control ((Ch => c2,
164                                           Color => Color_Pair'First,
165                                           Attr => Normal_Video)));
166                   Add (Str => " (ASCII control character)");
167                   Add (Ch => newl);
168                end if;
169             end;
170          end if;
171          --  TODO I am not sure why this was in the C version
172          --  the delay statement scroll anyway.
173          Get_Cursor_Position (Line => y, Column => x);
174          if y >= Lines - 1 then
175             Move_Cursor (Line => 0, Column => 0);
176          end if;
177          Clear_To_End_Of_Line;
178       end if;
179
180       firsttime := False;
181       if c = Character'Pos ('g') then
182          declare
183             package p is new ncurses2.genericPuts (1024);
184             use p;
185             use p.BS;
186             timedout : Boolean := False;
187             boundedbuf : Bounded_String;
188          begin
189             Add (Str => "getstr test: ");
190             Set_Echo_Mode (SwitchOn => True);
191             --  Note that if delay mode is set
192             --  Get can raise an exception.
193             --  The C version would print the string it had so far
194             --  also TODO get longer length string, like the C version
195             declare begin
196                myGet (Str => boundedbuf);
197             exception when Curses_Exception =>
198                Add (Str => "Timed out.");
199                Add (Ch => newl);
200                timedout := True;
201             end;
202             --  note that the Ada Get will stop reading at 1024.
203             if not timedout then
204                Set_Echo_Mode (SwitchOn => False);
205                Add (Str => " I saw '");
206                myAdd (Str => boundedbuf);
207                Add (Str => "'.");
208                Add (Ch => newl);
209             end if;
210          end;
211       elsif c = Character'Pos ('s') then
212          ShellOut (True);
213       elsif c = Character'Pos ('x') or
214             c = Character'Pos ('q') or
215            (c = Key_None and blockflag = Blocking)
216       then
217          exit;
218       elsif c = Character'Pos ('?') then
219          Add (Str => "Type any key to see its keypad value.  Also:");
220          Add (Ch => newl);
221          Add (Str => "g -- triggers a getstr test");
222          Add (Ch => newl);
223          Add (Str => "s -- shell out");
224          Add (Ch => newl);
225          Add (Str => "q -- quit");
226          Add (Ch => newl);
227          Add (Str => "? -- repeats this help message");
228          Add (Ch => newl);
229       end if;
230
231       loop
232          c := Getchar;
233          exit when c /= Key_None;
234          if blockflag /= Blocking then
235             Put (tmp6, incount); --  argh string length!
236             Add (Str => tmp6);
237             Add (Str => ": input timed out");
238             Add (Ch => newl);
239          else
240             Put (tmp6, incount);
241             Add (Str => tmp6);
242             Add (Str => ": input error");
243             Add (Ch => newl);
244             exit;
245          end if;
246          incount := incount + 1;
247       end loop;
248    end loop;
249
250    End_Mouse (tmp2);
251    Set_Timeout_Mode (Mode => Blocking, Amount => 0); --  amount is ignored
252    Set_Raw_Mode (SwitchOn => False);
253    Set_NL_Mode (SwitchOn => True);
254    Erase;
255    End_Windows;
256 end ncurses2.getch_test;