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