Ada95/samples/ncurses2-getch_test.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                       GNAT ncurses Binding Samples                       --
   4 --                                                                          --
   5 --                                 ncurses                                  --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright (c) 2000-2008,2009 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.8 $
  39 --  $Date: 2009/12/26 17:38:58 $
  40 --  Binding Version 01.00
  41 ------------------------------------------------------------------------------
  42 --  Character input test
  43 --  test the keypad feature
  44
  45 with ncurses2.util; use ncurses2.util;
  46
  47 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  48 with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
  49 with Ada.Characters.Handling;
  50 with Ada.Strings.Bounded;
  51
  52 with ncurses2.genericPuts;
  53
  54 procedure ncurses2.getch_test is
  55    use Int_IO;
  56
  57    function mouse_decode (ep : Mouse_Event) return String;
  58
  59    function mouse_decode (ep : Mouse_Event) return String is
  60       Y      : Line_Position;
  61       X      : Column_Position;
  62       Button : Mouse_Button;
  63       State  : Button_State;
  64       package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (200);
  65       use BS;
  66       buf : Bounded_String := To_Bounded_String ("");
  67    begin
  68       --  Note that these bindings do not allow
  69       --  two button states,
  70       --  The C version can print {click-1, click-3} for example.
  71       --  They also don't have the 'id' or z coordinate.
  72       Get_Event (ep, Y, X, Button, State);
  73
  74       --  TODO Append (buf, "id "); from C version
  75       Append (buf, "at (");
  76       Append (buf, Column_Position'Image (X));
  77       Append (buf, ", ");
  78       Append (buf, Line_Position'Image (Y));
  79       Append (buf, ") state");
  80       Append (buf, Mouse_Button'Image (Button));
  81
  82       Append (buf, " = ");
  83       Append (buf, Button_State'Image (State));
  84       return To_String (buf);
  85    end mouse_decode;
  86
  87    buf : String (1 .. 1024); --  TODO was BUFSIZE
  88    n : Integer;
  89    c : Key_Code;
  90    blockflag : Timeout_Mode := Blocking;
  91    firsttime : Boolean := True;
  92    tmp2  : Event_Mask;
  93    tmp6 : String (1 .. 6);
  94    tmp20 : String (1 .. 20);
  95    x : Column_Position;
  96    y : Line_Position;
  97    tmpx : Integer;
  98    incount : Integer := 0;
  99
 100 begin
 101    Refresh;
 102    tmp2 := Start_Mouse (All_Events);
 103    Add (Str => "Delay in 10ths of a second (<CR> for blocking input)? ");
 104    Set_Echo_Mode (SwitchOn => True);
 105    Get (Str => buf);
 106
 107    Set_Echo_Mode (SwitchOn => False);
 108    Set_NL_Mode (SwitchOn => False);
 109
 110    if Ada.Characters.Handling.Is_Digit (buf (1)) then
 111       Get (Item => n, From => buf, Last => tmpx);
 112       Set_Timeout_Mode (Mode => Delayed, Amount => n * 100);
 113       blockflag := Delayed;
 114    end if;
 115
 116    c := Character'Pos ('?');
 117    Set_Raw_Mode (SwitchOn => True);
 118    loop
 119       if not firsttime then
 120          Add (Str => "Key pressed: ");
 121          Put (tmp6, Integer (c), 8);
 122          Add (Str => tmp6);
 123          Add (Ch => ' ');
 124          if c = Key_Mouse then
 125             declare
 126                event : Mouse_Event;
 127             begin
 128                event := Get_Mouse;
 129                Add (Str => "KEY_MOUSE, ");
 130                Add (Str => mouse_decode (event));
 131                Add (Ch => newl);
 132             end;
 133          elsif c >= Key_Min then
 134             Key_Name (c, tmp20);
 135             Add (Str => tmp20);
 136             --  I used tmp and got bitten by the length problem:->
 137             Add (Ch => newl);
 138          elsif c > 16#80# then --  TODO fix, use constant if possible
 139             declare
 140                c2 : constant Character := Character'Val (c mod 16#80#);
 141             begin
 142                if Ada.Characters.Handling.Is_Graphic (c2) then
 143                   Add (Str => "M-");
 144                   Add (Ch => c2);
 145                else
 146                   Add (Str => "M-");
 147                   Add (Str => Un_Control ((Ch => c2,
 148                                            Color => Color_Pair'First,
 149                                            Attr => Normal_Video)));
 150                end if;
 151                Add (Str => " (high-half character)");
 152                Add (Ch => newl);
 153             end;
 154          else
 155             declare
 156                c2 : constant Character := Character'Val (c mod 16#80#);
 157             begin
 158                if Ada.Characters.Handling.Is_Graphic (c2) then
 159                   Add (Ch => c2);
 160                   Add (Str => " (ASCII printable character)");
 161                   Add (Ch => newl);
 162                else
 163                   Add (Str => Un_Control ((Ch => c2,
 164                                           Color => Color_Pair'First,
 165                                           Attr => Normal_Video)));
 166                   Add (Str => " (ASCII control character)");
 167                   Add (Ch => newl);
 168                end if;
 169             end;
 170          end if;
 171          --  TODO I am not sure why this was in the C version
 172          --  the delay statement scroll anyway.
 173          Get_Cursor_Position (Line => y, Column => x);
 174          if y >= Lines - 1 then
 175             Move_Cursor (Line => 0, Column => 0);
 176          end if;
 177          Clear_To_End_Of_Line;
 178       end if;
 179
 180       firsttime := False;
 181       if c = Character'Pos ('g') then
 182          declare
 183             package p is new ncurses2.genericPuts (1024);
 184             use p;
 185             use p.BS;
 186             timedout : Boolean := False;
 187             boundedbuf : Bounded_String;
 188          begin
 189             Add (Str => "getstr test: ");
 190             Set_Echo_Mode (SwitchOn => True);
 191             --  Note that if delay mode is set
 192             --  Get can raise an exception.
 193             --  The C version would print the string it had so far
 194             --  also TODO get longer length string, like the C version
 195             declare begin
 196                myGet (Str => boundedbuf);
 197             exception when Curses_Exception =>
 198                Add (Str => "Timed out.");
 199                Add (Ch => newl);
 200                timedout := True;
 201             end;
 202             --  note that the Ada Get will stop reading at 1024.
 203             if not timedout then
 204                Set_Echo_Mode (SwitchOn => False);
 205                Add (Str => " I saw '");
 206                myAdd (Str => boundedbuf);
 207                Add (Str => "'.");
 208                Add (Ch => newl);
 209             end if;
 210          end;
 211       elsif c = Character'Pos ('s') then
 212          ShellOut (True);
 213       elsif c = Character'Pos ('x') or c = Character'Pos ('q') or
 214         (c = Key_None and blockflag = Blocking) then
 215          exit;
 216       elsif c = Character'Pos ('?') then
 217          Add (Str => "Type any key to see its keypad value.  Also:");
 218          Add (Ch => newl);
 219          Add (Str => "g -- triggers a getstr test");
 220          Add (Ch => newl);
 221          Add (Str => "s -- shell out");
 222          Add (Ch => newl);
 223          Add (Str => "q -- quit");
 224          Add (Ch => newl);
 225          Add (Str => "? -- repeats this help message");
 226          Add (Ch => newl);
 227       end if;
 228
 229       loop
 230          c := Getchar;
 231          exit when c /= Key_None;
 232          if blockflag /= Blocking then
 233             Put (tmp6, incount); --  argh string length!
 234             Add (Str => tmp6);
 235             Add (Str => ": input timed out");
 236             Add (Ch => newl);
 237          else
 238             Put (tmp6, incount);
 239             Add (Str => tmp6);
 240             Add (Str => ": input error");
 241             Add (Ch => newl);
 242             exit;
 243          end if;
 244          incount := incount + 1;
 245       end loop;
 246    end loop;
 247
 248    End_Mouse (tmp2);
 249    Set_Timeout_Mode (Mode => Blocking, Amount => 0); --  amount is ignored
 250    Set_Raw_Mode (SwitchOn => False);
 251    Set_NL_Mode (SwitchOn => True);
 252    Erase;
 253    End_Windows;
 254 end ncurses2.getch_test;