Gitiles
Code Review Sign In
gerrit.omnirom.org / android_external_libncurses / refs/heads/android-16 / . / Ada95 / samples / ncurses2-getch_test.adb
blob: 8bcb7a412acfc43303cbdd4088d4ff29396fde43 [file] [log] [blame]
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]1------------------------------------------------------------------------------
2-- --
3-- GNAT ncurses Binding Samples --
4-- --
5-- ncurses --
6-- --
7-- B O D Y --
8-- --
9------------------------------------------------------------------------------
micky3879b9f5e72025-07-08 18:04:53 -0400[diff] [blame]10-- Copyright 2020 Thomas E. Dickey --
11-- Copyright 2000-2009,2014 Free Software Foundation, Inc. --
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]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
micky3879b9f5e72025-07-08 18:04:53 -0400[diff] [blame]39-- $Revision: 1.10 $
40-- $Date: 2020/02/02 23:34:34 $
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]41-- Binding Version 01.00
42------------------------------------------------------------------------------
43-- Character input test
44-- test the keypad feature
45
46with ncurses2.util; use ncurses2.util;
47
48with Terminal_Interface.Curses; use Terminal_Interface.Curses;
49with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
50with Ada.Characters.Handling;
51with Ada.Strings.Bounded;
52
53with ncurses2.genericPuts;
54
55procedure 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
101begin
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 => "'.");
Steve Kondikae271bc2015-11-15 02:50:53 +0100[diff] [blame]209 Add (Ch => newl);
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]210 end if;
211 end;
212 elsif c = Character'Pos ('s') then
213 ShellOut (True);
Steve Kondikae271bc2015-11-15 02:50:53 +0100[diff] [blame]214 elsif c = Character'Pos ('x') or
215 c = Character'Pos ('q') or
216 (c = Key_None and blockflag = Blocking)
217 then
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]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;
257end ncurses2.getch_test;