1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 2000-2006,2008 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: 2008/07/26 18:47:50 $
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
.acs_and_scroll
;
68 with ncurses2
.flushinp_test
;
69 with ncurses2
.test_sgr_attributes
;
70 with ncurses2
.menu_test
;
71 with ncurses2
.demo_pad
;
72 with ncurses2
.demo_forms
;
73 with ncurses2
.overlap_test
;
74 with ncurses2
.trace_set
;
76 with ncurses2
.getopt
; use ncurses2
.getopt
;
78 package body ncurses2
.m
is
81 function To_trace
(n
: Integer) return Trace_Attribute_Set
;
83 procedure Set_Terminal_Modes
;
84 function Do_Single_Test
(c
: Character) return Boolean;
86 function To_trace
(n
: Integer) return Trace_Attribute_Set
is
87 a
: Trace_Attribute_Set
:= (others => False);
109 a
.Cursor_Move
:= True;
114 a
.Character_Output
:= True;
124 a
.Virtual_Puts
:= True;
129 a
.Input_Events
:= True;
139 a
.Internal_Calls
:= True;
144 a
.Character_Calls
:= True;
149 a
.Termcap_TermInfo
:= True;
155 -- these are type Stdscr_Init_Proc;
157 function rip_footer
(
159 Columns
: Column_Count
) return Integer;
160 pragma Convention
(C
, rip_footer
);
162 function rip_footer
(
164 Columns
: Column_Count
) return Integer is
166 Set_Background
(Win
, (Ch
=> ' ',
167 Attr
=> (Reverse_Video
=> True, others => False),
170 Move_Cursor
(Win
, 0, 0);
171 Add
(Win
, "footer:" & Columns
'Img & " columns");
172 Refresh_Without_Update
(Win
);
173 return 0; -- Curses_OK;
176 function rip_header
(
178 Columns
: Column_Count
) return Integer;
179 pragma Convention
(C
, rip_header
);
181 function rip_header
(
183 Columns
: Column_Count
) return Integer is
185 Set_Background
(Win
, (Ch
=> ' ',
186 Attr
=> (Reverse_Video
=> True, others => False),
189 Move_Cursor
(Win
, 0, 0);
190 Add
(Win
, "header:" & Columns
'Img & " columns");
191 -- 'Img is a GNAT extention
192 Refresh_Without_Update
(Win
);
193 return 0; -- Curses_OK;
197 -- type Stringa is access String;
198 use Ada
.Strings
.Unbounded
;
199 -- tbl : constant array (Positive range <>) of Stringa := (
200 tbl
: constant array (Positive range <>) of Unbounded_String
202 To_Unbounded_String
("Usage: ncurses [options]"),
203 To_Unbounded_String
(""),
204 To_Unbounded_String
("Options:"),
205 To_Unbounded_String
(" -a f,b set default-colors " &
206 "(assumed white-on-black)"),
207 To_Unbounded_String
(" -d use default-colors if terminal " &
209 To_Unbounded_String
(" -e fmt specify format for soft-keys " &
211 To_Unbounded_String
(" -f rip-off footer line " &
213 To_Unbounded_String
(" -h rip-off header line " &
215 To_Unbounded_String
(" -s msec specify nominal time for " &
216 "panel-demo (default: 1, to hold)"),
217 To_Unbounded_String
(" -t mask specify default trace-level " &
218 "(may toggle with ^T)")
221 for n
in tbl
'Range loop
222 Put_Line
(Standard_Error
, To_String
(tbl
(n
)));
224 -- exit(EXIT_FAILURE);
225 -- TODO should we use Set_Exit_Status and throw and exception?
228 procedure Set_Terminal_Modes
is begin
229 Set_Raw_Mode
(SwitchOn
=> False);
230 Set_Cbreak_Mode
(SwitchOn
=> True);
231 Set_Echo_Mode
(SwitchOn
=> False);
232 Allow_Scrolling
(Mode
=> True);
233 Use_Insert_Delete_Line
(Do_Idl
=> True);
234 Set_KeyPad_Mode
(SwitchOn
=> True);
235 end Set_Terminal_Modes
;
237 nap_msec
: Integer := 1;
239 function Do_Single_Test
(c
: Character) return Boolean is
247 if not Has_Colors
then
248 Cannot
("does not support color.");
253 if not Has_Colors
then
254 Cannot
("does not support color.");
255 elsif not Can_Change_Color
then
256 Cannot
("has hardwired color values.");
265 demo_panels
(nap_msec
);
269 flushinp_test
(Standard_Window
);
284 when others => return False;
290 my_e_param
: Soft_Label_Key_Format
:= Four_Four
;
291 assumed_colors
: Boolean := False;
292 default_colors
: Boolean := False;
293 default_fg
: Color_Number
:= White
;
294 default_bg
: Color_Number
:= Black
;
295 -- nap_msec was an unsigned long integer in the C version,
296 -- yet napms only takes an int!
300 optind
: Integer := 1; -- must be initialized to one.
301 optarg
: getopt
.stringa
;
306 package myio
is new Ada
.Text_IO
.Integer_IO
(Integer);
309 save_trace
: Integer := 0;
310 save_trace_set
: Trace_Attribute_Set
;
312 function main
return Integer is
315 Qgetopt
(c
, Argument_Count
, Argument
'Access,
316 "a:de:fhs:t:", optind
, optarg
);
318 c2
:= Character'Val (c
);
321 -- Ada doesn't have scanf, it doesn't even have a
322 -- regular expression library.
323 assumed_colors
:= True;
324 myio
.Get
(optarg
.all, Integer (default_fg
), length
);
325 myio
.Get
(optarg
.all (length
+ 2 .. optarg
.all'Length),
326 Integer (default_bg
), length
);
328 default_colors
:= True;
330 myio
.Get
(optarg
.all, tmpi
, length
);
335 my_e_param
:= Soft_Label_Key_Format
'Val (tmpi
);
337 Rip_Off_Lines
(-1, rip_footer
'Access);
339 Rip_Off_Lines
(1, rip_header
'Access);
341 myio
.Get
(optarg
.all, nap_msec
, length
);
343 myio
.Get
(optarg
.all, save_trace
, length
);
350 -- the C version had a bunch of macros here.
352 -- if (!isatty(fileno(stdin)))
353 -- isatty is not available in the standard Ada so skip it.
354 save_trace_set
:= To_trace
(save_trace
);
355 Trace_On
(save_trace_set
);
357 Init_Soft_Label_Keys
(my_e_param
);
360 Set_Background
(Ch
=> (Ch
=> Blank
,
361 Attr
=> Normal_Video
,
362 Color
=> Color_Pair
'First));
366 if default_colors
then
368 elsif assumed_colors
then
369 Assume_Default_Colors
(default_fg
, default_bg
);
374 Save_Curses_Mode
(Curses
);
378 -- TODO add macro #if blocks.
379 Put_Line
("Welcome to " & Curses_Version
& ". Press ? for help.");
382 Put_Line
("This is the ncurses main menu");
383 Put_Line
("a = keyboard and mouse input test");
384 Put_Line
("b = character attribute test");
385 Put_Line
("c = color test pattern");
386 Put_Line
("d = edit RGB color values");
387 Put_Line
("e = exercise soft keys");
388 Put_Line
("f = display ACS characters");
389 Put_Line
("g = display windows and scrolling");
390 Put_Line
("i = test of flushinp()");
391 Put_Line
("k = display character attributes");
392 Put_Line
("m = menu code test");
393 Put_Line
("o = exercise panels library");
394 Put_Line
("p = exercise pad features");
395 Put_Line
("q = quit");
396 Put_Line
("r = exercise forms code");
397 Put_Line
("s = overlapping-refresh test");
398 Put_Line
("t = set trace level");
399 Put_Line
("? = repeat this command summary");
404 command
:= Ada
.Characters
.Latin_1
.NUL
;
411 -- TODO if read(ch) <= 0
412 -- TODO ada doesn't have an Is_Space function
414 -- TODO if ch = '\n' or '\r' are these in Ada?
416 -- end loop get_input;
420 if Do_Single_Test
(command
) then
423 Reset_Curses_Mode
(Curses
);
427 if command
= '?' then
428 Put_Line
("This is the ncurses capability tester.");
429 Put_Line
("You may select a test from the main menu by " &
431 Put_Line
("key letter of the choice (the letter to left " &
433 Put_Line
("at the > prompt. The commands `x' or `q' will " &
436 -- continue; --why continue in the C version?
439 when Curses_Exception
=> End_Windows
;
442 exit when command
= 'q';
445 return 0; -- TODO ExitProgram(EXIT_SUCCESS);