+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.9 $
+------------------------------------------------------------------------------
+with Ada.Tags; use Ada.Tags;
+with Ada.Unchecked_Deallocation;
+with Unchecked_Conversion;
+
+with Interfaces.C; use Interfaces.C;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+with GNAT.Htable;
+
+package body Terminal_Interface.Curses.Forms is
+
+------------------------------------------------------------------------------
+ -- |
+ -- |
+ -- |
+ -- subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
+
+ function FOS_2_CInt is new
+ Unchecked_Conversion (Field_Option_Set,
+ C_Int);
+
+ function CInt_2_FOS is new
+ Unchecked_Conversion (C_Int,
+ Field_Option_Set);
+
+ function FrmOS_2_CInt is new
+ Unchecked_Conversion (Form_Option_Set,
+ C_Int);
+
+ function CInt_2_FrmOS is new
+ Unchecked_Conversion (C_Int,
+ Form_Option_Set);
+
+ procedure Request_Name (Key : in Form_Request_Code;
+ Name : out String)
+ is
+ function Form_Request_Name (Key : C_Int) return chars_ptr;
+ pragma Import (C, Form_Request_Name, "form_request_name");
+ begin
+ Fill_String (Form_Request_Name (C_Int (Key)), Name);
+ end Request_Name;
+------------------------------------------------------------------------------
+ procedure Free_Field_User_Wrapper is
+ new Ada.Unchecked_Deallocation (Field_User_Wrapper,
+ Field_User_Wrapper_Access);
+
+ procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access);
+ procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access);
+
+ procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access)
+ is
+ begin
+ A.N := A.N - 1;
+ if A.N = 0 then
+ Free_Field_User_Wrapper (A);
+ end if;
+ end Release_User_Wrapper;
+ pragma Inline (Release_User_Wrapper);
+
+ procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access)
+ is
+ begin
+ A.N := A.N + 1;
+ end Dup_User_Wrapper;
+ pragma Inline (Dup_User_Wrapper);
+------------------------------------------------------------------------------
+ procedure Free_Form_User_Wrapper is
+ new Ada.Unchecked_Deallocation (Form_User_Wrapper,
+ Form_User_Wrapper_Access);
+ -- |
+ -- |
+ -- |
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_new.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Create (Height : Line_Count;
+ Width : Column_Count;
+ Top : Line_Position;
+ Left : Column_Position;
+ Off_Screen : Natural := 0;
+ More_Buffers : Buffer_Number := Buffer_Number'First)
+ return Field
+ is
+ function Newfield (H, W, T, L, O, M : C_Int) return Field;
+ pragma Import (C, Newfield, "new_field");
+ Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
+ C_Int (Top), C_Int (Left),
+ C_Int (Off_Screen),
+ C_Int (More_Buffers));
+
+ A : Field_User_Wrapper_Access;
+ Res : Eti_Error;
+ begin
+ if Fld = Null_Field then
+ raise Form_Exception;
+ else
+ A := new Field_User_Wrapper'(U => System.Null_Address,
+ T => null,
+ N => 1);
+ Res := Set_Field_Userptr (Fld, A);
+ if Res /= E_Ok then
+ Free_Field_User_Wrapper (A);
+ Eti_Exception (Res);
+ end if;
+ end if;
+ return Fld;
+ end Create;
+-- |
+-- |
+-- |
+ procedure Delete (Fld : in out Field)
+ is
+ function Free_Field (Fld : Field) return C_Int;
+ pragma Import (C, Free_Field, "free_field");
+ procedure Free_Field_Type is
+ new Ada.Unchecked_Deallocation (Field_Type'Class,
+ Field_Type_Access);
+
+ A : Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ if A /= null then
+ if A.T /= null then
+ Free_Field_Type (A.T);
+ end if;
+ Release_User_Wrapper (A);
+ end if;
+ Res := Free_Field (Fld);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ Fld := Null_Field;
+ end Delete;
+ -- |
+ -- |
+ -- |
+ function Duplicate (Fld : Field;
+ Top : Line_Position;
+ Left : Column_Position) return Field
+ is
+ function Dup_Field (Fld : Field;
+ Top : C_Int;
+ Left : C_Int) return Field;
+ pragma Import (C, Dup_Field, "dup_field");
+
+ A : Field_User_Wrapper_Access := Field_Userptr (Fld);
+ F : constant Field := Dup_Field (Fld,
+ C_Int (Top),
+ C_Int (Left));
+ begin
+ if F = Null_Field then
+ raise Form_Exception;
+ else
+ Dup_User_Wrapper (A);
+ end if;
+ return F;
+ end Duplicate;
+ -- |
+ -- |
+ -- |
+ function Link (Fld : Field;
+ Top : Line_Position;
+ Left : Column_Position) return Field
+ is
+ function Lnk_Field (Fld : Field;
+ Top : C_Int;
+ Left : C_Int) return Field;
+ pragma Import (C, Lnk_Field, "link_field");
+
+ A : Field_User_Wrapper_Access := Field_Userptr (Fld);
+ F : constant Field := Lnk_Field (Fld,
+ C_Int (Top),
+ C_Int (Left));
+ begin
+ if F = Null_Field then
+ raise Form_Exception;
+ else
+ Dup_User_Wrapper (A);
+ end if;
+ return F;
+ end Link;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_just.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Justification (Fld : in Field;
+ Just : in Field_Justification := None)
+ is
+ function Set_Field_Just (Fld : Field;
+ Just : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Just, "set_field_just");
+
+ Res : constant Eti_Error :=
+ Set_Field_Just (Fld,
+ C_Int (Field_Justification'Pos (Just)));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Justification;
+ -- |
+ -- |
+ -- |
+ function Get_Justification (Fld : Field) return Field_Justification
+ is
+ function Field_Just (Fld : Field) return C_Int;
+ pragma Import (C, Field_Just, "field_just");
+ begin
+ return Field_Justification'Val (Field_Just (Fld));
+ end Get_Justification;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_buffer.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Buffer
+ (Fld : in Field;
+ Buffer : in Buffer_Number := Buffer_Number'First;
+ Str : in String)
+ is
+ type Char_Ptr is access all Interfaces.C.Char;
+ function Set_Fld_Buffer (Fld : Field;
+ Bufnum : C_Int;
+ S : Char_Ptr)
+ return C_Int;
+ pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
+
+ Txt : char_array (0 .. Str'Length);
+ Len : size_t;
+ Res : Eti_Error;
+ begin
+ To_C (Str, Txt, Len);
+ Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Buffer;
+ -- |
+ -- |
+ -- |
+ procedure Get_Buffer
+ (Fld : in Field;
+ Buffer : in Buffer_Number := Buffer_Number'First;
+ Str : out String)
+ is
+ function Field_Buffer (Fld : Field;
+ B : C_Int) return chars_ptr;
+ pragma Import (C, Field_Buffer, "field_buffer");
+ begin
+ Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
+ end Get_Buffer;
+ -- |
+ -- |
+ -- |
+ procedure Set_Status (Fld : in Field;
+ Status : in Boolean := True)
+ is
+ function Set_Fld_Status (Fld : Field;
+ St : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Status, "set_field_status");
+
+ Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
+ begin
+ if Res /= E_Ok then
+ raise Form_Exception;
+ end if;
+ end Set_Status;
+ -- |
+ -- |
+ -- |
+ function Changed (Fld : Field) return Boolean
+ is
+ function Field_Status (Fld : Field) return C_Int;
+ pragma Import (C, Field_Status, "field_status");
+
+ Res : constant C_Int := Field_Status (Fld);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Changed;
+ -- |
+ -- |
+ -- |
+ procedure Set_Maximum_Size (Fld : in Field;
+ Max : in Natural := 0)
+ is
+ function Set_Field_Max (Fld : Field;
+ M : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Max, "set_max_field");
+
+ Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Maximum_Size;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_opts.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Normalize_Field_Options (Options : in out C_Int);
+ pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
+
+ procedure Set_Options (Fld : in Field;
+ Options : in Field_Option_Set)
+ is
+ function Set_Field_Opts (Fld : Field;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Opts, "set_field_opts");
+
+ Opt : C_Int := FOS_2_CInt (Options);
+ Res : Eti_Error;
+ begin
+ Normalize_Field_Options (Opt);
+ Res := Set_Field_Opts (Fld, Opt);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Options;
+ -- |
+ -- |
+ -- |
+ procedure Switch_Options (Fld : in Field;
+ Options : in Field_Option_Set;
+ On : Boolean := True)
+ is
+ function Field_Opts_On (Fld : Field;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Field_Opts_On, "field_opts_on");
+ function Field_Opts_Off (Fld : Field;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Field_Opts_Off, "field_opts_off");
+
+ Err : Eti_Error;
+ Opt : C_Int := FOS_2_CInt (Options);
+ begin
+ Normalize_Field_Options (Opt);
+ if On then
+ Err := Field_Opts_On (Fld, Opt);
+ else
+ Err := Field_Opts_Off (Fld, Opt);
+ end if;
+ if Err /= E_Ok then
+ Eti_Exception (Err);
+ end if;
+ end Switch_Options;
+ -- |
+ -- |
+ -- |
+ procedure Get_Options (Fld : in Field;
+ Options : out Field_Option_Set)
+ is
+ function Field_Opts (Fld : Field) return C_Int;
+ pragma Import (C, Field_Opts, "field_opts");
+
+ Res : C_Int := Field_Opts (Fld);
+ begin
+ Normalize_Field_Options (Res);
+ Options := CInt_2_FOS (Res);
+ end Get_Options;
+ -- |
+ -- |
+ -- |
+ function Get_Options (Fld : Field := Null_Field)
+ return Field_Option_Set
+ is
+ Fos : Field_Option_Set;
+ begin
+ Get_Options (Fld, Fos);
+ return Fos;
+ end Get_Options;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_attributes.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Foreground
+ (Fld : in Field;
+ Fore : in Character_Attribute_Set := Normal_Video;
+ Color : in Color_Pair := Color_Pair'First)
+ is
+ function Set_Field_Fore (Fld : Field;
+ Attr : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Fore, "set_field_fore");
+
+ Ch : constant Attributed_Character := (Ch => Character'First,
+ Color => Color,
+ Attr => Fore);
+ Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Foreground;
+ -- |
+ -- |
+ -- |
+ procedure Foreground (Fld : in Field;
+ Fore : out Character_Attribute_Set)
+ is
+ function Field_Fore (Fld : Field) return C_Int;
+ pragma Import (C, Field_Fore, "field_fore");
+ begin
+ Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
+ end Foreground;
+
+ procedure Foreground (Fld : in Field;
+ Fore : out Character_Attribute_Set;
+ Color : out Color_Pair)
+ is
+ function Field_Fore (Fld : Field) return C_Int;
+ pragma Import (C, Field_Fore, "field_fore");
+ begin
+ Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
+ Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
+ end Foreground;
+ -- |
+ -- |
+ -- |
+ procedure Set_Background
+ (Fld : in Field;
+ Back : in Character_Attribute_Set := Normal_Video;
+ Color : in Color_Pair := Color_Pair'First)
+ is
+ function Set_Field_Back (Fld : Field;
+ Attr : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Back, "set_field_back");
+
+ Ch : constant Attributed_Character := (Ch => Character'First,
+ Color => Color,
+ Attr => Back);
+ Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Background;
+ -- |
+ -- |
+ -- |
+ procedure Background (Fld : in Field;
+ Back : out Character_Attribute_Set)
+ is
+ function Field_Back (Fld : Field) return C_Int;
+ pragma Import (C, Field_Back, "field_back");
+ begin
+ Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
+ end Background;
+
+ procedure Background (Fld : in Field;
+ Back : out Character_Attribute_Set;
+ Color : out Color_Pair)
+ is
+ function Field_Back (Fld : Field) return C_Int;
+ pragma Import (C, Field_Back, "field_back");
+ begin
+ Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
+ Color := CInt_To_Chtype (Field_Back (Fld)).Color;
+ end Background;
+ -- |
+ -- |
+ -- |
+ procedure Set_Pad_Character (Fld : in Field;
+ Pad : in Character := Space)
+ is
+ function Set_Field_Pad (Fld : Field;
+ Ch : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Pad, "set_field_pad");
+
+ Res : constant Eti_Error := Set_Field_Pad (Fld,
+ C_Int (Character'Pos (Pad)));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Pad_Character;
+ -- |
+ -- |
+ -- |
+ procedure Pad_Character (Fld : in Field;
+ Pad : out Character)
+ is
+ function Field_Pad (Fld : Field) return C_Int;
+ pragma Import (C, Field_Pad, "field_pad");
+ begin
+ Pad := Character'Val (Field_Pad (Fld));
+ end Pad_Character;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_info.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Info (Fld : in Field;
+ Lines : out Line_Count;
+ Columns : out Column_Count;
+ First_Row : out Line_Position;
+ First_Column : out Column_Position;
+ Off_Screen : out Natural;
+ Additional_Buffers : out Buffer_Number)
+ is
+ type C_Int_Access is access all C_Int;
+ function Fld_Info (Fld : Field;
+ L, C, Fr, Fc, Os, Ab : C_Int_Access)
+ return C_Int;
+ pragma Import (C, Fld_Info, "field_info");
+
+ L, C, Fr, Fc, Os, Ab : aliased C_Int;
+ Res : constant Eti_Error := Fld_Info (Fld,
+ L'Access, C'Access,
+ Fr'Access, Fc'Access,
+ Os'Access, Ab'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ Lines := Line_Count (L);
+ Columns := Column_Count (C);
+ First_Row := Line_Position (Fr);
+ First_Column := Column_Position (Fc);
+ Off_Screen := Natural (Os);
+ Additional_Buffers := Buffer_Number (Ab);
+ end if;
+ end Info;
+-- |
+-- |
+-- |
+ procedure Dynamic_Info (Fld : in Field;
+ Lines : out Line_Count;
+ Columns : out Column_Count;
+ Max : out Natural)
+ is
+ type C_Int_Access is access all C_Int;
+ function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int;
+ pragma Import (C, Dyn_Info, "dynamic_field_info");
+
+ L, C, M : aliased C_Int;
+ Res : constant Eti_Error := Dyn_Info (Fld,
+ L'Access, C'Access,
+ M'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ Lines := Line_Count (L);
+ Columns := Column_Count (C);
+ Max := Natural (M);
+ end if;
+ end Dynamic_Info;
+ -- |
+ -- |=====================================================================
+ -- | man page form_win.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Window (Frm : in Form;
+ Win : in Window)
+ is
+ function Set_Form_Win (Frm : Form;
+ Win : Window) return C_Int;
+ pragma Import (C, Set_Form_Win, "set_form_win");
+
+ Res : constant Eti_Error := Set_Form_Win (Frm, Win);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Window;
+ -- |
+ -- |
+ -- |
+ function Get_Window (Frm : Form) return Window
+ is
+ function Form_Win (Frm : Form) return Window;
+ pragma Import (C, Form_Win, "form_win");
+
+ W : constant Window := Form_Win (Frm);
+ begin
+ return W;
+ end Get_Window;
+ -- |
+ -- |
+ -- |
+ procedure Set_Sub_Window (Frm : in Form;
+ Win : in Window)
+ is
+ function Set_Form_Sub (Frm : Form;
+ Win : Window) return C_Int;
+ pragma Import (C, Set_Form_Sub, "set_form_sub");
+
+ Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Sub_Window;
+ -- |
+ -- |
+ -- |
+ function Get_Sub_Window (Frm : Form) return Window
+ is
+ function Form_Sub (Frm : Form) return Window;
+ pragma Import (C, Form_Sub, "form_sub");
+
+ W : constant Window := Form_Sub (Frm);
+ begin
+ return W;
+ end Get_Sub_Window;
+ -- |
+ -- |
+ -- |
+ procedure Scale (Frm : in Form;
+ Lines : out Line_Count;
+ Columns : out Column_Count)
+ is
+ type C_Int_Access is access all C_Int;
+ function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int;
+ pragma Import (C, M_Scale, "scale_form");
+
+ X, Y : aliased C_Int;
+ Res : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ Lines := Line_Count (Y);
+ Columns := Column_Count (X);
+ end Scale;
+ -- |
+ -- |=====================================================================
+ -- | man page menu_hook.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Field_Init_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Field_Init (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Field_Init, "set_field_init");
+
+ Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Field_Init_Hook;
+ -- |
+ -- |
+ -- |
+ procedure Set_Field_Term_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Field_Term (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Field_Term, "set_field_term");
+
+ Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Field_Term_Hook;
+ -- |
+ -- |
+ -- |
+ procedure Set_Form_Init_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Form_Init (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Form_Init, "set_form_init");
+
+ Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Form_Init_Hook;
+ -- |
+ -- |
+ -- |
+ procedure Set_Form_Term_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Form_Term (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Form_Term, "set_form_term");
+
+ Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Form_Term_Hook;
+ -- |
+ -- |=====================================================================
+ -- | man page form_fields.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Free_Allocated_Fields is
+ new Ada.Unchecked_Deallocation (Field_Array, Field_Array_Access);
+ -- |
+ -- |
+ -- |
+ -- This is a bit delicate if we want to manipulate an Ada created form
+ -- from C routines or vice versa.
+ -- In Ada created forms we use the low level user pointer to maintain
+ -- binding internal additional informations about the form. This
+ -- internal information contains a hook for the Ada provided user pointer.
+ -- Unless you understand this implementation, the safest way in mixed
+ -- language programs to deal with user pointers is, that only the language
+ -- that created the form should also manipulate the user pointer for that
+ -- form.
+ procedure Redefine (Frm : in Form;
+ Flds : in Field_Array)
+ is
+ function Set_Frm_Fields (Frm : Form;
+ Items : Field_Array) return C_Int;
+ pragma Import (C, Set_Frm_Fields, "set_form_fields");
+
+ A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
+ I : Field_Array_Access;
+ Res : Eti_Error;
+ begin
+ if A = null or else A.I = null then raise Form_Exception;
+ else
+ I := new Field_Array (1 .. (Flds'Length + 1));
+ I.all (1 .. Flds'Length) := Flds (Flds'First .. Flds'Last);
+ I.all (Flds'Length + 1) := Null_Field;
+ Res := Set_Frm_Fields (Frm, I.all);
+ if Res /= E_Ok then
+ Free_Allocated_Fields (I);
+ Eti_Exception (Res);
+ else
+ Free_Allocated_Fields (A.I);
+ A.I := I;
+ end if;
+ end if;
+ end Redefine;
+ -- |
+ -- |
+ -- |
+ function Fields (Frm : Form) return Field_Array_Access
+ is
+ A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
+ begin
+ if A = null or else A.I = null then
+ raise Form_Exception;
+ else
+ return A.I;
+ end if;
+ end Fields;
+ -- |
+ -- |
+ -- |
+ function Field_Count (Frm : Form) return Natural
+ is
+ function Count (Frm : Form) return C_Int;
+ pragma Import (C, Count, "field_count");
+ begin
+ return Natural (Count (Frm));
+ end Field_Count;
+ -- |
+ -- |
+ -- |
+ procedure Move (Fld : in Field;
+ Line : in Line_Position;
+ Column : in Column_Position)
+ is
+ function Move (Fld : Field; L, C : C_Int) return C_Int;
+ pragma Import (C, Move, "move_field");
+
+ Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Move;
+ -- |
+ -- |=====================================================================
+ -- | man page form_new.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Create (Fields : Field_Array) return Form
+ is
+ function NewForm (Fields : Field_Array) return Form;
+ pragma Import (C, NewForm, "new_form");
+
+ M : Form;
+ I : Field_Array_Access;
+ U : Form_User_Wrapper_Access;
+ Res : Eti_Error;
+ begin
+ I := new Field_Array (1 .. (Fields'Length + 1));
+ I.all (1 .. Fields'Length) := Fields (Fields'First .. Fields'Last);
+ I.all (Fields'Length + 1) := Null_Field;
+ M := NewForm (I.all);
+ if M = Null_Form then
+ Free_Allocated_Fields (I);
+ raise Form_Exception;
+ end if;
+ U := new Form_User_Wrapper'(U => System.Null_Address, I => I);
+ Res := Set_Form_Userptr (M, U);
+ if Res /= E_Ok then
+ Free_Allocated_Fields (I);
+ Free_Form_User_Wrapper (U);
+ Eti_Exception (Res);
+ end if;
+ return M;
+ end Create;
+ -- |
+ -- |
+ -- |
+ procedure Delete (Frm : in out Form)
+ is
+ function Free (Frm : Form) return C_Int;
+ pragma Import (C, Free, "free_form");
+
+ U : Form_User_Wrapper_Access := Form_Userptr (Frm);
+ Res : constant Eti_Error := Free (Frm);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ if U = null or else U.I = null then
+ raise Form_Exception;
+ end if;
+ Free_Allocated_Fields (U.I);
+ Free_Form_User_Wrapper (U);
+ Frm := Null_Form;
+ end Delete;
+ -- |
+ -- |=====================================================================
+ -- | man page form_opts.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Normalize_Form_Options (Options : in out C_Int);
+ pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
+
+ procedure Set_Options (Frm : in Form;
+ Options : in Form_Option_Set)
+ is
+ function Set_Form_Opts (Frm : Form;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Set_Form_Opts, "set_form_opts");
+
+ Opt : C_Int := FrmOS_2_CInt (Options);
+ Res : Eti_Error;
+ begin
+ Normalize_Form_Options (Opt);
+ Res := Set_Form_Opts (Frm, Opt);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Options;
+ -- |
+ -- |
+ -- |
+ procedure Switch_Options (Frm : in Form;
+ Options : in Form_Option_Set;
+ On : Boolean := True)
+ is
+ function Form_Opts_On (Frm : Form;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Form_Opts_On, "form_opts_on");
+ function Form_Opts_Off (Frm : Form;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Form_Opts_Off, "form_opts_off");
+
+ Err : Eti_Error;
+ Opt : C_Int := FrmOS_2_CInt (Options);
+ begin
+ Normalize_Form_Options (Opt);
+ if On then
+ Err := Form_Opts_On (Frm, Opt);
+ else
+ Err := Form_Opts_Off (Frm, Opt);
+ end if;
+ if Err /= E_Ok then
+ Eti_Exception (Err);
+ end if;
+ end Switch_Options;
+ -- |
+ -- |
+ -- |
+ procedure Get_Options (Frm : in Form;
+ Options : out Form_Option_Set)
+ is
+ function Form_Opts (Frm : Form) return C_Int;
+ pragma Import (C, Form_Opts, "form_opts");
+
+ Res : C_Int := Form_Opts (Frm);
+ begin
+ Normalize_Form_Options (Res);
+ Options := CInt_2_FrmOS (Res);
+ end Get_Options;
+ -- |
+ -- |
+ -- |
+ function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
+ is
+ Fos : Form_Option_Set;
+ begin
+ Get_Options (Frm, Fos);
+ return Fos;
+ end Get_Options;
+ -- |
+ -- |=====================================================================
+ -- | man page form_post.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Post (Frm : in Form;
+ Post : in Boolean := True)
+ is
+ function M_Post (Frm : Form) return C_Int;
+ pragma Import (C, M_Post, "post_form");
+ function M_Unpost (Frm : Form) return C_Int;
+ pragma Import (C, M_Unpost, "unpost_form");
+
+ Res : Eti_Error;
+ begin
+ if Post then
+ Res := M_Post (Frm);
+ else
+ Res := M_Unpost (Frm);
+ end if;
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Post;
+ -- |
+ -- |=====================================================================
+ -- | man page form_cursor.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Position_Cursor (Frm : Form)
+ is
+ function Pos_Form_Cursor (Frm : Form) return C_Int;
+ pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
+
+ Res : constant Eti_Error := Pos_Form_Cursor (Frm);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Position_Cursor;
+ -- |
+ -- |=====================================================================
+ -- | man page form_data.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Data_Ahead (Frm : Form) return Boolean
+ is
+ function Ahead (Frm : Form) return C_Int;
+ pragma Import (C, Ahead, "data_ahead");
+
+ Res : constant C_Int := Ahead (Frm);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Data_Ahead;
+ -- |
+ -- |
+ -- |
+ function Data_Behind (Frm : Form) return Boolean
+ is
+ function Behind (Frm : Form) return C_Int;
+ pragma Import (C, Behind, "data_behind");
+
+ Res : constant C_Int := Behind (Frm);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Data_Behind;
+ -- |
+ -- |=====================================================================
+ -- | man page form_driver.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Driver (Frm : Form;
+ Key : Key_Code) return Driver_Result
+ is
+ function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
+ pragma Import (C, Frm_Driver, "form_driver");
+
+ R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
+ begin
+ if R /= E_Ok then
+ if R = E_Unknown_Command then
+ return Unknown_Request;
+ elsif R = E_Invalid_Field then
+ return Invalid_Field;
+ elsif R = E_Request_Denied then
+ return Request_Denied;
+ else
+ Eti_Exception (R);
+ return Form_Ok;
+ end if;
+ else
+ return Form_Ok;
+ end if;
+ end Driver;
+ -- |
+ -- |=====================================================================
+ -- | man page form_page.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Current (Frm : in Form;
+ Fld : in Field)
+ is
+ function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
+ pragma Import (C, Set_Current_Fld, "set_current_field");
+
+ Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Current;
+ -- |
+ -- |
+ -- |
+ function Current (Frm : in Form) return Field
+ is
+ function Current_Fld (Frm : Form) return Field;
+ pragma Import (C, Current_Fld, "current_field");
+
+ Fld : constant Field := Current_Fld (Frm);
+ begin
+ if Fld = Null_Field then
+ raise Form_Exception;
+ end if;
+ return Fld;
+ end Current;
+ -- |
+ -- |
+ -- |
+ procedure Set_Page (Frm : in Form;
+ Page : in Page_Number := Page_Number'First)
+ is
+ function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
+ pragma Import (C, Set_Frm_Page, "set_form_page");
+
+ Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Page;
+ -- |
+ -- |
+ -- |
+ function Page (Frm : Form) return Page_Number
+ is
+ function Get_Page (Frm : Form) return C_Int;
+ pragma Import (C, Get_Page, "form_page");
+
+ P : constant C_Int := Get_Page (Frm);
+ begin
+ if P < 0 then
+ raise Form_Exception;
+ else
+ return Page_Number (P);
+ end if;
+ end Page;
+
+ function Get_Index (Fld : Field) return Positive
+ is
+ function Get_Fieldindex (Fld : Field) return C_Int;
+ pragma Import (C, Get_Fieldindex, "field_index");
+
+ Res : constant C_Int := Get_Fieldindex (Fld);
+ begin
+ if Res = Curses_Err then
+ raise Form_Exception;
+ end if;
+ return Positive (Natural (Res) + Positive'First);
+ end Get_Index;
+
+ -- |
+ -- |=====================================================================
+ -- | man page form_new_page.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_New_Page (Fld : in Field;
+ New_Page : in Boolean := True)
+ is
+ function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
+ pragma Import (C, Set_Page, "set_new_page");
+
+ Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_New_Page;
+ -- |
+ -- |
+ -- |
+ function Is_New_Page (Fld : Field) return Boolean
+ is
+ function Is_New (Fld : Field) return C_Int;
+ pragma Import (C, Is_New, "new_page");
+
+ Res : constant C_Int := Is_New (Fld);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_New_Page;
+
+------------------------------------------------------------------------------
+ -- We use a GNAT internal hash table mechanism to create an association
+ -- between an Ada_Defined_Field_Type and it's low level C_Field_Type
+ -- peer.
+ -- It shouldn´t be too complicated to reimplent this hashing mechanism
+ -- for other compilers.
+ --
+ type Tag_Type_Pair;
+ type Tag_Pair_Access is access all Tag_Type_Pair;
+ pragma Controlled (Tag_Pair_Access);
+
+ Null_Tag_Pair : constant Tag_Pair_Access := Tag_Pair_Access'(null);
+
+ type Tag_Type_Pair is
+ record
+ Ada_Tag : Tag;
+ Cft : C_Field_Type;
+ Next : Tag_Pair_Access;
+ end record;
+
+ type Htable_Headers is range 1 .. 31;
+ procedure Free_Tag_Type_Pair is
+ new Ada.Unchecked_Deallocation (Tag_Type_Pair, Tag_Pair_Access);
+
+ procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access);
+ function Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access;
+ function Get_Pair_Tag (T : Tag_Pair_Access) return Tag;
+
+ function Hash (T : Tag) return Htable_Headers;
+ function Equal (A, B : Tag) return Boolean;
+
+ package External_Pair_Htable is new GNAT.Htable.Static_Htable
+ (Header_Num => Htable_Headers,
+ Element => Tag_Type_Pair,
+ Elmt_Ptr => Tag_Pair_Access,
+ Null_Ptr => Null_Tag_Pair,
+ Set_Next => Set_Pair_Link,
+ Next => Get_Pair_Link,
+ Key => Tag,
+ Get_Key => Get_Pair_Tag,
+ Hash => Hash,
+ Equal => Equal);
+
+ procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access)
+ is
+ begin
+ T.all.Next := Next;
+ end Set_Pair_Link;
+
+ function Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access
+ is
+ begin
+ return T.all.Next;
+ end Get_Pair_Link;
+
+ function Get_Pair_Tag (T : Tag_Pair_Access) return Tag
+ is
+ begin
+ return T.all.Ada_Tag;
+ end Get_Pair_Tag;
+
+ function Equal (A, B : Tag) return Boolean
+ is
+ begin
+ return A = B;
+ end Equal;
+
+ function Hash (T : Tag) return Htable_Headers
+ is
+ function H is new GNAT.Htable.Hash (Htable_Headers);
+ begin
+ return H (External_Tag (T));
+ end Hash;
+
+ function Search_Type (T : Ada_Defined_Field_Type'Class)
+ return C_Field_Type
+ is
+ P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
+ begin
+ if P /= null then
+ return P.Cft;
+ else
+ return Null_Field_Type;
+ end if;
+ end Search_Type;
+
+ -- Register an Ada_Defined_Field_Type given by its Tag
+ -- with it's associated C_Field_Type.
+ procedure Register_Type (T : in Ada_Defined_Field_Type'Class;
+ Cft : in C_Field_Type)
+ is
+ C : C_Field_Type := Search_Type (T);
+ P : Tag_Pair_Access;
+ begin
+ if C /= Null_Field_Type then
+ raise Form_Exception;
+ else
+ P := new Tag_Type_Pair'(T'Tag, Cft, null);
+ External_Pair_Htable.Set (P);
+ end if;
+ end Register_Type;
+
+ -- Unregister an Ada_Defined_Field_Type given by it's tag
+ procedure Unregister_Type (T : in Ada_Defined_Field_Type'Class)
+ is
+ function Free_Fieldtype (Ft : C_Field_Type) return C_Int;
+ pragma Import (C, Free_Fieldtype, "free_fieldtype");
+
+ P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
+ Ft : C_Field_Type;
+ Res : C_Int;
+ begin
+ if P = null then
+ raise Form_Exception;
+ else
+ Ft := P.Cft;
+ External_Pair_Htable.Remove (T'Tag);
+ Free_Tag_Type_Pair (P);
+ Res := Free_Fieldtype (Ft);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end if;
+ end Unregister_Type;
+
+----------------------------------------------------------------------------
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : Field;
+ Fld_Type : Ada_Defined_Field_Type)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Ct : C_Field_Type;
+ Arg1 : Ada_Defined_Field_Type'Class)
+ return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ Res : Eti_Error;
+ C : constant C_Field_Type := Search_Type (Fld_Type);
+ begin
+ if C = Null_Field_Type then
+ raise Form_Exception;
+ else
+ Res := Set_Fld_Type (Fld, C, Fld_Type);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Ada_Defined_Field_Type)
+ return C_Field_Type
+ is
+ C : constant C_Field_Type := Search_Type (Ftype);
+ begin
+ if C = Null_Field_Type then
+ raise Form_Exception;
+ else
+ return C;
+ end if;
+ end Native_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Alpha_Field)
+ return C_Field_Type
+ is
+ C_Alpha_Field_Type : C_Field_Type;
+ pragma Import (C, C_Alpha_Field_Type, "TYPE_ALPHA");
+ begin
+ return C_Alpha_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Alpha_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Alpha_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Alpha_Numeric_Field)
+ return C_Field_Type
+ is
+ C_Alpha_Numeric_Field_Type : C_Field_Type;
+ pragma Import (C, C_Alpha_Numeric_Field_Type, "TYPE_ALNUM");
+ begin
+ return C_Alpha_Numeric_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Alpha_Numeric_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Alpha_Numeric_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Integer_Field)
+ return C_Field_Type
+ is
+ C_Integer_Field_Type : C_Field_Type;
+ pragma Import (C, C_Integer_Field_Type, "TYPE_INTEGER");
+ begin
+ return C_Integer_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Integer_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : C_Int;
+ Arg2 : C_Long_Int;
+ Arg3 : C_Long_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Precision),
+ Arg2 => C_Long_Int (Fld_Type.Lower_Limit),
+ Arg3 => C_Long_Int (Fld_Type.Upper_Limit));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Integer_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Numeric_Field)
+ return C_Field_Type
+ is
+ C_Numeric_Field_Type : C_Field_Type;
+ pragma Import (C, C_Numeric_Field_Type, "TYPE_NUMERIC");
+ begin
+ return C_Numeric_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Numeric_Field)
+ is
+ type Double is new Interfaces.C.double;
+
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : Double;
+ Arg2 : Double;
+ Arg3 : Double) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => Double (Fld_Type.Precision),
+ Arg2 => Double (Fld_Type.Lower_Limit),
+ Arg3 => Double (Fld_Type.Upper_Limit));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Numeric_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Regular_Expression_Field)
+ return C_Field_Type
+ is
+ C_Regexp_Field_Type : C_Field_Type;
+ pragma Import (C, C_Regexp_Field_Type, "TYPE_REGEXP");
+ begin
+ return C_Regexp_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Regular_Expression_Field)
+ is
+ type Char_Ptr is access all Interfaces.C.Char;
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : Char_Ptr) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Txt : char_array (0 .. Fld_Type.Regular_Expression.all'Length);
+ Len : size_t;
+ Res : Eti_Error;
+ begin
+ To_C (Fld_Type.Regular_Expression.all, Txt, Len);
+ Res := Set_Fld_Type (Arg1 => Txt (Txt'First)'Access);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Regular_Expression_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Enumeration_Field)
+ return C_Field_Type
+ is
+ C_Enum_Type : C_Field_Type;
+ pragma Import (C, C_Enum_Type, "TYPE_ENUM");
+ begin
+ return C_Enum_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ function Create (Info : Enumeration_Info;
+ Auto_Release_Names : Boolean := False)
+ return Enumeration_Field
+ is
+ procedure Release_String is
+ new Ada.Unchecked_Deallocation (String,
+ String_Access);
+ E : Enumeration_Field;
+ L : constant size_t := 1 + size_t (Info.C);
+ S : String_Access;
+ begin
+ E.Case_Sensitive := Info.Case_Sensitive;
+ E.Match_Must_Be_Unique := Info.Match_Must_Be_Unique;
+ E.Arr := new chars_ptr_array (size_t (1) .. L);
+ for I in 1 .. Positive (L - 1) loop
+ if Info.Names (I) = null then
+ raise Form_Exception;
+ end if;
+ E.Arr (size_t (I)) := New_String (Info.Names (I).all);
+ if Auto_Release_Names then
+ S := Info.Names (I);
+ Release_String (S);
+ end if;
+ end loop;
+ E.Arr (L) := Null_Ptr;
+ return E;
+ end Create;
+
+ procedure Release (Enum : in out Enumeration_Field)
+ is
+ I : size_t := 0;
+ P : chars_ptr;
+ begin
+ loop
+ P := Enum.Arr (I);
+ exit when P = Null_Ptr;
+ Free (P);
+ Enum.Arr (I) := Null_Ptr;
+ I := I + 1;
+ end loop;
+ Enum.Arr := null;
+ end Release;
+
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Enumeration_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : chars_ptr_array;
+ Arg2 : C_Int; -- case
+ Arg3 : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ if Fld_Type.Arr = null then
+ raise Form_Exception;
+ end if;
+ Res := Set_Fld_Type (Arg1 => Fld_Type.Arr.all,
+ Arg2 => C_Int (Boolean'Pos
+ (Fld_Type.Case_Sensitive)),
+ Arg3 =>
+ C_Int (Boolean'Pos
+ (Fld_Type.Match_Must_Be_Unique)));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Enumeration_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+
+
+ function Native_Type (Ftype : Internet_V4_Address_Field)
+ return C_Field_Type
+ is
+ C_IPV4_Field_Type : C_Field_Type;
+ pragma Import (C, C_IPV4_Field_Type, "TYPE_IPV4");
+ begin
+ return C_IPV4_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Internet_V4_Address_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type))
+ return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type;
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Internet_V4_Address_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_validation.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Get_Type (Fld : in Field) return Field_Type_Access
+ is
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ begin
+ if A = null then
+ return null;
+ else
+ return A.T;
+ end if;
+ end Get_Type;
+
+begin
+ Default_Field_Options := Get_Options (Null_Field);
+ Default_Form_Options := Get_Options (Null_Form);
+end Terminal_Interface.Curses.Forms;
projects / ncurses.git / commitdiff