1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding -- 4-- -- 5-- Terminal_Interface.Curses.Forms.Field_Types -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright (c) 1998-2011,2014 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: Juergen Pfeifer, 1996 37-- Version Control: 38-- $Revision: 1.28 $ 39-- $Date: 2014/09/13 19:00:47 $ 40-- Binding Version 01.00 41------------------------------------------------------------------------------ 42with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; 43with Ada.Unchecked_Deallocation; 44with System.Address_To_Access_Conversions; 45 46-- | 47-- |===================================================================== 48-- | man page form_fieldtype.3x 49-- |===================================================================== 50-- | 51package body Terminal_Interface.Curses.Forms.Field_Types is 52 53 use type System.Address; 54 55 package Argument_Conversions is 56 new System.Address_To_Access_Conversions (Argument); 57 58 function Get_Fieldtype (F : Field) return C_Field_Type; 59 pragma Import (C, Get_Fieldtype, "field_type"); 60 61 function Get_Arg (F : Field) return System.Address; 62 pragma Import (C, Get_Arg, "field_arg"); 63 -- | 64 -- |===================================================================== 65 -- | man page form_field_validation.3x 66 -- |===================================================================== 67 -- | 68 -- | 69 -- | 70 function Get_Type (Fld : Field) return Field_Type_Access 71 is 72 Low_Level : constant C_Field_Type := Get_Fieldtype (Fld); 73 Arg : Argument_Access; 74 begin 75 if Low_Level = Null_Field_Type then 76 return null; 77 else 78 if Low_Level = M_Builtin_Router or else 79 Low_Level = M_Generic_Type or else 80 Low_Level = M_Choice_Router or else 81 Low_Level = M_Generic_Choice 82 then 83 Arg := Argument_Access 84 (Argument_Conversions.To_Pointer (Get_Arg (Fld))); 85 if Arg = null then 86 raise Form_Exception; 87 else 88 return Arg.all.Typ; 89 end if; 90 else 91 raise Form_Exception; 92 end if; 93 end if; 94 end Get_Type; 95 96 function Copy_Arg (Usr : System.Address) return System.Address 97 is 98 begin 99 return Usr; 100 end Copy_Arg; 101 102 procedure Free_Arg (Usr : System.Address) 103 is 104 procedure Free_Type is new Ada.Unchecked_Deallocation 105 (Field_Type'Class, Field_Type_Access); 106 procedure Freeargs is new Ada.Unchecked_Deallocation 107 (Argument, Argument_Access); 108 109 To_Be_Free : Argument_Access 110 := Argument_Access (Argument_Conversions.To_Pointer (Usr)); 111 Low_Level : C_Field_Type; 112 begin 113 if To_Be_Free /= null then 114 if To_Be_Free.all.Usr /= System.Null_Address then 115 Low_Level := To_Be_Free.all.Cft; 116 if Low_Level.all.Freearg /= null then 117 Low_Level.all.Freearg (To_Be_Free.all.Usr); 118 end if; 119 end if; 120 if To_Be_Free.all.Typ /= null then 121 Free_Type (To_Be_Free.all.Typ); 122 end if; 123 Freeargs (To_Be_Free); 124 end if; 125 end Free_Arg; 126 127 procedure Wrap_Builtin (Fld : Field; 128 Typ : Field_Type'Class; 129 Cft : C_Field_Type := C_Builtin_Router) 130 is 131 Usr_Arg : constant System.Address := Get_Arg (Fld); 132 Low_Level : constant C_Field_Type := Get_Fieldtype (Fld); 133 Arg : Argument_Access; 134 function Set_Fld_Type (F : Field := Fld; 135 Cf : C_Field_Type := Cft; 136 Arg1 : Argument_Access) return Eti_Error; 137 pragma Import (C, Set_Fld_Type, "set_field_type_user"); 138 139 begin 140 pragma Assert (Low_Level /= Null_Field_Type); 141 if Cft /= C_Builtin_Router and then Cft /= C_Choice_Router then 142 raise Form_Exception; 143 else 144 Arg := new Argument'(Usr => System.Null_Address, 145 Typ => new Field_Type'Class'(Typ), 146 Cft => Get_Fieldtype (Fld)); 147 if Usr_Arg /= System.Null_Address then 148 if Low_Level.all.Copyarg /= null then 149 Arg.all.Usr := Low_Level.all.Copyarg (Usr_Arg); 150 else 151 Arg.all.Usr := Usr_Arg; 152 end if; 153 end if; 154 155 Eti_Exception (Set_Fld_Type (Arg1 => Arg)); 156 end if; 157 end Wrap_Builtin; 158 159 function Field_Check_Router (Fld : Field; 160 Usr : System.Address) return Curses_Bool 161 is 162 Arg : constant Argument_Access 163 := Argument_Access (Argument_Conversions.To_Pointer (Usr)); 164 begin 165 pragma Assert (Arg /= null and then Arg.all.Cft /= Null_Field_Type 166 and then Arg.all.Typ /= null); 167 if Arg.all.Cft.all.Fcheck /= null then 168 return Arg.all.Cft.all.Fcheck (Fld, Arg.all.Usr); 169 else 170 return 1; 171 end if; 172 end Field_Check_Router; 173 174 function Char_Check_Router (Ch : C_Int; 175 Usr : System.Address) return Curses_Bool 176 is 177 Arg : constant Argument_Access 178 := Argument_Access (Argument_Conversions.To_Pointer (Usr)); 179 begin 180 pragma Assert (Arg /= null and then Arg.all.Cft /= Null_Field_Type 181 and then Arg.all.Typ /= null); 182 if Arg.all.Cft.all.Ccheck /= null then 183 return Arg.all.Cft.all.Ccheck (Ch, Arg.all.Usr); 184 else 185 return 1; 186 end if; 187 end Char_Check_Router; 188 189 function Next_Router (Fld : Field; 190 Usr : System.Address) return Curses_Bool 191 is 192 Arg : constant Argument_Access 193 := Argument_Access (Argument_Conversions.To_Pointer (Usr)); 194 begin 195 pragma Assert (Arg /= null and then Arg.all.Cft /= Null_Field_Type 196 and then Arg.all.Typ /= null); 197 if Arg.all.Cft.all.Next /= null then 198 return Arg.all.Cft.all.Next (Fld, Arg.all.Usr); 199 else 200 return 1; 201 end if; 202 end Next_Router; 203 204 function Prev_Router (Fld : Field; 205 Usr : System.Address) return Curses_Bool 206 is 207 Arg : constant Argument_Access := 208 Argument_Access (Argument_Conversions.To_Pointer (Usr)); 209 begin 210 pragma Assert (Arg /= null and then Arg.all.Cft /= Null_Field_Type 211 and then Arg.all.Typ /= null); 212 if Arg.all.Cft.all.Prev /= null then 213 return Arg.all.Cft.all.Prev (Fld, Arg.all.Usr); 214 else 215 return 1; 216 end if; 217 end Prev_Router; 218 219 -- ----------------------------------------------------------------------- 220 -- 221 function C_Builtin_Router return C_Field_Type 222 is 223 T : C_Field_Type; 224 begin 225 if M_Builtin_Router = Null_Field_Type then 226 T := New_Fieldtype (Field_Check_Router'Access, 227 Char_Check_Router'Access); 228 if T = Null_Field_Type then 229 raise Form_Exception; 230 else 231 Eti_Exception (Set_Fieldtype_Arg (T, 232 Make_Arg'Access, 233 Copy_Arg'Access, 234 Free_Arg'Access)); 235 end if; 236 M_Builtin_Router := T; 237 end if; 238 pragma Assert (M_Builtin_Router /= Null_Field_Type); 239 return M_Builtin_Router; 240 end C_Builtin_Router; 241 242 -- ----------------------------------------------------------------------- 243 -- 244 function C_Choice_Router return C_Field_Type 245 is 246 T : C_Field_Type; 247 begin 248 if M_Choice_Router = Null_Field_Type then 249 T := New_Fieldtype (Field_Check_Router'Access, 250 Char_Check_Router'Access); 251 if T = Null_Field_Type then 252 raise Form_Exception; 253 else 254 Eti_Exception (Set_Fieldtype_Arg (T, 255 Make_Arg'Access, 256 Copy_Arg'Access, 257 Free_Arg'Access)); 258 259 Eti_Exception (Set_Fieldtype_Choice (T, 260 Next_Router'Access, 261 Prev_Router'Access)); 262 end if; 263 M_Choice_Router := T; 264 end if; 265 pragma Assert (M_Choice_Router /= Null_Field_Type); 266 return M_Choice_Router; 267 end C_Choice_Router; 268 269end Terminal_Interface.Curses.Forms.Field_Types; 270