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, 0 insertions, 1161 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 deleted file mode 100644 index f65984c..0000000 --- a/ncurses-5.3/Ada95/src/terminal_interface-curses-forms.adb +++ /dev/null @@ -1,1161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |