1------------------------------------------------------------------------------
2--                                                                          --
3--                       GNAT ncurses Binding Samples                       --
4--                                                                          --
5--                               ncurses2.util                              --
6--                                                                          --
7--                                 B O D Y                                  --
8--                                                                          --
9------------------------------------------------------------------------------
10-- Copyright 2020 Thomas E. Dickey                                          --
11-- Copyright 2000-2008,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.10 $
40--  $Date: 2020/02/02 23:34:34 $
41--  Binding Version 01.00
42------------------------------------------------------------------------------
43with Ada.Text_IO; use Ada.Text_IO;
44
45with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
46
47with Interfaces.C;
48with Interfaces.C.Strings;
49
50with Ada.Characters.Handling;
51
52with ncurses2.genericPuts;
53
54package body ncurses2.util is
55
56   --  #defines from C
57   --  #define CTRL(x)         ((x) & 0x1f)
58   function CTRL (c : Character) return Key_Code is
59   begin
60      return Character'Pos (c) mod 16#20#;
61      --  uses a property of ASCII
62      --  A = 16#41#; a = 16#61#; ^A = 1 or 16#1#
63   end CTRL;
64
65   function CTRL (c : Character) return Character is
66   begin
67      return Character'Val (Character'Pos (c) mod 16#20#);
68      --  uses a property of ASCII
69      --  A = 16#41#; a = 16#61#; ^A = 1 or 16#1#
70   end CTRL;
71
72   save_trace : Trace_Attribute_Set;
73   --  Common function to allow ^T to toggle trace-mode in the middle of a test
74   --  so that trace-files can be made smaller.
75   function Getchar (win : Window := Standard_Window) return Key_Code is
76      c : Key_Code;
77   begin
78      --  #ifdef TRACE
79      c := Get_Keystroke (win);
80      while c = CTRL ('T') loop
81         --  if _nc_tracing  in C
82         if Current_Trace_Setting /= Trace_Disable then
83            save_trace := Current_Trace_Setting;
84            Trace_Put ("TOGGLE-TRACING OFF");
85            Current_Trace_Setting := Trace_Disable;
86         else
87            Current_Trace_Setting := save_trace;
88         end if;
89         Trace_On (Current_Trace_Setting);
90         if Current_Trace_Setting /= Trace_Disable then
91            Trace_Put ("TOGGLE-TRACING ON");
92         end if;
93      end loop;
94      --  #else c := Get_Keystroke;
95      return c;
96   end Getchar;
97
98   procedure Getchar (win : Window := Standard_Window) is
99   begin
100      if Getchar (win) < 0 then
101         Beep;
102      end if;
103   end Getchar;
104
105   procedure Pause is
106   begin
107      Move_Cursor (Line => Lines - 1, Column => 0);
108      Add (Str => "Press any key to continue... ");
109      Getchar;
110   end Pause;
111
112   procedure Cannot (s : String) is
113      use Interfaces.C;
114      use Interfaces.C.Strings;
115      function getenv (x : char_array)  return chars_ptr;
116      pragma Import (C, getenv, "getenv");
117      tmp1 : char_array (0 .. 10);
118      package p is new ncurses2.genericPuts (1024);
119      use p;
120      use p.BS;
121
122      tmpb : BS.Bounded_String;
123
124      Length : size_t;
125   begin
126      To_C ("TERM", tmp1, Length);
127      Fill_String (getenv (tmp1), tmpb);
128      Add (Ch => newl);
129      myAdd (Str => "This " & tmpb & " terminal " & s);
130      Pause;
131   end Cannot;
132
133   procedure ShellOut (message : Boolean) is
134      use Interfaces.C;
135      Txt : char_array (0 .. 10);
136      Length : size_t;
137      procedure system (x : char_array);
138      pragma Import (C, system, "system");
139   begin
140      To_C ("sh", Txt,  Length);
141      if message then
142         Add (Str => "Shelling out...");
143      end if;
144      Save_Curses_Mode (Mode => Curses);
145      End_Windows;
146      system (Txt);
147      if message then
148         Add (Str => "returned from shellout.");
149         Add (Ch => newl);
150      end if;
151      Refresh;
152   end ShellOut;
153
154   function Is_Digit (c : Key_Code) return Boolean is
155   begin
156      if c >= 16#100# then
157         return False;
158      else
159         return Ada.Characters.Handling.Is_Digit (Character'Val (c));
160      end if;
161   end Is_Digit;
162
163   procedure P (s : String) is
164   begin
165      Add (Str => s);
166      Add (Ch => newl);
167   end P;
168
169   function Code_To_Char (c : Key_Code) return Character is
170   begin
171      if c > Character'Pos (Character'Last) then
172         return Character'Val (0);
173         --  maybe raise exception?
174      else
175         return Character'Val (c);
176      end if;
177   end Code_To_Char;
178
179   --  This was untestable due to a bug in GNAT (3.12p)
180   --  Hmm, what bug? I don't remember.
181   function ctoi (c : Character) return Integer is
182   begin
183      return Character'Pos (c) - Character'Pos ('0');
184   end ctoi;
185
186end ncurses2.util;
187