Gitiles
Code Review Sign In
gerrit.omnirom.org / android_external_libncurses / b2cef93693cf7cfd01098c9b69603c90f0f4b803 / . / Ada95 / samples / ncurses2-getch_test.adb
blob: 8f020e7c123b4ee9970ea136f315d41f4ea825d5 [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------------------------------------------------------------------------------
Steve Kondikae271bc2015-11-15 02:50:53 +0100[diff] [blame]10-- Copyright (c) 2000-2009,2014 Free Software Foundation, Inc. --
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]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
Steve Kondikae271bc2015-11-15 02:50:53 +0100[diff] [blame]38-- $Revision: 1.9 $
39-- $Date: 2014/09/13 19:10:18 $
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]40-- Binding Version 01.00
41------------------------------------------------------------------------------
42-- Character input test
43-- test the keypad feature
44
45with ncurses2.util; use ncurses2.util;
46
47with Terminal_Interface.Curses; use Terminal_Interface.Curses;
48with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
49with Ada.Characters.Handling;
50with Ada.Strings.Bounded;
51
52with ncurses2.genericPuts;
53
54procedure 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
100begin
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 => "'.");
Steve Kondikae271bc2015-11-15 02:50:53 +0100[diff] [blame]208 Add (Ch => newl);
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]209 end if;
210 end;
211 elsif c = Character'Pos ('s') then
212 ShellOut (True);
Steve Kondikae271bc2015-11-15 02:50:53 +0100[diff] [blame]213 elsif c = Character'Pos ('x') or
214 c = Character'Pos ('q') or
215 (c = Key_None and blockflag = Blocking)
216 then
Amit Daniel Kachhape6a01f52011-07-20 11:45:59 +0530[diff] [blame]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;
256end ncurses2.getch_test;