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