1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding Samples -- 4-- -- 5-- ncurses2.trace_set -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright 2020,2023 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.8 $ 40-- $Date: 2023/06/17 17:21:47 $ 41-- Binding Version 01.00 42------------------------------------------------------------------------------ 43with ncurses2.util; use ncurses2.util; 44with Terminal_Interface.Curses; use Terminal_Interface.Curses; 45with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace; 46with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus; 47 48with Ada.Strings.Bounded; 49 50-- interactively set the trace level 51 52procedure 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'("Maximum"), 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, "Maximum"); 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; 419begin 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() 496end ncurses2.trace_set; 497