-- B O D Y --
-- --
------------------------------------------------------------------------------
--- Copyright (c) 2000 Free Software Foundation, Inc. --
+-- Copyright (c) 2000-2011,2014 Free Software Foundation, Inc. --
-- --
-- Permission is hereby granted, free of charge, to any person obtaining a --
-- copy of this software and associated documentation files (the --
------------------------------------------------------------------------------
-- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
-- Version Control
--- $Revision: 1.1 $
+-- $Revision: 1.6 $
+-- $Date: 2014/09/13 19:10:18 $
-- Binding Version 01.00
------------------------------------------------------------------------------
with ncurses2.util; use ncurses2.util;
procedure ncurses2.trace_set is
- function menu_virtualize (c : Key_Code) return Menu_Request_Code;
+ function menu_virtualize (c : Key_Code) return Key_Code;
function subset (super, sub : Trace_Attribute_Set) return Boolean;
function trace_or (a, b : Trace_Attribute_Set) return Trace_Attribute_Set;
function trace_num (tlevel : Trace_Attribute_Set) return String;
function tracetrace (tlevel : Trace_Attribute_Set) return String;
- function run_trace_menu (m : Menu) return Boolean;
+ function run_trace_menu (m : Menu; count : Integer) return Boolean;
- function menu_virtualize (c : Key_Code) return Menu_Request_Code is
+ function menu_virtualize (c : Key_Code) return Key_Code is
begin
case c is
when Character'Pos (newl) | Key_Exit =>
end case;
end menu_virtualize;
-
type string_a is access String;
type tbl_entry is record
name : string_a;
package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (300);
-
function subset (super, sub : Trace_Attribute_Set) return Boolean is
begin
if
(super.Internal_Calls or not sub.Internal_Calls) and
(super.Character_Calls or not sub.Character_Calls) and
(super.Termcap_TermInfo or not sub.Termcap_TermInfo) and
- True then
+ True
+ then
return True;
else
return False;
return result'Img;
end trace_num;
-
function tracetrace (tlevel : Trace_Attribute_Set) return String is
use BS;
Append (buf, "Trace_Disable");
else
-
if subset (tlevel,
- Trace_Attribute_Set'(Times => True, others => False)) then
+ Trace_Attribute_Set'(Times => True, others => False))
+ then
Append (buf, "Times");
Append (buf, ", ");
end if;
if subset (tlevel,
- Trace_Attribute_Set'(Tputs => True, others => False)) then
+ Trace_Attribute_Set'(Tputs => True, others => False))
+ then
Append (buf, "Tputs");
Append (buf, ", ");
end if;
if subset (tlevel,
- Trace_Attribute_Set'(Update => True, others => False)) then
+ Trace_Attribute_Set'(Update => True, others => False))
+ then
Append (buf, "Update");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(Cursor_Move => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "Cursor_Move");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(Character_Output => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "Character_Output");
Append (buf, ", ");
end if;
if subset (tlevel,
- Trace_Ordinary) then
+ Trace_Ordinary)
+ then
Append (buf, "Ordinary");
Append (buf, ", ");
end if;
if subset (tlevel,
- Trace_Attribute_Set'(Calls => True, others => False)) then
+ Trace_Attribute_Set'(Calls => True, others => False))
+ then
Append (buf, "Calls");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(Virtual_Puts => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "Virtual_Puts");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(Input_Events => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "Input_Events");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(TTY_State => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "TTY_State");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(Internal_Calls => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "Internal_Calls");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(Character_Calls => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "Character_Calls");
Append (buf, ", ");
end if;
if subset (tlevel,
Trace_Attribute_Set'(Termcap_TermInfo => True,
- others => False)) then
+ others => False))
+ then
Append (buf, "Termcap_TermInfo");
Append (buf, ", ");
end if;
if subset (tlevel,
- Trace_Maximum) then
+ Trace_Maximum)
+ then
Append (buf, "Maximium");
Append (buf, ", ");
end if;
return To_String (buf);
end tracetrace;
- function run_trace_menu (m : Menu) return Boolean is
+ function run_trace_menu (m : Menu; count : Integer) return Boolean is
i, p : Item;
changed : Boolean;
c, v : Key_Code;
begin
loop
- changed := False;
+ changed := (count /= 0);
c := Getchar (Get_Window (m));
v := menu_virtualize (c);
case Driver (m, v) is
nc_tracing, mask : Trace_Attribute_Set;
pragma Import (C, nc_tracing, "_nc_tracing");
- items_a : Item_Array_Access :=
+ items_a : constant Item_Array_Access :=
new Item_Array (t_tbl'First .. t_tbl'Last + 1);
mrows : Line_Count;
mcols : Column_Count;
menu_x : constant Column_Position := 8;
ip : Item;
m : Menu;
+ count : Integer;
newtrace : Trace_Attribute_Set;
begin
Add (Line => 0, Column => 0, Str => "Interactively set trace level:");
Refresh;
for n in t_tbl'Range loop
- items_a (n) := New_Item (t_tbl (n).name.all);
+ items_a.all (n) := New_Item (t_tbl (n).name.all);
end loop;
- items_a (t_tbl'Last + 1) := Null_Item;
+ items_a.all (t_tbl'Last + 1) := Null_Item;
m := New_Menu (items_a);
end if;
end loop;
- while run_trace_menu (m) loop
- null;
+ count := 1;
+ while run_trace_menu (m, count) loop
+ count := count + 1;
end loop;
newtrace := Trace_Disable;
projects / ncurses.git / blobdiff