• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
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
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 => "'.");
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;
257end ncurses2.getch_test;
258