diff options
Diffstat (limited to 'ncurses-5.3/Ada95/src/terminal_interface-curses-forms.adb')
| -rw-r--r-- | ncurses-5.3/Ada95/src/terminal_interface-curses-forms.adb | 1161 |
1 files changed, 1161 insertions, 0 deletions
diff --git a/ncurses-5.3/Ada95/src/terminal_interface-curses-forms.adb b/ncurses-5.3/Ada95/src/terminal_interface-curses-forms.adb new file mode 100644 index 0000000..f65984c --- /dev/null +++ b/ncurses-5.3/Ada95/src/terminal_interface-curses-forms.adb @@ -0,0 +1,1161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT ncurses Binding -- +-- -- +-- Terminal_Interface.Curses.Forms -- +-- -- +-- 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, 1996 +-- Contact: http://www.familiepfeifer.de/Contact.aspx?Lang=en +-- Version Control: +-- $Revision$ +-- Binding Version 01.00 +------------------------------------------------------------------------------ +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; + +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with Interfaces.C.Pointers; + +with Terminal_Interface.Curses.Aux; + +package body Terminal_Interface.Curses.Forms is + + use Terminal_Interface.Curses.Aux; + + type C_Field_Array is array (Natural range <>) of aliased Field; + package F_Array is new + Interfaces.C.Pointers (Natural, Field, C_Field_Array, Null_Field); + +------------------------------------------------------------------------------ + -- | + -- | + -- | + -- subtype chars_ptr is Interfaces.C.Strings.chars_ptr; + + function FOS_2_CInt is new + Ada.Unchecked_Conversion (Field_Option_Set, + C_Int); + + function CInt_2_FOS is new + Ada.Unchecked_Conversion (C_Int, + Field_Option_Set); + + function FrmOS_2_CInt is new + Ada.Unchecked_Conversion (Form_Option_Set, + C_Int); + + function CInt_2_FrmOS is new + Ada.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; + + function Request_Name (Key : Form_Request_Code) return String + is + function Form_Request_Name (Key : C_Int) return chars_ptr; + pragma Import (C, Form_Request_Name, "form_request_name"); + begin + return Fill_String (Form_Request_Name (C_Int (Key))); + end Request_Name; +------------------------------------------------------------------------------ + -- | + -- | + -- | + -- | + -- |===================================================================== + -- | 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)); + begin + if Fld = Null_Field then + raise Form_Exception; + 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"); + + Res : Eti_Error; + begin + 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"); + + F : constant Field := Dup_Field (Fld, + C_Int (Top), + C_Int (Left)); + begin + if F = Null_Field then + raise Form_Exception; + 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"); + + F : constant Field := Lnk_Field (Fld, + C_Int (Top), + C_Int (Left)); + begin + if F = Null_Field then + raise Form_Exception; + 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; + + function Get_Buffer + (Fld : in Field; + Buffer : in Buffer_Number := Buffer_Number'First) return String + is + function Field_Buffer (Fld : Field; + B : C_Int) return chars_ptr; + pragma Import (C, Field_Buffer, "field_buffer"); + begin + return Fill_String (Field_Buffer (Fld, C_Int (Buffer))); + 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 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 + 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 + 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 + 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_Chtype) 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, AttrChar_To_Chtype (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_Chtype; + pragma Import (C, Field_Fore, "field_fore"); + begin + Fore := Chtype_To_AttrChar (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_Chtype; + pragma Import (C, Field_Fore, "field_fore"); + begin + Fore := Chtype_To_AttrChar (Field_Fore (Fld)).Attr; + Color := Chtype_To_AttrChar (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_Chtype) 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, AttrChar_To_Chtype (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_Chtype; + pragma Import (C, Field_Back, "field_back"); + begin + Back := Chtype_To_AttrChar (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_Chtype; + pragma Import (C, Field_Back, "field_back"); + begin + Back := Chtype_To_AttrChar (Field_Back (Fld)).Attr; + Color := Chtype_To_AttrChar (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 Redefine (Frm : in Form; + Flds : in Field_Array_Access) + is + function Set_Frm_Fields (Frm : Form; + Items : System.Address) return C_Int; + pragma Import (C, Set_Frm_Fields, "set_form_fields"); + + Res : Eti_Error; + begin + pragma Assert (Flds (Flds'Last) = Null_Field); + if Flds (Flds'Last) /= Null_Field then + raise Form_Exception; + else + Res := Set_Frm_Fields (Frm, Flds (Flds'First)'Address); + if Res /= E_Ok then + Eti_Exception (Res); + end if; + end if; + end Redefine; + -- | + -- | + -- | + function Fields (Frm : Form; + Index : Positive) return Field + is + use F_Array; + + function C_Fields (Frm : Form) return Pointer; + pragma Import (C, C_Fields, "form_fields"); + + P : Pointer := C_Fields (Frm); + begin + if P = null or else Index not in 1 .. Field_Count (Frm) then + raise Form_Exception; + else + P := P + ptrdiff_t (C_Int (Index) - 1); + return P.all; + 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_Access) return Form + is + function NewForm (Fields : System.Address) return Form; + pragma Import (C, NewForm, "new_form"); + + M : Form; + begin + pragma Assert (Fields (Fields'Last) = Null_Field); + if Fields (Fields'Last) /= Null_Field then + raise Form_Exception; + else + M := NewForm (Fields (Fields'First)'Address); + if M = Null_Form then + raise Form_Exception; + end if; + return M; + end if; + end Create; + -- | + -- | + -- | + procedure Delete (Frm : in out Form) + is + function Free (Frm : Form) return C_Int; + pragma Import (C, Free, "free_form"); + + Res : constant Eti_Error := Free (Frm); + begin + if Res /= E_Ok then + Eti_Exception (Res); + end if; + Frm := Null_Form; + end Delete; + -- | + -- |===================================================================== + -- | man page form_opts.3x + -- |===================================================================== + -- | + -- | + -- | + 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 + 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 + 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 + 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; + + procedure Free (FA : in out Field_Array_Access; + Free_Fields : in Boolean := False) + is + procedure Release is new Ada.Unchecked_Deallocation + (Field_Array, Field_Array_Access); + begin + if FA /= null and then Free_Fields then + for I in FA'First .. (FA'Last - 1) loop + if (FA (I) /= Null_Field) then + Delete (FA (I)); + end if; + end loop; + end if; + Release (FA); + end Free; + + -- |===================================================================== + + function Default_Field_Options return Field_Option_Set + is + begin + return Get_Options (Null_Field); + end Default_Field_Options; + + function Default_Form_Options return Form_Option_Set + is + begin + return Get_Options (Null_Form); + end Default_Form_Options; + +end Terminal_Interface.Curses.Forms; |