1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding Samples -- 4-- -- 5-- ncurses -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright 2018,2020 Thomas E. Dickey -- 11-- Copyright 2000-2007,2008 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.11 $ 40-- $Date: 2020/02/02 23:34:34 $ 41-- Binding Version 01.00 42------------------------------------------------------------------------------ 43-- TODO use Default_Character where appropriate 44 45-- This is an Ada version of ncurses 46-- I translated this because it tests the most features. 47 48with Terminal_Interface.Curses; use Terminal_Interface.Curses; 49with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace; 50 51with Ada.Text_IO; use Ada.Text_IO; 52 53with Ada.Characters.Latin_1; 54 55with Ada.Command_Line; use Ada.Command_Line; 56 57with Ada.Strings.Unbounded; 58 59with ncurses2.util; use ncurses2.util; 60with ncurses2.getch_test; 61with ncurses2.attr_test; 62with ncurses2.color_test; 63with ncurses2.demo_panels; 64with ncurses2.color_edit; 65with ncurses2.slk_test; 66with ncurses2.acs_display; 67with ncurses2.acs_and_scroll; 68with ncurses2.flushinp_test; 69with ncurses2.test_sgr_attributes; 70with ncurses2.menu_test; 71with ncurses2.demo_pad; 72with ncurses2.demo_forms; 73with ncurses2.overlap_test; 74with ncurses2.trace_set; 75 76with ncurses2.getopt; use ncurses2.getopt; 77 78package body ncurses2.m is 79 80 function To_trace (n : Integer) return Trace_Attribute_Set; 81 procedure usage; 82 procedure Set_Terminal_Modes; 83 function Do_Single_Test (c : Character) return Boolean; 84 85 function To_trace (n : Integer) return Trace_Attribute_Set is 86 a : Trace_Attribute_Set := (others => False); 87 m : Integer; 88 rest : Integer; 89 begin 90 m := n mod 2; 91 if 1 = m then 92 a.Times := True; 93 end if; 94 rest := n / 2; 95 96 m := rest mod 2; 97 if 1 = m then 98 a.Tputs := True; 99 end if; 100 rest := rest / 2; 101 m := rest mod 2; 102 if 1 = m then 103 a.Update := True; 104 end if; 105 rest := rest / 2; 106 m := rest mod 2; 107 if 1 = m then 108 a.Cursor_Move := True; 109 end if; 110 rest := rest / 2; 111 m := rest mod 2; 112 if 1 = m then 113 a.Character_Output := True; 114 end if; 115 rest := rest / 2; 116 m := rest mod 2; 117 if 1 = m then 118 a.Calls := True; 119 end if; 120 rest := rest / 2; 121 m := rest mod 2; 122 if 1 = m then 123 a.Virtual_Puts := True; 124 end if; 125 rest := rest / 2; 126 m := rest mod 2; 127 if 1 = m then 128 a.Input_Events := True; 129 end if; 130 rest := rest / 2; 131 m := rest mod 2; 132 if 1 = m then 133 a.TTY_State := True; 134 end if; 135 rest := rest / 2; 136 m := rest mod 2; 137 if 1 = m then 138 a.Internal_Calls := True; 139 end if; 140 rest := rest / 2; 141 m := rest mod 2; 142 if 1 = m then 143 a.Character_Calls := True; 144 end if; 145 rest := rest / 2; 146 m := rest mod 2; 147 if 1 = m then 148 a.Termcap_TermInfo := True; 149 end if; 150 151 return a; 152 end To_trace; 153 154 -- these are type Stdscr_Init_Proc; 155 156 function rip_footer ( 157 Win : Window; 158 Columns : Column_Count) return Integer; 159 pragma Convention (C, rip_footer); 160 161 function rip_footer ( 162 Win : Window; 163 Columns : Column_Count) return Integer is 164 begin 165 Set_Background (Win, (Ch => ' ', 166 Attr => (Reverse_Video => True, others => False), 167 Color => 0)); 168 Erase (Win); 169 Move_Cursor (Win, 0, 0); 170 Add (Win, "footer:" & Columns'Img & " columns"); 171 Refresh_Without_Update (Win); 172 return 0; -- Curses_OK; 173 end rip_footer; 174 175 function rip_header ( 176 Win : Window; 177 Columns : Column_Count) return Integer; 178 pragma Convention (C, rip_header); 179 180 function rip_header ( 181 Win : Window; 182 Columns : Column_Count) return Integer is 183 begin 184 Set_Background (Win, (Ch => ' ', 185 Attr => (Reverse_Video => True, others => False), 186 Color => 0)); 187 Erase (Win); 188 Move_Cursor (Win, 0, 0); 189 Add (Win, "header:" & Columns'Img & " columns"); 190 -- 'Img is a GNAT extension 191 Refresh_Without_Update (Win); 192 return 0; -- Curses_OK; 193 end rip_header; 194 195 procedure usage is 196 -- type Stringa is access String; 197 use Ada.Strings.Unbounded; 198 -- tbl : constant array (Positive range <>) of Stringa := ( 199 tbl : constant array (Positive range <>) of Unbounded_String 200 := ( 201 To_Unbounded_String ("Usage: ncurses [options]"), 202 To_Unbounded_String (""), 203 To_Unbounded_String ("Options:"), 204 To_Unbounded_String (" -a f,b set default-colors " & 205 "(assumed white-on-black)"), 206 To_Unbounded_String (" -d use default-colors if terminal " & 207 "supports them"), 208 To_Unbounded_String (" -e fmt specify format for soft-keys " & 209 "test (e)"), 210 To_Unbounded_String (" -f rip-off footer line " & 211 "(can repeat)"), 212 To_Unbounded_String (" -h rip-off header line " & 213 "(can repeat)"), 214 To_Unbounded_String (" -s msec specify nominal time for " & 215 "panel-demo (default: 1, to hold)"), 216 To_Unbounded_String (" -t mask specify default trace-level " & 217 "(may toggle with ^T)") 218 ); 219 begin 220 for n in tbl'Range loop 221 Put_Line (Standard_Error, To_String (tbl (n))); 222 end loop; 223 -- exit(EXIT_FAILURE); 224 -- TODO should we use Set_Exit_Status and throw and exception? 225 end usage; 226 227 procedure Set_Terminal_Modes is begin 228 Set_Raw_Mode (SwitchOn => False); 229 Set_Cbreak_Mode (SwitchOn => True); 230 Set_Echo_Mode (SwitchOn => False); 231 Allow_Scrolling (Mode => True); 232 Use_Insert_Delete_Line (Do_Idl => True); 233 Set_KeyPad_Mode (SwitchOn => True); 234 end Set_Terminal_Modes; 235 236 nap_msec : Integer := 1; 237 238 function Do_Single_Test (c : Character) return Boolean is 239 begin 240 case c is 241 when 'a' => 242 getch_test; 243 when 'b' => 244 attr_test; 245 when 'c' => 246 if not Has_Colors then 247 Cannot ("does not support color."); 248 else 249 color_test; 250 end if; 251 when 'd' => 252 if not Has_Colors then 253 Cannot ("does not support color."); 254 elsif not Can_Change_Color then 255 Cannot ("has hardwired color values."); 256 else 257 color_edit; 258 end if; 259 when 'e' => 260 slk_test; 261 when 'f' => 262 acs_display; 263 when 'o' => 264 demo_panels (nap_msec); 265 when 'g' => 266 acs_and_scroll; 267 when 'i' => 268 flushinp_test (Standard_Window); 269 when 'k' => 270 test_sgr_attributes; 271 when 'm' => 272 menu_test; 273 when 'p' => 274 demo_pad; 275 when 'r' => 276 demo_forms; 277 when 's' => 278 overlap_test; 279 when 't' => 280 trace_set; 281 when '?' => 282 null; 283 when others => return False; 284 end case; 285 return True; 286 end Do_Single_Test; 287 288 command : Character; 289 my_e_param : Soft_Label_Key_Format := Four_Four; 290 assumed_colors : Boolean := False; 291 default_colors : Boolean := False; 292 default_fg : Color_Number := White; 293 default_bg : Color_Number := Black; 294 -- nap_msec was an unsigned long integer in the C version, 295 -- yet napms only takes an int! 296 297 c : Integer; 298 c2 : Character; 299 optind : Integer := 1; -- must be initialized to one. 300 optarg : getopt.stringa; 301 302 length : Integer; 303 tmpi : Integer; 304 305 package myio is new Ada.Text_IO.Integer_IO (Integer); 306 307 save_trace : Integer := 0; 308 save_trace_set : Trace_Attribute_Set; 309 310 function main return Integer is 311 begin 312 loop 313 Qgetopt (c, Argument_Count, Argument'Access, 314 "a:de:fhs:t:", optind, optarg); 315 exit when c = -1; 316 c2 := Character'Val (c); 317 case c2 is 318 when 'a' => 319 -- Ada doesn't have scanf, it doesn't even have a 320 -- regular expression library. 321 assumed_colors := True; 322 myio.Get (optarg.all, Integer (default_fg), length); 323 myio.Get (optarg.all (length + 2 .. optarg.all'Length), 324 Integer (default_bg), length); 325 when 'd' => 326 default_colors := True; 327 when 'e' => 328 myio.Get (optarg.all, tmpi, length); 329 if tmpi > 3 then 330 usage; 331 return 1; 332 end if; 333 my_e_param := Soft_Label_Key_Format'Val (tmpi); 334 when 'f' => 335 Rip_Off_Lines (-1, rip_footer'Access); 336 when 'h' => 337 Rip_Off_Lines (1, rip_header'Access); 338 when 's' => 339 myio.Get (optarg.all, nap_msec, length); 340 when 't' => 341 myio.Get (optarg.all, save_trace, length); 342 when others => 343 usage; 344 return 1; 345 end case; 346 end loop; 347 348 -- the C version had a bunch of macros here. 349 350 -- if (!isatty(fileno(stdin))) 351 -- isatty is not available in the standard Ada so skip it. 352 save_trace_set := To_trace (save_trace); 353 Trace_On (save_trace_set); 354 355 Init_Soft_Label_Keys (my_e_param); 356 357 Init_Screen; 358 Set_Background (Ch => (Ch => Blank, 359 Attr => Normal_Video, 360 Color => Color_Pair'First)); 361 362 if Has_Colors then 363 Start_Color; 364 if default_colors then 365 Use_Default_Colors; 366 elsif assumed_colors then 367 Assume_Default_Colors (default_fg, default_bg); 368 end if; 369 end if; 370 371 Set_Terminal_Modes; 372 Save_Curses_Mode (Curses); 373 374 End_Windows; 375 376 -- TODO add macro #if blocks. 377 Put_Line ("Welcome to " & Curses_Version & ". Press ? for help."); 378 379 loop 380 Put_Line ("This is the ncurses main menu"); 381 Put_Line ("a = keyboard and mouse input test"); 382 Put_Line ("b = character attribute test"); 383 Put_Line ("c = color test pattern"); 384 Put_Line ("d = edit RGB color values"); 385 Put_Line ("e = exercise soft keys"); 386 Put_Line ("f = display ACS characters"); 387 Put_Line ("g = display windows and scrolling"); 388 Put_Line ("i = test of flushinp()"); 389 Put_Line ("k = display character attributes"); 390 Put_Line ("m = menu code test"); 391 Put_Line ("o = exercise panels library"); 392 Put_Line ("p = exercise pad features"); 393 Put_Line ("q = quit"); 394 Put_Line ("r = exercise forms code"); 395 Put_Line ("s = overlapping-refresh test"); 396 Put_Line ("t = set trace level"); 397 Put_Line ("? = repeat this command summary"); 398 399 Put ("> "); 400 Flush; 401 402 command := Ada.Characters.Latin_1.NUL; 403 -- get_input: 404 -- loop 405 declare 406 Ch : Character; 407 begin 408 Get (Ch); 409 -- TODO if read(ch) <= 0 410 -- TODO ada doesn't have an Is_Space function 411 command := Ch; 412 -- TODO if ch = '\n' or '\r' are these in Ada? 413 end; 414 -- end loop get_input; 415 416 declare 417 begin 418 if Do_Single_Test (command) then 419 Flush_Input; 420 Set_Terminal_Modes; 421 Reset_Curses_Mode (Curses); 422 Clear; 423 Refresh; 424 End_Windows; 425 if command = '?' then 426 Put_Line ("This is the ncurses capability tester."); 427 Put_Line ("You may select a test from the main menu by " & 428 "typing the"); 429 Put_Line ("key letter of the choice (the letter to left " & 430 "of the =)"); 431 Put_Line ("at the > prompt. The commands `x' or `q' will " & 432 "exit."); 433 end if; 434 -- continue; --why continue in the C version? 435 end if; 436 exception 437 when Curses_Exception => End_Windows; 438 end; 439 440 exit when command = 'q'; 441 end loop; 442 Curses_Free_All; 443 return 0; -- TODO ExitProgram(EXIT_SUCCESS); 444 end main; 445 446end ncurses2.m; 447