source: trunk/ncurses/Ada95/samples/ncurses2-m.adb@ 2872

Last change on this file since 2872 was 2621, checked in by bird, 20 years ago

GNU ncurses 5.5
File size: 15.2 KB
Line 
1------------------------------------------------------------------------------
2-- --
3-- GNAT ncurses Binding Samples --
4-- --
5-- ncurses --
6-- --
7-- B O D Y --
8-- --
9------------------------------------------------------------------------------
10-- Copyright (c) 2000,2004 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.5 $
39-- $Date: 2004/08/21 21:37:00 $
40-- Binding Version 01.00
41------------------------------------------------------------------------------
42-- TODO use Default_Character where appropriate
43
44-- This is an Ada version of ncurses
45-- I translated this because it tests the most features.
46
47with Terminal_Interface.Curses; use Terminal_Interface.Curses;
48with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
49
50with Ada.Text_IO; use Ada.Text_IO;
51
52with Ada.Characters.Latin_1;
53-- with Ada.Characters.Handling;
54
55with Ada.Command_Line; use Ada.Command_Line;
56
57with Ada.Strings.Unbounded;
58
59
60with ncurses2.util; use ncurses2.util;
61with ncurses2.getch_test;
62with ncurses2.attr_test;
63with ncurses2.color_test;
64with ncurses2.demo_panels;
65with ncurses2.color_edit;
66with ncurses2.slk_test;
67with ncurses2.acs_display;
68with ncurses2.color_edit;
69with ncurses2.acs_and_scroll;
70with ncurses2.flushinp_test;
71with ncurses2.test_sgr_attributes;
72with ncurses2.menu_test;
73with ncurses2.demo_pad;
74with ncurses2.demo_forms;
75with ncurses2.overlap_test;
76with ncurses2.trace_set;
77
78with ncurses2.getopt; use ncurses2.getopt;
79
80package body ncurses2.m is
81 use Int_IO;
82
83 function To_trace (n : Integer) return Trace_Attribute_Set;
84 procedure usage;
85 procedure Set_Terminal_Modes;
86 function Do_Single_Test (c : Character) return Boolean;
87
88 function To_trace (n : Integer) return Trace_Attribute_Set is
89 a : Trace_Attribute_Set := (others => False);
90 m : Integer;
91 rest : Integer;
92 begin
93 m := n mod 2;
94 if 1 = m then
95 a.Times := True;
96 end if;
97 rest := n / 2;
98
99 m := rest mod 2;
100 if 1 = m then
101 a.Tputs := True;
102 end if;
103 rest := rest / 2;
104 m := rest mod 2;
105 if 1 = m then
106 a.Update := True;
107 end if;
108 rest := rest / 2;
109 m := rest mod 2;
110 if 1 = m then
111 a.Cursor_Move := True;
112 end if;
113 rest := rest / 2;
114 m := rest mod 2;
115 if 1 = m then
116 a.Character_Output := True;
117 end if;
118 rest := rest / 2;
119 m := rest mod 2;
120 if 1 = m then
121 a.Calls := True;
122 end if;
123 rest := rest / 2;
124 m := rest mod 2;
125 if 1 = m then
126 a.Virtual_Puts := True;
127 end if;
128 rest := rest / 2;
129 m := rest mod 2;
130 if 1 = m then
131 a.Input_Events := True;
132 end if;
133 rest := rest / 2;
134 m := rest mod 2;
135 if 1 = m then
136 a.TTY_State := True;
137 end if;
138 rest := rest / 2;
139 m := rest mod 2;
140 if 1 = m then
141 a.Internal_Calls := True;
142 end if;
143 rest := rest / 2;
144 m := rest mod 2;
145 if 1 = m then
146 a.Character_Calls := True;
147 end if;
148 rest := rest / 2;
149 m := rest mod 2;
150 if 1 = m then
151 a.Termcap_TermInfo := True;
152 end if;
153
154 return a;
155 end To_trace;
156
157 -- these are type Stdscr_Init_Proc;
158
159 function rip_footer (
160 Win : Window;
161 Columns : Column_Count) return Integer;
162 pragma Convention (C, rip_footer);
163
164 function rip_footer (
165 Win : Window;
166 Columns : Column_Count) return Integer is
167 begin
168 Set_Background (Win, (Ch => ' ',
169 Attr => (Reverse_Video => True, others => False),
170 Color => 0));
171 Erase (Win);
172 Move_Cursor (Win, 0, 0);
173 Add (Win, "footer:" & Columns'Img & " columns");
174 Refresh_Without_Update (Win);
175 return 0; -- Curses_OK;
176 end rip_footer;
177
178
179 function rip_header (
180 Win : Window;
181 Columns : Column_Count) return Integer;
182 pragma Convention (C, rip_header);
183
184 function rip_header (
185 Win : Window;
186 Columns : Column_Count) return Integer is
187 begin
188 Set_Background (Win, (Ch => ' ',
189 Attr => (Reverse_Video => True, others => False),
190 Color => 0));
191 Erase (Win);
192 Move_Cursor (Win, 0, 0);
193 Add (Win, "header:" & Columns'Img & " columns");
194 -- 'Img is a GNAT extention
195 Refresh_Without_Update (Win);
196 return 0; -- Curses_OK;
197 end rip_header;
198
199 procedure usage is
200 -- type Stringa is access String;
201 use Ada.Strings.Unbounded;
202 -- tbl : constant array (Positive range <>) of Stringa := (
203 tbl : constant array (Positive range <>) of Unbounded_String
204 := (
205 To_Unbounded_String ("Usage: ncurses [options]"),
206 To_Unbounded_String (""),
207 To_Unbounded_String ("Options:"),
208 To_Unbounded_String (" -a f,b set default-colors " &
209 "(assumed white-on-black)"),
210 To_Unbounded_String (" -d use default-colors if terminal " &
211 "supports them"),
212 To_Unbounded_String (" -e fmt specify format for soft-keys " &
213 "test (e)"),
214 To_Unbounded_String (" -f rip-off footer line " &
215 "(can repeat)"),
216 To_Unbounded_String (" -h rip-off header line " &
217 "(can repeat)"),
218 To_Unbounded_String (" -s msec specify nominal time for " &
219 "panel-demo (default: 1, to hold)"),
220 To_Unbounded_String (" -t mask specify default trace-level " &
221 "(may toggle with ^T)")
222 );
223 begin
224 for n in tbl'Range loop
225 Put_Line (Standard_Error, To_String (tbl (n)));
226 end loop;
227 -- exit(EXIT_FAILURE);
228 -- TODO should we use Set_Exit_Status and throw and exception?
229 end usage;
230
231 procedure Set_Terminal_Modes is begin
232 Set_Raw_Mode (SwitchOn => False);
233 Set_Cbreak_Mode (SwitchOn => True);
234 Set_Echo_Mode (SwitchOn => False);
235 Allow_Scrolling (Mode => True);
236 Use_Insert_Delete_Line (Do_Idl => True);
237 Set_KeyPad_Mode (SwitchOn => True);
238 end Set_Terminal_Modes;
239
240
241 nap_msec : Integer := 1;
242
243 function Do_Single_Test (c : Character) return Boolean is
244 begin
245 case c is
246 when 'a' =>
247 getch_test;
248 when 'b' =>
249 attr_test;
250 when 'c' =>
251 if not Has_Colors then
252 Cannot ("does not support color.");
253 else
254 color_test;
255 end if;
256 when 'd' =>
257 if not Has_Colors then
258 Cannot ("does not support color.");
259 elsif not Can_Change_Color then
260 Cannot ("has hardwired color values.");
261 else
262 color_edit;
263 end if;
264 when 'e' =>
265 slk_test;
266 when 'f' =>
267 acs_display;
268 when 'o' =>
269 demo_panels (nap_msec);
270 when 'g' =>
271 acs_and_scroll;
272 when 'i' =>
273 flushinp_test (Standard_Window);
274 when 'k' =>
275 test_sgr_attributes;
276 when 'm' =>
277 menu_test;
278 when 'p' =>
279 demo_pad;
280 when 'r' =>
281 demo_forms;
282 when 's' =>
283 overlap_test;
284 when 't' =>
285 trace_set;
286 when '?' =>
287 null;
288 when others => return False;
289 end case;
290 return True;
291 end Do_Single_Test;
292
293
294 command : Character;
295 my_e_param : Soft_Label_Key_Format := Four_Four;
296 assumed_colors : Boolean := False;
297 default_colors : Boolean := False;
298 default_fg : Color_Number := White;
299 default_bg : Color_Number := Black;
300 -- nap_msec was an unsigned long integer in the C version,
301 -- yet napms only takes an int!
302
303 c : Integer;
304 c2 : Character;
305 optind : Integer := 1; -- must be initialized to one.
306 optarg : getopt.stringa;
307
308 length : Integer;
309 tmpi : Integer;
310
311 package myio is new Ada.Text_IO.Integer_IO (Integer);
312 use myio;
313
314 save_trace : Integer := 0;
315 save_trace_set : Trace_Attribute_Set;
316
317 function main return Integer is
318 begin
319 loop
320 Qgetopt (c, Argument_Count, Argument'Access,
321 "a:de:fhs:t:", optind, optarg);
322 exit when c = -1;
323 c2 := Character'Val (c);
324 case c2 is
325 when 'a' =>
326 -- Ada doesn't have scanf, it doesn't even have a
327 -- regular expression library.
328 assumed_colors := True;
329 myio.Get (optarg.all, Integer (default_fg), length);
330 myio.Get (optarg.all (length + 2 .. optarg.all'Length),
331 Integer (default_bg), length);
332 when 'd' =>
333 default_colors := True;
334 when 'e' =>
335 myio.Get (optarg.all, tmpi, length);
336 if tmpi > 3 then
337 usage;
338 return 1;
339 end if;
340 my_e_param := Soft_Label_Key_Format'Val (tmpi);
341 when 'f' =>
342 Rip_Off_Lines (-1, rip_footer'Access);
343 when 'h' =>
344 Rip_Off_Lines (1, rip_header'Access);
345 when 's' =>
346 myio.Get (optarg.all, nap_msec, length);
347 when 't' =>
348 myio.Get (optarg.all, save_trace, length);
349 when others =>
350 usage;
351 return 1;
352 end case;
353 end loop;
354
355 -- the C version had a bunch of macros here.
356
357 -- if (!isatty(fileno(stdin)))
358 -- isatty is not available in the standard Ada so skip it.
359 save_trace_set := To_trace (save_trace);
360 Trace_On (save_trace_set);
361
362
363 Init_Soft_Label_Keys (my_e_param);
364
365 Init_Screen;
366 Set_Background (Ch => (Ch => Blank,
367 Attr => Normal_Video,
368 Color => Color_Pair'First));
369
370 if Has_Colors then
371 Start_Color;
372 if default_colors then
373 Use_Default_Colors;
374 elsif assumed_colors then
375 Assume_Default_Colors (default_fg, default_bg);
376 end if;
377 end if;
378
379 Set_Terminal_Modes;
380 Save_Curses_Mode (Curses);
381
382 End_Windows;
383
384 -- TODO add macro #if blocks.
385 Put_Line ("Welcome to " & Curses_Version & ". Press ? for help.");
386
387 loop
388 Put_Line ("This is the ncurses main menu");
389 Put_Line ("a = keyboard and mouse input test");
390 Put_Line ("b = character attribute test");
391 Put_Line ("c = color test pattern");
392 Put_Line ("d = edit RGB color values");
393 Put_Line ("e = exercise soft keys");
394 Put_Line ("f = display ACS characters");
395 Put_Line ("g = display windows and scrolling");
396 Put_Line ("i = test of flushinp()");
397 Put_Line ("k = display character attributes");
398 Put_Line ("m = menu code test");
399 Put_Line ("o = exercise panels library");
400 Put_Line ("p = exercise pad features");
401 Put_Line ("q = quit");
402 Put_Line ("r = exercise forms code");
403 Put_Line ("s = overlapping-refresh test");
404 Put_Line ("t = set trace level");
405 Put_Line ("? = repeat this command summary");
406
407 Put ("> ");
408 Flush;
409
410 command := Ada.Characters.Latin_1.NUL;
411 -- get_input:
412 -- loop
413 declare
414 Ch : Character;
415 begin
416 Get (Ch);
417 -- TODO if read(ch) <= 0
418 -- TODO ada doesn't have an Is_Space function
419 command := Ch;
420 -- TODO if ch = '\n' or '\r' are these in Ada?
421 end;
422 -- end loop get_input;
423
424 declare
425 begin
426 if Do_Single_Test (command) then
427 Flush_Input;
428 Set_Terminal_Modes;
429 Reset_Curses_Mode (Curses);
430 Clear;
431 Refresh;
432 End_Windows;
433 if command = '?' then
434 Put_Line ("This is the ncurses capability tester.");
435 Put_Line ("You may select a test from the main menu by " &
436 "typing the");
437 Put_Line ("key letter of the choice (the letter to left " &
438 "of the =)");
439 Put_Line ("at the > prompt. The commands `x' or `q' will " &
440 "exit.");
441 end if;
442 -- continue; --why continue in the C version?
443 end if;
444 exception
445 when Curses_Exception => End_Windows;
446 end;
447
448 exit when command = 'q';
449 end loop;
450 return 0; -- TODO ExitProgram(EXIT_SUCCESS);
451 end main;
452
453end ncurses2.m;
454
455
456
457
458
459
460
Note: See TracBrowser for help on using the repository browser.