1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding -- 4-- -- 5-- Terminal_Interface.Curses.Terminfo -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright 2020 Thomas E. Dickey -- 11-- Copyright 2000-2006,2009 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: Juergen Pfeifer, 1996 38-- Version Control: 39-- $Revision: 1.7 $ 40-- $Date: 2020/02/02 23:34:34 $ 41-- Binding Version 01.00 42------------------------------------------------------------------------------ 43 44with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; 45with Interfaces.C; use Interfaces.C; 46with Interfaces.C.Strings; use Interfaces.C.Strings; 47with Ada.Unchecked_Conversion; 48 49package body Terminal_Interface.Curses.Terminfo is 50 51 function Is_MinusOne_Pointer (P : chars_ptr) return Boolean; 52 53 function Is_MinusOne_Pointer (P : chars_ptr) return Boolean is 54 type Weird_Address is new System.Storage_Elements.Integer_Address; 55 Invalid_Pointer : constant Weird_Address := -1; 56 function To_Weird is new Ada.Unchecked_Conversion 57 (Source => chars_ptr, Target => Weird_Address); 58 begin 59 if To_Weird (P) = Invalid_Pointer then 60 return True; 61 else 62 return False; 63 end if; 64 end Is_MinusOne_Pointer; 65 pragma Inline (Is_MinusOne_Pointer); 66 67------------------------------------------------------------------------------ 68 function Get_Flag (Name : String) return Boolean 69 is 70 function tigetflag (id : char_array) return Curses_Bool; 71 pragma Import (C, tigetflag); 72 Txt : char_array (0 .. Name'Length); 73 Length : size_t; 74 begin 75 To_C (Name, Txt, Length); 76 if tigetflag (Txt) = Curses_Bool (Curses_True) then 77 return True; 78 else 79 return False; 80 end if; 81 end Get_Flag; 82 83------------------------------------------------------------------------------ 84 procedure Get_String (Name : String; 85 Value : out Terminfo_String; 86 Result : out Boolean) 87 is 88 function tigetstr (id : char_array) return chars_ptr; 89 pragma Import (C, tigetstr, "tigetstr"); 90 Txt : char_array (0 .. Name'Length); 91 Length : size_t; 92 Txt2 : chars_ptr; 93 begin 94 To_C (Name, Txt, Length); 95 Txt2 := tigetstr (Txt); 96 if Txt2 = Null_Ptr then 97 Result := False; 98 elsif Is_MinusOne_Pointer (Txt2) then 99 raise Curses_Exception; 100 else 101 Value := Terminfo_String (Fill_String (Txt2)); 102 Result := True; 103 end if; 104 end Get_String; 105 106------------------------------------------------------------------------------ 107 function Has_String (Name : String) return Boolean 108 is 109 function tigetstr (id : char_array) return chars_ptr; 110 pragma Import (C, tigetstr, "tigetstr"); 111 Txt : char_array (0 .. Name'Length); 112 Length : size_t; 113 Txt2 : chars_ptr; 114 begin 115 To_C (Name, Txt, Length); 116 Txt2 := tigetstr (Txt); 117 if Txt2 = Null_Ptr then 118 return False; 119 elsif Is_MinusOne_Pointer (Txt2) then 120 raise Curses_Exception; 121 else 122 return True; 123 end if; 124 end Has_String; 125 126------------------------------------------------------------------------------ 127 function Get_Number (Name : String) return Integer is 128 function tigetstr (s : char_array) return C_Int; 129 pragma Import (C, tigetstr); 130 Txt : char_array (0 .. Name'Length); 131 Length : size_t; 132 begin 133 To_C (Name, Txt, Length); 134 return Integer (tigetstr (Txt)); 135 end Get_Number; 136 137------------------------------------------------------------------------------ 138 procedure Put_String (Str : Terminfo_String; 139 affcnt : Natural := 1; 140 putc : putctype := null) is 141 function tputs (str : char_array; 142 affcnt : C_Int; 143 putc : putctype) return C_Int; 144 function putp (str : char_array) return C_Int; 145 pragma Import (C, tputs); 146 pragma Import (C, putp); 147 Txt : char_array (0 .. Str'Length); 148 Length : size_t; 149 Err : C_Int; 150 begin 151 To_C (String (Str), Txt, Length); 152 if putc = null then 153 Err := putp (Txt); 154 else 155 Err := tputs (Txt, C_Int (affcnt), putc); 156 end if; 157 if Err = Curses_Err then 158 raise Curses_Exception; 159 end if; 160 end Put_String; 161 162end Terminal_Interface.Curses.Terminfo; 163