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;