7b49fc52d1eb91b7e65842714dd795fa00f444c7
[ncurses.git] / Ada95 / samples / ncurses2-m.adb
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
47 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
48 with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
49
50 with Ada.Text_IO; use Ada.Text_IO;
51
52 with Ada.Characters.Latin_1;
53 --  with Ada.Characters.Handling;
54
55 with Ada.Command_Line; use Ada.Command_Line;
56
57 with Ada.Strings.Unbounded;
58
59
60 with ncurses2.util; use ncurses2.util;
61 with ncurses2.getch_test;
62 with ncurses2.attr_test;
63 with ncurses2.color_test;
64 with ncurses2.demo_panels;
65 with ncurses2.color_edit;
66 with ncurses2.slk_test;
67 with ncurses2.acs_display;
68 with ncurses2.color_edit;
69 with ncurses2.acs_and_scroll;
70 with ncurses2.flushinp_test;
71 with ncurses2.test_sgr_attributes;
72 with ncurses2.menu_test;
73 with ncurses2.demo_pad;
74 with ncurses2.demo_forms;
75 with ncurses2.overlap_test;
76 with ncurses2.trace_set;
77
78 with ncurses2.getopt; use ncurses2.getopt;
79
80 package 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
453 end ncurses2.m;
454
455
456
457
458
459
460