ncurses 6.1 - patch 20191221
[ncurses.git] / Ada95 / samples / ncurses2-trace_set.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                       GNAT ncurses Binding Samples                       --
4 --                                                                          --
5 --                            ncurses2.trace_set                            --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 2000-2011,2014 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.6 $
39 --  $Date: 2014/09/13 19:10:18 $
40 --  Binding Version 01.00
41 ------------------------------------------------------------------------------
42 with ncurses2.util; use ncurses2.util;
43 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
44 with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
45 with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus;
46
47 with Ada.Strings.Bounded;
48
49 --  interactively set the trace level
50
51 procedure ncurses2.trace_set is
52
53    function menu_virtualize (c : Key_Code) return Key_Code;
54    function subset (super, sub : Trace_Attribute_Set) return Boolean;
55    function trace_or (a, b : Trace_Attribute_Set) return Trace_Attribute_Set;
56    function trace_num (tlevel : Trace_Attribute_Set) return String;
57    function tracetrace (tlevel : Trace_Attribute_Set) return String;
58    function run_trace_menu (m : Menu; count : Integer) return Boolean;
59
60    function menu_virtualize (c : Key_Code) return Key_Code is
61    begin
62       case c is
63          when Character'Pos (newl) | Key_Exit =>
64             return Menu_Request_Code'Last + 1; --  MAX_COMMAND? TODO
65          when Character'Pos ('u') =>
66             return M_ScrollUp_Line;
67          when Character'Pos ('d') =>
68             return M_ScrollDown_Line;
69          when Character'Pos ('b') | Key_Next_Page =>
70             return M_ScrollUp_Page;
71          when Character'Pos ('f') | Key_Previous_Page =>
72             return M_ScrollDown_Page;
73          when Character'Pos ('n') | Key_Cursor_Down =>
74             return M_Next_Item;
75          when Character'Pos ('p') | Key_Cursor_Up =>
76             return M_Previous_Item;
77          when Character'Pos (' ') =>
78             return M_Toggle_Item;
79          when Key_Mouse =>
80             return c;
81          when others =>
82             Beep;
83             return c;
84       end case;
85    end menu_virtualize;
86
87    type string_a is access String;
88    type tbl_entry is record
89       name : string_a;
90       mask : Trace_Attribute_Set;
91    end record;
92
93    t_tbl : constant array (Positive range <>) of tbl_entry :=
94      (
95       (new String'("Disable"),
96        Trace_Disable),
97       (new String'("Times"),
98        Trace_Attribute_Set'(Times => True, others => False)),
99       (new String'("Tputs"),
100        Trace_Attribute_Set'(Tputs => True, others => False)),
101       (new String'("Update"),
102        Trace_Attribute_Set'(Update => True, others => False)),
103       (new String'("Cursor_Move"),
104        Trace_Attribute_Set'(Cursor_Move => True, others => False)),
105       (new String'("Character_Output"),
106        Trace_Attribute_Set'(Character_Output => True, others => False)),
107       (new String'("Ordinary"),
108        Trace_Ordinary),
109       (new String'("Calls"),
110        Trace_Attribute_Set'(Calls => True, others => False)),
111       (new String'("Virtual_Puts"),
112        Trace_Attribute_Set'(Virtual_Puts => True, others => False)),
113       (new String'("Input_Events"),
114        Trace_Attribute_Set'(Input_Events => True, others => False)),
115       (new String'("TTY_State"),
116        Trace_Attribute_Set'(TTY_State => True, others => False)),
117       (new String'("Internal_Calls"),
118        Trace_Attribute_Set'(Internal_Calls => True, others => False)),
119       (new String'("Character_Calls"),
120        Trace_Attribute_Set'(Character_Calls => True, others => False)),
121       (new String'("Termcap_TermInfo"),
122        Trace_Attribute_Set'(Termcap_TermInfo => True, others => False)),
123       (new String'("Maximium"),
124        Trace_Maximum)
125       );
126
127    package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (300);
128
129    function subset (super, sub : Trace_Attribute_Set) return Boolean is
130    begin
131       if
132         (super.Times or not sub.Times) and
133         (super.Tputs or not sub.Tputs) and
134         (super.Update or not sub.Update) and
135         (super.Cursor_Move or not sub.Cursor_Move) and
136         (super.Character_Output or not sub.Character_Output) and
137         (super.Calls or not sub.Calls) and
138         (super.Virtual_Puts or not sub.Virtual_Puts) and
139         (super.Input_Events or not sub.Input_Events) and
140         (super.TTY_State or not sub.TTY_State) and
141         (super.Internal_Calls or not sub.Internal_Calls) and
142         (super.Character_Calls or not sub.Character_Calls) and
143         (super.Termcap_TermInfo or not sub.Termcap_TermInfo) and
144         True
145       then
146          return True;
147       else
148          return False;
149       end if;
150    end subset;
151
152    function trace_or (a, b : Trace_Attribute_Set) return Trace_Attribute_Set is
153       retval : Trace_Attribute_Set := Trace_Disable;
154    begin
155       retval.Times := (a.Times or b.Times);
156       retval.Tputs := (a.Tputs or b.Tputs);
157       retval.Update := (a.Update or b.Update);
158       retval.Cursor_Move := (a.Cursor_Move or b.Cursor_Move);
159       retval.Character_Output := (a.Character_Output or b.Character_Output);
160       retval.Calls := (a.Calls or b.Calls);
161       retval.Virtual_Puts := (a.Virtual_Puts or b.Virtual_Puts);
162       retval.Input_Events := (a.Input_Events or b.Input_Events);
163       retval.TTY_State := (a.TTY_State or b.TTY_State);
164       retval.Internal_Calls := (a.Internal_Calls or b.Internal_Calls);
165       retval.Character_Calls := (a.Character_Calls or b.Character_Calls);
166       retval.Termcap_TermInfo := (a.Termcap_TermInfo or b.Termcap_TermInfo);
167
168       return retval;
169    end trace_or;
170
171    --  Print the hexadecimal value of the mask so
172    --  users can set it from the command line.
173
174    function trace_num (tlevel : Trace_Attribute_Set) return String is
175       result : Integer := 0;
176       m : Integer := 1;
177    begin
178
179       if tlevel.Times then
180          result := result + m;
181       end if;
182       m := m * 2;
183
184       if tlevel.Tputs then
185          result := result + m;
186       end if;
187       m := m * 2;
188
189       if tlevel.Update then
190          result := result + m;
191       end if;
192       m := m * 2;
193
194       if tlevel.Cursor_Move then
195          result := result + m;
196       end if;
197       m := m * 2;
198
199       if tlevel.Character_Output then
200          result := result + m;
201       end if;
202       m := m * 2;
203
204       if tlevel.Calls then
205          result := result + m;
206       end if;
207       m := m * 2;
208
209       if tlevel.Virtual_Puts then
210          result := result + m;
211       end if;
212       m := m * 2;
213
214       if tlevel.Input_Events then
215          result := result + m;
216       end if;
217       m := m * 2;
218
219       if tlevel.TTY_State then
220          result := result + m;
221       end if;
222       m := m * 2;
223
224       if tlevel.Internal_Calls then
225          result := result + m;
226       end if;
227       m := m * 2;
228
229       if tlevel.Character_Calls then
230          result := result + m;
231       end if;
232       m := m * 2;
233
234       if tlevel.Termcap_TermInfo then
235          result := result + m;
236       end if;
237       m := m * 2;
238       return result'Img;
239    end trace_num;
240
241    function tracetrace (tlevel : Trace_Attribute_Set) return String is
242
243       use BS;
244       buf : Bounded_String := To_Bounded_String ("");
245    begin
246       --  The C version prints the hexadecimal value of the mask, we
247       --  won't do that here because this is Ada.
248
249       if tlevel = Trace_Disable then
250          Append (buf, "Trace_Disable");
251       else
252
253          if subset (tlevel,
254                     Trace_Attribute_Set'(Times => True, others => False))
255          then
256             Append (buf, "Times");
257             Append (buf, ", ");
258          end if;
259
260          if subset (tlevel,
261                     Trace_Attribute_Set'(Tputs => True, others => False))
262          then
263             Append (buf, "Tputs");
264             Append (buf, ", ");
265          end if;
266
267          if subset (tlevel,
268                     Trace_Attribute_Set'(Update => True, others => False))
269          then
270             Append (buf, "Update");
271             Append (buf, ", ");
272          end if;
273
274          if subset (tlevel,
275                     Trace_Attribute_Set'(Cursor_Move => True,
276                                          others => False))
277          then
278             Append (buf, "Cursor_Move");
279             Append (buf, ", ");
280          end if;
281
282          if subset (tlevel,
283                     Trace_Attribute_Set'(Character_Output => True,
284                                          others => False))
285          then
286             Append (buf, "Character_Output");
287             Append (buf, ", ");
288          end if;
289
290          if subset (tlevel,
291                     Trace_Ordinary)
292          then
293             Append (buf, "Ordinary");
294             Append (buf, ", ");
295          end if;
296
297          if subset (tlevel,
298                     Trace_Attribute_Set'(Calls => True, others => False))
299          then
300             Append (buf, "Calls");
301             Append (buf, ", ");
302          end if;
303
304          if subset (tlevel,
305                     Trace_Attribute_Set'(Virtual_Puts => True,
306                                          others => False))
307          then
308             Append (buf, "Virtual_Puts");
309             Append (buf, ", ");
310          end if;
311
312          if subset (tlevel,
313                     Trace_Attribute_Set'(Input_Events => True,
314                                          others => False))
315          then
316             Append (buf, "Input_Events");
317             Append (buf, ", ");
318          end if;
319
320          if subset (tlevel,
321                     Trace_Attribute_Set'(TTY_State => True,
322                                          others => False))
323          then
324             Append (buf, "TTY_State");
325             Append (buf, ", ");
326          end if;
327
328          if subset (tlevel,
329                     Trace_Attribute_Set'(Internal_Calls => True,
330                                          others => False))
331          then
332             Append (buf, "Internal_Calls");
333             Append (buf, ", ");
334          end if;
335
336          if subset (tlevel,
337                     Trace_Attribute_Set'(Character_Calls => True,
338                                          others => False))
339          then
340             Append (buf, "Character_Calls");
341             Append (buf, ", ");
342          end if;
343
344          if subset (tlevel,
345                     Trace_Attribute_Set'(Termcap_TermInfo => True,
346                                          others => False))
347          then
348             Append (buf, "Termcap_TermInfo");
349             Append (buf, ", ");
350          end if;
351
352          if subset (tlevel,
353                     Trace_Maximum)
354          then
355             Append (buf, "Maximium");
356             Append (buf, ", ");
357          end if;
358       end if;
359
360       if To_String (buf) (Length (buf) - 1) = ',' then
361          Delete (buf, Length (buf) - 1, Length (buf));
362       end if;
363
364       return To_String (buf);
365    end tracetrace;
366
367    function run_trace_menu (m : Menu; count : Integer) return Boolean is
368       i, p : Item;
369       changed : Boolean;
370       c, v : Key_Code;
371    begin
372       loop
373          changed := (count /= 0);
374          c := Getchar (Get_Window (m));
375          v := menu_virtualize (c);
376          case Driver (m, v) is
377             when Unknown_Request =>
378                return False;
379             when others =>
380                i := Current (m);
381                if i = Menus.Items (m, 1) then -- the first item
382                   for n in t_tbl'First + 1 .. t_tbl'Last loop
383                      if Value (i) then
384                         Set_Value (i, False);
385                         changed := True;
386                      end if;
387                   end loop;
388                else
389                   for n in t_tbl'First + 1 .. t_tbl'Last loop
390                      p := Menus.Items (m, n);
391                      if Value (p) then
392                         Set_Value (Menus.Items (m, 1), False);
393                         changed := True;
394                         exit;
395                      end if;
396                   end loop;
397                end if;
398                if not changed then
399                   return True;
400                end if;
401          end case;
402       end loop;
403    end run_trace_menu;
404
405    nc_tracing, mask : Trace_Attribute_Set;
406    pragma Import (C, nc_tracing, "_nc_tracing");
407    items_a : constant Item_Array_Access :=
408      new Item_Array (t_tbl'First .. t_tbl'Last + 1);
409    mrows : Line_Count;
410    mcols : Column_Count;
411    menuwin : Window;
412    menu_y : constant Line_Position := 8;
413    menu_x : constant Column_Position := 8;
414    ip : Item;
415    m : Menu;
416    count : Integer;
417    newtrace : Trace_Attribute_Set;
418 begin
419    Add (Line => 0, Column => 0, Str => "Interactively set trace level:");
420    Add (Line => 2, Column => 0,
421         Str => "  Press space bar to toggle a selection.");
422    Add (Line => 3, Column => 0,
423         Str => "  Use up and down arrow to move the select bar.");
424    Add (Line => 4, Column => 0,
425         Str => "  Press return to set the trace level.");
426    Add (Line => 6, Column => 0, Str => "(Current trace level is ");
427    Add (Str => tracetrace (nc_tracing) & " numerically: " &
428         trace_num (nc_tracing));
429    Add (Ch => ')');
430
431    Refresh;
432
433    for n in t_tbl'Range loop
434       items_a.all (n) := New_Item (t_tbl (n).name.all);
435    end loop;
436    items_a.all (t_tbl'Last + 1) := Null_Item;
437
438    m := New_Menu (items_a);
439
440    Set_Format (m, 16, 2);
441    Scale (m, mrows, mcols);
442
443    Switch_Options (m, (One_Valued => True, others => False), On => False);
444    menuwin := New_Window (mrows + 2, mcols + 2, menu_y, menu_x);
445    Set_Window (m, menuwin);
446    Set_KeyPad_Mode (menuwin, SwitchOn => True);
447    Box (menuwin);
448
449    Set_Sub_Window (m, Derived_Window (menuwin, mrows, mcols, 1, 1));
450
451    Post (m);
452
453    for n in t_tbl'Range loop
454       ip := Items (m, n);
455       mask := t_tbl (n).mask;
456       if mask = Trace_Disable then
457          Set_Value (ip, nc_tracing = Trace_Disable);
458       elsif subset (sub => mask, super => nc_tracing) then
459          Set_Value (ip, True);
460       end if;
461    end loop;
462
463    count := 1;
464    while run_trace_menu (m, count) loop
465       count := count + 1;
466    end loop;
467
468    newtrace := Trace_Disable;
469    for n in t_tbl'Range loop
470       ip := Items (m, n);
471       if Value (ip) then
472          mask := t_tbl (n).mask;
473          newtrace := trace_or (newtrace, mask);
474       end if;
475    end loop;
476
477    Trace_On (newtrace);
478    Trace_Put ("trace level interactively set to " &
479               tracetrace (nc_tracing));
480
481    Move_Cursor (Line => Lines - 4, Column => 0);
482    Add (Str => "Trace level is ");
483    Add (Str => tracetrace (nc_tracing));
484    Add (Ch => newl);
485    Pause; -- was just Add(); Getchar
486
487    Post (m, False);
488    --  menuwin has subwindows I think, which makes an error.
489    declare begin
490       Delete (menuwin);
491    exception when Curses_Exception => null; end;
492
493    --  free_menu(m);
494    --  free_item()
495 end ncurses2.trace_set;