Ada95/samples/ncurses2-m.adb

   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
  48 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  49 with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
  50
  51 with Ada.Text_IO; use Ada.Text_IO;
  52
  53 with Ada.Characters.Latin_1;
  54
  55 with Ada.Command_Line; use Ada.Command_Line;
  56
  57 with Ada.Strings.Unbounded;
  58
  59 with ncurses2.util; use ncurses2.util;
  60 with ncurses2.getch_test;
  61 with ncurses2.attr_test;
  62 with ncurses2.color_test;
  63 with ncurses2.demo_panels;
  64 with ncurses2.color_edit;
  65 with ncurses2.slk_test;
  66 with ncurses2.acs_display;
  67 with ncurses2.acs_and_scroll;
  68 with ncurses2.flushinp_test;
  69 with ncurses2.test_sgr_attributes;
  70 with ncurses2.menu_test;
  71 with ncurses2.demo_pad;
  72 with ncurses2.demo_forms;
  73 with ncurses2.overlap_test;
  74 with ncurses2.trace_set;
  75
  76 with ncurses2.getopt; use ncurses2.getopt;
  77
  78 package 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
 446 end ncurses2.m;