| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT ncurses Binding -- |
| -- -- |
| -- Terminal_Interface.Curses.Forms -- |
| -- -- |
| -- B O D Y -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| -- Copyright (c) 1998-2004,2008 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 |
| -- Version Control: |
| -- $Revision: 1.26 $ |
| -- $Date: 2008/07/26 18:50:44 $ |
| -- 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 : constant 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 : constant 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 : constant 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 > 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 : constant 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 : constant 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 : constant 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 : constant 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; |
