ncurses 5.0

[ncurses.git] / Ada95 / src / terminal_interface-curses-forms-field_types-user.adb

diff --git a/Ada95/src/terminal_interface-curses-forms-field_types-user.adb b/Ada95/src/terminal_interface-curses-forms-field_types-user.adb
new file mode 100644 (file)
index 0000000..aa923c4
--- /dev/null
+++ b/Ada95/src/terminal_interface-curses-forms-field_types-user.adb
@@ -0,0 +1,132 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                           GNAT ncurses Binding                           --
+--                                                                          --
+--              Terminal_Interface.Curses.Forms.Field_Types.User            --
+--                                                                          --
+--                                 B O D Y                                  --
+--                                                                          --
+------------------------------------------------------------------------------
+-- Copyright (c) 1998 Free Software Foundation, Inc.                        --
+--                                                                          --
+-- Permission is hereby granted, free of charge, to any person obtaining a  --
+-- copy of this software and associated documentation files (the            --
+-- "Software"), to deal in the Software without restriction, including      --
+-- without limitation the rights to use, copy, modify, merge, publish,      --
+-- distribute, distribute with modifications, sublicense, and/or sell       --
+-- copies of the Software, and to permit persons to whom the Software is    --
+-- furnished to do so, subject to the following conditions:                 --
+--                                                                          --
+-- The above copyright notice and this permission notice shall be included  --
+-- in all copies or substantial portions of the Software.                   --
+--                                                                          --
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
+-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
+-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
+-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
+-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
+-- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
+--                                                                          --
+-- Except as contained in this notice, the name(s) of the above copyright   --
+-- holders shall not be used in advertising or otherwise to promote the     --
+-- sale, use or other dealings in this Software without prior written       --
+-- authorization.                                                           --
+------------------------------------------------------------------------------
+--  Author: Juergen Pfeifer <juergen.pfeifer@gmx.net> 1996
+--  Version Control:
+--  $Revision: 1.8 $
+--  Binding Version 01.00
+------------------------------------------------------------------------------
+with Ada.Unchecked_Conversion;
+with Interfaces.C;
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+
+package body Terminal_Interface.Curses.Forms.Field_Types.User is
+
+   use type Interfaces.C.int;
+
+   procedure Set_Field_Type (Fld : in Field;
+                             Typ : in User_Defined_Field_Type)
+   is
+      function Allocate_Arg (T : User_Defined_Field_Type'Class)
+                             return Argument_Access;
+
+      function Set_Fld_Type (F    : Field := Fld;
+                             Cft  : C_Field_Type := C_Generic_Type;
+                             Arg1 : Argument_Access)
+                             return C_Int;
+      pragma Import (C, Set_Fld_Type, "set_field_type");
+
+      Res : Eti_Error;
+
+      function Allocate_Arg (T : User_Defined_Field_Type'Class)
+                             return Argument_Access
+      is
+         Ptr : Field_Type_Access := new User_Defined_Field_Type'Class'(T);
+      begin
+         return new Argument'(Usr => System.Null_Address,
+                              Typ => Ptr,
+                              Cft => Null_Field_Type);
+      end Allocate_Arg;
+
+   begin
+      Res := Set_Fld_Type (Arg1 => Allocate_Arg (Typ));
+      if Res /= E_Ok then
+         Eti_Exception (Res);
+      end if;
+   end Set_Field_Type;
+
+   function To_Argument_Access is new Ada.Unchecked_Conversion
+     (System.Address, Argument_Access);
+
+   function Generic_Field_Check (Fld : Field;
+                                 Usr : System.Address) return C_Int
+   is
+      Result : Boolean;
+      Udf    : User_Defined_Field_Type_Access :=
+        User_Defined_Field_Type_Access (To_Argument_Access (Usr).Typ);
+   begin
+      Result := Field_Check (Fld, Udf.all);
+      return C_Int (Boolean'Pos (Result));
+   end Generic_Field_Check;
+
+   function Generic_Char_Check (Ch  : C_Int;
+                                Usr : System.Address) return C_Int
+   is
+      Result : Boolean;
+      Udf    : User_Defined_Field_Type_Access :=
+        User_Defined_Field_Type_Access (To_Argument_Access (Usr).Typ);
+   begin
+      Result := Character_Check (Character'Val (Ch), Udf.all);
+      return C_Int (Boolean'Pos (Result));
+   end Generic_Char_Check;
+
+   --  -----------------------------------------------------------------------
+   --
+   function C_Generic_Type return C_Field_Type
+   is
+      Res : Eti_Error;
+      T   : C_Field_Type;
+   begin
+      if M_Generic_Type = Null_Field_Type then
+         T := New_Fieldtype (Generic_Field_Check'Access,
+                             Generic_Char_Check'Access);
+         if T = Null_Field_Type then
+            raise Form_Exception;
+         else
+            Res := Set_Fieldtype_Arg (T,
+                                      Make_Arg'Access,
+                                      Copy_Arg'Access,
+                                      Free_Arg'Access);
+            if Res /= E_Ok then
+               Eti_Exception (Res);
+            end if;
+         end if;
+         M_Generic_Type := T;
+      end if;
+      pragma Assert (M_Generic_Type /= Null_Field_Type);
+      return M_Generic_Type;
+   end C_Generic_Type;
+
+end Terminal_Interface.Curses.Forms.Field_Types.User;