1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
5 -- ncurses2.trace_set --
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:46: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;
47 with Ada.Strings.Bounded;
49 -- interactively set the trace level
51 procedure ncurses2.trace_set is
53 function menu_virtualize (c : Key_Code) return Menu_Request_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;
60 function menu_virtualize (c : Key_Code) return Menu_Request_Code 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 =>
75 when Character'Pos ('p') | Key_Cursor_Up =>
76 return M_Previous_Item;
77 when Character'Pos (' ') =>
87 type string_a is access String;
88 type tbl_entry is record
90 mask : Trace_Attribute_Set;
93 t_tbl : constant array (Positive range <>) of tbl_entry :=
95 (new String'("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"),
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"),
127 package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (300);
129 function subset (super, sub : Trace_Attribute_Set) return Boolean is
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
151 function trace_or (a, b : Trace_Attribute_Set) return Trace_Attribute_Set is
152 retval : Trace_Attribute_Set := Trace_Disable;
154 retval.Times := (a.Times or b.Times);
155 retval.Tputs := (a.Tputs or b.Tputs);
156 retval.Update := (a.Update or b.Update);
157 retval.Cursor_Move := (a.Cursor_Move or b.Cursor_Move);
158 retval.Character_Output := (a.Character_Output or b.Character_Output);
159 retval.Calls := (a.Calls or b.Calls);
160 retval.Virtual_Puts := (a.Virtual_Puts or b.Virtual_Puts);
161 retval.Input_Events := (a.Input_Events or b.Input_Events);
162 retval.TTY_State := (a.TTY_State or b.TTY_State);
163 retval.Internal_Calls := (a.Internal_Calls or b.Internal_Calls);
164 retval.Character_Calls := (a.Character_Calls or b.Character_Calls);
165 retval.Termcap_TermInfo := (a.Termcap_TermInfo or b.Termcap_TermInfo);
170 -- Print the hexadecimal value of the mask so
171 -- users can set it from the command line.
173 function trace_num (tlevel : Trace_Attribute_Set) return String is
174 result : Integer := 0;
179 result := result + m;
184 result := result + m;
188 if tlevel.Update then
189 result := result + m;
193 if tlevel.Cursor_Move then
194 result := result + m;
198 if tlevel.Character_Output then
199 result := result + m;
204 result := result + m;
208 if tlevel.Virtual_Puts then
209 result := result + m;
213 if tlevel.Input_Events then
214 result := result + m;
218 if tlevel.TTY_State then
219 result := result + m;
223 if tlevel.Internal_Calls then
224 result := result + m;
228 if tlevel.Character_Calls then
229 result := result + m;
233 if tlevel.Termcap_TermInfo then
234 result := result + m;
240 function tracetrace (tlevel : Trace_Attribute_Set) return String is
243 buf : Bounded_String := To_Bounded_String ("");
245 -- The C version prints the hexadecimal value of the mask, we
246 -- won't do that here because this is Ada.
248 if tlevel = Trace_Disable then
249 Append (buf, "Trace_Disable");
253 Trace_Attribute_Set'(Times => True, others => False)) then
254 Append (buf, "Times");
259 Trace_Attribute_Set'(Tputs => True, others => False)) then
260 Append (buf, "Tputs");
265 Trace_Attribute_Set'(Update => True, others => False)) then
266 Append (buf, "Update");
271 Trace_Attribute_Set'(Cursor_Move => True,
272 others => False)) then
273 Append (buf, "Cursor_Move");
278 Trace_Attribute_Set'(Character_Output => True,
279 others => False)) then
280 Append (buf, "Character_Output");
286 Append (buf, "Ordinary");
291 Trace_Attribute_Set'(Calls => True, others => False)) then
292 Append (buf, "Calls");
297 Trace_Attribute_Set'(Virtual_Puts => True,
298 others => False)) then
299 Append (buf, "Virtual_Puts");
304 Trace_Attribute_Set'(Input_Events => True,
305 others => False)) then
306 Append (buf, "Input_Events");
311 Trace_Attribute_Set'(TTY_State => True,
312 others => False)) then
313 Append (buf, "TTY_State");
318 Trace_Attribute_Set'(Internal_Calls => True,
319 others => False)) then
320 Append (buf, "Internal_Calls");
325 Trace_Attribute_Set'(Character_Calls => True,
326 others => False)) then
327 Append (buf, "Character_Calls");
332 Trace_Attribute_Set'(Termcap_TermInfo => True,
333 others => False)) then
334 Append (buf, "Termcap_TermInfo");
340 Append (buf, "Maximium");
345 if To_String (buf) (Length (buf) - 1) = ',' then
346 Delete (buf, Length (buf) - 1, Length (buf));
349 return To_String (buf);
352 function run_trace_menu (m : Menu; count : Integer) return Boolean is
358 changed := (count /= 0);
359 c := Getchar (Get_Window (m));
360 v := menu_virtualize (c);
361 case Driver (m, v) is
362 when Unknown_Request =>
366 if i = Menus.Items (m, 1) then -- the first item
367 for n in t_tbl'First + 1 .. t_tbl'Last loop
369 Set_Value (i, False);
374 for n in t_tbl'First + 1 .. t_tbl'Last loop
375 p := Menus.Items (m, n);
377 Set_Value (Menus.Items (m, 1), False);
390 nc_tracing, mask : Trace_Attribute_Set;
391 pragma Import (C, nc_tracing, "_nc_tracing");
392 items_a : constant Item_Array_Access :=
393 new Item_Array (t_tbl'First .. t_tbl'Last + 1);
395 mcols : Column_Count;
397 menu_y : constant Line_Position := 8;
398 menu_x : constant Column_Position := 8;
402 newtrace : Trace_Attribute_Set;
404 Add (Line => 0, Column => 0, Str => "Interactively set trace level:");
405 Add (Line => 2, Column => 0,
406 Str => " Press space bar to toggle a selection.");
407 Add (Line => 3, Column => 0,
408 Str => " Use up and down arrow to move the select bar.");
409 Add (Line => 4, Column => 0,
410 Str => " Press return to set the trace level.");
411 Add (Line => 6, Column => 0, Str => "(Current trace level is ");
412 Add (Str => tracetrace (nc_tracing) & " numerically: " &
413 trace_num (nc_tracing));
418 for n in t_tbl'Range loop
419 items_a (n) := New_Item (t_tbl (n).name.all);
421 items_a (t_tbl'Last + 1) := Null_Item;
423 m := New_Menu (items_a);
425 Set_Format (m, 16, 2);
426 Scale (m, mrows, mcols);
428 Switch_Options (m, (One_Valued => True, others => False), On => False);
429 menuwin := New_Window (mrows + 2, mcols + 2, menu_y, menu_x);
430 Set_Window (m, menuwin);
431 Set_KeyPad_Mode (menuwin, SwitchOn => True);
434 Set_Sub_Window (m, Derived_Window (menuwin, mrows, mcols, 1, 1));
438 for n in t_tbl'Range loop
440 mask := t_tbl (n).mask;
441 if mask = Trace_Disable then
442 Set_Value (ip, nc_tracing = Trace_Disable);
443 elsif subset (sub => mask, super => nc_tracing) then
444 Set_Value (ip, True);
449 while run_trace_menu (m, count) loop
453 newtrace := Trace_Disable;
454 for n in t_tbl'Range loop
457 mask := t_tbl (n).mask;
458 newtrace := trace_or (newtrace, mask);
463 Trace_Put ("trace level interactively set to " &
464 tracetrace (nc_tracing));
466 Move_Cursor (Line => Lines - 4, Column => 0);
467 Add (Str => "Trace level is ");
468 Add (Str => tracetrace (nc_tracing));
470 Pause; -- was just Add(); Getchar
473 -- menuwin has subwindows I think, which makes an error.
476 exception when Curses_Exception => null; end;
480 end ncurses2.trace_set;