Ada95/ada_include/terminal_interface-curses-forms-field_types.adb

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