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