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