Ada95/src/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-2004,2006 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.19 $
  39 --  $Date: 2006/06/25 14:24:40 $
  40 --  Binding Version 01.00
  41 ------------------------------------------------------------------------------
  42 with Interfaces.C;
  43 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
  44 with Ada.Unchecked_Deallocation;
  45 with Ada.Unchecked_Conversion;
  46 --  |
  47 --  |=====================================================================
  48 --  | man page form_fieldtype.3x
  49 --  |=====================================================================
  50 --  |
  51 package body Terminal_Interface.Curses.Forms.Field_Types is
  52
  53    use type Interfaces.C.int;
  54    use type System.Address;
  55
  56    pragma Warnings (Off);
  57    function To_Argument_Access is new Ada.Unchecked_Conversion
  58      (System.Address, Argument_Access);
  59    pragma Warnings (On);
  60
  61    function Get_Fieldtype (F : Field) return C_Field_Type;
  62    pragma Import (C, Get_Fieldtype, "field_type");
  63
  64    function Get_Arg (F : Field) return System.Address;
  65    pragma Import (C, Get_Arg, "field_arg");
  66    --  |
  67    --  |=====================================================================
  68    --  | man page form_field_validation.3x
  69    --  |=====================================================================
  70    --  |
  71    --  |
  72    --  |
  73    function Get_Type (Fld : in Field) return Field_Type_Access
  74    is
  75       Low_Level : constant C_Field_Type := Get_Fieldtype (Fld);
  76       Arg : Argument_Access;
  77    begin
  78       if Low_Level = Null_Field_Type then
  79          return null;
  80       else
  81          if Low_Level = M_Builtin_Router or else
  82            Low_Level = M_Generic_Type or else
  83            Low_Level = M_Choice_Router or else
  84            Low_Level = M_Generic_Choice then
  85             Arg := To_Argument_Access (Get_Arg (Fld));
  86             if Arg = null then
  87                raise Form_Exception;
  88             else
  89                return Arg.Typ;
  90             end if;
  91          else
  92             raise Form_Exception;
  93          end if;
  94       end if;
  95    end Get_Type;
  96
  97    function Make_Arg (Args : System.Address) return System.Address
  98    is
  99       --  Actually args is a double indirected pointer to the arguments
 100       --  of a C variable argument list. In theory it is now quite
 101       --  complicated to write portable routine that reads the arguments,
 102       --  because one has to know the growth direction of the stack and
 103       --  the sizes of the individual arguments.
 104       --  Fortunately we are only interested in the first argument (#0),
 105       --  we know its size and for the first arg we don't care about
 106       --  into which stack direction we have to proceed. We simply
 107       --  resolve the double indirection and thats it.
 108       type V is access all System.Address;
 109       function To_Access is new Ada.Unchecked_Conversion (System.Address,
 110                                                           V);
 111    begin
 112       return To_Access (To_Access (Args).all).all;
 113    end Make_Arg;
 114
 115    function Copy_Arg (Usr : System.Address) return System.Address
 116    is
 117    begin
 118       return Usr;
 119    end Copy_Arg;
 120
 121    procedure Free_Arg (Usr : in System.Address)
 122    is
 123       procedure Free_Type is new Ada.Unchecked_Deallocation
 124         (Field_Type'Class, Field_Type_Access);
 125       procedure Freeargs is new Ada.Unchecked_Deallocation
 126         (Argument, Argument_Access);
 127
 128       To_Be_Free : Argument_Access := To_Argument_Access (Usr);
 129       Low_Level  : C_Field_Type;
 130    begin
 131       if To_Be_Free /= null then
 132          if To_Be_Free.Usr /= System.Null_Address then
 133             Low_Level := To_Be_Free.Cft;
 134             if Low_Level.Freearg /= null then
 135                Low_Level.Freearg (To_Be_Free.Usr);
 136             end if;
 137          end if;
 138          if To_Be_Free.Typ /= null then
 139             Free_Type (To_Be_Free.Typ);
 140          end if;
 141          Freeargs (To_Be_Free);
 142       end if;
 143    end Free_Arg;
 144
 145    procedure Wrap_Builtin (Fld : Field;
 146                            Typ : Field_Type'Class;
 147                            Cft : C_Field_Type := C_Builtin_Router)
 148    is
 149       Usr_Arg   : constant System.Address := Get_Arg (Fld);
 150       Low_Level : constant C_Field_Type := Get_Fieldtype (Fld);
 151       Arg : Argument_Access;
 152       Res : Eti_Error;
 153       function Set_Fld_Type (F    : Field := Fld;
 154                              Cf   : C_Field_Type := Cft;
 155                              Arg1 : Argument_Access) return C_Int;
 156       pragma Import (C, Set_Fld_Type, "set_field_type");
 157
 158    begin
 159       pragma Assert (Low_Level /= Null_Field_Type);
 160       if Cft /= C_Builtin_Router and then Cft /= C_Choice_Router then
 161          raise Form_Exception;
 162       else
 163          Arg := new Argument'(Usr => System.Null_Address,
 164                               Typ => new Field_Type'Class'(Typ),
 165                               Cft => Get_Fieldtype (Fld));
 166          if Usr_Arg /= System.Null_Address then
 167             if Low_Level.Copyarg /= null then
 168                Arg.Usr := Low_Level.Copyarg (Usr_Arg);
 169             else
 170                Arg.Usr := Usr_Arg;
 171             end if;
 172          end if;
 173
 174          Res := Set_Fld_Type (Arg1 => Arg);
 175          if Res /= E_Ok then
 176             Eti_Exception (Res);
 177          end if;
 178       end if;
 179    end Wrap_Builtin;
 180
 181    function Field_Check_Router (Fld : Field;
 182                                 Usr : System.Address) return C_Int
 183    is
 184       Arg  : constant Argument_Access := To_Argument_Access (Usr);
 185    begin
 186       pragma Assert (Arg /= null and then Arg.Cft /= Null_Field_Type
 187                      and then Arg.Typ /= null);
 188       if Arg.Cft.Fcheck /= null then
 189          return Arg.Cft.Fcheck (Fld, Arg.Usr);
 190       else
 191          return 1;
 192       end if;
 193    end Field_Check_Router;
 194
 195    function Char_Check_Router (Ch  : C_Int;
 196                                Usr : System.Address) return C_Int
 197    is
 198       Arg  : constant Argument_Access := To_Argument_Access (Usr);
 199    begin
 200       pragma Assert (Arg /= null and then Arg.Cft /= Null_Field_Type
 201                      and then Arg.Typ /= null);
 202       if Arg.Cft.Ccheck /= null then
 203          return Arg.Cft.Ccheck (Ch, Arg.Usr);
 204       else
 205          return 1;
 206       end if;
 207    end Char_Check_Router;
 208
 209    function Next_Router (Fld : Field;
 210                          Usr : System.Address) return C_Int
 211    is
 212       Arg  : constant Argument_Access := To_Argument_Access (Usr);
 213    begin
 214       pragma Assert (Arg /= null and then Arg.Cft /= Null_Field_Type
 215                      and then Arg.Typ /= null);
 216       if Arg.Cft.Next /= null then
 217          return Arg.Cft.Next (Fld, Arg.Usr);
 218       else
 219          return 1;
 220       end if;
 221    end Next_Router;
 222
 223    function Prev_Router (Fld : Field;
 224                          Usr : System.Address) return C_Int
 225    is
 226       Arg  : constant Argument_Access := To_Argument_Access (Usr);
 227    begin
 228       pragma Assert (Arg /= null and then Arg.Cft /= Null_Field_Type
 229                      and then Arg.Typ /= null);
 230       if Arg.Cft.Prev /= null then
 231          return Arg.Cft.Prev (Fld, Arg.Usr);
 232       else
 233          return 1;
 234       end if;
 235    end Prev_Router;
 236
 237    --  -----------------------------------------------------------------------
 238    --
 239    function C_Builtin_Router return C_Field_Type
 240    is
 241       Res : Eti_Error;
 242       T   : C_Field_Type;
 243    begin
 244       if M_Builtin_Router = Null_Field_Type then
 245          T := New_Fieldtype (Field_Check_Router'Access,
 246                              Char_Check_Router'Access);
 247          if T = Null_Field_Type then
 248             raise Form_Exception;
 249          else
 250             Res := Set_Fieldtype_Arg (T,
 251                                       Make_Arg'Access,
 252                                       Copy_Arg'Access,
 253                                       Free_Arg'Access);
 254             if Res /= E_Ok then
 255                Eti_Exception (Res);
 256             end if;
 257          end if;
 258          M_Builtin_Router := T;
 259       end if;
 260       pragma Assert (M_Builtin_Router /= Null_Field_Type);
 261       return M_Builtin_Router;
 262    end C_Builtin_Router;
 263
 264    --  -----------------------------------------------------------------------
 265    --
 266    function C_Choice_Router return C_Field_Type
 267    is
 268       Res : Eti_Error;
 269       T   : C_Field_Type;
 270    begin
 271       if M_Choice_Router = Null_Field_Type then
 272          T := New_Fieldtype (Field_Check_Router'Access,
 273                              Char_Check_Router'Access);
 274          if T = Null_Field_Type then
 275             raise Form_Exception;
 276          else
 277             Res := Set_Fieldtype_Arg (T,
 278                                       Make_Arg'Access,
 279                                       Copy_Arg'Access,
 280                                       Free_Arg'Access);
 281             if Res /= E_Ok then
 282                Eti_Exception (Res);
 283             end if;
 284
 285             Res := Set_Fieldtype_Choice (T,
 286                                          Next_Router'Access,
 287                                          Prev_Router'Access);
 288             if Res /= E_Ok then
 289                Eti_Exception (Res);
 290             end if;
 291          end if;
 292          M_Choice_Router := T;
 293       end if;
 294       pragma Assert (M_Choice_Router /= Null_Field_Type);
 295       return M_Choice_Router;
 296    end C_Choice_Router;
 297
 298 end Terminal_Interface.Curses.Forms.Field_Types;