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