1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 2000-2004,2006 Free Software Foundation, Inc. --
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: --
20 -- The above copyright notice and this permission notice shall be included --
21 -- in all copies or substantial portions of the Software. --
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. --
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 --
35 ------------------------------------------------------------------------------
36 -- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
39 -- $Date: 2007/05/05 18:02:40 $
40 -- Binding Version 01.00
41 ------------------------------------------------------------------------------
42 -- TODO use Default_Character where appropriate
44 -- This is an Ada version of ncurses
45 -- I translated this because it tests the most features.
47 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
48 with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
50 with Ada.Text_IO; use Ada.Text_IO;
52 with Ada.Characters.Latin_1;
53 -- with Ada.Characters.Handling;
55 with Ada.Command_Line; use Ada.Command_Line;
57 with Ada.Strings.Unbounded;
59 with ncurses2.util; use ncurses2.util;
60 with ncurses2.getch_test;
61 with ncurses2.attr_test;
62 with ncurses2.color_test;
63 with ncurses2.demo_panels;
64 with ncurses2.color_edit;
65 with ncurses2.slk_test;
66 with ncurses2.acs_display;
67 with ncurses2.color_edit;
68 with ncurses2.acs_and_scroll;
69 with ncurses2.flushinp_test;
70 with ncurses2.test_sgr_attributes;
71 with ncurses2.menu_test;
72 with ncurses2.demo_pad;
73 with ncurses2.demo_forms;
74 with ncurses2.overlap_test;
75 with ncurses2.trace_set;
77 with ncurses2.getopt; use ncurses2.getopt;
79 package body ncurses2.m is
82 function To_trace (n : Integer) return Trace_Attribute_Set;
84 procedure Set_Terminal_Modes;
85 function Do_Single_Test (c : Character) return Boolean;
87 function To_trace (n : Integer) return Trace_Attribute_Set is
88 a : Trace_Attribute_Set := (others => False);
110 a.Cursor_Move := True;
115 a.Character_Output := True;
125 a.Virtual_Puts := True;
130 a.Input_Events := True;
140 a.Internal_Calls := True;
145 a.Character_Calls := True;
150 a.Termcap_TermInfo := True;
156 -- these are type Stdscr_Init_Proc;
158 function rip_footer (
160 Columns : Column_Count) return Integer;
161 pragma Convention (C, rip_footer);
163 function rip_footer (
165 Columns : Column_Count) return Integer is
167 Set_Background (Win, (Ch => ' ',
168 Attr => (Reverse_Video => True, others => False),
171 Move_Cursor (Win, 0, 0);
172 Add (Win, "footer:" & Columns'Img & " columns");
173 Refresh_Without_Update (Win);
174 return 0; -- Curses_OK;
177 function rip_header (
179 Columns : Column_Count) return Integer;
180 pragma Convention (C, rip_header);
182 function rip_header (
184 Columns : Column_Count) return Integer is
186 Set_Background (Win, (Ch => ' ',
187 Attr => (Reverse_Video => True, others => False),
190 Move_Cursor (Win, 0, 0);
191 Add (Win, "header:" & Columns'Img & " columns");
192 -- 'Img is a GNAT extention
193 Refresh_Without_Update (Win);
194 return 0; -- Curses_OK;
198 -- type Stringa is access String;
199 use Ada.Strings.Unbounded;
200 -- tbl : constant array (Positive range <>) of Stringa := (
201 tbl : constant array (Positive range <>) of Unbounded_String
203 To_Unbounded_String ("Usage: ncurses [options]"),
204 To_Unbounded_String (""),
205 To_Unbounded_String ("Options:"),
206 To_Unbounded_String (" -a f,b set default-colors " &
207 "(assumed white-on-black)"),
208 To_Unbounded_String (" -d use default-colors if terminal " &
210 To_Unbounded_String (" -e fmt specify format for soft-keys " &
212 To_Unbounded_String (" -f rip-off footer line " &
214 To_Unbounded_String (" -h rip-off header line " &
216 To_Unbounded_String (" -s msec specify nominal time for " &
217 "panel-demo (default: 1, to hold)"),
218 To_Unbounded_String (" -t mask specify default trace-level " &
219 "(may toggle with ^T)")
222 for n in tbl'Range loop
223 Put_Line (Standard_Error, To_String (tbl (n)));
225 -- exit(EXIT_FAILURE);
226 -- TODO should we use Set_Exit_Status and throw and exception?
229 procedure Set_Terminal_Modes is begin
230 Set_Raw_Mode (SwitchOn => False);
231 Set_Cbreak_Mode (SwitchOn => True);
232 Set_Echo_Mode (SwitchOn => False);
233 Allow_Scrolling (Mode => True);
234 Use_Insert_Delete_Line (Do_Idl => True);
235 Set_KeyPad_Mode (SwitchOn => True);
236 end Set_Terminal_Modes;
238 nap_msec : Integer := 1;
240 function Do_Single_Test (c : Character) return Boolean is
248 if not Has_Colors then
249 Cannot ("does not support color.");
254 if not Has_Colors then
255 Cannot ("does not support color.");
256 elsif not Can_Change_Color then
257 Cannot ("has hardwired color values.");
266 demo_panels (nap_msec);
270 flushinp_test (Standard_Window);
285 when others => return False;
291 my_e_param : Soft_Label_Key_Format := Four_Four;
292 assumed_colors : Boolean := False;
293 default_colors : Boolean := False;
294 default_fg : Color_Number := White;
295 default_bg : Color_Number := Black;
296 -- nap_msec was an unsigned long integer in the C version,
297 -- yet napms only takes an int!
301 optind : Integer := 1; -- must be initialized to one.
302 optarg : getopt.stringa;
307 package myio is new Ada.Text_IO.Integer_IO (Integer);
310 save_trace : Integer := 0;
311 save_trace_set : Trace_Attribute_Set;
313 function main return Integer is
316 Qgetopt (c, Argument_Count, Argument'Access,
317 "a:de:fhs:t:", optind, optarg);
319 c2 := Character'Val (c);
322 -- Ada doesn't have scanf, it doesn't even have a
323 -- regular expression library.
324 assumed_colors := True;
325 myio.Get (optarg.all, Integer (default_fg), length);
326 myio.Get (optarg.all (length + 2 .. optarg.all'Length),
327 Integer (default_bg), length);
329 default_colors := True;
331 myio.Get (optarg.all, tmpi, length);
336 my_e_param := Soft_Label_Key_Format'Val (tmpi);
338 Rip_Off_Lines (-1, rip_footer'Access);
340 Rip_Off_Lines (1, rip_header'Access);
342 myio.Get (optarg.all, nap_msec, length);
344 myio.Get (optarg.all, save_trace, length);
351 -- the C version had a bunch of macros here.
353 -- if (!isatty(fileno(stdin)))
354 -- isatty is not available in the standard Ada so skip it.
355 save_trace_set := To_trace (save_trace);
356 Trace_On (save_trace_set);
358 Init_Soft_Label_Keys (my_e_param);
361 Set_Background (Ch => (Ch => Blank,
362 Attr => Normal_Video,
363 Color => Color_Pair'First));
367 if default_colors then
369 elsif assumed_colors then
370 Assume_Default_Colors (default_fg, default_bg);
375 Save_Curses_Mode (Curses);
379 -- TODO add macro #if blocks.
380 Put_Line ("Welcome to " & Curses_Version & ". Press ? for help.");
383 Put_Line ("This is the ncurses main menu");
384 Put_Line ("a = keyboard and mouse input test");
385 Put_Line ("b = character attribute test");
386 Put_Line ("c = color test pattern");
387 Put_Line ("d = edit RGB color values");
388 Put_Line ("e = exercise soft keys");
389 Put_Line ("f = display ACS characters");
390 Put_Line ("g = display windows and scrolling");
391 Put_Line ("i = test of flushinp()");
392 Put_Line ("k = display character attributes");
393 Put_Line ("m = menu code test");
394 Put_Line ("o = exercise panels library");
395 Put_Line ("p = exercise pad features");
396 Put_Line ("q = quit");
397 Put_Line ("r = exercise forms code");
398 Put_Line ("s = overlapping-refresh test");
399 Put_Line ("t = set trace level");
400 Put_Line ("? = repeat this command summary");
405 command := Ada.Characters.Latin_1.NUL;
412 -- TODO if read(ch) <= 0
413 -- TODO ada doesn't have an Is_Space function
415 -- TODO if ch = '\n' or '\r' are these in Ada?
417 -- end loop get_input;
421 if Do_Single_Test (command) then
424 Reset_Curses_Mode (Curses);
428 if command = '?' then
429 Put_Line ("This is the ncurses capability tester.");
430 Put_Line ("You may select a test from the main menu by " &
432 Put_Line ("key letter of the choice (the letter to left " &
434 Put_Line ("at the > prompt. The commands `x' or `q' will " &
437 -- continue; --why continue in the C version?
440 when Curses_Exception => End_Windows;
443 exit when command = 'q';
446 return 0; -- TODO ExitProgram(EXIT_SUCCESS);